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     my $conf = new FS::Conf;
 647
 648     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 649       if ( $opt{'adjust_next_bill'}
 650            || $conf->config('unsuspend-always_adjust_next_bill_date') )
 651       && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 652
 653     $hash{'susp'} = '';
 654     my $new = new FS::cust_pkg ( \%hash );
 655     $error = $new->replace($self);
 656     if ( $error ) {
 657       $dbh->rollback if $oldAutoCommit;
 658       return $error;
 659     }
 660   }
 661
 662   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 663
 664   ''; #no errors
 665 }
 666
 667 =item last_bill
 668
 669 Returns the last bill date, or if there is no last bill date, the setup date.
 670 Useful for billing metered services.
 671
 672 =cut
 673
 674 sub last_bill {
 675   my $self = shift;
 676   if ( $self->dbdef_table->column('last_bill') ) {
 677     return $self->setfield('last_bill', $_[0]) if @_;
 678     return $self->getfield('last_bill') if $self->getfield('last_bill');
 679   }
 680   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 681                                                   'edate'  => $self->bill,  } );
 682   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 683 }
 684
 685 =item last_reason
 686
 687 Returns the most recent FS::reason associated with the package.
 688
 689 =cut
 690
 691 sub last_reason {
 692   my $self = shift;
 693   my $cust_pkg_reason = qsearchs( {
 694                                     'table' => 'cust_pkg_reason',
 695                                     'hashref' => { 'pkgnum' => $self->pkgnum, },
 696                                     'extra_sql'=> 'ORDER BY date DESC',
 697                                   } );
 698   qsearchs ( 'reason', { 'reasonnum' => $cust_pkg_reason->reasonnum } )
 699     if $cust_pkg_reason;
 700 }
 701
 702 =item part_pkg
 703
 704 Returns the definition for this billing item, as an FS::part_pkg object (see
 705 L<FS::part_pkg>).
 706
 707 =cut
 708
 709 sub part_pkg {
 710   my $self = shift;
 711   #exists( $self->{'_pkgpart'} )
 712   $self->{'_pkgpart'}
 713     ? $self->{'_pkgpart'}
 714     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 715 }
 716
 717 =item calc_setup
 718
 719 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 720 item.
 721
 722 =cut
 723
 724 sub calc_setup {
 725   my $self = shift;
 726   $self->part_pkg->calc_setup($self, @_);
 727 }
 728
 729 =item calc_recur
 730
 731 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 732 item.
 733
 734 =cut
 735
 736 sub calc_recur {
 737   my $self = shift;
 738   $self->part_pkg->calc_recur($self, @_);
 739 }
 740
 741 =item calc_remain
 742
 743 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 744 billing item.
 745
 746 =cut
 747
 748 sub calc_remain {
 749   my $self = shift;
 750   $self->part_pkg->calc_remain($self, @_);
 751 }
 752
 753 =item calc_cancel
 754
 755 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 756 billing item.
 757
 758 =cut
 759
 760 sub calc_cancel {
 761   my $self = shift;
 762   $self->part_pkg->calc_cancel($self, @_);
 763 }
 764
 765 =item cust_svc [ SVCPART ]
 766
 767 Returns the services for this package, as FS::cust_svc objects (see
 768 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 769 services.
 770
 771 =cut
 772
 773 sub cust_svc {
 774   my $self = shift;
 775
 776   if ( @_ ) {
 777     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 778                                   'svcpart' => shift,          } );
 779   }
 780
 781   #if ( $self->{'_svcnum'} ) {
 782   #  values %{ $self->{'_svcnum'}->cache };
 783   #} else {
 784     $self->_sort_cust_svc(
 785       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 786     );
 787   #}
 788
 789 }
 790
 791 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 792
 793 Returns historical services for this package created before END TIMESTAMP and
 794 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 795 (see L<FS::h_cust_svc>).
 796
 797 =cut
 798
 799 sub h_cust_svc {
 800   my $self = shift;
 801
 802   $self->_sort_cust_svc(
 803     [ qsearch( 'h_cust_svc',
 804                { 'pkgnum' => $self->pkgnum, },
 805                FS::h_cust_svc->sql_h_search(@_),
 806              )
 807     ]
 808   );
 809 }
 810
 811 sub _sort_cust_svc {
 812   my( $self, $arrayref ) = @_;
 813
 814   map  { $_->[0] }
 815   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 816   map {
 817         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 818                                              'svcpart' => $_->svcpart     } );
 819         [ $_,
 820           $pkg_svc ? $pkg_svc->primary_svc : '',
 821           $pkg_svc ? $pkg_svc->quantity : 0,
 822         ];
 823       }
 824   @$arrayref;
 825
 826 }
 827
 828 =item num_cust_svc [ SVCPART ]
 829
 830 Returns the number of provisioned services for this package.  If a svcpart is
 831 specified, counts only the matching services.
 832
 833 =cut
 834
 835 sub num_cust_svc {
 836   my $self = shift;
 837   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 838   $sql .= ' AND svcpart = ?' if @_;
 839   my $sth = dbh->prepare($sql) or die dbh->errstr;
 840   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 841   $sth->fetchrow_arrayref->[0];
 842 }
 843
 844 =item available_part_svc
 845
 846 Returns a list FS::part_svc objects representing services included in this
 847 package but not yet provisioned.  Each FS::part_svc object also has an extra
 848 field, I<num_avail>, which specifies the number of available services.
 849
 850 =cut
 851
 852 sub available_part_svc {
 853   my $self = shift;
 854   grep { $_->num_avail > 0 }
 855     map {
 856           my $part_svc = $_->part_svc;
 857           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 858             $_->quantity - $self->num_cust_svc($_->svcpart);
 859           $part_svc;
 860         }
 861       $self->part_pkg->pkg_svc;
 862 }
 863
 864 =item status
 865
 866 Returns a short status string for this package, currently:
 867
 868 =over 4
 869
 870 =item not yet billed
 871
 872 =item one-time charge
 873
 874 =item active
 875
 876 =item suspended
 877
 878 =item cancelled
 879
 880 =back
 881
 882 =cut
 883
 884 sub status {
 885   my $self = shift;
 886
 887   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
 888
 889   return 'cancelled' if $self->get('cancel');
 890   return 'suspended' if $self->susp;
 891   return 'not yet billed' unless $self->setup;
 892   return 'one-time charge' if $freq =~ /^(0|$)/;
 893   return 'active';
 894 }
 895
 896 =item statuses
 897
 898 Class method that returns the list of possible status strings for pacakges
 899 (see L<the status method|/status>).  For example:
 900
 901   @statuses = FS::cust_pkg->statuses();
 902
 903 =cut
 904
 905 tie my %statuscolor, 'Tie::IxHash',
 906   'not yet billed'  => '000000',
 907   'one-time charge' => '000000',
 908   'active'          => '00CC00',
 909   'suspended'       => 'FF9900',
 910   'cancelled'       => 'FF0000',
 911 ;
 912
 913 sub statuses {
 914   my $self = shift; #could be class...
 915   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
 916                                       # mayble split btw one-time vs. recur
 917     keys %statuscolor;
 918 }
 919
 920 =item statuscolor
 921
 922 Returns a hex triplet color string for this package's status.
 923
 924 =cut
 925
 926 sub statuscolor {
 927   my $self = shift;
 928   $statuscolor{$self->status};
 929 }
 930
 931 =item labels
 932
 933 Returns a list of lists, calling the label method for all services
 934 (see L<FS::cust_svc>) of this billing item.
 935
 936 =cut
 937
 938 sub labels {
 939   my $self = shift;
 940   map { [ $_->label ] } $self->cust_svc;
 941 }
 942
 943 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
 944
 945 Like the labels method, but returns historical information on services that
 946 were active as of END_TIMESTAMP and (optionally) not cancelled before
 947 START_TIMESTAMP.
 948
 949 Returns a list of lists, calling the label method for all (historical) services
 950 (see L<FS::h_cust_svc>) of this billing item.
 951
 952 =cut
 953
 954 sub h_labels {
 955   my $self = shift;
 956   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
 957 }
 958
 959 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
 960
 961 Like h_labels, except returns a simple flat list, and shortens long
 962 (currently >5) lists of identical services to one line that lists the service
 963 label and the number of individual services rather than individual items.
 964
 965 =cut
 966
 967 sub h_labels_short {
 968   my $self = shift;
 969
 970   my %labels;
 971   #tie %labels, 'Tie::IxHash';
 972   push @{ $labels{$_->[0]} }, $_->[1]
 973     foreach $self->h_labels(@_);
 974   my @labels;
 975   foreach my $label ( keys %labels ) {
 976     my @values = @{ $labels{$label} };
 977     my $num = scalar(@values);
 978     if ( $num > 5 ) {
 979       push @labels, "$label ($num)";
 980     } else {
 981       push @labels, map { "$label: $_" } @values;
 982     }
 983   }
 984
 985  @labels;
 986
 987 }
 988
 989 =item cust_main
 990
 991 Returns the parent customer object (see L<FS::cust_main>).
 992
 993 =cut
 994
 995 sub cust_main {
 996   my $self = shift;
 997   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 998 }
 999
1000 =item seconds_since TIMESTAMP
1001
1002 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1003 package have been online since TIMESTAMP, according to the session monitor.
1004
1005 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1006 L<Time::Local> and L<Date::Parse> for conversion functions.
1007
1008 =cut
1009
1010 sub seconds_since {
1011   my($self, $since) = @_;
1012   my $seconds = 0;
1013
1014   foreach my $cust_svc (
1015     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1016   ) {
1017     $seconds += $cust_svc->seconds_since($since);
1018   }
1019
1020   $seconds;
1021
1022 }
1023
1024 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1025
1026 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1027 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1028 (exclusive).
1029
1030 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1031 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1032 functions.
1033
1034
1035 =cut
1036
1037 sub seconds_since_sqlradacct {
1038   my($self, $start, $end) = @_;
1039
1040   my $seconds = 0;
1041
1042   foreach my $cust_svc (
1043     grep {
1044       my $part_svc = $_->part_svc;
1045       $part_svc->svcdb eq 'svc_acct'
1046         && scalar($part_svc->part_export('sqlradius'));
1047     } $self->cust_svc
1048   ) {
1049     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1050   }
1051
1052   $seconds;
1053
1054 }
1055
1056 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1057
1058 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1059 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1060 TIMESTAMP_END
1061 (exclusive).
1062
1063 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1064 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1065 functions.
1066
1067 =cut
1068
1069 sub attribute_since_sqlradacct {
1070   my($self, $start, $end, $attrib) = @_;
1071
1072   my $sum = 0;
1073
1074   foreach my $cust_svc (
1075     grep {
1076       my $part_svc = $_->part_svc;
1077       $part_svc->svcdb eq 'svc_acct'
1078         && scalar($part_svc->part_export('sqlradius'));
1079     } $self->cust_svc
1080   ) {
1081     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1082   }
1083
1084   $sum;
1085
1086 }
1087
1088 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1089
1090 Transfers as many services as possible from this package to another package.
1091
1092 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1093 object.  The destination package must already exist.
1094
1095 Services are moved only if the destination allows services with the correct
1096 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1097 this option with caution!  No provision is made for export differences
1098 between the old and new service definitions.  Probably only should be used
1099 when your exports for all service definitions of a given svcdb are identical.
1100 (attempt a transfer without it first, to move all possible svcpart-matching
1101 services)
1102
1103 Any services that can't be moved remain in the original package.
1104
1105 Returns an error, if there is one; otherwise, returns the number of services
1106 that couldn't be moved.
1107
1108 =cut
1109
1110 sub transfer {
1111   my ($self, $dest_pkgnum, %opt) = @_;
1112
1113   my $remaining = 0;
1114   my $dest;
1115   my %target;
1116
1117   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1118     $dest = $dest_pkgnum;
1119     $dest_pkgnum = $dest->pkgnum;
1120   } else {
1121     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1122   }
1123
1124   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1125
1126   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1127     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1128   }
1129
1130   foreach my $cust_svc ($dest->cust_svc) {
1131     $target{$cust_svc->svcpart}--;
1132   }
1133
1134   my %svcpart2svcparts = ();
1135   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1136     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1137     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1138       next if exists $svcpart2svcparts{$svcpart};
1139       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1140       $svcpart2svcparts{$svcpart} = [
1141         map  { $_->[0] }
1142         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1143         map {
1144               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1145                                                    'svcpart' => $_          } );
1146               [ $_,
1147                 $pkg_svc ? $pkg_svc->primary_svc : '',
1148                 $pkg_svc ? $pkg_svc->quantity : 0,
1149               ];
1150             }
1151
1152         grep { $_ != $svcpart }
1153         map  { $_->svcpart }
1154         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1155       ];
1156       warn "alternates for svcpart $svcpart: ".
1157            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1158         if $DEBUG;
1159     }
1160   }
1161
1162   foreach my $cust_svc ($self->cust_svc) {
1163     if($target{$cust_svc->svcpart} > 0) {
1164       $target{$cust_svc->svcpart}--;
1165       my $new = new FS::cust_svc {
1166         svcnum  => $cust_svc->svcnum,
1167         svcpart => $cust_svc->svcpart,
1168         pkgnum  => $dest_pkgnum,
1169       };
1170       my $error = $new->replace($cust_svc);
1171       return $error if $error;
1172     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1173       if ( $DEBUG ) {
1174         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1175         warn "alternates to consider: ".
1176              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1177       }
1178       my @alternate = grep {
1179                              warn "considering alternate svcpart $_: ".
1180                                   "$target{$_} available in new package\n"
1181                                if $DEBUG;
1182                              $target{$_} > 0;
1183                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1184       if ( @alternate ) {
1185         warn "alternate(s) found\n" if $DEBUG;
1186         my $change_svcpart = $alternate[0];
1187         $target{$change_svcpart}--;
1188         my $new = new FS::cust_svc {
1189           svcnum  => $cust_svc->svcnum,
1190           svcpart => $change_svcpart,
1191           pkgnum  => $dest_pkgnum,
1192         };
1193         my $error = $new->replace($cust_svc);
1194         return $error if $error;
1195       } else {
1196         $remaining++;
1197       }
1198     } else {
1199       $remaining++
1200     }
1201   }
1202   return $remaining;
1203 }
1204
1205 =item reexport
1206
1207 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1208 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1209
1210 =cut
1211
1212 sub reexport {
1213   my $self = shift;
1214
1215   local $SIG{HUP} = 'IGNORE';
1216   local $SIG{INT} = 'IGNORE';
1217   local $SIG{QUIT} = 'IGNORE';
1218   local $SIG{TERM} = 'IGNORE';
1219   local $SIG{TSTP} = 'IGNORE';
1220   local $SIG{PIPE} = 'IGNORE';
1221
1222   my $oldAutoCommit = $FS::UID::AutoCommit;
1223   local $FS::UID::AutoCommit = 0;
1224   my $dbh = dbh;
1225
1226   foreach my $cust_svc ( $self->cust_svc ) {
1227     #false laziness w/svc_Common::insert
1228     my $svc_x = $cust_svc->svc_x;
1229     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1230       my $error = $part_export->export_insert($svc_x);
1231       if ( $error ) {
1232         $dbh->rollback if $oldAutoCommit;
1233         return $error;
1234       }
1235     }
1236   }
1237
1238   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1239   '';
1240
1241 }
1242
1243 =back
1244
1245 =head1 CLASS METHODS
1246
1247 =over 4
1248
1249 =item recurring_sql
1250
1251 Returns an SQL expression identifying recurring packages.
1252
1253 =cut
1254
1255 sub recurring_sql { "
1256   '0' != ( select freq from part_pkg
1257              where cust_pkg.pkgpart = part_pkg.pkgpart )
1258 "; }
1259
1260 =item onetime_sql
1261
1262 Returns an SQL expression identifying one-time packages.
1263
1264 =cut
1265
1266 sub onetime_sql { "
1267   '0' = ( select freq from part_pkg
1268             where cust_pkg.pkgpart = part_pkg.pkgpart )
1269 "; }
1270
1271 =item active_sql
1272
1273 Returns an SQL expression identifying active packages.
1274
1275 =cut
1276
1277 sub active_sql { "
1278   ". $_[0]->recurring_sql(). "
1279   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1280   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1281 "; }
1282
1283 =item inactive_sql
1284
1285 Returns an SQL expression identifying inactive packages (one-time packages
1286 that are otherwise unsuspended/uncancelled).
1287
1288 =cut
1289
1290 sub inactive_sql { "
1291   ". $_[0]->onetime_sql(). "
1292   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1293   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1294 "; }
1295
1296 =item susp_sql
1297 =item suspended_sql
1298
1299 Returns an SQL expression identifying suspended packages.
1300
1301 =cut
1302
1303 sub suspended_sql { susp_sql(@_); }
1304 sub susp_sql {
1305   #$_[0]->recurring_sql(). ' AND '.
1306   "
1307         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1308     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1309   ";
1310 }
1311
1312 =item cancel_sql
1313 =item cancelled_sql
1314
1315 Returns an SQL exprression identifying cancelled packages.
1316
1317 =cut
1318
1319 sub cancelled_sql { cancel_sql(@_); }
1320 sub cancel_sql {
1321   #$_[0]->recurring_sql(). ' AND '.
1322   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1323 }
1324
1325 =head1 SUBROUTINES
1326
1327 =over 4
1328
1329 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1330
1331 CUSTNUM is a customer (see L<FS::cust_main>)
1332
1333 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1334 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1335 permitted.
1336
1337 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1338 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1339 new billing items.  An error is returned if this is not possible (see
1340 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1341 parameter.
1342
1343 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1344 newly-created cust_pkg objects.
1345
1346 =cut
1347
1348 sub order {
1349   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1350
1351   my $conf = new FS::Conf;
1352
1353   # Transactionize this whole mess
1354   local $SIG{HUP} = 'IGNORE';
1355   local $SIG{INT} = 'IGNORE';
1356   local $SIG{QUIT} = 'IGNORE';
1357   local $SIG{TERM} = 'IGNORE';
1358   local $SIG{TSTP} = 'IGNORE';
1359   local $SIG{PIPE} = 'IGNORE';
1360
1361   my $oldAutoCommit = $FS::UID::AutoCommit;
1362   local $FS::UID::AutoCommit = 0;
1363   my $dbh = dbh;
1364
1365   my $error;
1366   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1367   return "Customer not found: $custnum" unless $cust_main;
1368
1369   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1370                          @$remove_pkgnum;
1371
1372   my $change = scalar(@old_cust_pkg) != 0;
1373
1374   my %hash = ();
1375   if ( scalar(@old_cust_pkg) == 1 ) {
1376     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1377     $hash{'setup'} = time;
1378   }
1379
1380   # Create the new packages.
1381   foreach my $pkgpart (@$pkgparts) {
1382     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1383                                       pkgpart => $pkgpart,
1384                                       %hash,
1385                                     };
1386     $error = $cust_pkg->insert( 'change' => $change );
1387     if ($error) {
1388       $dbh->rollback if $oldAutoCommit;
1389       return $error;
1390     }
1391     push @$return_cust_pkg, $cust_pkg;
1392   }
1393   # $return_cust_pkg now contains refs to all of the newly
1394   # created packages.
1395
1396   # Transfer services and cancel old packages.
1397   foreach my $old_pkg (@old_cust_pkg) {
1398
1399     foreach my $new_pkg (@$return_cust_pkg) {
1400       $error = $old_pkg->transfer($new_pkg);
1401       if ($error and $error == 0) {
1402         # $old_pkg->transfer failed.
1403         $dbh->rollback if $oldAutoCommit;
1404         return $error;
1405       }
1406     }
1407
1408     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1409       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1410       foreach my $new_pkg (@$return_cust_pkg) {
1411         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1412         if ($error and $error == 0) {
1413           # $old_pkg->transfer failed.
1414         $dbh->rollback if $oldAutoCommit;
1415         return $error;
1416         }
1417       }
1418     }
1419
1420     if ($error > 0) {
1421       # Transfers were successful, but we went through all of the
1422       # new packages and still had services left on the old package.
1423       # We can't cancel the package under the circumstances, so abort.
1424       $dbh->rollback if $oldAutoCommit;
1425       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1426     }
1427     $error = $old_pkg->cancel( quiet=>1 );
1428     if ($error) {
1429       $dbh->rollback;
1430       return $error;
1431     }
1432   }
1433   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1434   '';
1435 }
1436
1437 sub insert_reason {
1438   my ($self, %options) = @_;
1439
1440   my $otaker = $FS::CurrentUser::CurrentUser->name;
1441   $otaker = $FS::CurrentUser::CurrentUser->username
1442     if (($otaker) eq "User, Legacy");
1443
1444   my $cust_pkg_reason =
1445     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
1446                               'reasonnum' => $options{'reason'},
1447                               'otaker'    => $otaker,
1448                               'date'      => $options{'date'}
1449                                                ? $options{'date'}
1450                                                : time,
1451                             });
1452   return $cust_pkg_reason->insert;
1453 }
1454
1455 =item set_usage USAGE_VALUE_HASHREF
1456
1457 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
1458 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
1459 upbytes, downbytes, and totalbytes are appropriate keys.
1460
1461 All svc_accts which are part of this package have their values reset.
1462
1463 =cut
1464
1465 sub set_usage {
1466   my ($self, $valueref) = @_;
1467
1468   foreach my $cust_svc ($self->cust_svc){
1469     my $svc_x = $cust_svc->svc_x;
1470     $svc_x->set_usage($valueref)
1471       if $svc_x->can("set_usage");
1472   }
1473 }
1474
1475 =back
1476
1477 =head1 BUGS
1478
1479 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1480
1481 In sub order, the @pkgparts array (passed by reference) is clobbered.
1482
1483 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1484 method to pass dates to the recur_prog expression, it should do so.
1485
1486 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1487 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1488 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1489 configuration values.  Probably need a subroutine which decides what to do
1490 based on whether or not we've fetched the user yet, rather than a hash.  See
1491 FS::UID and the TODO.
1492
1493 Now that things are transactional should the check in the insert method be
1494 moved to check ?
1495
1496 =head1 SEE ALSO
1497
1498 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1499 L<FS::pkg_svc>, schema.html from the base documentation
1500
1501 =cut
1502
1503 1;
1504