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