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   map  { $_->[0] }
1177   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1178   map {
1179         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1180                                              'svcpart' => $_->svcpart     } );
1181         [ $_,
1182           $pkg_svc ? $pkg_svc->primary_svc : '',
1183           $pkg_svc ? $pkg_svc->quantity : 0,
1184         ];
1185       }
1186   @$arrayref;
1187
1188 }
1189
1190 =item num_cust_svc [ SVCPART ]
1191
1192 Returns the number of provisioned services for this package.  If a svcpart is
1193 specified, counts only the matching services.
1194
1195 =cut
1196
1197 sub num_cust_svc {
1198   my $self = shift;
1199   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1200   $sql .= ' AND svcpart = ?' if @_;
1201   my $sth = dbh->prepare($sql) or die dbh->errstr;
1202   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1203   $sth->fetchrow_arrayref->[0];
1204 }
1205
1206 =item available_part_svc
1207
1208 Returns a list of FS::part_svc objects representing services included in this
1209 package but not yet provisioned.  Each FS::part_svc object also has an extra
1210 field, I<num_avail>, which specifies the number of available services.
1211
1212 =cut
1213
1214 sub available_part_svc {
1215   my $self = shift;
1216   grep { $_->num_avail > 0 }
1217     map {
1218           my $part_svc = $_->part_svc;
1219           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1220             $_->quantity - $self->num_cust_svc($_->svcpart);
1221           $part_svc;
1222         }
1223       $self->part_pkg->pkg_svc;
1224 }
1225
1226 =item part_svc
1227
1228 Returns a list of FS::part_svc objects representing provisioned and available
1229 services included in this package.  Each FS::part_svc object also has the
1230 following extra fields:
1231
1232 =over 4
1233
1234 =item num_cust_svc  (count)
1235
1236 =item num_avail     (quantity - count)
1237
1238 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1239
1240 svcnum
1241 label -> ($cust_svc->label)[1]
1242
1243 =back
1244
1245 =cut
1246
1247 sub part_svc {
1248   my $self = shift;
1249
1250   #XXX some sort of sort order besides numeric by svcpart...
1251   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1252     my $pkg_svc = $_;
1253     my $part_svc = $pkg_svc->part_svc;
1254     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1255     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1256     $part_svc->{'Hash'}{'num_avail'}    =
1257       max( 0, $pkg_svc->quantity - $num_cust_svc );
1258     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1259     $part_svc;
1260   } $self->part_pkg->pkg_svc;
1261
1262   #extras
1263   push @part_svc, map {
1264     my $part_svc = $_;
1265     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1266     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1267     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1268     $part_svc->{'Hash'}{'cust_pkg_svc'} = [ $self->cust_svc($part_svc->svcpart) ];
1269     $part_svc;
1270   } $self->extra_part_svc;
1271
1272   @part_svc;
1273
1274 }
1275
1276 =item extra_part_svc
1277
1278 Returns a list of FS::part_svc objects corresponding to services in this
1279 package which are still provisioned but not (any longer) available in the
1280 package definition.
1281
1282 =cut
1283
1284 sub extra_part_svc {
1285   my $self = shift;
1286
1287   my $pkgnum  = $self->pkgnum;
1288   my $pkgpart = $self->pkgpart;
1289
1290   qsearch( {
1291     'table'     => 'part_svc',
1292     'hashref'   => {},
1293     'extra_sql' => "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1294                                   WHERE pkg_svc.svcpart = part_svc.svcpart
1295                                     AND pkg_svc.pkgpart = $pkgpart
1296                                     AND quantity > 0
1297                               )
1298                       AND 0 < ( SELECT count(*)
1299                                   FROM cust_svc
1300                                     LEFT JOIN cust_pkg using ( pkgnum )
1301                                   WHERE cust_svc.svcpart = part_svc.svcpart
1302                                     AND pkgnum = $pkgnum
1303                               )",
1304   } );
1305 }
1306
1307 =item status
1308
1309 Returns a short status string for this package, currently:
1310
1311 =over 4
1312
1313 =item not yet billed
1314
1315 =item one-time charge
1316
1317 =item active
1318
1319 =item suspended
1320
1321 =item cancelled
1322
1323 =back
1324
1325 =cut
1326
1327 sub status {
1328   my $self = shift;
1329
1330   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1331
1332   return 'cancelled' if $self->get('cancel');
1333   return 'suspended' if $self->susp;
1334   return 'not yet billed' unless $self->setup;
1335   return 'one-time charge' if $freq =~ /^(0|$)/;
1336   return 'active';
1337 }
1338
1339 =item statuses
1340
1341 Class method that returns the list of possible status strings for pacakges
1342 (see L<the status method|/status>).  For example:
1343
1344   @statuses = FS::cust_pkg->statuses();
1345
1346 =cut
1347
1348 tie my %statuscolor, 'Tie::IxHash',
1349   'not yet billed'  => '000000',
1350   'one-time charge' => '000000',
1351   'active'          => '00CC00',
1352   'suspended'       => 'FF9900',
1353   'cancelled'       => 'FF0000',
1354 ;
1355
1356 sub statuses {
1357   my $self = shift; #could be class...
1358   grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1359                                       # mayble split btw one-time vs. recur
1360     keys %statuscolor;
1361 }
1362
1363 =item statuscolor
1364
1365 Returns a hex triplet color string for this package's status.
1366
1367 =cut
1368
1369 sub statuscolor {
1370   my $self = shift;
1371   $statuscolor{$self->status};
1372 }
1373
1374 =item labels
1375
1376 Returns a list of lists, calling the label method for all services
1377 (see L<FS::cust_svc>) of this billing item.
1378
1379 =cut
1380
1381 sub labels {
1382   my $self = shift;
1383   map { [ $_->label ] } $self->cust_svc;
1384 }
1385
1386 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1387
1388 Like the labels method, but returns historical information on services that
1389 were active as of END_TIMESTAMP and (optionally) not cancelled before
1390 START_TIMESTAMP.
1391
1392 Returns a list of lists, calling the label method for all (historical) services
1393 (see L<FS::h_cust_svc>) of this billing item.
1394
1395 =cut
1396
1397 sub h_labels {
1398   my $self = shift;
1399   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1400 }
1401
1402 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1403
1404 Like h_labels, except returns a simple flat list, and shortens long
1405 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1406 identical services to one line that lists the service label and the number of
1407 individual services rather than individual items.
1408
1409 =cut
1410
1411 sub h_labels_short {
1412   my $self = shift;
1413
1414   my $conf = new FS::Conf;
1415   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1416
1417   my %labels;
1418   #tie %labels, 'Tie::IxHash';
1419   push @{ $labels{$_->[0]} }, $_->[1]
1420     foreach $self->h_labels(@_);
1421   my @labels;
1422   foreach my $label ( keys %labels ) {
1423     my %seen = ();
1424     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1425     my $num = scalar(@values);
1426     if ( $num > $max_same_services ) {
1427       push @labels, "$label ($num)";
1428     } else {
1429       push @labels, map { "$label: $_" } @values;
1430     }
1431   }
1432
1433  @labels;
1434
1435 }
1436
1437 =item cust_main
1438
1439 Returns the parent customer object (see L<FS::cust_main>).
1440
1441 =cut
1442
1443 sub cust_main {
1444   my $self = shift;
1445   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1446 }
1447
1448 =item seconds_since TIMESTAMP
1449
1450 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1451 package have been online since TIMESTAMP, according to the session monitor.
1452
1453 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1454 L<Time::Local> and L<Date::Parse> for conversion functions.
1455
1456 =cut
1457
1458 sub seconds_since {
1459   my($self, $since) = @_;
1460   my $seconds = 0;
1461
1462   foreach my $cust_svc (
1463     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1464   ) {
1465     $seconds += $cust_svc->seconds_since($since);
1466   }
1467
1468   $seconds;
1469
1470 }
1471
1472 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1473
1474 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1475 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1476 (exclusive).
1477
1478 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1479 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1480 functions.
1481
1482
1483 =cut
1484
1485 sub seconds_since_sqlradacct {
1486   my($self, $start, $end) = @_;
1487
1488   my $seconds = 0;
1489
1490   foreach my $cust_svc (
1491     grep {
1492       my $part_svc = $_->part_svc;
1493       $part_svc->svcdb eq 'svc_acct'
1494         && scalar($part_svc->part_export('sqlradius'));
1495     } $self->cust_svc
1496   ) {
1497     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1498   }
1499
1500   $seconds;
1501
1502 }
1503
1504 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1505
1506 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1507 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1508 TIMESTAMP_END
1509 (exclusive).
1510
1511 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1512 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1513 functions.
1514
1515 =cut
1516
1517 sub attribute_since_sqlradacct {
1518   my($self, $start, $end, $attrib) = @_;
1519
1520   my $sum = 0;
1521
1522   foreach my $cust_svc (
1523     grep {
1524       my $part_svc = $_->part_svc;
1525       $part_svc->svcdb eq 'svc_acct'
1526         && scalar($part_svc->part_export('sqlradius'));
1527     } $self->cust_svc
1528   ) {
1529     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1530   }
1531
1532   $sum;
1533
1534 }
1535
1536 =item quantity
1537
1538 =cut
1539
1540 sub quantity {
1541   my( $self, $value ) = @_;
1542   if ( defined($value) ) {
1543     $self->setfield('quantity', $value);
1544   }
1545   $self->getfield('quantity') || 1;
1546 }
1547
1548 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1549
1550 Transfers as many services as possible from this package to another package.
1551
1552 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1553 object.  The destination package must already exist.
1554
1555 Services are moved only if the destination allows services with the correct
1556 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1557 this option with caution!  No provision is made for export differences
1558 between the old and new service definitions.  Probably only should be used
1559 when your exports for all service definitions of a given svcdb are identical.
1560 (attempt a transfer without it first, to move all possible svcpart-matching
1561 services)
1562
1563 Any services that can't be moved remain in the original package.
1564
1565 Returns an error, if there is one; otherwise, returns the number of services
1566 that couldn't be moved.
1567
1568 =cut
1569
1570 sub transfer {
1571   my ($self, $dest_pkgnum, %opt) = @_;
1572
1573   my $remaining = 0;
1574   my $dest;
1575   my %target;
1576
1577   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1578     $dest = $dest_pkgnum;
1579     $dest_pkgnum = $dest->pkgnum;
1580   } else {
1581     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1582   }
1583
1584   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1585
1586   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1587     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1588   }
1589
1590   foreach my $cust_svc ($dest->cust_svc) {
1591     $target{$cust_svc->svcpart}--;
1592   }
1593
1594   my %svcpart2svcparts = ();
1595   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1596     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1597     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1598       next if exists $svcpart2svcparts{$svcpart};
1599       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1600       $svcpart2svcparts{$svcpart} = [
1601         map  { $_->[0] }
1602         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1603         map {
1604               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1605                                                    'svcpart' => $_          } );
1606               [ $_,
1607                 $pkg_svc ? $pkg_svc->primary_svc : '',
1608                 $pkg_svc ? $pkg_svc->quantity : 0,
1609               ];
1610             }
1611
1612         grep { $_ != $svcpart }
1613         map  { $_->svcpart }
1614         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1615       ];
1616       warn "alternates for svcpart $svcpart: ".
1617            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1618         if $DEBUG;
1619     }
1620   }
1621
1622   foreach my $cust_svc ($self->cust_svc) {
1623     if($target{$cust_svc->svcpart} > 0) {
1624       $target{$cust_svc->svcpart}--;
1625       my $new = new FS::cust_svc { $cust_svc->hash };
1626       $new->pkgnum($dest_pkgnum);
1627       my $error = $new->replace($cust_svc);
1628       return $error if $error;
1629     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1630       if ( $DEBUG ) {
1631         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1632         warn "alternates to consider: ".
1633              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1634       }
1635       my @alternate = grep {
1636                              warn "considering alternate svcpart $_: ".
1637                                   "$target{$_} available in new package\n"
1638                                if $DEBUG;
1639                              $target{$_} > 0;
1640                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1641       if ( @alternate ) {
1642         warn "alternate(s) found\n" if $DEBUG;
1643         my $change_svcpart = $alternate[0];
1644         $target{$change_svcpart}--;
1645         my $new = new FS::cust_svc { $cust_svc->hash };
1646         $new->svcpart($change_svcpart);
1647         $new->pkgnum($dest_pkgnum);
1648         my $error = $new->replace($cust_svc);
1649         return $error if $error;
1650       } else {
1651         $remaining++;
1652       }
1653     } else {
1654       $remaining++
1655     }
1656   }
1657   return $remaining;
1658 }
1659
1660 =item reexport
1661
1662 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1663 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1664
1665 =cut
1666
1667 sub reexport {
1668   my $self = shift;
1669
1670   local $SIG{HUP} = 'IGNORE';
1671   local $SIG{INT} = 'IGNORE';
1672   local $SIG{QUIT} = 'IGNORE';
1673   local $SIG{TERM} = 'IGNORE';
1674   local $SIG{TSTP} = 'IGNORE';
1675   local $SIG{PIPE} = 'IGNORE';
1676
1677   my $oldAutoCommit = $FS::UID::AutoCommit;
1678   local $FS::UID::AutoCommit = 0;
1679   my $dbh = dbh;
1680
1681   foreach my $cust_svc ( $self->cust_svc ) {
1682     #false laziness w/svc_Common::insert
1683     my $svc_x = $cust_svc->svc_x;
1684     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1685       my $error = $part_export->export_insert($svc_x);
1686       if ( $error ) {
1687         $dbh->rollback if $oldAutoCommit;
1688         return $error;
1689       }
1690     }
1691   }
1692
1693   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1694   '';
1695
1696 }
1697
1698 =back
1699
1700 =head1 CLASS METHODS
1701
1702 =over 4
1703
1704 =item recurring_sql
1705
1706 Returns an SQL expression identifying recurring packages.
1707
1708 =cut
1709
1710 sub recurring_sql { "
1711   '0' != ( select freq from part_pkg
1712              where cust_pkg.pkgpart = part_pkg.pkgpart )
1713 "; }
1714
1715 =item onetime_sql
1716
1717 Returns an SQL expression identifying one-time packages.
1718
1719 =cut
1720
1721 sub onetime_sql { "
1722   '0' = ( select freq from part_pkg
1723             where cust_pkg.pkgpart = part_pkg.pkgpart )
1724 "; }
1725
1726 =item active_sql
1727
1728 Returns an SQL expression identifying active packages.
1729
1730 =cut
1731
1732 sub active_sql { "
1733   ". $_[0]->recurring_sql(). "
1734   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1735   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1736 "; }
1737
1738 =item inactive_sql
1739
1740 Returns an SQL expression identifying inactive packages (one-time packages
1741 that are otherwise unsuspended/uncancelled).
1742
1743 =cut
1744
1745 sub inactive_sql { "
1746   ". $_[0]->onetime_sql(). "
1747   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1748   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1749 "; }
1750
1751 =item susp_sql
1752 =item suspended_sql
1753
1754 Returns an SQL expression identifying suspended packages.
1755
1756 =cut
1757
1758 sub suspended_sql { susp_sql(@_); }
1759 sub susp_sql {
1760   #$_[0]->recurring_sql(). ' AND '.
1761   "
1762         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
1763     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
1764   ";
1765 }
1766
1767 =item cancel_sql
1768 =item cancelled_sql
1769
1770 Returns an SQL exprression identifying cancelled packages.
1771
1772 =cut
1773
1774 sub cancelled_sql { cancel_sql(@_); }
1775 sub cancel_sql {
1776   #$_[0]->recurring_sql(). ' AND '.
1777   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
1778 }
1779
1780 =item search_sql HASHREF
1781
1782 (Class method)
1783
1784 Returns a qsearch hash expression to search for parameters specified in HASHREF.
1785 Valid parameters are
1786
1787 =over 4
1788
1789 =item agentnum
1790
1791 =item magic
1792
1793 active, inactive, suspended, cancel (or cancelled)
1794
1795 =item status
1796
1797 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
1798
1799 =item classnum
1800
1801 =item pkgpart
1802
1803 pkgpart or arrayref or hashref of pkgparts
1804
1805 =item setup
1806
1807 arrayref of beginning and ending epoch date
1808
1809 =item last_bill
1810
1811 arrayref of beginning and ending epoch date
1812
1813 =item bill
1814
1815 arrayref of beginning and ending epoch date
1816
1817 =item adjourn
1818
1819 arrayref of beginning and ending epoch date
1820
1821 =item susp
1822
1823 arrayref of beginning and ending epoch date
1824
1825 =item expire
1826
1827 arrayref of beginning and ending epoch date
1828
1829 =item cancel
1830
1831 arrayref of beginning and ending epoch date
1832
1833 =item query
1834
1835 pkgnum or APKG_pkgnum
1836
1837 =item cust_fields
1838
1839 a value suited to passing to FS::UI::Web::cust_header
1840
1841 =item CurrentUser
1842
1843 specifies the user for agent virtualization
1844
1845 =back
1846
1847 =cut
1848
1849 sub search_sql {
1850   my ($class, $params) = @_;
1851   my @where = ();
1852
1853   ##
1854   # parse agent
1855   ##
1856
1857   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
1858     push @where,
1859       "agentnum = $1";
1860   }
1861
1862   ##
1863   # parse status
1864   ##
1865
1866   if (    $params->{'magic'}  eq 'active'
1867        || $params->{'status'} eq 'active' ) {
1868
1869     push @where, FS::cust_pkg->active_sql();
1870
1871   } elsif (    $params->{'magic'}  eq 'inactive'
1872             || $params->{'status'} eq 'inactive' ) {
1873
1874     push @where, FS::cust_pkg->inactive_sql();
1875
1876   } elsif (    $params->{'magic'}  eq 'suspended'
1877             || $params->{'status'} eq 'suspended'  ) {
1878
1879     push @where, FS::cust_pkg->suspended_sql();
1880
1881   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
1882             || $params->{'status'} =~ /^cancell?ed$/ ) {
1883
1884     push @where, FS::cust_pkg->cancelled_sql();
1885
1886   } elsif ( $params->{'status'} =~ /^(one-time charge|inactive)$/ ) {
1887
1888     push @where, FS::cust_pkg->inactive_sql();
1889
1890   }
1891
1892   ###
1893   # parse package class
1894   ###
1895
1896   #false lazinessish w/graph/cust_bill_pkg.cgi
1897   my $classnum = 0;
1898   my @pkg_class = ();
1899   if ( exists($params->{'classnum'})
1900        && $params->{'classnum'} =~ /^(\d*)$/
1901      )
1902   {
1903     $classnum = $1;
1904     if ( $classnum ) { #a specific class
1905       push @where, "classnum = $classnum";
1906
1907       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
1908       #die "classnum $classnum not found!" unless $pkg_class[0];
1909       #$title .= $pkg_class[0]->classname.' ';
1910
1911     } elsif ( $classnum eq '' ) { #the empty class
1912
1913       push @where, "classnum IS NULL";
1914       #$title .= 'Empty class ';
1915       #@pkg_class = ( '(empty class)' );
1916     } elsif ( $classnum eq '0' ) {
1917       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
1918       #push @pkg_class, '(empty class)';
1919     } else {
1920       die "illegal classnum";
1921     }
1922   }
1923   #eslaf
1924
1925   ###
1926   # parse part_pkg
1927   ###
1928
1929   if ( ref($params->{'pkgpart'}) ) {
1930
1931     my @pkgpart = ();
1932     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
1933       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
1934     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
1935       @pkgpart = @{ $params->{'pkgpart'} };
1936     } else {
1937       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
1938     }
1939
1940     @pkgpart = grep /^(\d+)$/, @pkgpart;
1941
1942     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
1943
1944   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1945     push @where, "pkgpart = $1";
1946   }
1947
1948   ###
1949   # parse dates
1950   ###
1951
1952   my $orderby = '';
1953
1954   #false laziness w/report_cust_pkg.html
1955   my %disable = (
1956     'all'             => {},
1957     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
1958     'active'          => { 'susp'=>1, 'cancel'=>1 },
1959     'suspended'       => { 'cancel' => 1 },
1960     'cancelled'       => {},
1961     ''                => {},
1962   );
1963
1964   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
1965
1966     next unless exists($params->{$field});
1967
1968     my($beginning, $ending) = @{$params->{$field}};
1969
1970     next if $beginning == 0 && $ending == 4294967295;
1971
1972     push @where,
1973       "cust_pkg.$field IS NOT NULL",
1974       "cust_pkg.$field >= $beginning",
1975       "cust_pkg.$field <= $ending";
1976
1977     $orderby ||= "ORDER BY cust_pkg.$field";
1978
1979   }
1980
1981   $orderby ||= 'ORDER BY bill';
1982
1983   ###
1984   # parse magic, legacy, etc.
1985   ###
1986
1987   if ( $params->{'magic'} &&
1988        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
1989   ) {
1990
1991     $orderby = 'ORDER BY pkgnum';
1992
1993     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
1994       push @where, "pkgpart = $1";
1995     }
1996
1997   } elsif ( $params->{'query'} eq 'pkgnum' ) {
1998
1999     $orderby = 'ORDER BY pkgnum';
2000
2001   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2002
2003     $orderby = 'ORDER BY pkgnum';
2004
2005     push @where, '0 < (
2006       SELECT count(*) FROM pkg_svc
2007        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2008          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2009                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2010                                      AND cust_svc.svcpart = pkg_svc.svcpart
2011                                 )
2012     )';
2013
2014   }
2015
2016   ##
2017   # setup queries, links, subs, etc. for the search
2018   ##
2019
2020   # here is the agent virtualization
2021   if ($params->{CurrentUser}) {
2022     my $access_user =
2023       qsearchs('access_user', { username => $params->{CurrentUser} });
2024
2025     if ($access_user) {
2026       push @where, $access_user->agentnums_sql('table' => 'cust_main');
2027     }else{
2028       push @where, "1=0";
2029     }
2030   }else{
2031     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table' => 'cust_main');
2032   }
2033
2034   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2035
2036   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2037                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2038                   'LEFT JOIN pkg_class USING ( classnum ) ';
2039
2040   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2041
2042   my $sql_query = {
2043     'table'       => 'cust_pkg',
2044     'hashref'     => {},
2045     'select'      => join(', ',
2046                                 'cust_pkg.*',
2047                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2048                                 'pkg_class.classname',
2049                                 'cust_main.custnum as cust_main_custnum',
2050                                 FS::UI::Web::cust_sql_fields(
2051                                   $params->{'cust_fields'}
2052                                 ),
2053                      ),
2054     'extra_sql'   => "$extra_sql $orderby",
2055     'addl_from'   => $addl_from,
2056     'count_query' => $count_query,
2057   };
2058
2059 }
2060
2061 =head1 SUBROUTINES
2062
2063 =over 4
2064
2065 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
2066
2067 CUSTNUM is a customer (see L<FS::cust_main>)
2068
2069 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2070 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2071 permitted.
2072
2073 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2074 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2075 new billing items.  An error is returned if this is not possible (see
2076 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2077 parameter.
2078
2079 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2080 newly-created cust_pkg objects.
2081
2082 =cut
2083
2084 sub order {
2085   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2086
2087   my $conf = new FS::Conf;
2088
2089   # Transactionize this whole mess
2090   local $SIG{HUP} = 'IGNORE';
2091   local $SIG{INT} = 'IGNORE';
2092   local $SIG{QUIT} = 'IGNORE';
2093   local $SIG{TERM} = 'IGNORE';
2094   local $SIG{TSTP} = 'IGNORE';
2095   local $SIG{PIPE} = 'IGNORE';
2096
2097   my $oldAutoCommit = $FS::UID::AutoCommit;
2098   local $FS::UID::AutoCommit = 0;
2099   my $dbh = dbh;
2100
2101   my $error;
2102   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2103   return "Customer not found: $custnum" unless $cust_main;
2104
2105   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2106                          @$remove_pkgnum;
2107
2108   my $change = scalar(@old_cust_pkg) != 0;
2109
2110   my %hash = ();
2111   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2112
2113     my $time = time;
2114
2115     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
2116
2117     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( setup );
2118     $hash{'setup'} = $time if $old_cust_pkg[0]->setup;
2119
2120     $hash{'change_date'} = $time;
2121     $hash{"change_$_"}  = $old_cust_pkg[0]->$_() foreach qw( pkgnum pkgpart );
2122   }
2123
2124   # Create the new packages.
2125   foreach my $pkgpart (@$pkgparts) {
2126     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2127                                       pkgpart => $pkgpart,
2128                                       %hash,
2129                                     };
2130     $error = $cust_pkg->insert( 'change' => $change );
2131     if ($error) {
2132       $dbh->rollback if $oldAutoCommit;
2133       return $error;
2134     }
2135     push @$return_cust_pkg, $cust_pkg;
2136   }
2137   # $return_cust_pkg now contains refs to all of the newly
2138   # created packages.
2139
2140   # Transfer services and cancel old packages.
2141   foreach my $old_pkg (@old_cust_pkg) {
2142
2143     foreach my $new_pkg (@$return_cust_pkg) {
2144       $error = $old_pkg->transfer($new_pkg);
2145       if ($error and $error == 0) {
2146         # $old_pkg->transfer failed.
2147         $dbh->rollback if $oldAutoCommit;
2148         return $error;
2149       }
2150     }
2151
2152     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2153       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2154       foreach my $new_pkg (@$return_cust_pkg) {
2155         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2156         if ($error and $error == 0) {
2157           # $old_pkg->transfer failed.
2158         $dbh->rollback if $oldAutoCommit;
2159         return $error;
2160         }
2161       }
2162     }
2163
2164     if ($error > 0) {
2165       # Transfers were successful, but we went through all of the
2166       # new packages and still had services left on the old package.
2167       # We can't cancel the package under the circumstances, so abort.
2168       $dbh->rollback if $oldAutoCommit;
2169       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2170     }
2171
2172     #reset usage if changing pkgpart
2173     foreach my $new_pkg (@$return_cust_pkg) {
2174       if ($old_pkg->pkgpart != $new_pkg->pkgpart) {
2175         my $part_pkg = $new_pkg->part_pkg;
2176         $error = $part_pkg->reset_usage($new_pkg, $part_pkg->is_prepaid
2177                                                     ? ()
2178                                                     : ( 'null' => 1 )
2179                                        )
2180           if $part_pkg->can('reset_usage');
2181
2182         if ($error) {
2183           $dbh->rollback if $oldAutoCommit;
2184           return "Error setting usage values: $error";
2185         }
2186       }
2187     }
2188
2189     $error = $old_pkg->cancel( quiet=>1 );
2190     if ($error) {
2191       $dbh->rollback;
2192       return $error;
2193     }
2194   }
2195   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2196   '';
2197 }
2198
2199 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2200
2201 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2202 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2203 permitted.
2204
2205 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2206 replace.  The services (see L<FS::cust_svc>) are moved to the
2207 new billing items.  An error is returned if this is not possible (see
2208 L<FS::pkg_svc>).
2209
2210 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2211 newly-created cust_pkg objects.
2212
2213 =cut
2214
2215 sub bulk_change {
2216   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2217
2218   # Transactionize this whole mess
2219   local $SIG{HUP} = 'IGNORE';
2220   local $SIG{INT} = 'IGNORE';
2221   local $SIG{QUIT} = 'IGNORE';
2222   local $SIG{TERM} = 'IGNORE';
2223   local $SIG{TSTP} = 'IGNORE';
2224   local $SIG{PIPE} = 'IGNORE';
2225
2226   my $oldAutoCommit = $FS::UID::AutoCommit;
2227   local $FS::UID::AutoCommit = 0;
2228   my $dbh = dbh;
2229
2230   my @errors;
2231   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2232                          @$remove_pkgnum;
2233
2234   while(scalar(@old_cust_pkg)) {
2235     my @return = ();
2236     my $custnum = $old_cust_pkg[0]->custnum;
2237     my (@remove) = map { $_->pkgnum }
2238                    grep { $_->custnum == $custnum } @old_cust_pkg;
2239     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2240
2241     my $error = order $custnum, $pkgparts, \@remove, \@return;
2242
2243     push @errors, $error
2244       if $error;
2245     push @$return_cust_pkg, @return;
2246   }
2247
2248   if (scalar(@errors)) {
2249     $dbh->rollback if $oldAutoCommit;
2250     return join(' / ', @errors);
2251   }
2252
2253   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2254   '';
2255 }
2256
2257 =item insert_reason
2258
2259 Associates this package with a (suspension or cancellation) reason (see
2260 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2261 L<FS::reason>).
2262
2263 Available options are:
2264
2265 =over 4
2266
2267 =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.
2268
2269 =item otaker_reason - the access_user (see L<FS::access_user>) providing the reason
2270
2271 =item date - a unix timestamp
2272
2273 =item action - the action (cancel, susp, adjourn, expire) associated with the reason
2274
2275 =back
2276
2277 If there is an error, returns the error, otherwise returns false.
2278
2279 =cut
2280
2281 sub insert_reason {
2282   my ($self, %options) = @_;
2283
2284   my $otaker = $options{reason_otaker} ||
2285                $FS::CurrentUser::CurrentUser->username;
2286
2287   my $reasonnum;
2288   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2289
2290     $reasonnum = $1;
2291
2292   } elsif ( ref($options{'reason'}) ) {
2293
2294     return 'Enter a new reason (or select an existing one)'
2295       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2296
2297     my $reason = new FS::reason({
2298       'reason_type' => $options{'reason'}->{'typenum'},
2299       'reason'      => $options{'reason'}->{'reason'},
2300     });
2301     my $error = $reason->insert;
2302     return $error if $error;
2303
2304     $reasonnum = $reason->reasonnum;
2305
2306   } else {
2307     return "Unparsable reason: ". $options{'reason'};
2308   }
2309
2310   my $cust_pkg_reason =
2311     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2312                               'reasonnum' => $reasonnum,
2313                               'otaker'    => $otaker,
2314                               'action'    => substr(uc($options{'action'}),0,1),
2315                               'date'      => $options{'date'}
2316                                                ? $options{'date'}
2317                                                : time,
2318                             });
2319
2320   $cust_pkg_reason->insert;
2321 }
2322
2323 =item set_usage USAGE_VALUE_HASHREF
2324
2325 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2326 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2327 upbytes, downbytes, and totalbytes are appropriate keys.
2328
2329 All svc_accts which are part of this package have their values reset.
2330
2331 =cut
2332
2333 sub set_usage {
2334   my ($self, $valueref, %opt) = @_;
2335
2336   foreach my $cust_svc ($self->cust_svc){
2337     my $svc_x = $cust_svc->svc_x;
2338     $svc_x->set_usage($valueref, %opt)
2339       if $svc_x->can("set_usage");
2340   }
2341 }
2342
2343 =back
2344
2345 =head1 BUGS
2346
2347 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2348
2349 In sub order, the @pkgparts array (passed by reference) is clobbered.
2350
2351 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2352 method to pass dates to the recur_prog expression, it should do so.
2353
2354 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2355 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2356 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2357 configuration values.  Probably need a subroutine which decides what to do
2358 based on whether or not we've fetched the user yet, rather than a hash.  See
2359 FS::UID and the TODO.
2360
2361 Now that things are transactional should the check in the insert method be
2362 moved to check ?
2363
2364 =head1 SEE ALSO
2365
2366 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2367 L<FS::pkg_svc>, schema.html from the base documentation
2368
2369 =cut
2370
2371 1;
2372