FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG);
   5 use Tie::IxHash;
   6 use FS::UID qw( getotaker dbh );
   7 use FS::Misc qw( send_email );
   8 use FS::Record qw( qsearch qsearchs );
   9 use FS::cust_main_Mixin;
  10 use FS::cust_svc;
  11 use FS::part_pkg;
  12 use FS::cust_main;
  13 use FS::type_pkgs;
  14 use FS::pkg_svc;
  15 use FS::cust_bill_pkg;
  16 use FS::h_cust_svc;
  17 use FS::reg_code;
  18 use FS::cust_pkg_reason;
  19
  20 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  21 # setup }
  22 # because they load configuration by setting FS::UID::callback (see TODO)
  23 use FS::svc_acct;
  24 use FS::svc_domain;
  25 use FS::svc_www;
  26 use FS::svc_forward;
  27
  28 # for sending cancel emails in sub cancel
  29 use FS::Conf;
  30
  31 @ISA = qw( FS::cust_main_Mixin FS::Record );
  32
  33 $DEBUG = 0;
  34
  35 $disable_agentcheck = 0;
  36
  37 # The order in which to unprovision services.
  38 @SVCDB_CANCEL_SEQ = qw( svc_external
  39                         svc_www
  40                         svc_forward
  41                         svc_acct
  42                         svc_domain
  43                         svc_broadband );
  44
  45 sub _cache {
  46   my $self = shift;
  47   my ( $hashref, $cache ) = @_;
  48   #if ( $hashref->{'pkgpart'} ) {
  49   if ( $hashref->{'pkg'} ) {
  50     # #@{ $self->{'_pkgnum'} } = ();
  51     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  52     # $self->{'_pkgpart'} = $subcache;
  53     # #push @{ $self->{'_pkgnum'} },
  54     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  55     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  56   }
  57   if ( exists $hashref->{'svcnum'} ) {
  58     #@{ $self->{'_pkgnum'} } = ();
  59     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  60     $self->{'_svcnum'} = $subcache;
  61     #push @{ $self->{'_pkgnum'} },
  62     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  63   }
  64 }
  65
  66 =head1 NAME
  67
  68 FS::cust_pkg - Object methods for cust_pkg objects
  69
  70 =head1 SYNOPSIS
  71
  72   use FS::cust_pkg;
  73
  74   $record = new FS::cust_pkg \%hash;
  75   $record = new FS::cust_pkg { 'column' => 'value' };
  76
  77   $error = $record->insert;
  78
  79   $error = $new_record->replace($old_record);
  80
  81   $error = $record->delete;
  82
  83   $error = $record->check;
  84
  85   $error = $record->cancel;
  86
  87   $error = $record->suspend;
  88
  89   $error = $record->unsuspend;
  90
  91   $part_pkg = $record->part_pkg;
  92
  93   @labels = $record->labels;
  94
  95   $seconds = $record->seconds_since($timestamp);
  96
  97   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  98   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  99
 100 =head1 DESCRIPTION
 101
 102 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 103 inherits from FS::Record.  The following fields are currently supported:
 104
 105 =over 4
 106
 107 =item pkgnum - primary key (assigned automatically for new billing items)
 108
 109 =item custnum - Customer (see L<FS::cust_main>)
 110
 111 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 112
 113 =item setup - date
 114
 115 =item bill - date (next bill date)
 116
 117 =item last_bill - last bill date
 118
 119 =item susp - date
 120
 121 =item expire - date
 122
 123 =item cancel - date
 124
 125 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 126
 127 =item manual_flag - If this field is set to 1, disables the automatic
 128 unsuspension of this package when using the B<unsuspendauto> config file.
 129
 130 =back
 131
 132 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
 133 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 134 conversion functions.
 135
 136 =head1 METHODS
 137
 138 =over 4
 139
 140 =item new HASHREF
 141
 142 Create a new billing item.  To add the item to the database, see L<"insert">.
 143
 144 =cut
 145
 146 sub table { 'cust_pkg'; }
 147 sub cust_linked { $_[0]->cust_main_custnum; }
 148 sub cust_unlinked_msg {
 149   my $self = shift;
 150   "WARNING: can't find cust_main.custnum ". $self->custnum.
 151   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 152 }
 153
 154 =item insert [ OPTION => VALUE ... ]
 155
 156 Adds this billing item to the database ("Orders" the item).  If there is an
 157 error, returns the error, otherwise returns false.
 158
 159 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 160 will be used to look up the package definition and agent restrictions will be
 161 ignored.
 162
 163 The following options are available: I<change>
 164
 165 I<change>, if set true, supresses any referral credit to a referring customer.
 166
 167 =cut
 168
 169 sub insert {
 170   my( $self, %options ) = @_;
 171
 172   local $SIG{HUP} = 'IGNORE';
 173   local $SIG{INT} = 'IGNORE';
 174   local $SIG{QUIT} = 'IGNORE';
 175   local $SIG{TERM} = 'IGNORE';
 176   local $SIG{TSTP} = 'IGNORE';
 177   local $SIG{PIPE} = 'IGNORE';
 178
 179   my $oldAutoCommit = $FS::UID::AutoCommit;
 180   local $FS::UID::AutoCommit = 0;
 181   my $dbh = dbh;
 182
 183   my $error = $self->SUPER::insert;
 184   if ( $error ) {
 185     $dbh->rollback if $oldAutoCommit;
 186     return $error;
 187   }
 188
 189   #if ( $self->reg_code ) {
 190   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 191   #  $error = $reg_code->delete;
 192   #  if ( $error ) {
 193   #    $dbh->rollback if $oldAutoCommit;
 194   #    return $error;
 195   #  }
 196   #}
 197
 198   my $conf = new FS::Conf;
 199   my $cust_main = $self->cust_main;
 200   my $part_pkg = $self->part_pkg;
 201   if ( $conf->exists('referral_credit')
 202        && $cust_main->referral_custnum
 203        && ! $options{'change'}
 204        && $part_pkg->freq !~ /^0\D?$/
 205      )
 206   {
 207     my $referring_cust_main = $cust_main->referring_cust_main;
 208     if ( $referring_cust_main->status ne 'cancelled' ) {
 209       my $error;
 210       if ( $part_pkg->freq !~ /^\d+$/ ) {
 211         warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
 212              ' for package '. $self->pkgnum.
 213              ' ( customer '. $self->custnum. ')'.
 214              ' - One-time referral credits not (yet) available for '.
 215              ' packages with '. $part_pkg->freq_pretty. ' frequency';
 216       } else {
 217
 218         my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
 219         my $error =
 220           $referring_cust_main->credit( $amount,
 221                                         'Referral credit for '. $cust_main->name
 222                                       );
 223         if ( $error ) {
 224           $dbh->rollback if $oldAutoCommit;
 225           return "Error crediting customer ". $cust_main->referral_custnum.
 226                " for referral: $error";
 227         }
 228
 229       }
 230
 231     }
 232   }
 233
 234   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 235   '';
 236
 237 }
 238
 239 =item delete
 240
 241 This method now works but you probably shouldn't use it.
 242
 243 You don't want to delete billing items, because there would then be no record
 244 the customer ever purchased the item.  Instead, see the cancel method.
 245
 246 =cut
 247
 248 #sub delete {
 249 #  return "Can't delete cust_pkg records!";
 250 #}
 251
 252 =item replace OLD_RECORD
 253
 254 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 255 returns the error, otherwise returns false.
 256
 257 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 258
 259 Changing pkgpart may have disasterous effects.  See the order subroutine.
 260
 261 setup and bill are normally updated by calling the bill method of a customer
 262 object (see L<FS::cust_main>).
 263
 264 suspend is normally updated by the suspend and unsuspend methods.
 265
 266 cancel is normally updated by the cancel method (and also the order subroutine
 267 in some cases).
 268
 269 Calls
 270
 271 =cut
 272
 273 sub replace {
 274   my( $new, $old, %options ) = @_;
 275
 276   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 277   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 278
 279   #allow this *sigh*
 280   #return "Can't change setup once it exists!"
 281   #  if $old->getfield('setup') &&
 282   #     $old->getfield('setup') != $new->getfield('setup');
 283
 284   #some logic for bill, susp, cancel?
 285
 286   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 287
 288   local $SIG{HUP} = 'IGNORE';
 289   local $SIG{INT} = 'IGNORE';
 290   local $SIG{QUIT} = 'IGNORE';
 291   local $SIG{TERM} = 'IGNORE';
 292   local $SIG{TSTP} = 'IGNORE';
 293   local $SIG{PIPE} = 'IGNORE';
 294
 295   my $oldAutoCommit = $FS::UID::AutoCommit;
 296   local $FS::UID::AutoCommit = 0;
 297   my $dbh = dbh;
 298
 299   if ($options{'reason'} && $new->expire && $old->expire ne $new->expire) {
 300     my $error = $new->insert_reason( 'reason' => $options{'reason'},
 301                                      'date'      => $new->expire,
 302                                     );
 303     if ( $error ) {
 304       dbh->rollback if $oldAutoCommit;
 305       return "Error inserting cust_pkg_reason: $error";
 306     }
 307   }
 308
 309   #save off and freeze RADIUS attributes for any associated svc_acct records
 310   my @svc_acct = ();
 311   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 312
 313                 #also check for specific exports?
 314                 # to avoid spurious modify export events
 315     @svc_acct = map  { $_->svc_x }
 316                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 317                      $old->cust_svc;
 318
 319     $_->snapshot foreach @svc_acct;
 320
 321   }
 322
 323   my $error = $new->SUPER::replace($old);
 324   if ( $error ) {
 325     $dbh->rollback if $oldAutoCommit;
 326     return $error;
 327   }
 328
 329   #for prepaid packages,
 330   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 331   foreach my $old_svc_acct ( @svc_acct ) {
 332     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 333     my $s_error = $new_svc_acct->replace($old_svc_acct);
 334     if ( $s_error ) {
 335       $dbh->rollback if $oldAutoCommit;
 336       return $s_error;
 337     }
 338   }
 339
 340   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 341   '';
 342
 343 }
 344
 345 =item check
 346
 347 Checks all fields to make sure this is a valid billing item.  If there is an
 348 error, returns the error, otherwise returns false.  Called by the insert and
 349 replace methods.
 350
 351 =cut
 352
 353 sub check {
 354   my $self = shift;
 355
 356   my $error =
 357     $self->ut_numbern('pkgnum')
 358     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 359     || $self->ut_numbern('pkgpart')
 360     || $self->ut_numbern('setup')
 361     || $self->ut_numbern('bill')
 362     || $self->ut_numbern('susp')
 363     || $self->ut_numbern('cancel')
 364   ;
 365   return $error if $error;
 366
 367   if ( $self->reg_code ) {
 368
 369     unless ( grep { $self->pkgpart == $_->pkgpart }
 370              map  { $_->reg_code_pkg }
 371              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 372                                      'agentnum' => $self->cust_main->agentnum })
 373            ) {
 374       return "Unknown registration code";
 375     }
 376
 377   } elsif ( $self->promo_code ) {
 378
 379     my $promo_part_pkg =
 380       qsearchs('part_pkg', {
 381         'pkgpart'    => $self->pkgpart,
 382         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 383       } );
 384     return 'Unknown promotional code' unless $promo_part_pkg;
 385
 386   } else {
 387
 388     unless ( $disable_agentcheck ) {
 389       my $agent =
 390         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 391       my $pkgpart_href = $agent->pkgpart_hashref;
 392       return "agent ". $agent->agentnum.
 393              " can't purchase pkgpart ". $self->pkgpart
 394         unless $pkgpart_href->{ $self->pkgpart };
 395     }
 396
 397     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 398     return $error if $error;
 399
 400   }
 401
 402   $self->otaker(getotaker) unless $self->otaker;
 403   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
 404   $self->otaker($1);
 405
 406   if ( $self->dbdef_table->column('manual_flag') ) {
 407     $self->manual_flag('') if $self->manual_flag eq ' ';
 408     $self->manual_flag =~ /^([01]?)$/
 409       or return "Illegal manual_flag ". $self->manual_flag;
 410     $self->manual_flag($1);
 411   }
 412
 413   $self->SUPER::check;
 414 }
 415
 416 =item cancel [ OPTION => VALUE ... ]
 417
 418 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 419 in this package, then cancels the package itself (sets the cancel field to
 420 now).
 421
 422 Available options are: I<quiet>
 423
 424 I<quiet> can be set true to supress email cancellation notices.
 425
 426 If there is an error, returns the error, otherwise returns false.
 427
 428 =cut
 429
 430 sub cancel {
 431   my( $self, %options ) = @_;
 432   my $error;
 433
 434   local $SIG{HUP} = 'IGNORE';
 435   local $SIG{INT} = 'IGNORE';
 436   local $SIG{QUIT} = 'IGNORE';
 437   local $SIG{TERM} = 'IGNORE';
 438   local $SIG{TSTP} = 'IGNORE';
 439   local $SIG{PIPE} = 'IGNORE';
 440
 441   my $oldAutoCommit = $FS::UID::AutoCommit;
 442   local $FS::UID::AutoCommit = 0;
 443   my $dbh = dbh;
 444
 445   if ($options{'reason'}) {
 446     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 447     if ( $error ) {
 448       dbh->rollback if $oldAutoCommit;
 449       return "Error inserting cust_pkg_reason: $error";
 450     }
 451   }
 452
 453   my %svc;
 454   foreach my $cust_svc (
 455       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 456   ) {
 457     push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
 458   }
 459
 460   foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
 461     foreach my $cust_svc (@{ $svc{$svcdb} }) {
 462       my $error = $cust_svc->cancel;
 463
 464       if ( $error ) {
 465         $dbh->rollback if $oldAutoCommit;
 466         return "Error cancelling cust_svc: $error";
 467       }
 468     }
 469   }
 470
 471   # Add a credit for remaining service
 472   my $remaining_value = $self->calc_remain();
 473   if ( $remaining_value > 0 ) {
 474     my $error = $self->cust_main->credit(
 475       $remaining_value,
 476       'Credit for unused time on '. $self->part_pkg->pkg,
 477     );
 478     if ($error) {
 479       $dbh->rollback if $oldAutoCommit;
 480       return "Error crediting customer \$$remaining_value for unused time on".
 481              $self->part_pkg->pkg. ": $error";
 482     }
 483   }
 484
 485   unless ( $self->getfield('cancel') ) {
 486     my %hash = $self->hash;
 487     $hash{'cancel'} = time;
 488     my $new = new FS::cust_pkg ( \%hash );
 489     $error = $new->replace($self);
 490     if ( $error ) {
 491       $dbh->rollback if $oldAutoCommit;
 492       return $error;
 493     }
 494   }
 495
 496   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 497
 498   my $conf = new FS::Conf;
 499   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 500   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 501     my $conf = new FS::Conf;
 502     my $error = send_email(
 503       'from'    => $conf->config('invoice_from'),
 504       'to'      => \@invoicing_list,
 505       'subject' => $conf->config('cancelsubject'),
 506       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 507     );
 508     #should this do something on errors?
 509   }
 510
 511   ''; #no errors
 512
 513 }
 514
 515 =item suspend
 516
 517 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 518 package, then suspends the package itself (sets the susp field to now).
 519
 520 If there is an error, returns the error, otherwise returns false.
 521
 522 =cut
 523
 524 sub suspend {
 525   my( $self, %options ) = @_;
 526   my $error ;
 527
 528   local $SIG{HUP} = 'IGNORE';
 529   local $SIG{INT} = 'IGNORE';
 530   local $SIG{QUIT} = 'IGNORE';
 531   local $SIG{TERM} = 'IGNORE';
 532   local $SIG{TSTP} = 'IGNORE';
 533   local $SIG{PIPE} = 'IGNORE';
 534
 535   my $oldAutoCommit = $FS::UID::AutoCommit;
 536   local $FS::UID::AutoCommit = 0;
 537   my $dbh = dbh;
 538
 539   if ($options{'reason'}) {
 540     $error = $self->insert_reason( 'reason' => $options{'reason'} );
 541     if ( $error ) {
 542       dbh->rollback if $oldAutoCommit;
 543       return "Error inserting cust_pkg_reason: $error";
 544     }
 545   }
 546
 547   foreach my $cust_svc (
 548     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 549   ) {
 550     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 551
 552     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 553       $dbh->rollback if $oldAutoCommit;
 554       return "Illegal svcdb value in part_svc!";
 555     };
 556     my $svcdb = $1;
 557     require "FS/$svcdb.pm";
 558
 559     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 560     if ($svc) {
 561       $error = $svc->suspend;
 562       if ( $error ) {
 563         $dbh->rollback if $oldAutoCommit;
 564         return $error;
 565       }
 566     }
 567
 568   }
 569
 570   unless ( $self->getfield('susp') ) {
 571     my %hash = $self->hash;
 572     $hash{'susp'} = time;
 573     my $new = new FS::cust_pkg ( \%hash );
 574     $error = $new->replace($self);
 575     if ( $error ) {
 576       $dbh->rollback if $oldAutoCommit;
 577       return $error;
 578     }
 579   }
 580
 581   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 582
 583   ''; #no errors
 584 }
 585
 586 =item unsuspend [ OPTION => VALUE ... ]
 587
 588 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 589 package, then unsuspends the package itself (clears the susp field).
 590
 591 Available options are: I<adjust_next_bill>.
 592
 593 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 594 the amount of time the account was inactive.  This was set true by default
 595 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 596 explicitly requested.  Price plans for which this makes sense (anniversary-date
 597 based than prorate or subscription) could have an option to enable this
 598 behaviour?
 599
 600 If there is an error, returns the error, otherwise returns false.
 601
 602 =cut
 603
 604 sub unsuspend {
 605   my( $self, %opt ) = @_;
 606   my $error;
 607
 608   local $SIG{HUP} = 'IGNORE';
 609   local $SIG{INT} = 'IGNORE';
 610   local $SIG{QUIT} = 'IGNORE';
 611   local $SIG{TERM} = 'IGNORE';
 612   local $SIG{TSTP} = 'IGNORE';
 613   local $SIG{PIPE} = 'IGNORE';
 614
 615   my $oldAutoCommit = $FS::UID::AutoCommit;
 616   local $FS::UID::AutoCommit = 0;
 617   my $dbh = dbh;
 618
 619   foreach my $cust_svc (
 620     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 621   ) {
 622     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 623
 624     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 625       $dbh->rollback if $oldAutoCommit;
 626       return "Illegal svcdb value in part_svc!";
 627     };
 628     my $svcdb = $1;
 629     require "FS/$svcdb.pm";
 630
 631     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 632     if ($svc) {
 633       $error = $svc->unsuspend;
 634       if ( $error ) {
 635         $dbh->rollback if $oldAutoCommit;
 636         return $error;
 637       }
 638     }
 639
 640   }
 641
 642   unless ( ! $self->getfield('susp') ) {
 643     my %hash = $self->hash;
 644     my $inactive = time - $hash{'susp'};
 645
 646     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 647       if $opt{'adjust_next_bill'}
 648       && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 649
 650     $hash{'susp'} = '';
 651     my $new = new FS::cust_pkg ( \%hash );
 652     $error = $new->replace($self);
 653     if ( $error ) {
 654       $dbh->rollback if $oldAutoCommit;
 655       return $error;
 656     }
 657   }
 658
 659   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 660
 661   ''; #no errors
 662 }
 663
 664 =item last_bill
 665
 666 Returns the last bill date, or if there is no last bill date, the setup date.
 667 Useful for billing metered services.
 668
 669 =cut
 670
 671 sub last_bill {
 672   my $self = shift;
 673   if ( $self->dbdef_table->column('last_bill') ) {
 674     return $self->setfield('last_bill', $_[0]) if @_;
 675     return $self->getfield('last_bill') if $self->getfield('last_bill');
 676   }
 677   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 678                                                   'edate'  => $self->bill,  } );
 679   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 680 }
 681
 682 =item last_reason
 683
 684 Returns the most recent FS::reason associated with the package.
 685
 686 =cut
 687
 688 sub last_reason {
 689   my $self = shift;
 690   my $cust_pkg_reason = qsearchs( {
 691                                     'table' => 'cust_pkg_reason',
 692                                     'hashref' => { 'pkgnum' => $self->pkgnum, },
 693                                     'extra_sql'=> 'ORDER BY date DESC',
 694                                   } );
 695   qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
 696     if $cust_pkg_reason;
 697 }
 698
 699 =item part_pkg
 700
 701 Returns the definition for this billing item, as an FS::part_pkg object (see
 702 L<FS::part_pkg>).
 703
 704 =cut
 705
 706 sub part_pkg {
 707   my $self = shift;
 708   #exists( $self->{'_pkgpart'} )
 709   $self->{'_pkgpart'}
 710     ? $self->{'_pkgpart'}
 711     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 712 }
 713
 714 =item calc_setup
 715
 716 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 717 item.
 718
 719 =cut
 720
 721 sub calc_setup {
 722   my $self = shift;
 723   $self->part_pkg->calc_setup($self, @_);
 724 }
 725
 726 =item calc_recur
 727
 728 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 729 item.
 730
 731 =cut
 732
 733 sub calc_recur {
 734   my $self = shift;
 735   $self->part_pkg->calc_recur($self, @_);
 736 }
 737
 738 =item calc_remain
 739
 740 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 741 billing item.
 742
 743 =cut
 744
 745 sub calc_remain {
 746   my $self = shift;
 747   $self->part_pkg->calc_remain($self, @_);
 748 }
 749
 750 =item calc_cancel
 751
 752 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 753 billing item.
 754
 755 =cut
 756
 757 sub calc_cancel {
 758   my $self = shift;
 759   $self->part_pkg->calc_cancel($self, @_);
 760 }
 761
 762 =item cust_svc [ SVCPART ]
 763
 764 Returns the services for this package, as FS::cust_svc objects (see
 765 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 766 services.
 767
 768 =cut
 769
 770 sub cust_svc {
 771   my $self = shift;
 772
 773   if ( @_ ) {
 774     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 775                                   'svcpart' => shift,          } );
 776   }
 777
 778   #if ( $self->{'_svcnum'} ) {
 779   #  values %{ $self->{'_svcnum'}->cache };
 780   #} else {
 781     $self->_sort_cust_svc(
 782       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 783     );
 784   #}
 785
 786 }
 787
 788 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 789
 790 Returns historical services for this package created before END TIMESTAMP and
 791 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 792 (see L<FS::h_cust_svc>).
 793
 794 =cut
 795
 796 sub h_cust_svc {
 797   my $self = shift;
 798
 799   $self->_sort_cust_svc(
 800     [ qsearch( 'h_cust_svc',
 801                { 'pkgnum' => $self->pkgnum, },
 802                FS::h_cust_svc->sql_h_search(@_),
 803              )
 804     ]
 805   );
 806 }
 807
 808 sub _sort_cust_svc {
 809   my( $self, $arrayref ) = @_;
 810
 811   map  { $_->[0] }
 812   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 813   map {
 814         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 815                                              'svcpart' => $_->svcpart     } );
 816         [ $_,
 817           $pkg_svc ? $pkg_svc->primary_svc : '',
 818           $pkg_svc ? $pkg_svc->quantity : 0,
 819         ];
 820       }
 821   @$arrayref;
 822
 823 }
 824
 825 =item num_cust_svc [ SVCPART ]
 826
 827 Returns the number of provisioned services for this package.  If a svcpart is
 828 specified, counts only the matching services.
 829
 830 =cut
 831
 832 sub num_cust_svc {
 833   my $self = shift;
 834   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 835   $sql .= ' AND svcpart = ?' if @_;
 836   my $sth = dbh->prepare($sql) or die dbh->errstr;
 837   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 838   $sth->fetchrow_arrayref->[0];
 839 }
 840
 841 =item available_part_svc
 842
 843 Returns a list FS::part_svc objects representing services included in this
 844 package but not yet provisioned.  Each FS::part_svc object also has an extra
 845 field, I<num_avail>, which specifies the number of available services.
 846
 847 =cut
 848
 849 sub available_part_svc {
 850   my $self = shift;
 851   grep { $_->num_avail > 0 }
 852     map {
 853           my $part_svc = $_->part_svc;
 854           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 855             $_->quantity - $self->num_cust_svc($_->svcpart);
 856           $part_svc;
 857         }
 858       $self->part_pkg->pkg_svc;
 859 }
 860
 861 =item status
 862
 863 Returns a short status string for this package, currently:
 864
 865 =over 4
 866
 867 =item not yet billed
 868
 869 =item one-time charge
 870
 871 =item active
 872
 873 =item suspended
 874
 875 =item cancelled
 876
 877 =back
 878
 879 =cut
 880
 881 sub status {
 882   my $self = shift;
 883
 884   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
 885
 886   return 'cancelled' if $self->get('cancel');
 887   return 'suspended' if $self->susp;
 888   return 'not yet billed' unless $self->setup;
 889   return 'one-time charge' if $freq =~ /^(0|$)/;
 890   return 'active';
 891 }
 892
 893 =item statuses
 894
 895 Class method that returns the list of possible status strings for pacakges
 896 (see L<the status method|/status>).  For example:
 897
 898   @statuses = FS::cust_pkg->statuses();
 899
 900 =cut
 901
 902 tie my %statuscolor, 'Tie::IxHash',
 903   'not yet billed'  => '000000',
 904   'one-time charge' => '000000',
 905   'active'          => '00CC00',
 906   'suspended'       => 'FF9900',
 907   'cancelled'       => 'FF0000',
 908 ;
 909
 910 sub statuses {
 911   my $self = shift; #could be class...
 912   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
 913                                       # mayble split btw one-time vs. recur
 914     keys %statuscolor;
 915 }
 916
 917 =item statuscolor
 918
 919 Returns a hex triplet color string for this package's status.
 920
 921 =cut
 922
 923 sub statuscolor {
 924   my $self = shift;
 925   $statuscolor{$self->status};
 926 }
 927
 928 =item labels
 929
 930 Returns a list of lists, calling the label method for all services
 931 (see L<FS::cust_svc>) of this billing item.
 932
 933 =cut
 934
 935 sub labels {
 936   my $self = shift;
 937   map { [ $_->label ] } $self->cust_svc;
 938 }
 939
 940 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
 941
 942 Like the labels method, but returns historical information on services that
 943 were active as of END_TIMESTAMP and (optionally) not cancelled before
 944 START_TIMESTAMP.
 945
 946 Returns a list of lists, calling the label method for all (historical) services
 947 (see L<FS::h_cust_svc>) of this billing item.
 948
 949 =cut
 950
 951 sub h_labels {
 952   my $self = shift;
 953   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
 954 }
 955
 956 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
 957
 958 Like h_labels, except returns a simple flat list, and shortens long
 959 (currently >5) lists of identical services to one line that lists the service
 960 label and the number of individual services rather than individual items.
 961
 962 =cut
 963
 964 sub h_labels_short {
 965   my $self = shift;
 966
 967   my %labels;
 968   #tie %labels, 'Tie::IxHash';
 969   push @{ $labels{$_->[0]} }, $_->[1]
 970     foreach $self->h_labels(@_);
 971   my @labels;
 972   foreach my $label ( keys %labels ) {
 973     my @values = @{ $labels{$label} };
 974     my $num = scalar(@values);
 975     if ( $num > 5 ) {
 976       push @labels, "$label ($num)";
 977     } else {
 978       push @labels, map { "$label: $_" } @values;
 979     }
 980   }
 981
 982  @labels;
 983
 984 }
 985
 986 =item cust_main
 987
 988 Returns the parent customer object (see L<FS::cust_main>).
 989
 990 =cut
 991
 992 sub cust_main {
 993   my $self = shift;
 994   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 995 }
 996
 997 =item seconds_since TIMESTAMP
 998
 999 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1000 package have been online since TIMESTAMP, according to the session monitor.
1001
1002 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1003 L<Time::Local> and L<Date::Parse> for conversion functions.
1004
1005 =cut
1006
1007 sub seconds_since {
1008   my($self, $since) = @_;
1009   my $seconds = 0;
1010
1011   foreach my $cust_svc (
1012     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1013   ) {
1014     $seconds += $cust_svc->seconds_since($since);
1015   }
1016
1017   $seconds;
1018
1019 }
1020
1021 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1022
1023 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1024 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1025 (exclusive).
1026
1027 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1028 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1029 functions.
1030
1031
1032 =cut
1033
1034 sub seconds_since_sqlradacct {
1035   my($self, $start, $end) = @_;
1036
1037   my $seconds = 0;
1038
1039   foreach my $cust_svc (
1040     grep {
1041       my $part_svc = $_->part_svc;
1042       $part_svc->svcdb eq 'svc_acct'
1043         && scalar($part_svc->part_export('sqlradius'));
1044     } $self->cust_svc
1045   ) {
1046     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1047   }
1048
1049   $seconds;
1050
1051 }
1052
1053 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1054
1055 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1056 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1057 TIMESTAMP_END
1058 (exclusive).
1059
1060 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1061 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1062 functions.
1063
1064 =cut
1065
1066 sub attribute_since_sqlradacct {
1067   my($self, $start, $end, $attrib) = @_;
1068
1069   my $sum = 0;
1070
1071   foreach my $cust_svc (
1072     grep {
1073       my $part_svc = $_->part_svc;
1074       $part_svc->svcdb eq 'svc_acct'
1075         && scalar($part_svc->part_export('sqlradius'));
1076     } $self->cust_svc
1077   ) {
1078     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1079   }
1080
1081   $sum;
1082
1083 }
1084
1085 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1086
1087 Transfers as many services as possible from this package to another package.
1088
1089 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1090 object.  The destination package must already exist.
1091
1092 Services are moved only if the destination allows services with the correct
1093 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1094 this option with caution!  No provision is made for export differences
1095 between the old and new service definitions.  Probably only should be used
1096 when your exports for all service definitions of a given svcdb are identical.
1097 (attempt a transfer without it first, to move all possible svcpart-matching
1098 services)
1099
1100 Any services that can't be moved remain in the original package.
1101
1102 Returns an error, if there is one; otherwise, returns the number of services
1103 that couldn't be moved.
1104
1105 =cut
1106
1107 sub transfer {
1108   my ($self, $dest_pkgnum, %opt) = @_;
1109
1110   my $remaining = 0;
1111   my $dest;
1112   my %target;
1113
1114   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1115     $dest = $dest_pkgnum;
1116     $dest_pkgnum = $dest->pkgnum;
1117   } else {
1118     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1119   }
1120
1121   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1122
1123   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1124     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1125   }
1126
1127   foreach my $cust_svc ($dest->cust_svc) {
1128     $target{$cust_svc->svcpart}--;
1129   }
1130
1131   my %svcpart2svcparts = ();
1132   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1133     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1134     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1135       next if exists $svcpart2svcparts{$svcpart};
1136       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1137       $svcpart2svcparts{$svcpart} = [
1138         map  { $_->[0] }
1139         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1140         map {
1141               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1142                                                    'svcpart' => $_          } );
1143               [ $_,
1144                 $pkg_svc ? $pkg_svc->primary_svc : '',
1145                 $pkg_svc ? $pkg_svc->quantity : 0,
1146               ];
1147             }
1148
1149         grep { $_ != $svcpart }
1150         map  { $_->svcpart }
1151         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1152       ];
1153       warn "alternates for svcpart $svcpart: ".
1154            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1155         if $DEBUG;
1156     }
1157   }
1158
1159   foreach my $cust_svc ($self->cust_svc) {
1160     if($target{$cust_svc->svcpart} > 0) {
1161       $target{$cust_svc->svcpart}--;
1162       my $new = new FS::cust_svc {
1163         svcnum  => $cust_svc->svcnum,
1164         svcpart => $cust_svc->svcpart,
1165         pkgnum  => $dest_pkgnum,
1166       };
1167       my $error = $new->replace($cust_svc);
1168       return $error if $error;
1169     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1170       if ( $DEBUG ) {
1171         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1172         warn "alternates to consider: ".
1173              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1174       }
1175       my @alternate = grep {
1176                              warn "considering alternate svcpart $_: ".
1177                                   "$target{$_} available in new package\n"
1178                                if $DEBUG;
1179                              $target{$_} > 0;
1180                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1181       if ( @alternate ) {
1182         warn "alternate(s) found\n" if $DEBUG;
1183         my $change_svcpart = $alternate[0];
1184         $target{$change_svcpart}--;
1185         my $new = new FS::cust_svc {
1186           svcnum  => $cust_svc->svcnum,
1187           svcpart => $change_svcpart,
1188           pkgnum  => $dest_pkgnum,
1189         };
1190         my $error = $new->replace($cust_svc);
1191         return $error if $error;
1192       } else {
1193         $remaining++;
1194       }
1195     } else {
1196       $remaining++
1197     }
1198   }
1199   return $remaining;
1200 }
1201
1202 =item reexport
1203
1204 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1205 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1206
1207 =cut
1208
1209 sub reexport {
1210   my $self = shift;
1211
1212   local $SIG{HUP} = 'IGNORE';
1213   local $SIG{INT} = 'IGNORE';
1214   local $SIG{QUIT} = 'IGNORE';
1215   local $SIG{TERM} = 'IGNORE';
1216   local $SIG{TSTP} = 'IGNORE';
1217   local $SIG{PIPE} = 'IGNORE';
1218
1219   my $oldAutoCommit = $FS::UID::AutoCommit;
1220   local $FS::UID::AutoCommit = 0;
1221   my $dbh = dbh;
1222
1223   foreach my $cust_svc ( $self->cust_svc ) {
1224     #false laziness w/svc_Common::insert
1225     my $svc_x = $cust_svc->svc_x;
1226     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1227       my $error = $part_export->export_insert($svc_x);
1228       if ( $error ) {
1229         $dbh->rollback if $oldAutoCommit;
1230         return $error;
1231       }
1232     }
1233   }
1234
1235   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1236   '';
1237
1238 }
1239
1240 =back
1241
1242 =head1 CLASS METHODS
1243
1244 =over 4
1245
1246 =item recurring_sql
1247
1248 Returns an SQL expression identifying recurring packages.
1249
1250 =cut
1251
1252 sub recurring_sql { "
1253   '0' != ( select freq from part_pkg
1254              where cust_pkg.pkgpart = part_pkg.pkgpart )
1255 "; }
1256
1257 =item onetime_sql
1258
1259 Returns an SQL expression identifying one-time packages.
1260
1261 =cut
1262
1263 sub onetime_sql { "
1264   '0' = ( select freq from part_pkg
1265             where cust_pkg.pkgpart = part_pkg.pkgpart )
1266 "; }
1267
1268 =item active_sql
1269
1270 Returns an SQL expression identifying active packages.
1271
1272 =cut
1273
1274 sub active_sql { "
1275   ". $_[0]->recurring_sql(). "
1276   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1277   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1278 "; }
1279
1280 =item inactive_sql
1281
1282 Returns an SQL expression identifying inactive packages (one-time packages
1283 that are otherwise unsuspended/uncancelled).
1284
1285 =cut
1286
1287 sub inactive_sql { "
1288   ". $_[0]->onetime_sql(). "
1289   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1290   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1291 "; }
1292
1293 =item susp_sql
1294 =item suspended_sql
1295
1296 Returns an SQL expression identifying suspended packages.
1297
1298 =cut
1299
1300 sub suspended_sql { susp_sql(@_); }
1301 sub susp_sql {
1302   #$_[0]->recurring_sql(). ' AND '.
1303   "
1304         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1305     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1306   ";
1307 }
1308
1309 =item cancel_sql
1310 =item cancelled_sql
1311
1312 Returns an SQL exprression identifying cancelled packages.
1313
1314 =cut
1315
1316 sub cancelled_sql { cancel_sql(@_); }
1317 sub cancel_sql {
1318   #$_[0]->recurring_sql(). ' AND '.
1319   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1320 }
1321
1322 =head1 SUBROUTINES
1323
1324 =over 4
1325
1326 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1327
1328 CUSTNUM is a customer (see L<FS::cust_main>)
1329
1330 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1331 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1332 permitted.
1333
1334 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1335 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1336 new billing items.  An error is returned if this is not possible (see
1337 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1338 parameter.
1339
1340 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1341 newly-created cust_pkg objects.
1342
1343 =cut
1344
1345 sub order {
1346   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1347
1348   my $conf = new FS::Conf;
1349
1350   # Transactionize this whole mess
1351   local $SIG{HUP} = 'IGNORE';
1352   local $SIG{INT} = 'IGNORE';
1353   local $SIG{QUIT} = 'IGNORE';
1354   local $SIG{TERM} = 'IGNORE';
1355   local $SIG{TSTP} = 'IGNORE';
1356   local $SIG{PIPE} = 'IGNORE';
1357
1358   my $oldAutoCommit = $FS::UID::AutoCommit;
1359   local $FS::UID::AutoCommit = 0;
1360   my $dbh = dbh;
1361
1362   my $error;
1363   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1364   return "Customer not found: $custnum" unless $cust_main;
1365
1366   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1367                          @$remove_pkgnum;
1368
1369   my $change = scalar(@old_cust_pkg) != 0;
1370
1371   my %hash = ();
1372   if ( scalar(@old_cust_pkg) == 1 ) {
1373     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1374     $hash{'setup'} = time;
1375   }
1376
1377   # Create the new packages.
1378   foreach my $pkgpart (@$pkgparts) {
1379     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1380                                       pkgpart => $pkgpart,
1381                                       %hash,
1382                                     };
1383     $error = $cust_pkg->insert( 'change' => $change );
1384     if ($error) {
1385       $dbh->rollback if $oldAutoCommit;
1386       return $error;
1387     }
1388     push @$return_cust_pkg, $cust_pkg;
1389   }
1390   # $return_cust_pkg now contains refs to all of the newly
1391   # created packages.
1392
1393   # Transfer services and cancel old packages.
1394   foreach my $old_pkg (@old_cust_pkg) {
1395
1396     foreach my $new_pkg (@$return_cust_pkg) {
1397       $error = $old_pkg->transfer($new_pkg);
1398       if ($error and $error == 0) {
1399         # $old_pkg->transfer failed.
1400         $dbh->rollback if $oldAutoCommit;
1401         return $error;
1402       }
1403     }
1404
1405     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1406       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1407       foreach my $new_pkg (@$return_cust_pkg) {
1408         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1409         if ($error and $error == 0) {
1410           # $old_pkg->transfer failed.
1411         $dbh->rollback if $oldAutoCommit;
1412         return $error;
1413         }
1414       }
1415     }
1416
1417     if ($error > 0) {
1418       # Transfers were successful, but we went through all of the
1419       # new packages and still had services left on the old package.
1420       # We can't cancel the package under the circumstances, so abort.
1421       $dbh->rollback if $oldAutoCommit;
1422       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1423     }
1424     $error = $old_pkg->cancel( quiet=>1 );
1425     if ($error) {
1426       $dbh->rollback;
1427       return $error;
1428     }
1429   }
1430   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1431   '';
1432 }
1433
1434 sub insert_reason {
1435   my ($self, %options) = @_;
1436
1437   my $otaker = $FS::CurrentUser::CurrentUser->name;
1438   $otaker = $FS::CurrentUser::CurrentUser->username
1439     if (($otaker) eq "User, Legacy");
1440
1441   my $cust_pkg_reason =
1442     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1443                               'reasonnum' => $options{'reason'},
1444                               'otaker'    => $otaker,
1445                               'date'      => $options{'date'}
1446                                                ? $options{'date'}
1447                                                : time,
1448                             });
1449   return $cust_pkg_reason->insert;
1450 }
1451
1452 =back
1453
1454 =head1 BUGS
1455
1456 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1457
1458 In sub order, the @pkgparts array (passed by reference) is clobbered.
1459
1460 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1461 method to pass dates to the recur_prog expression, it should do so.
1462
1463 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1464 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1465 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1466 configuration values.  Probably need a subroutine which decides what to do
1467 based on whether or not we've fetched the user yet, rather than a hash.  See
1468 FS::UID and the TODO.
1469
1470 Now that things are transactional should the check in the insert method be
1471 moved to check ?
1472
1473 =head1 SEE ALSO
1474
1475 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1476 L<FS::pkg_svc>, schema.html from the base documentation
1477
1478 =cut
1479
1480 1;
1481