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