FS/FS/cust_pkg.pm

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