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