FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use List::Util qw(max);
   6 use Tie::IxHash;
   7 use FS::UID qw( getotaker dbh );
   8 use FS::Misc qw( send_email );
   9 use FS::Record qw( qsearch qsearchs );
  10 use FS::cust_main_Mixin;
  11 use FS::cust_svc;
  12 use FS::part_pkg;
  13 use FS::cust_main;
  14 use FS::type_pkgs;
  15 use FS::pkg_svc;
  16 use FS::cust_bill_pkg;
  17 use FS::h_cust_svc;
  18 use FS::reg_code;
  19 use FS::part_svc;
  20 use FS::cust_pkg_reason;
  21 use FS::reason;
  22 use FS::UI::Web;
  23
  24 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  25 # setup }
  26 # because they load configuration by setting FS::UID::callback (see TODO)
  27 use FS::svc_acct;
  28 use FS::svc_domain;
  29 use FS::svc_www;
  30 use FS::svc_forward;
  31
  32 # for sending cancel emails in sub cancel
  33 use FS::Conf;
  34
  35 @ISA = qw( FS::cust_main_Mixin FS::option_Common FS::Record );
  36
  37 $DEBUG = 0;
  38
  39 $disable_agentcheck = 0;
  40
  41 sub _cache {
  42   my $self = shift;
  43   my ( $hashref, $cache ) = @_;
  44   #if ( $hashref->{'pkgpart'} ) {
  45   if ( $hashref->{'pkg'} ) {
  46     # #@{ $self->{'_pkgnum'} } = ();
  47     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  48     # $self->{'_pkgpart'} = $subcache;
  49     # #push @{ $self->{'_pkgnum'} },
  50     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  51     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  52   }
  53   if ( exists $hashref->{'svcnum'} ) {
  54     #@{ $self->{'_pkgnum'} } = ();
  55     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  56     $self->{'_svcnum'} = $subcache;
  57     #push @{ $self->{'_pkgnum'} },
  58     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  59   }
  60 }
  61
  62 =head1 NAME
  63
  64 FS::cust_pkg - Object methods for cust_pkg objects
  65
  66 =head1 SYNOPSIS
  67
  68   use FS::cust_pkg;
  69
  70   $record = new FS::cust_pkg \%hash;
  71   $record = new FS::cust_pkg { 'column' => 'value' };
  72
  73   $error = $record->insert;
  74
  75   $error = $new_record->replace($old_record);
  76
  77   $error = $record->delete;
  78
  79   $error = $record->check;
  80
  81   $error = $record->cancel;
  82
  83   $error = $record->suspend;
  84
  85   $error = $record->unsuspend;
  86
  87   $part_pkg = $record->part_pkg;
  88
  89   @labels = $record->labels;
  90
  91   $seconds = $record->seconds_since($timestamp);
  92
  93   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  94   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  95
  96 =head1 DESCRIPTION
  97
  98 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  99 inherits from FS::Record.  The following fields are currently supported:
 100
 101 =over 4
 102
 103 =item pkgnum - primary key (assigned automatically for new billing items)
 104
 105 =item custnum - Customer (see L<FS::cust_main>)
 106
 107 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 108
 109 =item setup - date
 110
 111 =item bill - date (next bill date)
 112
 113 =item last_bill - last bill date
 114
 115 =item adjourn - date
 116
 117 =item susp - date
 118
 119 =item expire - date
 120
 121 =item cancel - date
 122
 123 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 124
 125 =item manual_flag - If this field is set to 1, disables the automatic
 126 unsuspension of this package when using the B<unsuspendauto> config file.
 127
 128 =item quantity - If not set, defaults to 1
 129
 130 =back
 131
 132 Note: setup, bill, adjourn, 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($options{options} ? %{$options{options}} : ());
 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->
 221             credit( $amount,
 222                     'Referral credit for '.$cust_main->name,
 223                     'reason_type' => $conf->config('referral_credit_type')
 224                   );
 225         if ( $error ) {
 226           $dbh->rollback if $oldAutoCommit;
 227           return "Error crediting customer ". $cust_main->referral_custnum.
 228                " for referral: $error";
 229         }
 230
 231       }
 232
 233     }
 234   }
 235
 236   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 237     my $queue = new FS::queue {
 238       'job'     => 'FS::cust_main::queueable_print',
 239     };
 240     $error = $queue->insert(
 241       'custnum'  => $self->custnum,
 242       'template' => 'welcome_letter',
 243     );
 244
 245     if ($error) {
 246       warn "can't send welcome letter: $error";
 247     }
 248
 249   }
 250
 251   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 252   '';
 253
 254 }
 255
 256 =item delete
 257
 258 This method now works but you probably shouldn't use it.
 259
 260 You don't want to delete billing items, because there would then be no record
 261 the customer ever purchased the item.  Instead, see the cancel method.
 262
 263 =cut
 264
 265 #sub delete {
 266 #  return "Can't delete cust_pkg records!";
 267 #}
 268
 269 =item replace OLD_RECORD
 270
 271 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 272 returns the error, otherwise returns false.
 273
 274 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 275
 276 Changing pkgpart may have disasterous effects.  See the order subroutine.
 277
 278 setup and bill are normally updated by calling the bill method of a customer
 279 object (see L<FS::cust_main>).
 280
 281 suspend is normally updated by the suspend and unsuspend methods.
 282
 283 cancel is normally updated by the cancel method (and also the order subroutine
 284 in some cases).
 285
 286 Calls
 287
 288 =cut
 289
 290 sub replace {
 291   my( $new, $old, %options ) = @_;
 292
 293   # We absolutely have to have an old vs. new record to make this work.
 294   if (!defined($old)) {
 295     $old = qsearchs( 'cust_pkg', { 'pkgnum' => $new->pkgnum } );
 296   }
 297   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 298   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 299
 300   #allow this *sigh*
 301   #return "Can't change setup once it exists!"
 302   #  if $old->getfield('setup') &&
 303   #     $old->getfield('setup') != $new->getfield('setup');
 304
 305   #some logic for bill, susp, cancel?
 306
 307   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 308
 309   local $SIG{HUP} = 'IGNORE';
 310   local $SIG{INT} = 'IGNORE';
 311   local $SIG{QUIT} = 'IGNORE';
 312   local $SIG{TERM} = 'IGNORE';
 313   local $SIG{TSTP} = 'IGNORE';
 314   local $SIG{PIPE} = 'IGNORE';
 315
 316   my $oldAutoCommit = $FS::UID::AutoCommit;
 317   local $FS::UID::AutoCommit = 0;
 318   my $dbh = dbh;
 319
 320   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 321     if ($options{'reason'} && $new->$method && $old->$method ne $new->$method) {
 322       my $error = $new->insert_reason( 'reason' => $options{'reason'},
 323                                        'date'   => $new->$method,
 324                                        'action' => $method,
 325                                        'reason_otaker' => $options{'reason_otaker'},
 326                                      );
 327       if ( $error ) {
 328         dbh->rollback if $oldAutoCommit;
 329         return "Error inserting cust_pkg_reason: $error";
 330       }
 331     }
 332   }
 333
 334   #save off and freeze RADIUS attributes for any associated svc_acct records
 335   my @svc_acct = ();
 336   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 337
 338                 #also check for specific exports?
 339                 # to avoid spurious modify export events
 340     @svc_acct = map  { $_->svc_x }
 341                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 342                      $old->cust_svc;
 343
 344     $_->snapshot foreach @svc_acct;
 345
 346   }
 347
 348   my $error = $new->SUPER::replace($old,
 349                                    $options{options} ? ${options{options}} : ()
 350                                   );
 351   if ( $error ) {
 352     $dbh->rollback if $oldAutoCommit;
 353     return $error;
 354   }
 355
 356   #for prepaid packages,
 357   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 358   foreach my $old_svc_acct ( @svc_acct ) {
 359     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 360     my $s_error = $new_svc_acct->replace($old_svc_acct);
 361     if ( $s_error ) {
 362       $dbh->rollback if $oldAutoCommit;
 363       return $s_error;
 364     }
 365   }
 366
 367   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 368   '';
 369
 370 }
 371
 372 =item check
 373
 374 Checks all fields to make sure this is a valid billing item.  If there is an
 375 error, returns the error, otherwise returns false.  Called by the insert and
 376 replace methods.
 377
 378 =cut
 379
 380 sub check {
 381   my $self = shift;
 382
 383   my $error =
 384     $self->ut_numbern('pkgnum')
 385     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 386     || $self->ut_numbern('pkgpart')
 387     || $self->ut_numbern('setup')
 388     || $self->ut_numbern('bill')
 389     || $self->ut_numbern('susp')
 390     || $self->ut_numbern('cancel')
 391     || $self->ut_numbern('adjourn')
 392     || $self->ut_numbern('expire')
 393   ;
 394   return $error if $error;
 395
 396   if ( $self->reg_code ) {
 397
 398     unless ( grep { $self->pkgpart == $_->pkgpart }
 399              map  { $_->reg_code_pkg }
 400              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 401                                      'agentnum' => $self->cust_main->agentnum })
 402            ) {
 403       return "Unknown registration code";
 404     }
 405
 406   } elsif ( $self->promo_code ) {
 407
 408     my $promo_part_pkg =
 409       qsearchs('part_pkg', {
 410         'pkgpart'    => $self->pkgpart,
 411         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 412       } );
 413     return 'Unknown promotional code' unless $promo_part_pkg;
 414
 415   } else {
 416
 417     unless ( $disable_agentcheck ) {
 418       my $agent =
 419         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 420       my $pkgpart_href = $agent->pkgpart_hashref;
 421       return "agent ". $agent->agentnum.
 422              " can't purchase pkgpart ". $self->pkgpart
 423         unless $pkgpart_href->{ $self->pkgpart };
 424     }
 425
 426     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 427     return $error if $error;
 428
 429   }
 430
 431   $self->otaker(getotaker) unless $self->otaker;
 432   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 433   $self->otaker($1);
 434
 435   if ( $self->dbdef_table->column('manual_flag') ) {
 436     $self->manual_flag('') if $self->manual_flag eq ' ';
 437     $self->manual_flag =~ /^([01]?)$/
 438       or return "Illegal manual_flag ". $self->manual_flag;
 439     $self->manual_flag($1);
 440   }
 441
 442   $self->SUPER::check;
 443 }
 444
 445 =item cancel [ OPTION => VALUE ... ]
 446
 447 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 448 in this package, then cancels the package itself (sets the cancel field to
 449 now).
 450
 451 Available options are: I<quiet> I<reason> I<date>
 452
 453 I<quiet> can be set true to supress email cancellation notices.
 454 I<reason> can be set to a reasonnum (see L<FS::reason>) explaining the action
 455 I<date> can be set to a unix style timestamp to specify when to cancel (expire)
 456
 457 If there is an error, returns the error, otherwise returns false.
 458
 459 =cut
 460
 461 sub cancel {
 462   my( $self, %options ) = @_;
 463   my $error;
 464
 465   local $SIG{HUP} = 'IGNORE';
 466   local $SIG{INT} = 'IGNORE';
 467   local $SIG{QUIT} = 'IGNORE';
 468   local $SIG{TERM} = 'IGNORE';
 469   local $SIG{TSTP} = 'IGNORE';
 470   local $SIG{PIPE} = 'IGNORE';
 471
 472   my $oldAutoCommit = $FS::UID::AutoCommit;
 473   local $FS::UID::AutoCommit = 0;
 474   my $dbh = dbh;
 475
 476   my $old = $self->select_for_update;
 477
 478   if ( $old->get('cancel') || $self->get('cancel') ) {
 479     dbh->rollback if $oldAutoCommit;
 480     return "";  # no error
 481   }
 482
 483   my $date = $options{date} if $options{date}; # expire/cancel later
 484   $date = '' if ($date && $date <= time);      # complain instead?
 485
 486   if ($options{'reason'}) {
 487     $error = $self->insert_reason( 'reason' => $options{'reason'},
 488                                    'action' => $date ? 'expire' : 'cancel',
 489                                    'reason_otaker' => $options{'reason_otaker'},
 490                                  );
 491     if ( $error ) {
 492       dbh->rollback if $oldAutoCommit;
 493       return "Error inserting cust_pkg_reason: $error";
 494     }
 495   }
 496
 497   my %svc;
 498   unless ( $date ) {
 499     foreach my $cust_svc (
 500       #schwartz
 501       map  { $_->[0] }
 502       sort { $a->[1] <=> $b->[1] }
 503       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 504       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 505     ) {
 506
 507       my $error = $cust_svc->cancel;
 508
 509       if ( $error ) {
 510         $dbh->rollback if $oldAutoCommit;
 511         return "Error cancelling cust_svc: $error";
 512       }
 513     }
 514
 515     # Add a credit for remaining service
 516     my $remaining_value = $self->calc_remain();
 517     if ( $remaining_value > 0 ) {
 518       my $conf = new FS::Conf;
 519       my $error = $self->cust_main->credit(
 520         $remaining_value,
 521         'Credit for unused time on '. $self->part_pkg->pkg,
 522         'reason_type' => $conf->config('cancel_credit_type'),
 523       );
 524       if ($error) {
 525         $dbh->rollback if $oldAutoCommit;
 526         return "Error crediting customer \$$remaining_value for unused time on".
 527                $self->part_pkg->pkg. ": $error";
 528       }
 529     }
 530   }
 531
 532   my %hash = $self->hash;
 533   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = time);
 534   my $new = new FS::cust_pkg ( \%hash );
 535   $error = $new->replace( $self, options => { $self->options } );
 536   if ( $error ) {
 537     $dbh->rollback if $oldAutoCommit;
 538     return $error;
 539   }
 540
 541   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 542   return '' if $date; #no errors
 543
 544   my $conf = new FS::Conf;
 545   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 546   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 547     my $conf = new FS::Conf;
 548     my $error = send_email(
 549       'from'    => $conf->config('invoice_from'),
 550       'to'      => \@invoicing_list,
 551       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 552       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 553     );
 554     #should this do something on errors?
 555   }
 556
 557   ''; #no errors
 558
 559 }
 560
 561 =item unexpire
 562
 563 Cancels any pending expiration (sets the expire field to null).
 564
 565 If there is an error, returns the error, otherwise returns false.
 566
 567 =cut
 568
 569 sub unexpire {
 570   my( $self, %options ) = @_;
 571   my $error;
 572
 573   local $SIG{HUP} = 'IGNORE';
 574   local $SIG{INT} = 'IGNORE';
 575   local $SIG{QUIT} = 'IGNORE';
 576   local $SIG{TERM} = 'IGNORE';
 577   local $SIG{TSTP} = 'IGNORE';
 578   local $SIG{PIPE} = 'IGNORE';
 579
 580   my $oldAutoCommit = $FS::UID::AutoCommit;
 581   local $FS::UID::AutoCommit = 0;
 582   my $dbh = dbh;
 583
 584   my $old = $self->select_for_update;
 585
 586   my $pkgnum = $old->pkgnum;
 587   if ( $old->get('cancel') || $self->get('cancel') ) {
 588     dbh->rollback if $oldAutoCommit;
 589     return "Can't unexpire cancelled package $pkgnum";
 590     # or at least it's pointless
 591   }
 592
 593   unless ( $old->get('expire') && $self->get('expire') ) {
 594     dbh->rollback if $oldAutoCommit;
 595     return "";  # no error
 596   }
 597
 598   my %hash = $self->hash;
 599   $hash{'expire'} = '';
 600   my $new = new FS::cust_pkg ( \%hash );
 601   $error = $new->replace( $self, options => { $self->options } );
 602   if ( $error ) {
 603     $dbh->rollback if $oldAutoCommit;
 604     return $error;
 605   }
 606
 607   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 608
 609   ''; #no errors
 610
 611 }
 612
 613 =item suspend [ OPTION => VALUE ... ]
 614
 615 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 616 package, then suspends the package itself (sets the susp field to now).
 617
 618 Available options are: I<reason> I<date>
 619
 620 I<date> can be set to a unix style timestamp to specify when to suspend (adjourn)
 621 I<reason> can be set to a reasonnum (see L<FS::reason>) explaining the action
 622
 623 If there is an error, returns the error, otherwise returns false.
 624
 625 =cut
 626
 627 sub suspend {
 628   my( $self, %options ) = @_;
 629   my $error ;
 630
 631   local $SIG{HUP} = 'IGNORE';
 632   local $SIG{INT} = 'IGNORE';
 633   local $SIG{QUIT} = 'IGNORE';
 634   local $SIG{TERM} = 'IGNORE';
 635   local $SIG{TSTP} = 'IGNORE';
 636   local $SIG{PIPE} = 'IGNORE';
 637
 638   my $oldAutoCommit = $FS::UID::AutoCommit;
 639   local $FS::UID::AutoCommit = 0;
 640   my $dbh = dbh;
 641
 642   my $old = $self->select_for_update;
 643
 644   my $pkgnum = $old->pkgnum;
 645   if ( $old->get('cancel') || $self->get('cancel') ) {
 646     dbh->rollback if $oldAutoCommit;
 647     return "Can't suspend cancelled package $pkgnum";
 648   }
 649
 650   if ( $old->get('susp') || $self->get('susp') ) {
 651     dbh->rollback if $oldAutoCommit;
 652     return "";  # no error                     # complain on adjourn?
 653   }
 654
 655   my $date = $options{date} if $options{date}; # adjourn/suspend later
 656   $date = '' if ($date && $date <= time);      # complain instead?
 657
 658   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 659     dbh->rollback if $oldAutoCommit;
 660     return "Package $pkgnum expires before it would be suspended.";
 661   }
 662
 663   if ($options{'reason'}) {
 664     $error = $self->insert_reason( 'reason' => $options{'reason'},
 665                                    'action' => $date ? 'adjourn' : 'suspend',
 666                                    'reason_otaker' => $options{'reason_otaker'},
 667                                  );
 668     if ( $error ) {
 669       dbh->rollback if $oldAutoCommit;
 670       return "Error inserting cust_pkg_reason: $error";
 671     }
 672   }
 673
 674   unless ( $date ) {
 675     foreach my $cust_svc (
 676       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 677     ) {
 678       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 679
 680       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 681         $dbh->rollback if $oldAutoCommit;
 682         return "Illegal svcdb value in part_svc!";
 683       };
 684       my $svcdb = $1;
 685       require "FS/$svcdb.pm";
 686
 687       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 688       if ($svc) {
 689         $error = $svc->suspend;
 690         if ( $error ) {
 691           $dbh->rollback if $oldAutoCommit;
 692           return $error;
 693         }
 694       }
 695     }
 696   }
 697
 698   my %hash = $self->hash;
 699   $date ? ($hash{'adjourn'} = $date) : ($hash{'susp'} = time);
 700   my $new = new FS::cust_pkg ( \%hash );
 701   $error = $new->replace( $self, options => { $self->options } );
 702   if ( $error ) {
 703     $dbh->rollback if $oldAutoCommit;
 704     return $error;
 705   }
 706
 707   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 708
 709   ''; #no errors
 710 }
 711
 712 =item unsuspend [ OPTION => VALUE ... ]
 713
 714 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 715 package, then unsuspends the package itself (clears the susp field and the
 716 adjourn field if it is in the past).
 717
 718 Available options are: I<adjust_next_bill>.
 719
 720 I<adjust_next_bill> can be set true to adjust the next bill date forward by
 721 the amount of time the account was inactive.  This was set true by default
 722 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 723 explicitly requested.  Price plans for which this makes sense (anniversary-date
 724 based than prorate or subscription) could have an option to enable this
 725 behaviour?
 726
 727 If there is an error, returns the error, otherwise returns false.
 728
 729 =cut
 730
 731 sub unsuspend {
 732   my( $self, %opt ) = @_;
 733   my $error;
 734
 735   local $SIG{HUP} = 'IGNORE';
 736   local $SIG{INT} = 'IGNORE';
 737   local $SIG{QUIT} = 'IGNORE';
 738   local $SIG{TERM} = 'IGNORE';
 739   local $SIG{TSTP} = 'IGNORE';
 740   local $SIG{PIPE} = 'IGNORE';
 741
 742   my $oldAutoCommit = $FS::UID::AutoCommit;
 743   local $FS::UID::AutoCommit = 0;
 744   my $dbh = dbh;
 745
 746   my $old = $self->select_for_update;
 747
 748   my $pkgnum = $old->pkgnum;
 749   if ( $old->get('cancel') || $self->get('cancel') ) {
 750     dbh->rollback if $oldAutoCommit;
 751     return "Can't unsuspend cancelled package $pkgnum";
 752   }
 753
 754   unless ( $old->get('susp') && $self->get('susp') ) {
 755     dbh->rollback if $oldAutoCommit;
 756     return "";  # no error                     # complain instead?
 757   }
 758
 759   foreach my $cust_svc (
 760     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 761   ) {
 762     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 763
 764     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 765       $dbh->rollback if $oldAutoCommit;
 766       return "Illegal svcdb value in part_svc!";
 767     };
 768     my $svcdb = $1;
 769     require "FS/$svcdb.pm";
 770
 771     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 772     if ($svc) {
 773       $error = $svc->unsuspend;
 774       if ( $error ) {
 775         $dbh->rollback if $oldAutoCommit;
 776         return $error;
 777       }
 778     }
 779
 780   }
 781
 782   my %hash = $self->hash;
 783   my $inactive = time - $hash{'susp'};
 784
 785   my $conf = new FS::Conf;
 786
 787   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 788     if ( $opt{'adjust_next_bill'}
 789          || $conf->config('unsuspend-always_adjust_next_bill_date') )
 790     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 791
 792   $hash{'susp'} = '';
 793   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 794   my $new = new FS::cust_pkg ( \%hash );
 795   $error = $new->replace( $self, options => { $self->options } );
 796   if ( $error ) {
 797     $dbh->rollback if $oldAutoCommit;
 798     return $error;
 799   }
 800
 801   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 802
 803   ''; #no errors
 804 }
 805
 806 =item unadjourn
 807
 808 Cancels any pending suspension (sets the adjourn field to null).
 809
 810 If there is an error, returns the error, otherwise returns false.
 811
 812 =cut
 813
 814 sub unadjourn {
 815   my( $self, %options ) = @_;
 816   my $error;
 817
 818   local $SIG{HUP} = 'IGNORE';
 819   local $SIG{INT} = 'IGNORE';
 820   local $SIG{QUIT} = 'IGNORE';
 821   local $SIG{TERM} = 'IGNORE';
 822   local $SIG{TSTP} = 'IGNORE';
 823   local $SIG{PIPE} = 'IGNORE';
 824
 825   my $oldAutoCommit = $FS::UID::AutoCommit;
 826   local $FS::UID::AutoCommit = 0;
 827   my $dbh = dbh;
 828
 829   my $old = $self->select_for_update;
 830
 831   my $pkgnum = $old->pkgnum;
 832   if ( $old->get('cancel') || $self->get('cancel') ) {
 833     dbh->rollback if $oldAutoCommit;
 834     return "Can't unadjourn cancelled package $pkgnum";
 835     # or at least it's pointless
 836   }
 837
 838   if ( $old->get('susp') || $self->get('susp') ) {
 839     dbh->rollback if $oldAutoCommit;
 840     return "Can't unadjourn suspended package $pkgnum";
 841     # perhaps this is arbitrary
 842   }
 843
 844   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
 845     dbh->rollback if $oldAutoCommit;
 846     return "";  # no error
 847   }
 848
 849   my %hash = $self->hash;
 850   $hash{'adjourn'} = '';
 851   my $new = new FS::cust_pkg ( \%hash );
 852   $error = $new->replace( $self, options => { $self->options } );
 853   if ( $error ) {
 854     $dbh->rollback if $oldAutoCommit;
 855     return $error;
 856   }
 857
 858   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 859
 860   ''; #no errors
 861
 862 }
 863
 864 =item last_bill
 865
 866 Returns the last bill date, or if there is no last bill date, the setup date.
 867 Useful for billing metered services.
 868
 869 =cut
 870
 871 sub last_bill {
 872   my $self = shift;
 873   if ( $self->dbdef_table->column('last_bill') ) {
 874     return $self->setfield('last_bill', $_[0]) if @_;
 875     return $self->getfield('last_bill') if $self->getfield('last_bill');
 876   }
 877   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 878                                                   'edate'  => $self->bill,  } );
 879   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 880 }
 881
 882 =item last_cust_pkg_reason ACTION
 883
 884 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
 885 Returns false if there is no reason or the package is not currenly ACTION'd
 886 ACTION is one of adjourn, susp, cancel, or expire.
 887
 888 =cut
 889
 890 sub last_cust_pkg_reason {
 891   my ( $self, $action ) = ( shift, shift );
 892   my $date = $self->get($action);
 893   qsearchs( {
 894               'table' => 'cust_pkg_reason',
 895               'hashref' => { 'pkgnum' => $self->pkgnum,
 896                              'action' => substr(uc($action), 0, 1),
 897                              'date'   => $date,
 898                            },
 899               'order_by' => 'ORDER BY num DESC LIMIT 1',
 900            } );
 901 }
 902
 903 =item last_reason ACTION
 904
 905 Returns the most recent ACTION FS::reason associated with the package.
 906 Returns false if there is no reason or the package is not currenly ACTION'd
 907 ACTION is one of adjourn, susp, cancel, or expire.
 908
 909 =cut
 910
 911 sub last_reason {
 912   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
 913   $cust_pkg_reason->reason
 914     if $cust_pkg_reason;
 915 }
 916
 917 =item part_pkg
 918
 919 Returns the definition for this billing item, as an FS::part_pkg object (see
 920 L<FS::part_pkg>).
 921
 922 =cut
 923
 924 sub part_pkg {
 925   my $self = shift;
 926   #exists( $self->{'_pkgpart'} )
 927   $self->{'_pkgpart'}
 928     ? $self->{'_pkgpart'}
 929     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 930 }
 931
 932 =item old_cust_pkg
 933
 934 Returns the cancelled package this package was changed from, if any.
 935
 936 =cut
 937
 938 sub old_cust_pkg {
 939   my $self = shift;
 940   return '' unless $self->change_pkgnum;
 941   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
 942 }
 943
 944 =item calc_setup
 945
 946 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 947 item.
 948
 949 =cut
 950
 951 sub calc_setup {
 952   my $self = shift;
 953   $self->part_pkg->calc_setup($self, @_);
 954 }
 955
 956 =item calc_recur
 957
 958 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 959 item.
 960
 961 =cut
 962
 963 sub calc_recur {
 964   my $self = shift;
 965   $self->part_pkg->calc_recur($self, @_);
 966 }
 967
 968 =item calc_remain
 969
 970 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 971 billing item.
 972
 973 =cut
 974
 975 sub calc_remain {
 976   my $self = shift;
 977   $self->part_pkg->calc_remain($self, @_);
 978 }
 979
 980 =item calc_cancel
 981
 982 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 983 billing item.
 984
 985 =cut
 986
 987 sub calc_cancel {
 988   my $self = shift;
 989   $self->part_pkg->calc_cancel($self, @_);
 990 }
 991
 992 =item cust_bill_pkg
 993
 994 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
 995
 996 =cut
 997
 998 sub cust_bill_pkg {
 999   my $self = shift;
1000   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1001 }
1002
1003 =item cust_svc [ SVCPART ]
1004
1005 Returns the services for this package, as FS::cust_svc objects (see
1006 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1007 services.
1008
1009 =cut
1010
1011 sub cust_svc {
1012   my $self = shift;
1013
1014   if ( @_ ) {
1015     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1016                                   'svcpart' => shift,          } );
1017   }
1018
1019   #if ( $self->{'_svcnum'} ) {
1020   #  values %{ $self->{'_svcnum'}->cache };
1021   #} else {
1022     $self->_sort_cust_svc(
1023       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1024     );
1025   #}
1026
1027 }
1028
1029 =item overlimit [ SVCPART ]
1030
1031 Returns the services for this package which have exceeded their
1032 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1033 is specified, return only the matching services.
1034
1035 =cut
1036
1037 sub overlimit {
1038   my $self = shift;
1039   grep { $_->overlimit } $self->cust_svc;
1040 }
1041
1042 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1043
1044 Returns historical services for this package created before END TIMESTAMP and
1045 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1046 (see L<FS::h_cust_svc>).
1047
1048 =cut
1049
1050 sub h_cust_svc {
1051   my $self = shift;
1052
1053   $self->_sort_cust_svc(
1054     [ qsearch( 'h_cust_svc',
1055                { 'pkgnum' => $self->pkgnum, },
1056                FS::h_cust_svc->sql_h_search(@_),
1057              )
1058     ]
1059   );
1060 }
1061
1062 sub _sort_cust_svc {
1063   my( $self, $arrayref ) = @_;
1064
1065   map  { $_->[0] }
1066   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1067   map {
1068         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1069                                              'svcpart' => $_->svcpart     } );
1070         [ $_,
1071           $pkg_svc ? $pkg_svc->primary_svc : '',
1072           $pkg_svc ? $pkg_svc->quantity : 0,
1073         ];
1074       }
1075   @$arrayref;
1076
1077 }
1078
1079 =item num_cust_svc [ SVCPART ]
1080
1081 Returns the number of provisioned services for this package.  If a svcpart is
1082 specified, counts only the matching services.
1083
1084 =cut
1085
1086 sub num_cust_svc {
1087   my $self = shift;
1088   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1089   $sql .= ' AND svcpart = ?' if @_;
1090   my $sth = dbh->prepare($sql) or die dbh->errstr;
1091   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1092   $sth->fetchrow_arrayref->[0];
1093 }
1094
1095 =item available_part_svc
1096
1097 Returns a list of FS::part_svc objects representing services included in this
1098 package but not yet provisioned.  Each FS::part_svc object also has an extra
1099 field, I<num_avail>, which specifies the number of available services.
1100
1101 =cut
1102
1103 sub available_part_svc {
1104   my $self = shift;
1105   grep { $_->num_avail > 0 }
1106     map {
1107           my $part_svc = $_->part_svc;
1108           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1109             $_->quantity - $self->num_cust_svc($_->svcpart);
1110           $part_svc;
1111         }
1112       $self->part_pkg->pkg_svc;
1113 }
1114
1115 =item part_svc
1116
1117 Returns a list of FS::part_svc objects representing provisioned and available
1118 services included in this package.  Each FS::part_svc object also has the
1119 following extra fields:
1120
1121 =over 4
1122
1123 =item num_cust_svc  (count)
1124
1125 =item num_avail     (quantity - count)
1126
1127 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1128
1129 svcnum
1130 label -> ($cust_svc->label)[1]
1131
1132 =back
1133
1134 =cut
1135
1136 sub part_svc {
1137   my $self = shift;
1138
1139   #XXX some sort of sort order besides numeric by svcpart...
1140   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1141     my $pkg_svc = $_;
1142     my $part_svc = $pkg_svc->part_svc;
1143     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1144     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1145     $part_svc->{'Hash'}{'num_avail'}    =
1146       max( 0, $pkg_svc->quantity - $num_cust_svc );
1147     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1148     $part_svc;
1149   } $self->part_pkg->pkg_svc;
1150
1151   #extras
1152   push @part_svc, map {
1153     my $part_svc = $_;
1154     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1155     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1156     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1157     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1158     $part_svc;
1159   } $self->extra_part_svc;
1160
1161   @part_svc;
1162
1163 }
1164
1165 =item extra_part_svc
1166
1167 Returns a list of FS::part_svc objects corresponding to services in this
1168 package which are still provisioned but not (any longer) available in the
1169 package definition.
1170
1171 =cut
1172
1173 sub extra_part_svc {
1174   my $self = shift;
1175
1176   my $pkgnum  = $self->pkgnum;
1177   my $pkgpart = $self->pkgpart;
1178
1179   qsearch( {
1180     'table'     => 'part_svc',
1181     'hashref'   => {},
1182     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1183                                   WHERE pkg_svc.svcpart = part_svc.svcpart
1184                                     AND pkg_svc.pkgpart = $pkgpart
1185                                     AND quantity > 0
1186                               )
1187                       AND 0 < ( SELECT count(*)
1188                                   FROM cust_svc
1189                                     LEFT JOIN cust_pkg using ( pkgnum )
1190                                   WHERE cust_svc.svcpart = part_svc.svcpart
1191                                     AND pkgnum = $pkgnum
1192                               )",
1193   } );
1194 }
1195
1196 =item status
1197
1198 Returns a short status string for this package, currently:
1199
1200 =over 4
1201
1202 =item not yet billed
1203
1204 =item one-time charge
1205
1206 =item active
1207
1208 =item suspended
1209
1210 =item cancelled
1211
1212 =back
1213
1214 =cut
1215
1216 sub status {
1217   my $self = shift;
1218
1219   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1220
1221   return 'cancelled' if $self->get('cancel');
1222   return 'suspended' if $self->susp;
1223   return 'not yet billed' unless $self->setup;
1224   return 'one-time charge' if $freq =~ /^(0|$)/;
1225   return 'active';
1226 }
1227
1228 =item statuses
1229
1230 Class method that returns the list of possible status strings for pacakges
1231 (see L<the status method|/status>).  For example:
1232
1233   @statuses = FS::cust_pkg->statuses();
1234
1235 =cut
1236
1237 tie my %statuscolor, 'Tie::IxHash',
1238   'not yet billed'  => '000000',
1239   'one-time charge' => '000000',
1240   'active'          => '00CC00',
1241   'suspended'       => 'FF9900',
1242   'cancelled'       => 'FF0000',
1243 ;
1244
1245 sub statuses {
1246   my $self = shift; #could be class...
1247   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1248                                       # mayble split btw one-time vs. recur
1249     keys %statuscolor;
1250 }
1251
1252 =item statuscolor
1253
1254 Returns a hex triplet color string for this package's status.
1255
1256 =cut
1257
1258 sub statuscolor {
1259   my $self = shift;
1260   $statuscolor{$self->status};
1261 }
1262
1263 =item labels
1264
1265 Returns a list of lists, calling the label method for all services
1266 (see L<FS::cust_svc>) of this billing item.
1267
1268 =cut
1269
1270 sub labels {
1271   my $self = shift;
1272   map { [ $_->label ] } $self->cust_svc;
1273 }
1274
1275 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1276
1277 Like the labels method, but returns historical information on services that
1278 were active as of END_TIMESTAMP and (optionally) not cancelled before
1279 START_TIMESTAMP.
1280
1281 Returns a list of lists, calling the label method for all (historical) services
1282 (see L<FS::h_cust_svc>) of this billing item.
1283
1284 =cut
1285
1286 sub h_labels {
1287   my $self = shift;
1288   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1289 }
1290
1291 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1292
1293 Like h_labels, except returns a simple flat list, and shortens long
1294 (currently >5) lists of identical services to one line that lists the service
1295 label and the number of individual services rather than individual items.
1296
1297 =cut
1298
1299 sub h_labels_short {
1300   my $self = shift;
1301
1302   my %labels;
1303   #tie %labels, 'Tie::IxHash';
1304   push @{ $labels{$_->[0]} }, $_->[1]
1305     foreach $self->h_labels(@_);
1306   my @labels;
1307   foreach my $label ( keys %labels ) {
1308     my @values = @{ $labels{$label} };
1309     my $num = scalar(@values);
1310     if ( $num > 5 ) {
1311       push @labels, "$label ($num)";
1312     } else {
1313       push @labels, map { "$label: $_" } @values;
1314     }
1315   }
1316
1317  @labels;
1318
1319 }
1320
1321 =item cust_main
1322
1323 Returns the parent customer object (see L<FS::cust_main>).
1324
1325 =cut
1326
1327 sub cust_main {
1328   my $self = shift;
1329   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1330 }
1331
1332 =item seconds_since TIMESTAMP
1333
1334 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1335 package have been online since TIMESTAMP, according to the session monitor.
1336
1337 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1338 L<Time::Local> and L<Date::Parse> for conversion functions.
1339
1340 =cut
1341
1342 sub seconds_since {
1343   my($self, $since) = @_;
1344   my $seconds = 0;
1345
1346   foreach my $cust_svc (
1347     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1348   ) {
1349     $seconds += $cust_svc->seconds_since($since);
1350   }
1351
1352   $seconds;
1353
1354 }
1355
1356 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1357
1358 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1359 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1360 (exclusive).
1361
1362 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1363 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1364 functions.
1365
1366
1367 =cut
1368
1369 sub seconds_since_sqlradacct {
1370   my($self, $start, $end) = @_;
1371
1372   my $seconds = 0;
1373
1374   foreach my $cust_svc (
1375     grep {
1376       my $part_svc = $_->part_svc;
1377       $part_svc->svcdb eq 'svc_acct'
1378         && scalar($part_svc->part_export('sqlradius'));
1379     } $self->cust_svc
1380   ) {
1381     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1382   }
1383
1384   $seconds;
1385
1386 }
1387
1388 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1389
1390 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1391 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1392 TIMESTAMP_END
1393 (exclusive).
1394
1395 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1396 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1397 functions.
1398
1399 =cut
1400
1401 sub attribute_since_sqlradacct {
1402   my($self, $start, $end, $attrib) = @_;
1403
1404   my $sum = 0;
1405
1406   foreach my $cust_svc (
1407     grep {
1408       my $part_svc = $_->part_svc;
1409       $part_svc->svcdb eq 'svc_acct'
1410         && scalar($part_svc->part_export('sqlradius'));
1411     } $self->cust_svc
1412   ) {
1413     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1414   }
1415
1416   $sum;
1417
1418 }
1419
1420 =item quantity
1421
1422 =cut
1423
1424 sub quantity {
1425   my( $self, $value ) = @_;
1426   if ( defined($value) ) {
1427     $self->setfield('quantity', $value);
1428   }
1429   $self->getfield('quantity') || 1;
1430 }
1431
1432 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1433
1434 Transfers as many services as possible from this package to another package.
1435
1436 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1437 object.  The destination package must already exist.
1438
1439 Services are moved only if the destination allows services with the correct
1440 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1441 this option with caution!  No provision is made for export differences
1442 between the old and new service definitions.  Probably only should be used
1443 when your exports for all service definitions of a given svcdb are identical.
1444 (attempt a transfer without it first, to move all possible svcpart-matching
1445 services)
1446
1447 Any services that can't be moved remain in the original package.
1448
1449 Returns an error, if there is one; otherwise, returns the number of services
1450 that couldn't be moved.
1451
1452 =cut
1453
1454 sub transfer {
1455   my ($self, $dest_pkgnum, %opt) = @_;
1456
1457   my $remaining = 0;
1458   my $dest;
1459   my %target;
1460
1461   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1462     $dest = $dest_pkgnum;
1463     $dest_pkgnum = $dest->pkgnum;
1464   } else {
1465     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1466   }
1467
1468   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1469
1470   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1471     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1472   }
1473
1474   foreach my $cust_svc ($dest->cust_svc) {
1475     $target{$cust_svc->svcpart}--;
1476   }
1477
1478   my %svcpart2svcparts = ();
1479   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1480     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1481     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1482       next if exists $svcpart2svcparts{$svcpart};
1483       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1484       $svcpart2svcparts{$svcpart} = [
1485         map  { $_->[0] }
1486         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1487         map {
1488               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1489                                                    'svcpart' => $_          } );
1490               [ $_,
1491                 $pkg_svc ? $pkg_svc->primary_svc : '',
1492                 $pkg_svc ? $pkg_svc->quantity : 0,
1493               ];
1494             }
1495
1496         grep { $_ != $svcpart }
1497         map  { $_->svcpart }
1498         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1499       ];
1500       warn "alternates for svcpart $svcpart: ".
1501            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1502         if $DEBUG;
1503     }
1504   }
1505
1506   foreach my $cust_svc ($self->cust_svc) {
1507     if($target{$cust_svc->svcpart} > 0) {
1508       $target{$cust_svc->svcpart}--;
1509       my $new = new FS::cust_svc { $cust_svc->hash };
1510       $new->pkgnum($dest_pkgnum);
1511       my $error = $new->replace($cust_svc);
1512       return $error if $error;
1513     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1514       if ( $DEBUG ) {
1515         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1516         warn "alternates to consider: ".
1517              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1518       }
1519       my @alternate = grep {
1520                              warn "considering alternate svcpart $_: ".
1521                                   "$target{$_} available in new package\n"
1522                                if $DEBUG;
1523                              $target{$_} > 0;
1524                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1525       if ( @alternate ) {
1526         warn "alternate(s) found\n" if $DEBUG;
1527         my $change_svcpart = $alternate[0];
1528         $target{$change_svcpart}--;
1529         my $new = new FS::cust_svc { $cust_svc->hash };
1530         $new->svcpart($change_svcpart);
1531         $new->pkgnum($dest_pkgnum);
1532         my $error = $new->replace($cust_svc);
1533         return $error if $error;
1534       } else {
1535         $remaining++;
1536       }
1537     } else {
1538       $remaining++
1539     }
1540   }
1541   return $remaining;
1542 }
1543
1544 =item reexport
1545
1546 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1547 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1548
1549 =cut
1550
1551 sub reexport {
1552   my $self = shift;
1553
1554   local $SIG{HUP} = 'IGNORE';
1555   local $SIG{INT} = 'IGNORE';
1556   local $SIG{QUIT} = 'IGNORE';
1557   local $SIG{TERM} = 'IGNORE';
1558   local $SIG{TSTP} = 'IGNORE';
1559   local $SIG{PIPE} = 'IGNORE';
1560
1561   my $oldAutoCommit = $FS::UID::AutoCommit;
1562   local $FS::UID::AutoCommit = 0;
1563   my $dbh = dbh;
1564
1565   foreach my $cust_svc ( $self->cust_svc ) {
1566     #false laziness w/svc_Common::insert
1567     my $svc_x = $cust_svc->svc_x;
1568     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1569       my $error = $part_export->export_insert($svc_x);
1570       if ( $error ) {
1571         $dbh->rollback if $oldAutoCommit;
1572         return $error;
1573       }
1574     }
1575   }
1576
1577   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1578   '';
1579
1580 }
1581
1582 =back
1583
1584 =head1 CLASS METHODS
1585
1586 =over 4
1587
1588 =item recurring_sql
1589
1590 Returns an SQL expression identifying recurring packages.
1591
1592 =cut
1593
1594 sub recurring_sql { "
1595   '0' != ( select freq from part_pkg
1596              where cust_pkg.pkgpart = part_pkg.pkgpart )
1597 "; }
1598
1599 =item onetime_sql
1600
1601 Returns an SQL expression identifying one-time packages.
1602
1603 =cut
1604
1605 sub onetime_sql { "
1606   '0' = ( select freq from part_pkg
1607             where cust_pkg.pkgpart = part_pkg.pkgpart )
1608 "; }
1609
1610 =item active_sql
1611
1612 Returns an SQL expression identifying active packages.
1613
1614 =cut
1615
1616 sub active_sql { "
1617   ". $_[0]->recurring_sql(). "
1618   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1619   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1620 "; }
1621
1622 =item inactive_sql
1623
1624 Returns an SQL expression identifying inactive packages (one-time packages
1625 that are otherwise unsuspended/uncancelled).
1626
1627 =cut
1628
1629 sub inactive_sql { "
1630   ". $_[0]->onetime_sql(). "
1631   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1632   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1633 "; }
1634
1635 =item susp_sql
1636 =item suspended_sql
1637
1638 Returns an SQL expression identifying suspended packages.
1639
1640 =cut
1641
1642 sub suspended_sql { susp_sql(@_); }
1643 sub susp_sql {
1644   #$_[0]->recurring_sql(). ' AND '.
1645   "
1646         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1647     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1648   ";
1649 }
1650
1651 =item cancel_sql
1652 =item cancelled_sql
1653
1654 Returns an SQL exprression identifying cancelled packages.
1655
1656 =cut
1657
1658 sub cancelled_sql { cancel_sql(@_); }
1659 sub cancel_sql {
1660   #$_[0]->recurring_sql(). ' AND '.
1661   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1662 }
1663
1664 =item search_sql HASHREF
1665
1666 (Class method)
1667
1668 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1669 Valid parameters are
1670
1671 =over 4
1672
1673 =item agentnum
1674
1675 =item magic
1676
1677 active, inactive, suspended, cancel (or cancelled)
1678
1679 =item status
1680
1681 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1682
1683 =item classnum
1684
1685 =item pkgpart
1686
1687 list specified how?
1688
1689 =item setup
1690
1691 arrayref of beginning and ending epoch date
1692
1693 =item last_bill
1694
1695 arrayref of beginning and ending epoch date
1696
1697 =item bill
1698
1699 arrayref of beginning and ending epoch date
1700
1701 =item adjourn
1702
1703 arrayref of beginning and ending epoch date
1704
1705 =item susp
1706
1707 arrayref of beginning and ending epoch date
1708
1709 =item expire
1710
1711 arrayref of beginning and ending epoch date
1712
1713 =item cancel
1714
1715 arrayref of beginning and ending epoch date
1716
1717 =item query
1718
1719 pkgnum or APKG_pkgnum
1720
1721 =item cust_fields
1722
1723 a value suited to passing to FS::UI::Web::cust_header
1724
1725 =item CurrentUser
1726
1727 specifies the user for agent virtualization
1728
1729 =back
1730
1731 =cut
1732
1733 sub search_sql {
1734   my ($class, $params) = @_;
1735   my @where = ();
1736
1737   ##
1738   # parse agent
1739   ##
1740
1741   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1742     push @where,
1743       "agentnum = $1";
1744   }
1745
1746   ##
1747   # parse status
1748   ##
1749
1750   if (    $params->{'magic'}  eq 'active'
1751        || $params->{'status'} eq 'active' ) {
1752
1753     push @where, FS::cust_pkg->active_sql();
1754
1755   } elsif (    $params->{'magic'}  eq 'inactive'
1756             || $params->{'status'} eq 'inactive' ) {
1757
1758     push @where, FS::cust_pkg->inactive_sql();
1759
1760   } elsif (    $params->{'magic'}  eq 'suspended'
1761             || $params->{'status'} eq 'suspended'  ) {
1762
1763     push @where, FS::cust_pkg->suspended_sql();
1764
1765   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1766             || $params->{'status'} =~ /^cancell?ed$/ ) {
1767
1768     push @where, FS::cust_pkg->cancelled_sql();
1769
1770   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1771
1772     push @where, FS::cust_pkg->inactive_sql();
1773
1774   }
1775
1776   ###
1777   # parse package class
1778   ###
1779
1780   #false lazinessish w/graph/cust_bill_pkg.cgi
1781   my $classnum = 0;
1782   my @pkg_class = ();
1783   if ( exists($params->{'classnum'})
1784        && $params->{'classnum'} =~ /^(\d*)$/
1785      )
1786   {
1787     $classnum = $1;
1788     if ( $classnum ) { #a specific class
1789       push @where, "classnum = $classnum";
1790
1791       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1792       #die "classnum $classnum not found!" unless $pkg_class[0];
1793       #$title .= $pkg_class[0]->classname.' ';
1794
1795     } elsif ( $classnum eq '' ) { #the empty class
1796
1797       push @where, "classnum IS NULL";
1798       #$title .= 'Empty class ';
1799       #@pkg_class = ( '(empty class)' );
1800     } elsif ( $classnum eq '0' ) {
1801       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1802       #push @pkg_class, '(empty class)';
1803     } else {
1804       die "illegal classnum";
1805     }
1806   }
1807   #eslaf
1808
1809   ###
1810   # parse part_pkg
1811   ###
1812
1813   my $pkgpart = join (' OR pkgpart=',
1814                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
1815   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
1816
1817   ###
1818   # parse dates
1819   ###
1820
1821   my $orderby = '';
1822
1823   #false laziness w/report_cust_pkg.html
1824   my %disable = (
1825     'all'             => {},
1826     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1827     'active'          => { 'susp'=>1, 'cancel'=>1 },
1828     'suspended'       => { 'cancel' => 1 },
1829     'cancelled'       => {},
1830     ''                => {},
1831   );
1832
1833   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1834
1835     next unless exists($params->{$field});
1836
1837     my($beginning, $ending) = @{$params->{$field}};
1838
1839     next if $beginning == 0 && $ending == 4294967295;
1840
1841     push @where,
1842       "cust_pkg.$field IS NOT NULL",
1843       "cust_pkg.$field >= $beginning",
1844       "cust_pkg.$field <= $ending";
1845
1846     $orderby ||= "ORDER BY cust_pkg.$field";
1847
1848   }
1849
1850   $orderby ||= 'ORDER BY bill';
1851
1852   ###
1853   # parse magic, legacy, etc.
1854   ###
1855
1856   if ( $params->{'magic'} &&
1857        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1858   ) {
1859
1860     $orderby = 'ORDER BY pkgnum';
1861
1862     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1863       push @where, "pkgpart = $1";
1864     }
1865
1866   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1867
1868     $orderby = 'ORDER BY pkgnum';
1869
1870   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
1871
1872     $orderby = 'ORDER BY pkgnum';
1873
1874     push @where, '0 < (
1875       SELECT count(*) FROM pkg_svc
1876        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
1877          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
1878                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
1879                                      AND cust_svc.svcpart = pkg_svc.svcpart
1880                                 )
1881     )';
1882
1883   }
1884
1885   ##
1886   # setup queries, links, subs, etc. for the search
1887   ##
1888
1889   # here is the agent virtualization
1890   if ($params->{CurrentUser}) {
1891     my $access_user =
1892       qsearchs('access_user', { username => $params->{CurrentUser} });
1893
1894     if ($access_user) {
1895       push @where, $access_user->agentnums_sql('table' => 'cust_main');
1896     }else{
1897       push @where, "1=0";
1898     }
1899   }else{
1900     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table' => 'cust_main');
1901   }
1902
1903   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
1904
1905   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
1906                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
1907                   'LEFT JOIN pkg_class USING ( classnum ) ';
1908
1909   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
1910
1911   my $sql_query = {
1912     'table'       => 'cust_pkg',
1913     'hashref'     => {},
1914     'select'      => join(', ',
1915                                 'cust_pkg.*',
1916                                 ( map "part_pkg.$_", qw( pkg freq ) ),
1917                                 'pkg_class.classname',
1918                                 'cust_main.custnum as cust_main_custnum',
1919                                 FS::UI::Web::cust_sql_fields(
1920                                   $params->{'cust_fields'}
1921                                 ),
1922                      ),
1923     'extra_sql'   => "$extra_sql $orderby",
1924     'addl_from'   => $addl_from,
1925     'count_query' => $count_query,
1926   };
1927
1928 }
1929
1930 =head1 SUBROUTINES
1931
1932 =over 4
1933
1934 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1935
1936 CUSTNUM is a customer (see L<FS::cust_main>)
1937
1938 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1939 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1940 permitted.
1941
1942 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1943 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1944 new billing items.  An error is returned if this is not possible (see
1945 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1946 parameter.
1947
1948 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1949 newly-created cust_pkg objects.
1950
1951 =cut
1952
1953 sub order {
1954   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1955
1956   my $conf = new FS::Conf;
1957
1958   # Transactionize this whole mess
1959   local $SIG{HUP} = 'IGNORE';
1960   local $SIG{INT} = 'IGNORE';
1961   local $SIG{QUIT} = 'IGNORE';
1962   local $SIG{TERM} = 'IGNORE';
1963   local $SIG{TSTP} = 'IGNORE';
1964   local $SIG{PIPE} = 'IGNORE';
1965
1966   my $oldAutoCommit = $FS::UID::AutoCommit;
1967   local $FS::UID::AutoCommit = 0;
1968   my $dbh = dbh;
1969
1970   my $error;
1971   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1972   return "Customer not found: $custnum" unless $cust_main;
1973
1974   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1975                          @$remove_pkgnum;
1976
1977   my $change = scalar(@old_cust_pkg) != 0;
1978
1979   my %hash = ();
1980   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
1981
1982     my $time = time;
1983
1984     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1985
1986     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
1987     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
1988
1989     $hash{'change_date'} = $time;
1990     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
1991   }
1992
1993   # Create the new packages.
1994   foreach my $pkgpart (@$pkgparts) {
1995     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1996                                       pkgpart => $pkgpart,
1997                                       %hash,
1998                                     };
1999     $error = $cust_pkg->insert( 'change' => $change );
2000     if ($error) {
2001       $dbh->rollback if $oldAutoCommit;
2002       return $error;
2003     }
2004     push @$return_cust_pkg, $cust_pkg;
2005   }
2006   # $return_cust_pkg now contains refs to all of the newly
2007   # created packages.
2008
2009   # Transfer services and cancel old packages.
2010   foreach my $old_pkg (@old_cust_pkg) {
2011
2012     foreach my $new_pkg (@$return_cust_pkg) {
2013       $error = $old_pkg->transfer($new_pkg);
2014       if ($error and $error == 0) {
2015         # $old_pkg->transfer failed.
2016         $dbh->rollback if $oldAutoCommit;
2017         return $error;
2018       }
2019     }
2020
2021     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2022       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2023       foreach my $new_pkg (@$return_cust_pkg) {
2024         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2025         if ($error and $error == 0) {
2026           # $old_pkg->transfer failed.
2027         $dbh->rollback if $oldAutoCommit;
2028         return $error;
2029         }
2030       }
2031     }
2032
2033     if ($error > 0) {
2034       # Transfers were successful, but we went through all of the
2035       # new packages and still had services left on the old package.
2036       # We can't cancel the package under the circumstances, so abort.
2037       $dbh->rollback if $oldAutoCommit;
2038       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2039     }
2040     $error = $old_pkg->cancel( quiet=>1 );
2041     if ($error) {
2042       $dbh->rollback;
2043       return $error;
2044     }
2045   }
2046   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2047   '';
2048 }
2049
2050 =item insert_reason
2051
2052 Associates this package with a (suspension or cancellation) reason (see
2053 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2054 L<FS::reason>).
2055
2056 Available options are:
2057
2058 =over 4
2059
2060 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
2061
2062 =item date
2063
2064 =back
2065
2066 If there is an error, returns the error, otherwise returns false.
2067
2068 =cut
2069
2070 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2071
2072 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2073 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2074 permitted.
2075
2076 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2077 replace.  The services (see L<FS::cust_svc>) are moved to the
2078 new billing items.  An error is returned if this is not possible (see
2079 L<FS::pkg_svc>).
2080
2081 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2082 newly-created cust_pkg objects.
2083
2084 =cut
2085
2086 sub bulk_change {
2087   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2088
2089   # Transactionize this whole mess
2090   local $SIG{HUP} = 'IGNORE';
2091   local $SIG{INT} = 'IGNORE';
2092   local $SIG{QUIT} = 'IGNORE';
2093   local $SIG{TERM} = 'IGNORE';
2094   local $SIG{TSTP} = 'IGNORE';
2095   local $SIG{PIPE} = 'IGNORE';
2096
2097   my $oldAutoCommit = $FS::UID::AutoCommit;
2098   local $FS::UID::AutoCommit = 0;
2099   my $dbh = dbh;
2100
2101   my @errors;
2102   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2103                          @$remove_pkgnum;
2104
2105   while(scalar(@old_cust_pkg)) {
2106     my @return = ();
2107     my $custnum = $old_cust_pkg[0]->custnum;
2108     my (@remove) = map { $_->pkgnum }
2109                    grep { $_->custnum == $custnum } @old_cust_pkg;
2110     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2111
2112     my $error = order $custnum, $pkgparts, \@remove, \@return;
2113
2114     push @errors, $error
2115       if $error;
2116     push @$return_cust_pkg, @return;
2117   }
2118
2119   if (scalar(@errors)) {
2120     $dbh->rollback if $oldAutoCommit;
2121     return join(' / ', @errors);
2122   }
2123
2124   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2125   '';
2126 }
2127
2128 sub insert_reason {
2129   my ($self, %options) = @_;
2130
2131   my $otaker = $options{reason_otaker} ||
2132                $FS::CurrentUser::CurrentUser->username;
2133
2134   my $reasonnum;
2135   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2136
2137     $reasonnum = $1;
2138
2139   } elsif ( ref($options{'reason'}) ) {
2140
2141     return 'Enter a new reason (or select an existing one)'
2142       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2143
2144     my $reason = new FS::reason({
2145       'reason_type' => $options{'reason'}->{'typenum'},
2146       'reason'      => $options{'reason'}->{'reason'},
2147     });
2148     my $error = $reason->insert;
2149     return $error if $error;
2150
2151     $reasonnum = $reason->reasonnum;
2152
2153   } else {
2154     return "Unparsable reason: ". $options{'reason'};
2155   }
2156
2157   my $cust_pkg_reason =
2158     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2159                               'reasonnum' => $reasonnum,
2160                               'otaker'    => $otaker,
2161                               'action'    => substr(uc($options{'action'}),0,1),
2162                               'date'      => $options{'date'}
2163                                                ? $options{'date'}
2164                                                : time,
2165                             });
2166
2167   $cust_pkg_reason->insert;
2168 }
2169
2170 =item set_usage USAGE_VALUE_HASHREF
2171
2172 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2173 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2174 upbytes, downbytes, and totalbytes are appropriate keys.
2175
2176 All svc_accts which are part of this package have their values reset.
2177
2178 =cut
2179
2180 sub set_usage {
2181   my ($self, $valueref) = @_;
2182
2183   foreach my $cust_svc ($self->cust_svc){
2184     my $svc_x = $cust_svc->svc_x;
2185     $svc_x->set_usage($valueref)
2186       if $svc_x->can("set_usage");
2187   }
2188 }
2189
2190 =back
2191
2192 =head1 BUGS
2193
2194 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2195
2196 In sub order, the @pkgparts array (passed by reference) is clobbered.
2197
2198 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2199 method to pass dates to the recur_prog expression, it should do so.
2200
2201 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2202 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2203 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2204 configuration values.  Probably need a subroutine which decides what to do
2205 based on whether or not we've fetched the user yet, rather than a hash.  See
2206 FS::UID and the TODO.
2207
2208 Now that things are transactional should the check in the insert method be
2209 moved to check ?
2210
2211 =head1 SEE ALSO
2212
2213 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2214 L<FS::pkg_svc>, schema.html from the base documentation
2215
2216 =cut
2217
2218 1;
2219