FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common );
   6 use vars qw($disable_agentcheck $DEBUG $me);
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( getotaker dbh );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs );
  16 use FS::CurrentUser;
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::cust_location;
  21 use FS::pkg_svc;
  22 use FS::cust_bill_pkg;
  23 use FS::cust_pkg_detail;
  24 use FS::cust_event;
  25 use FS::h_cust_svc;
  26 use FS::reg_code;
  27 use FS::part_svc;
  28 use FS::cust_pkg_reason;
  29 use FS::reason;
  30 use FS::cust_pkg_discount;
  31 use FS::discount;
  32 use FS::UI::Web;
  33
  34 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  35 # setup }
  36 # because they load configuration by setting FS::UID::callback (see TODO)
  37 use FS::svc_acct;
  38 use FS::svc_domain;
  39 use FS::svc_www;
  40 use FS::svc_forward;
  41
  42 # for sending cancel emails in sub cancel
  43 use FS::Conf;
  44
  45 $DEBUG = 0;
  46 $me = '[FS::cust_pkg]';
  47
  48 $disable_agentcheck = 0;
  49
  50 sub _cache {
  51   my $self = shift;
  52   my ( $hashref, $cache ) = @_;
  53   #if ( $hashref->{'pkgpart'} ) {
  54   if ( $hashref->{'pkg'} ) {
  55     # #@{ $self->{'_pkgnum'} } = ();
  56     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  57     # $self->{'_pkgpart'} = $subcache;
  58     # #push @{ $self->{'_pkgnum'} },
  59     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  60     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  61   }
  62   if ( exists $hashref->{'svcnum'} ) {
  63     #@{ $self->{'_pkgnum'} } = ();
  64     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  65     $self->{'_svcnum'} = $subcache;
  66     #push @{ $self->{'_pkgnum'} },
  67     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  68   }
  69 }
  70
  71 =head1 NAME
  72
  73 FS::cust_pkg - Object methods for cust_pkg objects
  74
  75 =head1 SYNOPSIS
  76
  77   use FS::cust_pkg;
  78
  79   $record = new FS::cust_pkg \%hash;
  80   $record = new FS::cust_pkg { 'column' => 'value' };
  81
  82   $error = $record->insert;
  83
  84   $error = $new_record->replace($old_record);
  85
  86   $error = $record->delete;
  87
  88   $error = $record->check;
  89
  90   $error = $record->cancel;
  91
  92   $error = $record->suspend;
  93
  94   $error = $record->unsuspend;
  95
  96   $part_pkg = $record->part_pkg;
  97
  98   @labels = $record->labels;
  99
 100   $seconds = $record->seconds_since($timestamp);
 101
 102   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 103   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 104
 105 =head1 DESCRIPTION
 106
 107 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 108 inherits from FS::Record.  The following fields are currently supported:
 109
 110 =over 4
 111
 112 =item pkgnum
 113
 114 Primary key (assigned automatically for new billing items)
 115
 116 =item custnum
 117
 118 Customer (see L<FS::cust_main>)
 119
 120 =item pkgpart
 121
 122 Billing item definition (see L<FS::part_pkg>)
 123
 124 =item locationnum
 125
 126 Optional link to package location (see L<FS::location>)
 127
 128 =item start_date
 129
 130 date
 131
 132 =item setup
 133
 134 date
 135
 136 =item bill
 137
 138 date (next bill date)
 139
 140 =item last_bill
 141
 142 last bill date
 143
 144 =item adjourn
 145
 146 date
 147
 148 =item susp
 149
 150 date
 151
 152 =item expire
 153
 154 date
 155
 156 =item cancel
 157
 158 date
 159
 160 =item usernum
 161
 162 order taker (see L<FS::access_user>)
 163
 164 =item manual_flag
 165
 166 If this field is set to 1, disables the automatic
 167 unsuspension of this package when using the B<unsuspendauto> config option.
 168
 169 =item quantity
 170
 171 If not set, defaults to 1
 172
 173 =item change_date
 174
 175 Date of change from previous package
 176
 177 =item change_pkgnum
 178
 179 Previous pkgnum
 180
 181 =item change_pkgpart
 182
 183 Previous pkgpart
 184
 185 =item change_locationnum
 186
 187 Previous locationnum
 188
 189 =back
 190
 191 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 192 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 193 L<Time::Local> and L<Date::Parse> for conversion functions.
 194
 195 =head1 METHODS
 196
 197 =over 4
 198
 199 =item new HASHREF
 200
 201 Create a new billing item.  To add the item to the database, see L<"insert">.
 202
 203 =cut
 204
 205 sub table { 'cust_pkg'; }
 206 sub cust_linked { $_[0]->cust_main_custnum; }
 207 sub cust_unlinked_msg {
 208   my $self = shift;
 209   "WARNING: can't find cust_main.custnum ". $self->custnum.
 210   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 211 }
 212
 213 =item insert [ OPTION => VALUE ... ]
 214
 215 Adds this billing item to the database ("Orders" the item).  If there is an
 216 error, returns the error, otherwise returns false.
 217
 218 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 219 will be used to look up the package definition and agent restrictions will be
 220 ignored.
 221
 222 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 223 be created and inserted.  Multiple FS::pkg_referral records can be created by
 224 setting I<refnum> to an array reference of refnums or a hash reference with
 225 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 226 record will be created corresponding to cust_main.refnum.
 227
 228 The following options are available:
 229
 230 =over 4
 231
 232 =item change
 233
 234 If set true, supresses any referral credit to a referring customer.
 235
 236 =item options
 237
 238 cust_pkg_option records will be created
 239
 240 =item ticket_subject
 241
 242 a ticket will be added to this customer with this subject
 243
 244 =item ticket_queue
 245
 246 an optional queue name for ticket additions
 247
 248 =back
 249
 250 =cut
 251
 252 sub insert {
 253   my( $self, %options ) = @_;
 254
 255   if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
 256     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 257     $mon += 1 unless $mday == 1;
 258     until ( $mon < 12 ) { $mon -= 12; $year++; }
 259     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 260   }
 261
 262   my $expire_months = $self->part_pkg->option('expire_months', 1);
 263   if ( $expire_months && !$self->expire ) {
 264     my $start = $self->start_date || $self->setup || time;
 265
 266     #false laziness w/part_pkg::add_freq
 267     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
 268     $mon += $expire_months;
 269     until ( $mon < 12 ) { $mon -= 12; $year++; }
 270
 271     #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
 272     $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
 273   }
 274
 275   local $SIG{HUP} = 'IGNORE';
 276   local $SIG{INT} = 'IGNORE';
 277   local $SIG{QUIT} = 'IGNORE';
 278   local $SIG{TERM} = 'IGNORE';
 279   local $SIG{TSTP} = 'IGNORE';
 280   local $SIG{PIPE} = 'IGNORE';
 281
 282   my $oldAutoCommit = $FS::UID::AutoCommit;
 283   local $FS::UID::AutoCommit = 0;
 284   my $dbh = dbh;
 285
 286   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 287   if ( $error ) {
 288     $dbh->rollback if $oldAutoCommit;
 289     return $error;
 290   }
 291
 292   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 293   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 294   $self->process_m2m( 'link_table'   => 'pkg_referral',
 295                       'target_table' => 'part_referral',
 296                       'params'       => $self->refnum,
 297                     );
 298
 299   if ( $self->discountnum ) {
 300     my $error = $self->insert_discount();
 301     if ( $error ) {
 302       $dbh->rollback if $oldAutoCommit;
 303       return $error;
 304     }
 305   }
 306
 307   #if ( $self->reg_code ) {
 308   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 309   #  $error = $reg_code->delete;
 310   #  if ( $error ) {
 311   #    $dbh->rollback if $oldAutoCommit;
 312   #    return $error;
 313   #  }
 314   #}
 315
 316   my $conf = new FS::Conf;
 317
 318   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 319
 320     #eval '
 321     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 322     #  use RT;
 323     #';
 324     #die $@ if $@;
 325     #
 326     #RT::LoadConfig();
 327     #RT::Init();
 328     use FS::TicketSystem;
 329     FS::TicketSystem->init();
 330
 331     my $q = new RT::Queue($RT::SystemUser);
 332     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 333     my $t = new RT::Ticket($RT::SystemUser);
 334     my $mime = new MIME::Entity;
 335     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 336     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 337                 Subject => $options{ticket_subject},
 338                 MIMEObj => $mime,
 339               );
 340     $t->AddLink( Type   => 'MemberOf',
 341                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 342                );
 343   }
 344
 345   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 346     my $queue = new FS::queue {
 347       'job'     => 'FS::cust_main::queueable_print',
 348     };
 349     $error = $queue->insert(
 350       'custnum'  => $self->custnum,
 351       'template' => 'welcome_letter',
 352     );
 353
 354     if ($error) {
 355       warn "can't send welcome letter: $error";
 356     }
 357
 358   }
 359
 360   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 361   '';
 362
 363 }
 364
 365 =item delete
 366
 367 This method now works but you probably shouldn't use it.
 368
 369 You don't want to delete billing items, because there would then be no record
 370 the customer ever purchased the item.  Instead, see the cancel method.
 371
 372 =cut
 373
 374 #sub delete {
 375 #  return "Can't delete cust_pkg records!";
 376 #}
 377
 378 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 379
 380 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 381 returns the error, otherwise returns false.
 382
 383 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 384
 385 Changing pkgpart may have disasterous effects.  See the order subroutine.
 386
 387 setup and bill are normally updated by calling the bill method of a customer
 388 object (see L<FS::cust_main>).
 389
 390 suspend is normally updated by the suspend and unsuspend methods.
 391
 392 cancel is normally updated by the cancel method (and also the order subroutine
 393 in some cases).
 394
 395 Available options are:
 396
 397 =over 4
 398
 399 =item reason
 400
 401 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 402
 403 =item reason_otaker
 404
 405 the access_user (see L<FS::access_user>) providing the reason
 406
 407 =item options
 408
 409 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 410
 411 =back
 412
 413 =cut
 414
 415 sub replace {
 416   my $new = shift;
 417
 418   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 419               ? shift
 420               : $new->replace_old;
 421
 422   my $options =
 423     ( ref($_[0]) eq 'HASH' )
 424       ? shift
 425       : { @_ };
 426
 427   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 428   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 429
 430   #allow this *sigh*
 431   #return "Can't change setup once it exists!"
 432   #  if $old->getfield('setup') &&
 433   #     $old->getfield('setup') != $new->getfield('setup');
 434
 435   #some logic for bill, susp, cancel?
 436
 437   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 438
 439   local $SIG{HUP} = 'IGNORE';
 440   local $SIG{INT} = 'IGNORE';
 441   local $SIG{QUIT} = 'IGNORE';
 442   local $SIG{TERM} = 'IGNORE';
 443   local $SIG{TSTP} = 'IGNORE';
 444   local $SIG{PIPE} = 'IGNORE';
 445
 446   my $oldAutoCommit = $FS::UID::AutoCommit;
 447   local $FS::UID::AutoCommit = 0;
 448   my $dbh = dbh;
 449
 450   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 451     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 452       my $error = $new->insert_reason(
 453         'reason'        => $options->{'reason'},
 454         'date'          => $new->$method,
 455         'action'        => $method,
 456         'reason_otaker' => $options->{'reason_otaker'},
 457       );
 458       if ( $error ) {
 459         dbh->rollback if $oldAutoCommit;
 460         return "Error inserting cust_pkg_reason: $error";
 461       }
 462     }
 463   }
 464
 465   #save off and freeze RADIUS attributes for any associated svc_acct records
 466   my @svc_acct = ();
 467   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 468
 469                 #also check for specific exports?
 470                 # to avoid spurious modify export events
 471     @svc_acct = map  { $_->svc_x }
 472                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 473                      $old->cust_svc;
 474
 475     $_->snapshot foreach @svc_acct;
 476
 477   }
 478
 479   my $error = $new->SUPER::replace($old,
 480                                    $options->{options} ? $options->{options} : ()
 481                                   );
 482   if ( $error ) {
 483     $dbh->rollback if $oldAutoCommit;
 484     return $error;
 485   }
 486
 487   #for prepaid packages,
 488   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 489   foreach my $old_svc_acct ( @svc_acct ) {
 490     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 491     my $s_error = $new_svc_acct->replace($old_svc_acct);
 492     if ( $s_error ) {
 493       $dbh->rollback if $oldAutoCommit;
 494       return $s_error;
 495     }
 496   }
 497
 498   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 499   '';
 500
 501 }
 502
 503 =item check
 504
 505 Checks all fields to make sure this is a valid billing item.  If there is an
 506 error, returns the error, otherwise returns false.  Called by the insert and
 507 replace methods.
 508
 509 =cut
 510
 511 sub check {
 512   my $self = shift;
 513
 514   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 515
 516   my $error =
 517     $self->ut_numbern('pkgnum')
 518     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 519     || $self->ut_numbern('pkgpart')
 520     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 521     || $self->ut_numbern('start_date')
 522     || $self->ut_numbern('setup')
 523     || $self->ut_numbern('bill')
 524     || $self->ut_numbern('susp')
 525     || $self->ut_numbern('cancel')
 526     || $self->ut_numbern('adjourn')
 527     || $self->ut_numbern('expire')
 528     || $self->ut_enum('no_auto', [ '', 'Y' ])
 529   ;
 530   return $error if $error;
 531
 532   if ( $self->reg_code ) {
 533
 534     unless ( grep { $self->pkgpart == $_->pkgpart }
 535              map  { $_->reg_code_pkg }
 536              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 537                                      'agentnum' => $self->cust_main->agentnum })
 538            ) {
 539       return "Unknown registration code";
 540     }
 541
 542   } elsif ( $self->promo_code ) {
 543
 544     my $promo_part_pkg =
 545       qsearchs('part_pkg', {
 546         'pkgpart'    => $self->pkgpart,
 547         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 548       } );
 549     return 'Unknown promotional code' unless $promo_part_pkg;
 550
 551   } else {
 552
 553     unless ( $disable_agentcheck ) {
 554       my $agent =
 555         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 556       return "agent ". $agent->agentnum. ':'. $agent->agent.
 557              " can't purchase pkgpart ". $self->pkgpart
 558         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 559             || $agent->agentnum == $self->part_pkg->agentnum;
 560     }
 561
 562     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 563     return $error if $error;
 564
 565   }
 566
 567   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 568
 569   if ( $self->dbdef_table->column('manual_flag') ) {
 570     $self->manual_flag('') if $self->manual_flag eq ' ';
 571     $self->manual_flag =~ /^([01]?)$/
 572       or return "Illegal manual_flag ". $self->manual_flag;
 573     $self->manual_flag($1);
 574   }
 575
 576   $self->SUPER::check;
 577 }
 578
 579 =item cancel [ OPTION => VALUE ... ]
 580
 581 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 582 in this package, then cancels the package itself (sets the cancel field to
 583 now).
 584
 585 Available options are:
 586
 587 =over 4
 588
 589 =item quiet - can be set true to supress email cancellation notices.
 590
 591 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 592
 593 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 594
 595 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 596
 597 =item nobill - can be set true to skip billing if it might otherwise be done.
 598
 599 =back
 600
 601 If there is an error, returns the error, otherwise returns false.
 602
 603 =cut
 604
 605 sub cancel {
 606   my( $self, %options ) = @_;
 607   my $error;
 608
 609   my $conf = new FS::Conf;
 610
 611   warn "cust_pkg::cancel called with options".
 612        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 613     if $DEBUG;
 614
 615   local $SIG{HUP} = 'IGNORE';
 616   local $SIG{INT} = 'IGNORE';
 617   local $SIG{QUIT} = 'IGNORE';
 618   local $SIG{TERM} = 'IGNORE';
 619   local $SIG{TSTP} = 'IGNORE';
 620   local $SIG{PIPE} = 'IGNORE';
 621
 622   my $oldAutoCommit = $FS::UID::AutoCommit;
 623   local $FS::UID::AutoCommit = 0;
 624   my $dbh = dbh;
 625
 626   my $old = $self->select_for_update;
 627
 628   if ( $old->get('cancel') || $self->get('cancel') ) {
 629     dbh->rollback if $oldAutoCommit;
 630     return "";  # no error
 631   }
 632
 633   my $date = $options{date} if $options{date}; # expire/cancel later
 634   $date = '' if ($date && $date <= time);      # complain instead?
 635
 636   #race condition: usage could be ongoing until unprovisioned
 637   #resolved by performing a change package instead (which unprovisions) and
 638   #later cancelling
 639   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 640       my $copy = $self->new({$self->hash});
 641       my $error =
 642         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 643       warn "Error billing during cancel, custnum ".
 644         #$self->cust_main->custnum. ": $error"
 645         ": $error"
 646         if $error;
 647   }
 648
 649
 650   my $cancel_time = $options{'time'} || time;
 651
 652   if ( $options{'reason'} ) {
 653     $error = $self->insert_reason( 'reason' => $options{'reason'},
 654                                    'action' => $date ? 'expire' : 'cancel',
 655                                    'date'   => $date ? $date : $cancel_time,
 656                                    'reason_otaker' => $options{'reason_otaker'},
 657                                  );
 658     if ( $error ) {
 659       dbh->rollback if $oldAutoCommit;
 660       return "Error inserting cust_pkg_reason: $error";
 661     }
 662   }
 663
 664   my %svc;
 665   unless ( $date ) {
 666     foreach my $cust_svc (
 667       #schwartz
 668       map  { $_->[0] }
 669       sort { $a->[1] <=> $b->[1] }
 670       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 671       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 672     ) {
 673
 674       my $error = $cust_svc->cancel;
 675
 676       if ( $error ) {
 677         $dbh->rollback if $oldAutoCommit;
 678         return "Error cancelling cust_svc: $error";
 679       }
 680     }
 681
 682     # Add a credit for remaining service
 683     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 684     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 685       my $error = $self->cust_main->credit(
 686         $remaining_value,
 687         'Credit for unused time on '. $self->part_pkg->pkg,
 688         'reason_type' => $conf->config('cancel_credit_type'),
 689       );
 690       if ($error) {
 691         $dbh->rollback if $oldAutoCommit;
 692         return "Error crediting customer \$$remaining_value for unused time on".
 693                $self->part_pkg->pkg. ": $error";
 694       }
 695     }
 696   }
 697
 698   my %hash = $self->hash;
 699   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 700   my $new = new FS::cust_pkg ( \%hash );
 701   $error = $new->replace( $self, options => { $self->options } );
 702   if ( $error ) {
 703     $dbh->rollback if $oldAutoCommit;
 704     return $error;
 705   }
 706
 707   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 708   return '' if $date; #no errors
 709
 710   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 711   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 712     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 713     my $error = '';
 714     if ( $msgnum ) {
 715       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 716       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 717                                     'object'    => $self );
 718     }
 719     else {
 720       $error = send_email(
 721         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 722         'to'      => \@invoicing_list,
 723         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 724         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 725       );
 726     }
 727     #should this do something on errors?
 728   }
 729
 730   ''; #no errors
 731
 732 }
 733
 734 =item cancel_if_expired [ NOW_TIMESTAMP ]
 735
 736 Cancels this package if its expire date has been reached.
 737
 738 =cut
 739
 740 sub cancel_if_expired {
 741   my $self = shift;
 742   my $time = shift || time;
 743   return '' unless $self->expire && $self->expire <= $time;
 744   my $error = $self->cancel;
 745   if ( $error ) {
 746     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 747            $self->custnum. ": $error";
 748   }
 749   '';
 750 }
 751
 752 =item unexpire
 753
 754 Cancels any pending expiration (sets the expire field to null).
 755
 756 If there is an error, returns the error, otherwise returns false.
 757
 758 =cut
 759
 760 sub unexpire {
 761   my( $self, %options ) = @_;
 762   my $error;
 763
 764   local $SIG{HUP} = 'IGNORE';
 765   local $SIG{INT} = 'IGNORE';
 766   local $SIG{QUIT} = 'IGNORE';
 767   local $SIG{TERM} = 'IGNORE';
 768   local $SIG{TSTP} = 'IGNORE';
 769   local $SIG{PIPE} = 'IGNORE';
 770
 771   my $oldAutoCommit = $FS::UID::AutoCommit;
 772   local $FS::UID::AutoCommit = 0;
 773   my $dbh = dbh;
 774
 775   my $old = $self->select_for_update;
 776
 777   my $pkgnum = $old->pkgnum;
 778   if ( $old->get('cancel') || $self->get('cancel') ) {
 779     dbh->rollback if $oldAutoCommit;
 780     return "Can't unexpire cancelled package $pkgnum";
 781     # or at least it's pointless
 782   }
 783
 784   unless ( $old->get('expire') && $self->get('expire') ) {
 785     dbh->rollback if $oldAutoCommit;
 786     return "";  # no error
 787   }
 788
 789   my %hash = $self->hash;
 790   $hash{'expire'} = '';
 791   my $new = new FS::cust_pkg ( \%hash );
 792   $error = $new->replace( $self, options => { $self->options } );
 793   if ( $error ) {
 794     $dbh->rollback if $oldAutoCommit;
 795     return $error;
 796   }
 797
 798   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 799
 800   ''; #no errors
 801
 802 }
 803
 804 =item suspend [ OPTION => VALUE ... ]
 805
 806 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 807 package, then suspends the package itself (sets the susp field to now).
 808
 809 Available options are:
 810
 811 =over 4
 812
 813 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 814
 815 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 816
 817 =back
 818
 819 If there is an error, returns the error, otherwise returns false.
 820
 821 =cut
 822
 823 sub suspend {
 824   my( $self, %options ) = @_;
 825   my $error;
 826
 827   local $SIG{HUP} = 'IGNORE';
 828   local $SIG{INT} = 'IGNORE';
 829   local $SIG{QUIT} = 'IGNORE';
 830   local $SIG{TERM} = 'IGNORE';
 831   local $SIG{TSTP} = 'IGNORE';
 832   local $SIG{PIPE} = 'IGNORE';
 833
 834   my $oldAutoCommit = $FS::UID::AutoCommit;
 835   local $FS::UID::AutoCommit = 0;
 836   my $dbh = dbh;
 837
 838   my $old = $self->select_for_update;
 839
 840   my $pkgnum = $old->pkgnum;
 841   if ( $old->get('cancel') || $self->get('cancel') ) {
 842     dbh->rollback if $oldAutoCommit;
 843     return "Can't suspend cancelled package $pkgnum";
 844   }
 845
 846   if ( $old->get('susp') || $self->get('susp') ) {
 847     dbh->rollback if $oldAutoCommit;
 848     return "";  # no error                     # complain on adjourn?
 849   }
 850
 851   my $date = $options{date} if $options{date}; # adjourn/suspend later
 852   $date = '' if ($date && $date <= time);      # complain instead?
 853
 854   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 855     dbh->rollback if $oldAutoCommit;
 856     return "Package $pkgnum expires before it would be suspended.";
 857   }
 858
 859   my $suspend_time = $options{'time'} || time;
 860
 861   if ( $options{'reason'} ) {
 862     $error = $self->insert_reason( 'reason' => $options{'reason'},
 863                                    'action' => $date ? 'adjourn' : 'suspend',
 864                                    'date'   => $date ? $date : $suspend_time,
 865                                    'reason_otaker' => $options{'reason_otaker'},
 866                                  );
 867     if ( $error ) {
 868       dbh->rollback if $oldAutoCommit;
 869       return "Error inserting cust_pkg_reason: $error";
 870     }
 871   }
 872
 873   unless ( $date ) {
 874
 875     my @labels = ();
 876
 877     foreach my $cust_svc (
 878       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 879     ) {
 880       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 881
 882       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 883         $dbh->rollback if $oldAutoCommit;
 884         return "Illegal svcdb value in part_svc!";
 885       };
 886       my $svcdb = $1;
 887       require "FS/$svcdb.pm";
 888
 889       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 890       if ($svc) {
 891         $error = $svc->suspend;
 892         if ( $error ) {
 893           $dbh->rollback if $oldAutoCommit;
 894           return $error;
 895         }
 896         my( $label, $value ) = $cust_svc->label;
 897         push @labels, "$label: $value";
 898       }
 899     }
 900
 901     my $conf = new FS::Conf;
 902     if ( $conf->config('suspend_email_admin') ) {
 903
 904       my $error = send_email(
 905         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 906                                    #invoice_from ??? well as good as any
 907         'to'      => $conf->config('suspend_email_admin'),
 908         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 909         'body'    => [
 910           "This is an automatic message from your Freeside installation\n",
 911           "informing you that the following customer package has been suspended:\n",
 912           "\n",
 913           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 914           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 915           ( map { "Service : $_\n" } @labels ),
 916         ],
 917       );
 918
 919       if ( $error ) {
 920         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 921              "$error\n";
 922       }
 923
 924     }
 925
 926   }
 927
 928   my %hash = $self->hash;
 929   if ( $date ) {
 930     $hash{'adjourn'} = $date;
 931   } else {
 932     $hash{'susp'} = $suspend_time;
 933   }
 934   my $new = new FS::cust_pkg ( \%hash );
 935   $error = $new->replace( $self, options => { $self->options } );
 936   if ( $error ) {
 937     $dbh->rollback if $oldAutoCommit;
 938     return $error;
 939   }
 940
 941   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 942
 943   ''; #no errors
 944 }
 945
 946 =item unsuspend [ OPTION => VALUE ... ]
 947
 948 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 949 package, then unsuspends the package itself (clears the susp field and the
 950 adjourn field if it is in the past).
 951
 952 Available options are:
 953
 954 =over 4
 955
 956 =item adjust_next_bill
 957
 958 Can be set true to adjust the next bill date forward by
 959 the amount of time the account was inactive.  This was set true by default
 960 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 961 explicitly requested.  Price plans for which this makes sense (anniversary-date
 962 based than prorate or subscription) could have an option to enable this
 963 behaviour?
 964
 965 =back
 966
 967 If there is an error, returns the error, otherwise returns false.
 968
 969 =cut
 970
 971 sub unsuspend {
 972   my( $self, %opt ) = @_;
 973   my $error;
 974
 975   local $SIG{HUP} = 'IGNORE';
 976   local $SIG{INT} = 'IGNORE';
 977   local $SIG{QUIT} = 'IGNORE';
 978   local $SIG{TERM} = 'IGNORE';
 979   local $SIG{TSTP} = 'IGNORE';
 980   local $SIG{PIPE} = 'IGNORE';
 981
 982   my $oldAutoCommit = $FS::UID::AutoCommit;
 983   local $FS::UID::AutoCommit = 0;
 984   my $dbh = dbh;
 985
 986   my $old = $self->select_for_update;
 987
 988   my $pkgnum = $old->pkgnum;
 989   if ( $old->get('cancel') || $self->get('cancel') ) {
 990     dbh->rollback if $oldAutoCommit;
 991     return "Can't unsuspend cancelled package $pkgnum";
 992   }
 993
 994   unless ( $old->get('susp') && $self->get('susp') ) {
 995     dbh->rollback if $oldAutoCommit;
 996     return "";  # no error                     # complain instead?
 997   }
 998
 999   foreach my $cust_svc (
1000     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1001   ) {
1002     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1003
1004     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1005       $dbh->rollback if $oldAutoCommit;
1006       return "Illegal svcdb value in part_svc!";
1007     };
1008     my $svcdb = $1;
1009     require "FS/$svcdb.pm";
1010
1011     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1012     if ($svc) {
1013       $error = $svc->unsuspend;
1014       if ( $error ) {
1015         $dbh->rollback if $oldAutoCommit;
1016         return $error;
1017       }
1018     }
1019
1020   }
1021
1022   my %hash = $self->hash;
1023   my $inactive = time - $hash{'susp'};
1024
1025   my $conf = new FS::Conf;
1026
1027   if ( $inactive > 0 &&
1028        ( $hash{'bill'} || $hash{'setup'} ) &&
1029        ( $opt{'adjust_next_bill'} ||
1030          $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1031          $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1032      ) {
1033
1034     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1035
1036   }
1037
1038   $hash{'susp'} = '';
1039   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1040   my $new = new FS::cust_pkg ( \%hash );
1041   $error = $new->replace( $self, options => { $self->options } );
1042   if ( $error ) {
1043     $dbh->rollback if $oldAutoCommit;
1044     return $error;
1045   }
1046
1047   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1048
1049   ''; #no errors
1050 }
1051
1052 =item unadjourn
1053
1054 Cancels any pending suspension (sets the adjourn field to null).
1055
1056 If there is an error, returns the error, otherwise returns false.
1057
1058 =cut
1059
1060 sub unadjourn {
1061   my( $self, %options ) = @_;
1062   my $error;
1063
1064   local $SIG{HUP} = 'IGNORE';
1065   local $SIG{INT} = 'IGNORE';
1066   local $SIG{QUIT} = 'IGNORE';
1067   local $SIG{TERM} = 'IGNORE';
1068   local $SIG{TSTP} = 'IGNORE';
1069   local $SIG{PIPE} = 'IGNORE';
1070
1071   my $oldAutoCommit = $FS::UID::AutoCommit;
1072   local $FS::UID::AutoCommit = 0;
1073   my $dbh = dbh;
1074
1075   my $old = $self->select_for_update;
1076
1077   my $pkgnum = $old->pkgnum;
1078   if ( $old->get('cancel') || $self->get('cancel') ) {
1079     dbh->rollback if $oldAutoCommit;
1080     return "Can't unadjourn cancelled package $pkgnum";
1081     # or at least it's pointless
1082   }
1083
1084   if ( $old->get('susp') || $self->get('susp') ) {
1085     dbh->rollback if $oldAutoCommit;
1086     return "Can't unadjourn suspended package $pkgnum";
1087     # perhaps this is arbitrary
1088   }
1089
1090   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1091     dbh->rollback if $oldAutoCommit;
1092     return "";  # no error
1093   }
1094
1095   my %hash = $self->hash;
1096   $hash{'adjourn'} = '';
1097   my $new = new FS::cust_pkg ( \%hash );
1098   $error = $new->replace( $self, options => { $self->options } );
1099   if ( $error ) {
1100     $dbh->rollback if $oldAutoCommit;
1101     return $error;
1102   }
1103
1104   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1105
1106   ''; #no errors
1107
1108 }
1109
1110
1111 =item change HASHREF | OPTION => VALUE ...
1112
1113 Changes this package: cancels it and creates a new one, with a different
1114 pkgpart or locationnum or both.  All services are transferred to the new
1115 package (no change will be made if this is not possible).
1116
1117 Options may be passed as a list of key/value pairs or as a hash reference.
1118 Options are:
1119
1120 =over 4
1121
1122 =item locaitonnum
1123
1124 New locationnum, to change the location for this package.
1125
1126 =item cust_location
1127
1128 New FS::cust_location object, to create a new location and assign it
1129 to this package.
1130
1131 =item pkgpart
1132
1133 New pkgpart (see L<FS::part_pkg>).
1134
1135 =item refnum
1136
1137 New refnum (see L<FS::part_referral>).
1138
1139 =back
1140
1141 At least one option must be specified (otherwise, what's the point?)
1142
1143 Returns either the new FS::cust_pkg object or a scalar error.
1144
1145 For example:
1146
1147   my $err_or_new_cust_pkg = $old_cust_pkg->change
1148
1149 =cut
1150
1151 #some false laziness w/order
1152 sub change {
1153   my $self = shift;
1154   my $opt = ref($_[0]) ? shift : { @_ };
1155
1156 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1157 #
1158
1159   my $conf = new FS::Conf;
1160
1161   # Transactionize this whole mess
1162   local $SIG{HUP} = 'IGNORE';
1163   local $SIG{INT} = 'IGNORE';
1164   local $SIG{QUIT} = 'IGNORE';
1165   local $SIG{TERM} = 'IGNORE';
1166   local $SIG{TSTP} = 'IGNORE';
1167   local $SIG{PIPE} = 'IGNORE';
1168
1169   my $oldAutoCommit = $FS::UID::AutoCommit;
1170   local $FS::UID::AutoCommit = 0;
1171   my $dbh = dbh;
1172
1173   my $error;
1174
1175   my %hash = ();
1176
1177   my $time = time;
1178
1179   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1180
1181   #$hash{$_} = $self->$_() foreach qw( setup );
1182
1183   $hash{'setup'} = $time if $self->setup;
1184
1185   $hash{'change_date'} = $time;
1186   $hash{"change_$_"}  = $self->$_()
1187     foreach qw( pkgnum pkgpart locationnum );
1188
1189   if ( $opt->{'cust_location'} &&
1190        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1191     $error = $opt->{'cust_location'}->insert;
1192     if ( $error ) {
1193       $dbh->rollback if $oldAutoCommit;
1194       return "inserting cust_location (transaction rolled back): $error";
1195     }
1196     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1197   }
1198
1199   # Create the new package.
1200   my $cust_pkg = new FS::cust_pkg {
1201     custnum      => $self->custnum,
1202     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1203     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1204     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1205     %hash,
1206   };
1207
1208   $error = $cust_pkg->insert( 'change' => 1 );
1209   if ($error) {
1210     $dbh->rollback if $oldAutoCommit;
1211     return $error;
1212   }
1213
1214   # Transfer services and cancel old package.
1215
1216   $error = $self->transfer($cust_pkg);
1217   if ($error and $error == 0) {
1218     # $old_pkg->transfer failed.
1219     $dbh->rollback if $oldAutoCommit;
1220     return $error;
1221   }
1222
1223   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1224     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1225     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1226     if ($error and $error == 0) {
1227       # $old_pkg->transfer failed.
1228       $dbh->rollback if $oldAutoCommit;
1229       return $error;
1230     }
1231   }
1232
1233   if ($error > 0) {
1234     # Transfers were successful, but we still had services left on the old
1235     # package.  We can't change the package under this circumstances, so abort.
1236     $dbh->rollback if $oldAutoCommit;
1237     return "Unable to transfer all services from package ". $self->pkgnum;
1238   }
1239
1240   #reset usage if changing pkgpart
1241   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1242   if ($self->pkgpart != $cust_pkg->pkgpart) {
1243     my $part_pkg = $cust_pkg->part_pkg;
1244     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1245                                                  ? ()
1246                                                  : ( 'null' => 1 )
1247                                    )
1248       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1249
1250     if ($error) {
1251       $dbh->rollback if $oldAutoCommit;
1252       return "Error setting usage values: $error";
1253     }
1254   }
1255
1256   #Good to go, cancel old package.
1257   $error = $self->cancel( quiet=>1 );
1258   if ($error) {
1259     $dbh->rollback if $oldAutoCommit;
1260     return $error;
1261   }
1262
1263   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1264     #$self->cust_main
1265     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1266     if ( $error ) {
1267       $dbh->rollback if $oldAutoCommit;
1268       return $error;
1269     }
1270   }
1271
1272   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1273
1274   $cust_pkg;
1275
1276 }
1277
1278 =item last_bill
1279
1280 Returns the last bill date, or if there is no last bill date, the setup date.
1281 Useful for billing metered services.
1282
1283 =cut
1284
1285 sub last_bill {
1286   my $self = shift;
1287   return $self->setfield('last_bill', $_[0]) if @_;
1288   return $self->getfield('last_bill') if $self->getfield('last_bill');
1289   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1290                                                   'edate'  => $self->bill,  } );
1291   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1292 }
1293
1294 =item last_cust_pkg_reason ACTION
1295
1296 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1297 Returns false if there is no reason or the package is not currenly ACTION'd
1298 ACTION is one of adjourn, susp, cancel, or expire.
1299
1300 =cut
1301
1302 sub last_cust_pkg_reason {
1303   my ( $self, $action ) = ( shift, shift );
1304   my $date = $self->get($action);
1305   qsearchs( {
1306               'table' => 'cust_pkg_reason',
1307               'hashref' => { 'pkgnum' => $self->pkgnum,
1308                              'action' => substr(uc($action), 0, 1),
1309                              'date'   => $date,
1310                            },
1311               'order_by' => 'ORDER BY num DESC LIMIT 1',
1312            } );
1313 }
1314
1315 =item last_reason ACTION
1316
1317 Returns the most recent ACTION FS::reason associated with the package.
1318 Returns false if there is no reason or the package is not currenly ACTION'd
1319 ACTION is one of adjourn, susp, cancel, or expire.
1320
1321 =cut
1322
1323 sub last_reason {
1324   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1325   $cust_pkg_reason->reason
1326     if $cust_pkg_reason;
1327 }
1328
1329 =item part_pkg
1330
1331 Returns the definition for this billing item, as an FS::part_pkg object (see
1332 L<FS::part_pkg>).
1333
1334 =cut
1335
1336 sub part_pkg {
1337   my $self = shift;
1338   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1339   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1340   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1341 }
1342
1343 =item old_cust_pkg
1344
1345 Returns the cancelled package this package was changed from, if any.
1346
1347 =cut
1348
1349 sub old_cust_pkg {
1350   my $self = shift;
1351   return '' unless $self->change_pkgnum;
1352   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1353 }
1354
1355 =item calc_setup
1356
1357 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1358 item.
1359
1360 =cut
1361
1362 sub calc_setup {
1363   my $self = shift;
1364   $self->part_pkg->calc_setup($self, @_);
1365 }
1366
1367 =item calc_recur
1368
1369 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1370 item.
1371
1372 =cut
1373
1374 sub calc_recur {
1375   my $self = shift;
1376   $self->part_pkg->calc_recur($self, @_);
1377 }
1378
1379 =item calc_remain
1380
1381 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1382 billing item.
1383
1384 =cut
1385
1386 sub calc_remain {
1387   my $self = shift;
1388   $self->part_pkg->calc_remain($self, @_);
1389 }
1390
1391 =item calc_cancel
1392
1393 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1394 billing item.
1395
1396 =cut
1397
1398 sub calc_cancel {
1399   my $self = shift;
1400   $self->part_pkg->calc_cancel($self, @_);
1401 }
1402
1403 =item cust_bill_pkg
1404
1405 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1406
1407 =cut
1408
1409 sub cust_bill_pkg {
1410   my $self = shift;
1411   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1412 }
1413
1414 =item cust_pkg_detail [ DETAILTYPE ]
1415
1416 Returns any customer package details for this package (see
1417 L<FS::cust_pkg_detail>).
1418
1419 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1420
1421 =cut
1422
1423 sub cust_pkg_detail {
1424   my $self = shift;
1425   my %hash = ( 'pkgnum' => $self->pkgnum );
1426   $hash{detailtype} = shift if @_;
1427   qsearch({
1428     'table'    => 'cust_pkg_detail',
1429     'hashref'  => \%hash,
1430     'order_by' => 'ORDER BY weight, pkgdetailnum',
1431   });
1432 }
1433
1434 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1435
1436 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1437
1438 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1439
1440 If there is an error, returns the error, otherwise returns false.
1441
1442 =cut
1443
1444 sub set_cust_pkg_detail {
1445   my( $self, $detailtype, @details ) = @_;
1446
1447   local $SIG{HUP} = 'IGNORE';
1448   local $SIG{INT} = 'IGNORE';
1449   local $SIG{QUIT} = 'IGNORE';
1450   local $SIG{TERM} = 'IGNORE';
1451   local $SIG{TSTP} = 'IGNORE';
1452   local $SIG{PIPE} = 'IGNORE';
1453
1454   my $oldAutoCommit = $FS::UID::AutoCommit;
1455   local $FS::UID::AutoCommit = 0;
1456   my $dbh = dbh;
1457
1458   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1459     my $error = $current->delete;
1460     if ( $error ) {
1461       $dbh->rollback if $oldAutoCommit;
1462       return "error removing old detail: $error";
1463     }
1464   }
1465
1466   foreach my $detail ( @details ) {
1467     my $cust_pkg_detail = new FS::cust_pkg_detail {
1468       'pkgnum'     => $self->pkgnum,
1469       'detailtype' => $detailtype,
1470       'detail'     => $detail,
1471     };
1472     my $error = $cust_pkg_detail->insert;
1473     if ( $error ) {
1474       $dbh->rollback if $oldAutoCommit;
1475       return "error adding new detail: $error";
1476     }
1477
1478   }
1479
1480   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1481   '';
1482
1483 }
1484
1485 =item cust_event
1486
1487 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1488
1489 =cut
1490
1491 #false laziness w/cust_bill.pm
1492 sub cust_event {
1493   my $self = shift;
1494   qsearch({
1495     'table'     => 'cust_event',
1496     'addl_from' => 'JOIN part_event USING ( eventpart )',
1497     'hashref'   => { 'tablenum' => $self->pkgnum },
1498     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1499   });
1500 }
1501
1502 =item num_cust_event
1503
1504 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1505
1506 =cut
1507
1508 #false laziness w/cust_bill.pm
1509 sub num_cust_event {
1510   my $self = shift;
1511   my $sql =
1512     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1513     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1514   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1515   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1516   $sth->fetchrow_arrayref->[0];
1517 }
1518
1519 =item cust_svc [ SVCPART ]
1520
1521 Returns the services for this package, as FS::cust_svc objects (see
1522 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1523 services.
1524
1525 =cut
1526
1527 sub cust_svc {
1528   my $self = shift;
1529
1530   return () unless $self->num_cust_svc(@_);
1531
1532   if ( @_ ) {
1533     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1534                                   'svcpart' => shift,          } );
1535   }
1536
1537   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1538
1539   #if ( $self->{'_svcnum'} ) {
1540   #  values %{ $self->{'_svcnum'}->cache };
1541   #} else {
1542     $self->_sort_cust_svc(
1543       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1544     );
1545   #}
1546
1547 }
1548
1549 =item overlimit [ SVCPART ]
1550
1551 Returns the services for this package which have exceeded their
1552 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1553 is specified, return only the matching services.
1554
1555 =cut
1556
1557 sub overlimit {
1558   my $self = shift;
1559   return () unless $self->num_cust_svc(@_);
1560   grep { $_->overlimit } $self->cust_svc(@_);
1561 }
1562
1563 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1564
1565 Returns historical services for this package created before END TIMESTAMP and
1566 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1567 (see L<FS::h_cust_svc>).
1568
1569 =cut
1570
1571 sub h_cust_svc {
1572   my $self = shift;
1573
1574   $self->_sort_cust_svc(
1575     [ qsearch( 'h_cust_svc',
1576                { 'pkgnum' => $self->pkgnum, },
1577                FS::h_cust_svc->sql_h_search(@_),
1578              )
1579     ]
1580   );
1581 }
1582
1583 sub _sort_cust_svc {
1584   my( $self, $arrayref ) = @_;
1585
1586   my $sort =
1587     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1588
1589   map  { $_->[0] }
1590   sort $sort
1591   map {
1592         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1593                                              'svcpart' => $_->svcpart     } );
1594         [ $_,
1595           $pkg_svc ? $pkg_svc->primary_svc : '',
1596           $pkg_svc ? $pkg_svc->quantity : 0,
1597         ];
1598       }
1599   @$arrayref;
1600
1601 }
1602
1603 =item num_cust_svc [ SVCPART ]
1604
1605 Returns the number of provisioned services for this package.  If a svcpart is
1606 specified, counts only the matching services.
1607
1608 =cut
1609
1610 sub num_cust_svc {
1611   my $self = shift;
1612
1613   return $self->{'_num_cust_svc'}
1614     if !scalar(@_)
1615        && exists($self->{'_num_cust_svc'})
1616        && $self->{'_num_cust_svc'} =~ /\d/;
1617
1618   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1619     if $DEBUG > 2;
1620
1621   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1622   $sql .= ' AND svcpart = ?' if @_;
1623
1624   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1625   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1626   $sth->fetchrow_arrayref->[0];
1627 }
1628
1629 =item available_part_svc
1630
1631 Returns a list of FS::part_svc objects representing services included in this
1632 package but not yet provisioned.  Each FS::part_svc object also has an extra
1633 field, I<num_avail>, which specifies the number of available services.
1634
1635 =cut
1636
1637 sub available_part_svc {
1638   my $self = shift;
1639   grep { $_->num_avail > 0 }
1640     map {
1641           my $part_svc = $_->part_svc;
1642           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1643             $_->quantity - $self->num_cust_svc($_->svcpart);
1644           $part_svc;
1645         }
1646       $self->part_pkg->pkg_svc;
1647 }
1648
1649 =item part_svc
1650
1651 Returns a list of FS::part_svc objects representing provisioned and available
1652 services included in this package.  Each FS::part_svc object also has the
1653 following extra fields:
1654
1655 =over 4
1656
1657 =item num_cust_svc  (count)
1658
1659 =item num_avail     (quantity - count)
1660
1661 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1662
1663 svcnum
1664 label -> ($cust_svc->label)[1]
1665
1666 =back
1667
1668 =cut
1669
1670 sub part_svc {
1671   my $self = shift;
1672
1673   #XXX some sort of sort order besides numeric by svcpart...
1674   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1675     my $pkg_svc = $_;
1676     my $part_svc = $pkg_svc->part_svc;
1677     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1678     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1679     $part_svc->{'Hash'}{'num_avail'}    =
1680       max( 0, $pkg_svc->quantity - $num_cust_svc );
1681     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1682       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1683     $part_svc;
1684   } $self->part_pkg->pkg_svc;
1685
1686   #extras
1687   push @part_svc, map {
1688     my $part_svc = $_;
1689     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1690     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1691     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1692     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1693       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1694     $part_svc;
1695   } $self->extra_part_svc;
1696
1697   @part_svc;
1698
1699 }
1700
1701 =item extra_part_svc
1702
1703 Returns a list of FS::part_svc objects corresponding to services in this
1704 package which are still provisioned but not (any longer) available in the
1705 package definition.
1706
1707 =cut
1708
1709 sub extra_part_svc {
1710   my $self = shift;
1711
1712   my $pkgnum  = $self->pkgnum;
1713   my $pkgpart = $self->pkgpart;
1714
1715 #  qsearch( {
1716 #    'table'     => 'part_svc',
1717 #    'hashref'   => {},
1718 #    'extra_sql' =>
1719 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1720 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1721 #                       AND pkg_svc.pkgpart = ?
1722 #                       AND quantity > 0
1723 #                 )
1724 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1725 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1726 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1727 #                       AND pkgnum = ?
1728 #                 )",
1729 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1730 #  } );
1731
1732 #seems to benchmark slightly faster...
1733   qsearch( {
1734     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1735     #MySQL doesn't grok DISINCT ON
1736     'select'      => 'DISTINCT part_svc.*',
1737     'table'       => 'part_svc',
1738     'addl_from'   =>
1739       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1740                                AND pkg_svc.pkgpart   = ?
1741                                AND quantity > 0
1742                              )
1743        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1744        LEFT JOIN cust_pkg USING ( pkgnum )
1745       ',
1746     'hashref'     => {},
1747     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1748     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1749   } );
1750 }
1751
1752 =item status
1753
1754 Returns a short status string for this package, currently:
1755
1756 =over 4
1757
1758 =item not yet billed
1759
1760 =item one-time charge
1761
1762 =item active
1763
1764 =item suspended
1765
1766 =item cancelled
1767
1768 =back
1769
1770 =cut
1771
1772 sub status {
1773   my $self = shift;
1774
1775   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1776
1777   return 'cancelled' if $self->get('cancel');
1778   return 'suspended' if $self->susp;
1779   return 'not yet billed' unless $self->setup;
1780   return 'one-time charge' if $freq =~ /^(0|$)/;
1781   return 'active';
1782 }
1783
1784 =item ucfirst_status
1785
1786 Returns the status with the first character capitalized.
1787
1788 =cut
1789
1790 sub ucfirst_status {
1791   ucfirst(shift->status);
1792 }
1793
1794 =item statuses
1795
1796 Class method that returns the list of possible status strings for packages
1797 (see L<the status method|/status>).  For example:
1798
1799   @statuses = FS::cust_pkg->statuses();
1800
1801 =cut
1802
1803 tie my %statuscolor, 'Tie::IxHash',
1804   'not yet billed'  => '000000',
1805   'one-time charge' => '000000',
1806   'active'          => '00CC00',
1807   'suspended'       => 'FF9900',
1808   'cancelled'       => 'FF0000',
1809 ;
1810
1811 sub statuses {
1812   my $self = shift; #could be class...
1813   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1814   #                                    # mayble split btw one-time vs. recur
1815     keys %statuscolor;
1816 }
1817
1818 =item statuscolor
1819
1820 Returns a hex triplet color string for this package's status.
1821
1822 =cut
1823
1824 sub statuscolor {
1825   my $self = shift;
1826   $statuscolor{$self->status};
1827 }
1828
1829 =item pkg_label
1830
1831 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1832 "pkg-comment" depending on user preference).
1833
1834 =cut
1835
1836 sub pkg_label {
1837   my $self = shift;
1838   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1839   $label = $self->pkgnum. ": $label"
1840     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1841   $label;
1842 }
1843
1844 =item pkg_label_long
1845
1846 Returns a long label for this package, adding the primary service's label to
1847 pkg_label.
1848
1849 =cut
1850
1851 sub pkg_label_long {
1852   my $self = shift;
1853   my $label = $self->pkg_label;
1854   my $cust_svc = $self->primary_cust_svc;
1855   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1856   $label;
1857 }
1858
1859 =item primary_cust_svc
1860
1861 Returns a primary service (as FS::cust_svc object) if one can be identified.
1862
1863 =cut
1864
1865 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1866
1867 sub primary_cust_svc {
1868   my $self = shift;
1869
1870   my @cust_svc = $self->cust_svc;
1871
1872   return '' unless @cust_svc; #no serivces - irrelevant then
1873
1874   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1875
1876   # primary service as specified in the package definition
1877   # or exactly one service definition with quantity one
1878   my $svcpart = $self->part_pkg->svcpart;
1879   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1880   return $cust_svc[0] if scalar(@cust_svc) == 1;
1881
1882   #couldn't identify one thing..
1883   return '';
1884 }
1885
1886 =item labels
1887
1888 Returns a list of lists, calling the label method for all services
1889 (see L<FS::cust_svc>) of this billing item.
1890
1891 =cut
1892
1893 sub labels {
1894   my $self = shift;
1895   map { [ $_->label ] } $self->cust_svc;
1896 }
1897
1898 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1899
1900 Like the labels method, but returns historical information on services that
1901 were active as of END_TIMESTAMP and (optionally) not cancelled before
1902 START_TIMESTAMP.
1903
1904 Returns a list of lists, calling the label method for all (historical) services
1905 (see L<FS::h_cust_svc>) of this billing item.
1906
1907 =cut
1908
1909 sub h_labels {
1910   my $self = shift;
1911   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1912 }
1913
1914 =item labels_short
1915
1916 Like labels, except returns a simple flat list, and shortens long
1917 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1918 identical services to one line that lists the service label and the number of
1919 individual services rather than individual items.
1920
1921 =cut
1922
1923 sub labels_short {
1924   shift->_labels_short( 'labels', @_ );
1925 }
1926
1927 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1928
1929 Like h_labels, except returns a simple flat list, and shortens long
1930 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1931 identical services to one line that lists the service label and the number of
1932 individual services rather than individual items.
1933
1934 =cut
1935
1936 sub h_labels_short {
1937   shift->_labels_short( 'h_labels', @_ );
1938 }
1939
1940 sub _labels_short {
1941   my( $self, $method ) = ( shift, shift );
1942
1943   my $conf = new FS::Conf;
1944   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1945
1946   my %labels;
1947   #tie %labels, 'Tie::IxHash';
1948   push @{ $labels{$_->[0]} }, $_->[1]
1949     foreach $self->$method(@_);
1950   my @labels;
1951   foreach my $label ( keys %labels ) {
1952     my %seen = ();
1953     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1954     my $num = scalar(@values);
1955     if ( $num > $max_same_services ) {
1956       push @labels, "$label ($num)";
1957     } else {
1958       if ( $conf->exists('cust_bill-consolidate_services') ) {
1959         # push @labels, "$label: ". join(', ', @values);
1960         while ( @values ) {
1961           my $detail = "$label: ";
1962           $detail .= shift(@values). ', '
1963             while @values && length($detail.$values[0]) < 78;
1964           $detail =~ s/, $//;
1965           push @labels, $detail;
1966         }
1967       } else {
1968         push @labels, map { "$label: $_" } @values;
1969       }
1970     }
1971   }
1972
1973  @labels;
1974
1975 }
1976
1977 =item cust_main
1978
1979 Returns the parent customer object (see L<FS::cust_main>).
1980
1981 =cut
1982
1983 sub cust_main {
1984   my $self = shift;
1985   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1986 }
1987
1988 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1989
1990 =item cust_location
1991
1992 Returns the location object, if any (see L<FS::cust_location>).
1993
1994 =item cust_location_or_main
1995
1996 If this package is associated with a location, returns the locaiton (see
1997 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1998
1999 =item location_label [ OPTION => VALUE ... ]
2000
2001 Returns the label of the location object (see L<FS::cust_location>).
2002
2003 =cut
2004
2005 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2006
2007 =item seconds_since TIMESTAMP
2008
2009 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2010 package have been online since TIMESTAMP, according to the session monitor.
2011
2012 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2013 L<Time::Local> and L<Date::Parse> for conversion functions.
2014
2015 =cut
2016
2017 sub seconds_since {
2018   my($self, $since) = @_;
2019   my $seconds = 0;
2020
2021   foreach my $cust_svc (
2022     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2023   ) {
2024     $seconds += $cust_svc->seconds_since($since);
2025   }
2026
2027   $seconds;
2028
2029 }
2030
2031 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2032
2033 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2034 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2035 (exclusive).
2036
2037 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2038 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2039 functions.
2040
2041
2042 =cut
2043
2044 sub seconds_since_sqlradacct {
2045   my($self, $start, $end) = @_;
2046
2047   my $seconds = 0;
2048
2049   foreach my $cust_svc (
2050     grep {
2051       my $part_svc = $_->part_svc;
2052       $part_svc->svcdb eq 'svc_acct'
2053         && scalar($part_svc->part_export('sqlradius'));
2054     } $self->cust_svc
2055   ) {
2056     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2057   }
2058
2059   $seconds;
2060
2061 }
2062
2063 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2064
2065 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2066 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2067 TIMESTAMP_END
2068 (exclusive).
2069
2070 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2071 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2072 functions.
2073
2074 =cut
2075
2076 sub attribute_since_sqlradacct {
2077   my($self, $start, $end, $attrib) = @_;
2078
2079   my $sum = 0;
2080
2081   foreach my $cust_svc (
2082     grep {
2083       my $part_svc = $_->part_svc;
2084       $part_svc->svcdb eq 'svc_acct'
2085         && scalar($part_svc->part_export('sqlradius'));
2086     } $self->cust_svc
2087   ) {
2088     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2089   }
2090
2091   $sum;
2092
2093 }
2094
2095 =item quantity
2096
2097 =cut
2098
2099 sub quantity {
2100   my( $self, $value ) = @_;
2101   if ( defined($value) ) {
2102     $self->setfield('quantity', $value);
2103   }
2104   $self->getfield('quantity') || 1;
2105 }
2106
2107 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2108
2109 Transfers as many services as possible from this package to another package.
2110
2111 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2112 object.  The destination package must already exist.
2113
2114 Services are moved only if the destination allows services with the correct
2115 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2116 this option with caution!  No provision is made for export differences
2117 between the old and new service definitions.  Probably only should be used
2118 when your exports for all service definitions of a given svcdb are identical.
2119 (attempt a transfer without it first, to move all possible svcpart-matching
2120 services)
2121
2122 Any services that can't be moved remain in the original package.
2123
2124 Returns an error, if there is one; otherwise, returns the number of services
2125 that couldn't be moved.
2126
2127 =cut
2128
2129 sub transfer {
2130   my ($self, $dest_pkgnum, %opt) = @_;
2131
2132   my $remaining = 0;
2133   my $dest;
2134   my %target;
2135
2136   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2137     $dest = $dest_pkgnum;
2138     $dest_pkgnum = $dest->pkgnum;
2139   } else {
2140     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2141   }
2142
2143   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2144
2145   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2146     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2147   }
2148
2149   foreach my $cust_svc ($dest->cust_svc) {
2150     $target{$cust_svc->svcpart}--;
2151   }
2152
2153   my %svcpart2svcparts = ();
2154   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2155     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2156     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2157       next if exists $svcpart2svcparts{$svcpart};
2158       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2159       $svcpart2svcparts{$svcpart} = [
2160         map  { $_->[0] }
2161         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2162         map {
2163               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2164                                                    'svcpart' => $_          } );
2165               [ $_,
2166                 $pkg_svc ? $pkg_svc->primary_svc : '',
2167                 $pkg_svc ? $pkg_svc->quantity : 0,
2168               ];
2169             }
2170
2171         grep { $_ != $svcpart }
2172         map  { $_->svcpart }
2173         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2174       ];
2175       warn "alternates for svcpart $svcpart: ".
2176            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2177         if $DEBUG;
2178     }
2179   }
2180
2181   foreach my $cust_svc ($self->cust_svc) {
2182     if($target{$cust_svc->svcpart} > 0) {
2183       $target{$cust_svc->svcpart}--;
2184       my $new = new FS::cust_svc { $cust_svc->hash };
2185       $new->pkgnum($dest_pkgnum);
2186       my $error = $new->replace($cust_svc);
2187       return $error if $error;
2188     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2189       if ( $DEBUG ) {
2190         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2191         warn "alternates to consider: ".
2192              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2193       }
2194       my @alternate = grep {
2195                              warn "considering alternate svcpart $_: ".
2196                                   "$target{$_} available in new package\n"
2197                                if $DEBUG;
2198                              $target{$_} > 0;
2199                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2200       if ( @alternate ) {
2201         warn "alternate(s) found\n" if $DEBUG;
2202         my $change_svcpart = $alternate[0];
2203         $target{$change_svcpart}--;
2204         my $new = new FS::cust_svc { $cust_svc->hash };
2205         $new->svcpart($change_svcpart);
2206         $new->pkgnum($dest_pkgnum);
2207         my $error = $new->replace($cust_svc);
2208         return $error if $error;
2209       } else {
2210         $remaining++;
2211       }
2212     } else {
2213       $remaining++
2214     }
2215   }
2216   return $remaining;
2217 }
2218
2219 =item reexport
2220
2221 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2222 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2223
2224 =cut
2225
2226 sub reexport {
2227   my $self = shift;
2228
2229   local $SIG{HUP} = 'IGNORE';
2230   local $SIG{INT} = 'IGNORE';
2231   local $SIG{QUIT} = 'IGNORE';
2232   local $SIG{TERM} = 'IGNORE';
2233   local $SIG{TSTP} = 'IGNORE';
2234   local $SIG{PIPE} = 'IGNORE';
2235
2236   my $oldAutoCommit = $FS::UID::AutoCommit;
2237   local $FS::UID::AutoCommit = 0;
2238   my $dbh = dbh;
2239
2240   foreach my $cust_svc ( $self->cust_svc ) {
2241     #false laziness w/svc_Common::insert
2242     my $svc_x = $cust_svc->svc_x;
2243     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2244       my $error = $part_export->export_insert($svc_x);
2245       if ( $error ) {
2246         $dbh->rollback if $oldAutoCommit;
2247         return $error;
2248       }
2249     }
2250   }
2251
2252   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2253   '';
2254
2255 }
2256
2257 =item insert_reason
2258
2259 Associates this package with a (suspension or cancellation) reason (see
2260 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2261 L<FS::reason>).
2262
2263 Available options are:
2264
2265 =over 4
2266
2267 =item reason
2268
2269 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
2270
2271 =item reason_otaker
2272
2273 the access_user (see L<FS::access_user>) providing the reason
2274
2275 =item date
2276
2277 a unix timestamp
2278
2279 =item action
2280
2281 the action (cancel, susp, adjourn, expire) associated with the reason
2282
2283 =back
2284
2285 If there is an error, returns the error, otherwise returns false.
2286
2287 =cut
2288
2289 sub insert_reason {
2290   my ($self, %options) = @_;
2291
2292   my $otaker = $options{reason_otaker} ||
2293                $FS::CurrentUser::CurrentUser->username;
2294
2295   my $reasonnum;
2296   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2297
2298     $reasonnum = $1;
2299
2300   } elsif ( ref($options{'reason'}) ) {
2301
2302     return 'Enter a new reason (or select an existing one)'
2303       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2304
2305     my $reason = new FS::reason({
2306       'reason_type' => $options{'reason'}->{'typenum'},
2307       'reason'      => $options{'reason'}->{'reason'},
2308     });
2309     my $error = $reason->insert;
2310     return $error if $error;
2311
2312     $reasonnum = $reason->reasonnum;
2313
2314   } else {
2315     return "Unparsable reason: ". $options{'reason'};
2316   }
2317
2318   my $cust_pkg_reason =
2319     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2320                               'reasonnum' => $reasonnum,
2321                               'otaker'    => $otaker,
2322                               'action'    => substr(uc($options{'action'}),0,1),
2323                               'date'      => $options{'date'}
2324                                                ? $options{'date'}
2325                                                : time,
2326                             });
2327
2328   $cust_pkg_reason->insert;
2329 }
2330
2331 =item insert_discount
2332
2333 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2334 inserting a new discount on the fly (see L<FS::discount>).
2335
2336 Available options are:
2337
2338 =over 4
2339
2340 =item discountnum
2341
2342 =back
2343
2344 If there is an error, returns the error, otherwise returns false.
2345
2346 =cut
2347
2348 sub insert_discount {
2349   #my ($self, %options) = @_;
2350   my $self = shift;
2351
2352   my $cust_pkg_discount = new FS::cust_pkg_discount {
2353     'pkgnum'      => $self->pkgnum,
2354     'discountnum' => $self->discountnum,
2355     'months_used' => 0,
2356     'end_date'    => '', #XXX
2357     'otaker'      => $self->otaker,
2358     #for the create a new discount case
2359     '_type'       => $self->discountnum__type,
2360     'amount'      => $self->discountnum_amount,
2361     'percent'     => $self->discountnum_percent,
2362     'months'      => $self->discountnum_months,
2363     #'disabled'    => $self->discountnum_disabled,
2364   };
2365
2366   $cust_pkg_discount->insert;
2367 }
2368
2369 =item set_usage USAGE_VALUE_HASHREF
2370
2371 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2372 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2373 upbytes, downbytes, and totalbytes are appropriate keys.
2374
2375 All svc_accts which are part of this package have their values reset.
2376
2377 =cut
2378
2379 sub set_usage {
2380   my ($self, $valueref, %opt) = @_;
2381
2382   foreach my $cust_svc ($self->cust_svc){
2383     my $svc_x = $cust_svc->svc_x;
2384     $svc_x->set_usage($valueref, %opt)
2385       if $svc_x->can("set_usage");
2386   }
2387 }
2388
2389 =item recharge USAGE_VALUE_HASHREF
2390
2391 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2392 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2393 upbytes, downbytes, and totalbytes are appropriate keys.
2394
2395 All svc_accts which are part of this package have their values incremented.
2396
2397 =cut
2398
2399 sub recharge {
2400   my ($self, $valueref) = @_;
2401
2402   foreach my $cust_svc ($self->cust_svc){
2403     my $svc_x = $cust_svc->svc_x;
2404     $svc_x->recharge($valueref)
2405       if $svc_x->can("recharge");
2406   }
2407 }
2408
2409 =item cust_pkg_discount
2410
2411 =cut
2412
2413 sub cust_pkg_discount {
2414   my $self = shift;
2415   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2416 }
2417
2418 =item cust_pkg_discount_active
2419
2420 =cut
2421
2422 sub cust_pkg_discount_active {
2423   my $self = shift;
2424   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2425 }
2426
2427 =back
2428
2429 =head1 CLASS METHODS
2430
2431 =over 4
2432
2433 =item recurring_sql
2434
2435 Returns an SQL expression identifying recurring packages.
2436
2437 =cut
2438
2439 sub recurring_sql { "
2440   '0' != ( select freq from part_pkg
2441              where cust_pkg.pkgpart = part_pkg.pkgpart )
2442 "; }
2443
2444 =item onetime_sql
2445
2446 Returns an SQL expression identifying one-time packages.
2447
2448 =cut
2449
2450 sub onetime_sql { "
2451   '0' = ( select freq from part_pkg
2452             where cust_pkg.pkgpart = part_pkg.pkgpart )
2453 "; }
2454
2455 =item ordered_sql
2456
2457 Returns an SQL expression identifying ordered packages (recurring packages not
2458 yet billed).
2459
2460 =cut
2461
2462 sub ordered_sql {
2463    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2464 }
2465
2466 =item active_sql
2467
2468 Returns an SQL expression identifying active packages.
2469
2470 =cut
2471
2472 sub active_sql {
2473   $_[0]->recurring_sql. "
2474   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2475   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2476   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2477 "; }
2478
2479 =item not_yet_billed_sql
2480
2481 Returns an SQL expression identifying packages which have not yet been billed.
2482
2483 =cut
2484
2485 sub not_yet_billed_sql { "
2486       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2487   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2488   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2489 "; }
2490
2491 =item inactive_sql
2492
2493 Returns an SQL expression identifying inactive packages (one-time packages
2494 that are otherwise unsuspended/uncancelled).
2495
2496 =cut
2497
2498 sub inactive_sql { "
2499   ". $_[0]->onetime_sql(). "
2500   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2501   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2502   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2503 "; }
2504
2505 =item susp_sql
2506 =item suspended_sql
2507
2508 Returns an SQL expression identifying suspended packages.
2509
2510 =cut
2511
2512 sub suspended_sql { susp_sql(@_); }
2513 sub susp_sql {
2514   #$_[0]->recurring_sql(). ' AND '.
2515   "
2516         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2517     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2518   ";
2519 }
2520
2521 =item cancel_sql
2522 =item cancelled_sql
2523
2524 Returns an SQL exprression identifying cancelled packages.
2525
2526 =cut
2527
2528 sub cancelled_sql { cancel_sql(@_); }
2529 sub cancel_sql {
2530   #$_[0]->recurring_sql(). ' AND '.
2531   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2532 }
2533
2534 =item search HASHREF
2535
2536 (Class method)
2537
2538 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2539 Valid parameters are
2540
2541 =over 4
2542
2543 =item agentnum
2544
2545 =item magic
2546
2547 active, inactive, suspended, cancel (or cancelled)
2548
2549 =item status
2550
2551 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2552
2553 =item custom
2554
2555  boolean selects custom packages
2556
2557 =item classnum
2558
2559 =item pkgpart
2560
2561 pkgpart or arrayref or hashref of pkgparts
2562
2563 =item setup
2564
2565 arrayref of beginning and ending epoch date
2566
2567 =item last_bill
2568
2569 arrayref of beginning and ending epoch date
2570
2571 =item bill
2572
2573 arrayref of beginning and ending epoch date
2574
2575 =item adjourn
2576
2577 arrayref of beginning and ending epoch date
2578
2579 =item susp
2580
2581 arrayref of beginning and ending epoch date
2582
2583 =item expire
2584
2585 arrayref of beginning and ending epoch date
2586
2587 =item cancel
2588
2589 arrayref of beginning and ending epoch date
2590
2591 =item query
2592
2593 pkgnum or APKG_pkgnum
2594
2595 =item cust_fields
2596
2597 a value suited to passing to FS::UI::Web::cust_header
2598
2599 =item CurrentUser
2600
2601 specifies the user for agent virtualization
2602
2603 =item fcc_line
2604
2605  boolean selects packages containing fcc form 477 telco lines
2606
2607 =back
2608
2609 =cut
2610
2611 sub search {
2612   my ($class, $params) = @_;
2613   my @where = ();
2614
2615   ##
2616   # parse agent
2617   ##
2618
2619   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2620     push @where,
2621       "cust_main.agentnum = $1";
2622   }
2623
2624   ##
2625   # parse custnum
2626   ##
2627
2628   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2629     push @where,
2630       "cust_pkg.custnum = $1";
2631   }
2632
2633   ##
2634   # custbatch
2635   ##
2636
2637   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2638     push @where,
2639       "cust_pkg.pkgbatch = '$1'";
2640   }
2641
2642   ##
2643   # parse status
2644   ##
2645
2646   if (    $params->{'magic'}  eq 'active'
2647        || $params->{'status'} eq 'active' ) {
2648
2649     push @where, FS::cust_pkg->active_sql();
2650
2651   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2652             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2653
2654     push @where, FS::cust_pkg->not_yet_billed_sql();
2655
2656   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2657             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2658
2659     push @where, FS::cust_pkg->inactive_sql();
2660
2661   } elsif (    $params->{'magic'}  eq 'suspended'
2662             || $params->{'status'} eq 'suspended'  ) {
2663
2664     push @where, FS::cust_pkg->suspended_sql();
2665
2666   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2667             || $params->{'status'} =~ /^cancell?ed$/ ) {
2668
2669     push @where, FS::cust_pkg->cancelled_sql();
2670
2671   }
2672
2673   ###
2674   # parse package class
2675   ###
2676
2677   #false lazinessish w/graph/cust_bill_pkg.cgi
2678   my $classnum = 0;
2679   my @pkg_class = ();
2680   if ( exists($params->{'classnum'})
2681        && $params->{'classnum'} =~ /^(\d*)$/
2682      )
2683   {
2684     $classnum = $1;
2685     if ( $classnum ) { #a specific class
2686       push @where, "part_pkg.classnum = $classnum";
2687
2688       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2689       #die "classnum $classnum not found!" unless $pkg_class[0];
2690       #$title .= $pkg_class[0]->classname.' ';
2691
2692     } elsif ( $classnum eq '' ) { #the empty class
2693
2694       push @where, "part_pkg.classnum IS NULL";
2695       #$title .= 'Empty class ';
2696       #@pkg_class = ( '(empty class)' );
2697     } elsif ( $classnum eq '0' ) {
2698       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2699       #push @pkg_class, '(empty class)';
2700     } else {
2701       die "illegal classnum";
2702     }
2703   }
2704   #eslaf
2705
2706   ###
2707   # parse package report options
2708   ###
2709
2710   my @report_option = ();
2711   if ( exists($params->{'report_option'})
2712        && $params->{'report_option'} =~ /^([,\d]*)$/
2713      )
2714   {
2715     @report_option = split(',', $1);
2716   }
2717
2718   if (@report_option) {
2719     # this will result in the empty set for the dangling comma case as it should
2720     push @where,
2721       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2722                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2723                     AND optionname = 'report_option_$_'
2724                     AND optionvalue = '1' )"
2725          } @report_option;
2726   }
2727
2728   #eslaf
2729
2730   ###
2731   # parse custom
2732   ###
2733
2734   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2735
2736   ###
2737   # parse fcc_line
2738   ###
2739
2740   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2741
2742   ###
2743   # parse censustract
2744   ###
2745
2746   if ( exists($params->{'censustract'}) ) {
2747     $params->{'censustract'} =~ /^([.\d]*)$/;
2748     my $censustract = "cust_main.censustract = '$1'";
2749     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2750     push @where,  "( $censustract )";
2751   }
2752
2753   ###
2754   # parse part_pkg
2755   ###
2756
2757   if ( ref($params->{'pkgpart'}) ) {
2758
2759     my @pkgpart = ();
2760     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2761       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2762     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2763       @pkgpart = @{ $params->{'pkgpart'} };
2764     } else {
2765       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2766     }
2767
2768     @pkgpart = grep /^(\d+)$/, @pkgpart;
2769
2770     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2771
2772   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2773     push @where, "pkgpart = $1";
2774   }
2775
2776   ###
2777   # parse dates
2778   ###
2779
2780   my $orderby = '';
2781
2782   #false laziness w/report_cust_pkg.html
2783   my %disable = (
2784     'all'             => {},
2785     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2786     'active'          => { 'susp'=>1, 'cancel'=>1 },
2787     'suspended'       => { 'cancel' => 1 },
2788     'cancelled'       => {},
2789     ''                => {},
2790   );
2791
2792   if( exists($params->{'active'} ) ) {
2793     # This overrides all the other date-related fields
2794     my($beginning, $ending) = @{$params->{'active'}};
2795     push @where,
2796       "cust_pkg.setup IS NOT NULL",
2797       "cust_pkg.setup <= $ending",
2798       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2799       "NOT (".FS::cust_pkg->onetime_sql . ")";
2800   }
2801   else {
2802     foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2803
2804       next unless exists($params->{$field});
2805
2806       my($beginning, $ending) = @{$params->{$field}};
2807
2808       next if $beginning == 0 && $ending == 4294967295;
2809
2810       push @where,
2811         "cust_pkg.$field IS NOT NULL",
2812         "cust_pkg.$field >= $beginning",
2813         "cust_pkg.$field <= $ending";
2814
2815       $orderby ||= "ORDER BY cust_pkg.$field";
2816
2817     }
2818   }
2819
2820   $orderby ||= 'ORDER BY bill';
2821
2822   ###
2823   # parse magic, legacy, etc.
2824   ###
2825
2826   if ( $params->{'magic'} &&
2827        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2828   ) {
2829
2830     $orderby = 'ORDER BY pkgnum';
2831
2832     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2833       push @where, "pkgpart = $1";
2834     }
2835
2836   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2837
2838     $orderby = 'ORDER BY pkgnum';
2839
2840   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2841
2842     $orderby = 'ORDER BY pkgnum';
2843
2844     push @where, '0 < (
2845       SELECT count(*) FROM pkg_svc
2846        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2847          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2848                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2849                                      AND cust_svc.svcpart = pkg_svc.svcpart
2850                                 )
2851     )';
2852
2853   }
2854
2855   ##
2856   # setup queries, links, subs, etc. for the search
2857   ##
2858
2859   # here is the agent virtualization
2860   if ($params->{CurrentUser}) {
2861     my $access_user =
2862       qsearchs('access_user', { username => $params->{CurrentUser} });
2863
2864     if ($access_user) {
2865       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2866     } else {
2867       push @where, "1=0";
2868     }
2869   } else {
2870     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2871   }
2872
2873   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2874
2875   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2876                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2877                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2878
2879   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2880
2881   my $sql_query = {
2882     'table'       => 'cust_pkg',
2883     'hashref'     => {},
2884     'select'      => join(', ',
2885                                 'cust_pkg.*',
2886                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2887                                 'pkg_class.classname',
2888                                 'cust_main.custnum AS cust_main_custnum',
2889                                 FS::UI::Web::cust_sql_fields(
2890                                   $params->{'cust_fields'}
2891                                 ),
2892                      ),
2893     'extra_sql'   => "$extra_sql $orderby",
2894     'addl_from'   => $addl_from,
2895     'count_query' => $count_query,
2896   };
2897
2898 }
2899
2900 =item fcc_477_count
2901
2902 Returns a list of two package counts.  The first is a count of packages
2903 based on the supplied criteria and the second is the count of residential
2904 packages with those same criteria.  Criteria are specified as in the search
2905 method.
2906
2907 =cut
2908
2909 sub fcc_477_count {
2910   my ($class, $params) = @_;
2911
2912   my $sql_query = $class->search( $params );
2913
2914   my $count_sql = delete($sql_query->{'count_query'});
2915   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2916     or die "couldn't parse count_sql";
2917
2918   my $count_sth = dbh->prepare($count_sql)
2919     or die "Error preparing $count_sql: ". dbh->errstr;
2920   $count_sth->execute
2921     or die "Error executing $count_sql: ". $count_sth->errstr;
2922   my $count_arrayref = $count_sth->fetchrow_arrayref;
2923
2924   return ( @$count_arrayref );
2925
2926 }
2927
2928
2929 =item location_sql
2930
2931 Returns a list: the first item is an SQL fragment identifying matching
2932 packages/customers via location (taking into account shipping and package
2933 address taxation, if enabled), and subsequent items are the parameters to
2934 substitute for the placeholders in that fragment.
2935
2936 =cut
2937
2938 sub location_sql {
2939   my($class, %opt) = @_;
2940   my $ornull = $opt{'ornull'};
2941
2942   my $conf = new FS::Conf;
2943
2944   # '?' placeholders in _location_sql_where
2945   my $x = $ornull ? 3 : 2;
2946   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2947
2948   my $main_where;
2949   my @main_param;
2950   if ( $conf->exists('tax-ship_address') ) {
2951
2952     $main_where = "(
2953          (     ( ship_last IS NULL     OR  ship_last  = '' )
2954            AND ". _location_sql_where('cust_main', '', $ornull ). "
2955          )
2956       OR (       ship_last IS NOT NULL AND ship_last != ''
2957            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2958          )
2959     )";
2960     #    AND payby != 'COMP'
2961
2962     @main_param = ( @bill_param, @bill_param );
2963
2964   } else {
2965
2966     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2967     @main_param = @bill_param;
2968
2969   }
2970
2971   my $where;
2972   my @param;
2973   if ( $conf->exists('tax-pkg_address') ) {
2974
2975     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2976
2977     $where = " (
2978                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2979                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2980                )
2981              ";
2982     @param = ( @main_param, @bill_param );
2983
2984   } else {
2985
2986     $where = $main_where;
2987     @param = @main_param;
2988
2989   }
2990
2991   ( $where, @param );
2992
2993 }
2994
2995 #subroutine, helper for location_sql
2996 sub _location_sql_where {
2997   my $table  = shift;
2998   my $prefix = @_ ? shift : '';
2999   my $ornull = @_ ? shift : '';
3000
3001 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3002
3003   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3004
3005   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3006   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3007   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3008
3009 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3010   "
3011         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3012     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3013     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3014     AND   $table.${prefix}country = ?
3015   ";
3016 }
3017
3018 =head1 SUBROUTINES
3019
3020 =over 4
3021
3022 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3023
3024 CUSTNUM is a customer (see L<FS::cust_main>)
3025
3026 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3027 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3028 permitted.
3029
3030 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3031 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3032 new billing items.  An error is returned if this is not possible (see
3033 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3034 parameter.
3035
3036 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3037 newly-created cust_pkg objects.
3038
3039 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3040 and inserted.  Multiple FS::pkg_referral records can be created by
3041 setting I<refnum> to an array reference of refnums or a hash reference with
3042 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3043 record will be created corresponding to cust_main.refnum.
3044
3045 =cut
3046
3047 sub order {
3048   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3049
3050   my $conf = new FS::Conf;
3051
3052   # Transactionize this whole mess
3053   local $SIG{HUP} = 'IGNORE';
3054   local $SIG{INT} = 'IGNORE';
3055   local $SIG{QUIT} = 'IGNORE';
3056   local $SIG{TERM} = 'IGNORE';
3057   local $SIG{TSTP} = 'IGNORE';
3058   local $SIG{PIPE} = 'IGNORE';
3059
3060   my $oldAutoCommit = $FS::UID::AutoCommit;
3061   local $FS::UID::AutoCommit = 0;
3062   my $dbh = dbh;
3063
3064   my $error;
3065 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3066 #  return "Customer not found: $custnum" unless $cust_main;
3067
3068   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3069     if $DEBUG;
3070
3071   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3072                          @$remove_pkgnum;
3073
3074   my $change = scalar(@old_cust_pkg) != 0;
3075
3076   my %hash = ();
3077   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3078
3079     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3080          " to pkgpart ". $pkgparts->[0]. "\n"
3081       if $DEBUG;
3082
3083     my $err_or_cust_pkg =
3084       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3085                                 'refnum'  => $refnum,
3086                               );
3087
3088     unless (ref($err_or_cust_pkg)) {
3089       $dbh->rollback if $oldAutoCommit;
3090       return $err_or_cust_pkg;
3091     }
3092
3093     push @$return_cust_pkg, $err_or_cust_pkg;
3094     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3095     return '';
3096
3097   }
3098
3099   # Create the new packages.
3100   foreach my $pkgpart (@$pkgparts) {
3101
3102     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3103
3104     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3105                                       pkgpart => $pkgpart,
3106                                       refnum  => $refnum,
3107                                       %hash,
3108                                     };
3109     $error = $cust_pkg->insert( 'change' => $change );
3110     if ($error) {
3111       $dbh->rollback if $oldAutoCommit;
3112       return $error;
3113     }
3114     push @$return_cust_pkg, $cust_pkg;
3115   }
3116   # $return_cust_pkg now contains refs to all of the newly
3117   # created packages.
3118
3119   # Transfer services and cancel old packages.
3120   foreach my $old_pkg (@old_cust_pkg) {
3121
3122     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3123       if $DEBUG;
3124
3125     foreach my $new_pkg (@$return_cust_pkg) {
3126       $error = $old_pkg->transfer($new_pkg);
3127       if ($error and $error == 0) {
3128         # $old_pkg->transfer failed.
3129         $dbh->rollback if $oldAutoCommit;
3130         return $error;
3131       }
3132     }
3133
3134     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3135       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3136       foreach my $new_pkg (@$return_cust_pkg) {
3137         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3138         if ($error and $error == 0) {
3139           # $old_pkg->transfer failed.
3140         $dbh->rollback if $oldAutoCommit;
3141         return $error;
3142         }
3143       }
3144     }
3145
3146     if ($error > 0) {
3147       # Transfers were successful, but we went through all of the
3148       # new packages and still had services left on the old package.
3149       # We can't cancel the package under the circumstances, so abort.
3150       $dbh->rollback if $oldAutoCommit;
3151       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3152     }
3153     $error = $old_pkg->cancel( quiet=>1 );
3154     if ($error) {
3155       $dbh->rollback;
3156       return $error;
3157     }
3158   }
3159   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3160   '';
3161 }
3162
3163 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3164
3165 A bulk change method to change packages for multiple customers.
3166
3167 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3168 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3169 permitted.
3170
3171 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3172 replace.  The services (see L<FS::cust_svc>) are moved to the
3173 new billing items.  An error is returned if this is not possible (see
3174 L<FS::pkg_svc>).
3175
3176 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3177 newly-created cust_pkg objects.
3178
3179 =cut
3180
3181 sub bulk_change {
3182   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3183
3184   # Transactionize this whole mess
3185   local $SIG{HUP} = 'IGNORE';
3186   local $SIG{INT} = 'IGNORE';
3187   local $SIG{QUIT} = 'IGNORE';
3188   local $SIG{TERM} = 'IGNORE';
3189   local $SIG{TSTP} = 'IGNORE';
3190   local $SIG{PIPE} = 'IGNORE';
3191
3192   my $oldAutoCommit = $FS::UID::AutoCommit;
3193   local $FS::UID::AutoCommit = 0;
3194   my $dbh = dbh;
3195
3196   my @errors;
3197   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3198                          @$remove_pkgnum;
3199
3200   while(scalar(@old_cust_pkg)) {
3201     my @return = ();
3202     my $custnum = $old_cust_pkg[0]->custnum;
3203     my (@remove) = map { $_->pkgnum }
3204                    grep { $_->custnum == $custnum } @old_cust_pkg;
3205     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3206
3207     my $error = order $custnum, $pkgparts, \@remove, \@return;
3208
3209     push @errors, $error
3210       if $error;
3211     push @$return_cust_pkg, @return;
3212   }
3213
3214   if (scalar(@errors)) {
3215     $dbh->rollback if $oldAutoCommit;
3216     return join(' / ', @errors);
3217   }
3218
3219   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3220   '';
3221 }
3222
3223 # Used by FS::Upgrade to migrate to a new database.
3224 sub _upgrade_data {  # class method
3225   my ($class, %opts) = @_;
3226   $class->_upgrade_otaker(%opts);
3227 }
3228
3229 =back
3230
3231 =head1 BUGS
3232
3233 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3234
3235 In sub order, the @pkgparts array (passed by reference) is clobbered.
3236
3237 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3238 method to pass dates to the recur_prog expression, it should do so.
3239
3240 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3241 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3242 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3243 configuration values.  Probably need a subroutine which decides what to do
3244 based on whether or not we've fetched the user yet, rather than a hash.  See
3245 FS::UID and the TODO.
3246
3247 Now that things are transactional should the check in the insert method be
3248 moved to check ?
3249
3250 =head1 SEE ALSO
3251
3252 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3253 L<FS::pkg_svc>, schema.html from the base documentation
3254
3255 =cut
3256
3257 1;
3258