FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck $DEBUG);
   5 use Carp qw(cluck);
   6 use Scalar::Util qw( blessed );
   7 use List::Util qw(max);
   8 use Tie::IxHash;
   9 use MIME::Entity;
  10 use FS::UID qw( getotaker dbh );
  11 use FS::Misc qw( send_email );
  12 use FS::Record qw( qsearch qsearchs );
  13 use FS::m2m_Common;
  14 use FS::cust_main_Mixin;
  15 use FS::cust_svc;
  16 use FS::part_pkg;
  17 use FS::cust_main;
  18 use FS::cust_location;
  19 use FS::pkg_svc;
  20 use FS::cust_bill_pkg;
  21 use FS::cust_pkg_detail;
  22 use FS::cust_event;
  23 use FS::h_cust_svc;
  24 use FS::reg_code;
  25 use FS::part_svc;
  26 use FS::cust_pkg_reason;
  27 use FS::reason;
  28 use FS::UI::Web;
  29
  30 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  31 # setup }
  32 # because they load configuration by setting FS::UID::callback (see TODO)
  33 use FS::svc_acct;
  34 use FS::svc_domain;
  35 use FS::svc_www;
  36 use FS::svc_forward;
  37
  38 # for sending cancel emails in sub cancel
  39 use FS::Conf;
  40
  41 @ISA = qw( FS::m2m_Common FS::cust_main_Mixin FS::option_Common FS::Record );
  42
  43 $DEBUG = 0;
  44
  45 $disable_agentcheck = 0;
  46
  47 sub _cache {
  48   my $self = shift;
  49   my ( $hashref, $cache ) = @_;
  50   #if ( $hashref->{'pkgpart'} ) {
  51   if ( $hashref->{'pkg'} ) {
  52     # #@{ $self->{'_pkgnum'} } = ();
  53     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  54     # $self->{'_pkgpart'} = $subcache;
  55     # #push @{ $self->{'_pkgnum'} },
  56     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  57     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  58   }
  59   if ( exists $hashref->{'svcnum'} ) {
  60     #@{ $self->{'_pkgnum'} } = ();
  61     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  62     $self->{'_svcnum'} = $subcache;
  63     #push @{ $self->{'_pkgnum'} },
  64     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  65   }
  66 }
  67
  68 =head1 NAME
  69
  70 FS::cust_pkg - Object methods for cust_pkg objects
  71
  72 =head1 SYNOPSIS
  73
  74   use FS::cust_pkg;
  75
  76   $record = new FS::cust_pkg \%hash;
  77   $record = new FS::cust_pkg { 'column' => 'value' };
  78
  79   $error = $record->insert;
  80
  81   $error = $new_record->replace($old_record);
  82
  83   $error = $record->delete;
  84
  85   $error = $record->check;
  86
  87   $error = $record->cancel;
  88
  89   $error = $record->suspend;
  90
  91   $error = $record->unsuspend;
  92
  93   $part_pkg = $record->part_pkg;
  94
  95   @labels = $record->labels;
  96
  97   $seconds = $record->seconds_since($timestamp);
  98
  99   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 100   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 101
 102 =head1 DESCRIPTION
 103
 104 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 105 inherits from FS::Record.  The following fields are currently supported:
 106
 107 =over 4
 108
 109 =item pkgnum
 110
 111 Primary key (assigned automatically for new billing items)
 112
 113 =item custnum
 114
 115 Customer (see L<FS::cust_main>)
 116
 117 =item pkgpart
 118
 119 Billing item definition (see L<FS::part_pkg>)
 120
 121 =item locationnum
 122
 123 Optional link to package location (see L<FS::location>)
 124
 125 =item start_date
 126
 127 date
 128
 129 =item setup
 130
 131 date
 132
 133 =item bill
 134
 135 date (next bill date)
 136
 137 =item last_bill
 138
 139 last bill date
 140
 141 =item adjourn
 142
 143 date
 144
 145 =item susp
 146
 147 date
 148
 149 =item expire
 150
 151 date
 152
 153 =item cancel
 154
 155 date
 156
 157 =item otaker
 158
 159 order taker (assigned automatically if null, see L<FS::UID>)
 160
 161 =item manual_flag
 162
 163 If this field is set to 1, disables the automatic
 164 unsuspension of this package when using the B<unsuspendauto> config option.
 165
 166 =item quantity
 167
 168 If not set, defaults to 1
 169
 170 =item change_date
 171
 172 Date of change from previous package
 173
 174 =item change_pkgnum
 175
 176 Previous pkgnum
 177
 178 =item change_pkgpart
 179
 180 Previous pkgpart
 181
 182 =item change_locationnum
 183
 184 Previous locationnum
 185
 186 =back
 187
 188 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 189 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 190 L<Time::Local> and L<Date::Parse> for conversion functions.
 191
 192 =head1 METHODS
 193
 194 =over 4
 195
 196 =item new HASHREF
 197
 198 Create a new billing item.  To add the item to the database, see L<"insert">.
 199
 200 =cut
 201
 202 sub table { 'cust_pkg'; }
 203 sub cust_linked { $_[0]->cust_main_custnum; }
 204 sub cust_unlinked_msg {
 205   my $self = shift;
 206   "WARNING: can't find cust_main.custnum ". $self->custnum.
 207   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 208 }
 209
 210 =item insert [ OPTION => VALUE ... ]
 211
 212 Adds this billing item to the database ("Orders" the item).  If there is an
 213 error, returns the error, otherwise returns false.
 214
 215 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 216 will be used to look up the package definition and agent restrictions will be
 217 ignored.
 218
 219 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 220 be created and inserted.  Multiple FS::pkg_referral records can be created by
 221 setting I<refnum> to an array reference of refnums or a hash reference with
 222 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 223 record will be created corresponding to cust_main.refnum.
 224
 225 The following options are available:
 226
 227 =over 4
 228
 229 =item change
 230
 231 If set true, supresses any referral credit to a referring customer.
 232
 233 =item options
 234
 235 cust_pkg_option records will be created
 236
 237 =item ticket_subject
 238
 239 a ticket will be added to this customer with this subject
 240
 241 =item ticket_queue
 242
 243 an optional queue name for ticket additions
 244
 245 =back
 246
 247 =cut
 248
 249 sub insert {
 250   my( $self, %options ) = @_;
 251
 252   local $SIG{HUP} = 'IGNORE';
 253   local $SIG{INT} = 'IGNORE';
 254   local $SIG{QUIT} = 'IGNORE';
 255   local $SIG{TERM} = 'IGNORE';
 256   local $SIG{TSTP} = 'IGNORE';
 257   local $SIG{PIPE} = 'IGNORE';
 258
 259   my $oldAutoCommit = $FS::UID::AutoCommit;
 260   local $FS::UID::AutoCommit = 0;
 261   my $dbh = dbh;
 262
 263   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 264   if ( $error ) {
 265     $dbh->rollback if $oldAutoCommit;
 266     return $error;
 267   }
 268
 269   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 270   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 271   $self->process_m2m( 'link_table'   => 'pkg_referral',
 272                       'target_table' => 'part_referral',
 273                       'params'       => $self->refnum,
 274                     );
 275
 276   #if ( $self->reg_code ) {
 277   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 278   #  $error = $reg_code->delete;
 279   #  if ( $error ) {
 280   #    $dbh->rollback if $oldAutoCommit;
 281   #    return $error;
 282   #  }
 283   #}
 284
 285   my $conf = new FS::Conf;
 286
 287   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 288     eval '
 289       use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 290       use RT;
 291     ';
 292     die $@ if $@;
 293
 294     RT::LoadConfig();
 295     RT::Init();
 296     my $q = new RT::Queue($RT::SystemUser);
 297     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 298     my $t = new RT::Ticket($RT::SystemUser);
 299     my $mime = new MIME::Entity;
 300     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 301     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 302                 Subject => $options{ticket_subject},
 303                 MIMEObj => $mime,
 304               );
 305     $t->AddLink( Type   => 'MemberOf',
 306                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 307                );
 308   }
 309
 310   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 311     my $queue = new FS::queue {
 312       'job'     => 'FS::cust_main::queueable_print',
 313     };
 314     $error = $queue->insert(
 315       'custnum'  => $self->custnum,
 316       'template' => 'welcome_letter',
 317     );
 318
 319     if ($error) {
 320       warn "can't send welcome letter: $error";
 321     }
 322
 323   }
 324
 325   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 326   '';
 327
 328 }
 329
 330 =item delete
 331
 332 This method now works but you probably shouldn't use it.
 333
 334 You don't want to delete billing items, because there would then be no record
 335 the customer ever purchased the item.  Instead, see the cancel method.
 336
 337 =cut
 338
 339 #sub delete {
 340 #  return "Can't delete cust_pkg records!";
 341 #}
 342
 343 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 344
 345 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 346 returns the error, otherwise returns false.
 347
 348 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 349
 350 Changing pkgpart may have disasterous effects.  See the order subroutine.
 351
 352 setup and bill are normally updated by calling the bill method of a customer
 353 object (see L<FS::cust_main>).
 354
 355 suspend is normally updated by the suspend and unsuspend methods.
 356
 357 cancel is normally updated by the cancel method (and also the order subroutine
 358 in some cases).
 359
 360 Available options are:
 361
 362 =over 4
 363
 364 =item reason
 365
 366 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.
 367
 368 =item reason_otaker
 369
 370 the access_user (see L<FS::access_user>) providing the reason
 371
 372 =item options
 373
 374 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 375
 376 =back
 377
 378 =cut
 379
 380 sub replace {
 381   my $new = shift;
 382
 383   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 384               ? shift
 385               : $new->replace_old;
 386
 387   my $options =
 388     ( ref($_[0]) eq 'HASH' )
 389       ? shift
 390       : { @_ };
 391
 392   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 393   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 394
 395   #allow this *sigh*
 396   #return "Can't change setup once it exists!"
 397   #  if $old->getfield('setup') &&
 398   #     $old->getfield('setup') != $new->getfield('setup');
 399
 400   #some logic for bill, susp, cancel?
 401
 402   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 403
 404   local $SIG{HUP} = 'IGNORE';
 405   local $SIG{INT} = 'IGNORE';
 406   local $SIG{QUIT} = 'IGNORE';
 407   local $SIG{TERM} = 'IGNORE';
 408   local $SIG{TSTP} = 'IGNORE';
 409   local $SIG{PIPE} = 'IGNORE';
 410
 411   my $oldAutoCommit = $FS::UID::AutoCommit;
 412   local $FS::UID::AutoCommit = 0;
 413   my $dbh = dbh;
 414
 415   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 416     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 417       my $error = $new->insert_reason(
 418         'reason'        => $options->{'reason'},
 419         'date'          => $new->$method,
 420         'action'        => $method,
 421         'reason_otaker' => $options->{'reason_otaker'},
 422       );
 423       if ( $error ) {
 424         dbh->rollback if $oldAutoCommit;
 425         return "Error inserting cust_pkg_reason: $error";
 426       }
 427     }
 428   }
 429
 430   #save off and freeze RADIUS attributes for any associated svc_acct records
 431   my @svc_acct = ();
 432   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 433
 434                 #also check for specific exports?
 435                 # to avoid spurious modify export events
 436     @svc_acct = map  { $_->svc_x }
 437                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 438                      $old->cust_svc;
 439
 440     $_->snapshot foreach @svc_acct;
 441
 442   }
 443
 444   my $error = $new->SUPER::replace($old,
 445                                    $options->{options} ? $options->{options} : ()
 446                                   );
 447   if ( $error ) {
 448     $dbh->rollback if $oldAutoCommit;
 449     return $error;
 450   }
 451
 452   #for prepaid packages,
 453   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 454   foreach my $old_svc_acct ( @svc_acct ) {
 455     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 456     my $s_error = $new_svc_acct->replace($old_svc_acct);
 457     if ( $s_error ) {
 458       $dbh->rollback if $oldAutoCommit;
 459       return $s_error;
 460     }
 461   }
 462
 463   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 464   '';
 465
 466 }
 467
 468 =item check
 469
 470 Checks all fields to make sure this is a valid billing item.  If there is an
 471 error, returns the error, otherwise returns false.  Called by the insert and
 472 replace methods.
 473
 474 =cut
 475
 476 sub check {
 477   my $self = shift;
 478
 479   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 480
 481   my $error =
 482     $self->ut_numbern('pkgnum')
 483     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 484     || $self->ut_numbern('pkgpart')
 485     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 486     || $self->ut_numbern('start_date')
 487     || $self->ut_numbern('setup')
 488     || $self->ut_numbern('bill')
 489     || $self->ut_numbern('susp')
 490     || $self->ut_numbern('cancel')
 491     || $self->ut_numbern('adjourn')
 492     || $self->ut_numbern('expire')
 493   ;
 494   return $error if $error;
 495
 496   if ( $self->reg_code ) {
 497
 498     unless ( grep { $self->pkgpart == $_->pkgpart }
 499              map  { $_->reg_code_pkg }
 500              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 501                                      'agentnum' => $self->cust_main->agentnum })
 502            ) {
 503       return "Unknown registration code";
 504     }
 505
 506   } elsif ( $self->promo_code ) {
 507
 508     my $promo_part_pkg =
 509       qsearchs('part_pkg', {
 510         'pkgpart'    => $self->pkgpart,
 511         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 512       } );
 513     return 'Unknown promotional code' unless $promo_part_pkg;
 514
 515   } else {
 516
 517     unless ( $disable_agentcheck ) {
 518       my $agent =
 519         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 520       return "agent ". $agent->agentnum. ':'. $agent->agent.
 521              " can't purchase pkgpart ". $self->pkgpart
 522         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 523             || $agent->agentnum == $self->part_pkg->agentnum;
 524     }
 525
 526     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 527     return $error if $error;
 528
 529   }
 530
 531   $self->otaker(getotaker) unless $self->otaker;
 532   $self->otaker =~ /^(\w{1,32})$/ or return "Illegal otaker";
 533   $self->otaker($1);
 534
 535   if ( $self->dbdef_table->column('manual_flag') ) {
 536     $self->manual_flag('') if $self->manual_flag eq ' ';
 537     $self->manual_flag =~ /^([01]?)$/
 538       or return "Illegal manual_flag ". $self->manual_flag;
 539     $self->manual_flag($1);
 540   }
 541
 542   $self->SUPER::check;
 543 }
 544
 545 =item cancel [ OPTION => VALUE ... ]
 546
 547 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 548 in this package, then cancels the package itself (sets the cancel field to
 549 now).
 550
 551 Available options are:
 552
 553 =over 4
 554
 555 =item quiet - can be set true to supress email cancellation notices.
 556
 557 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 558
 559 =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.
 560
 561 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 562
 563 =item nobill - can be set true to skip billing if it might otherwise be done.
 564
 565 =back
 566
 567 If there is an error, returns the error, otherwise returns false.
 568
 569 =cut
 570
 571 sub cancel {
 572   my( $self, %options ) = @_;
 573   my $error;
 574
 575   my $conf = new FS::Conf;
 576
 577   warn "cust_pkg::cancel called with options".
 578        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 579     if $DEBUG;
 580
 581   local $SIG{HUP} = 'IGNORE';
 582   local $SIG{INT} = 'IGNORE';
 583   local $SIG{QUIT} = 'IGNORE';
 584   local $SIG{TERM} = 'IGNORE';
 585   local $SIG{TSTP} = 'IGNORE';
 586   local $SIG{PIPE} = 'IGNORE';
 587
 588   my $oldAutoCommit = $FS::UID::AutoCommit;
 589   local $FS::UID::AutoCommit = 0;
 590   my $dbh = dbh;
 591
 592   my $old = $self->select_for_update;
 593
 594   if ( $old->get('cancel') || $self->get('cancel') ) {
 595     dbh->rollback if $oldAutoCommit;
 596     return "";  # no error
 597   }
 598
 599   my $date = $options{date} if $options{date}; # expire/cancel later
 600   $date = '' if ($date && $date <= time);      # complain instead?
 601
 602   #race condition: usage could be ongoing until unprovisioned
 603   #resolved by performing a change package instead (which unprovisions) and
 604   #later cancelling
 605   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 606       my $copy = $self->new({$self->hash});
 607       my $error =
 608         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 609       warn "Error billing during cancel, custnum ".
 610         #$self->cust_main->custnum. ": $error"
 611         ": $error"
 612         if $error;
 613   }
 614
 615
 616   my $cancel_time = $options{'time'} || time;
 617
 618   if ( $options{'reason'} ) {
 619     $error = $self->insert_reason( 'reason' => $options{'reason'},
 620                                    'action' => $date ? 'expire' : 'cancel',
 621                                    'date'   => $date ? $date : $cancel_time,
 622                                    'reason_otaker' => $options{'reason_otaker'},
 623                                  );
 624     if ( $error ) {
 625       dbh->rollback if $oldAutoCommit;
 626       return "Error inserting cust_pkg_reason: $error";
 627     }
 628   }
 629
 630   my %svc;
 631   unless ( $date ) {
 632     foreach my $cust_svc (
 633       #schwartz
 634       map  { $_->[0] }
 635       sort { $a->[1] <=> $b->[1] }
 636       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 637       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 638     ) {
 639
 640       my $error = $cust_svc->cancel;
 641
 642       if ( $error ) {
 643         $dbh->rollback if $oldAutoCommit;
 644         return "Error cancelling cust_svc: $error";
 645       }
 646     }
 647
 648     # Add a credit for remaining service
 649     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 650     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 651       my $error = $self->cust_main->credit(
 652         $remaining_value,
 653         'Credit for unused time on '. $self->part_pkg->pkg,
 654         'reason_type' => $conf->config('cancel_credit_type'),
 655       );
 656       if ($error) {
 657         $dbh->rollback if $oldAutoCommit;
 658         return "Error crediting customer \$$remaining_value for unused time on".
 659                $self->part_pkg->pkg. ": $error";
 660       }
 661     }
 662   }
 663
 664   my %hash = $self->hash;
 665   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 666   my $new = new FS::cust_pkg ( \%hash );
 667   $error = $new->replace( $self, options => { $self->options } );
 668   if ( $error ) {
 669     $dbh->rollback if $oldAutoCommit;
 670     return $error;
 671   }
 672
 673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 674   return '' if $date; #no errors
 675
 676   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 677   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 678     my $error = send_email(
 679       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 680       'to'      => \@invoicing_list,
 681       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 682       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 683     );
 684     #should this do something on errors?
 685   }
 686
 687   ''; #no errors
 688
 689 }
 690
 691 =item cancel_if_expired [ NOW_TIMESTAMP ]
 692
 693 Cancels this package if its expire date has been reached.
 694
 695 =cut
 696
 697 sub cancel_if_expired {
 698   my $self = shift;
 699   my $time = shift || time;
 700   return '' unless $self->expire && $self->expire <= $time;
 701   my $error = $self->cancel;
 702   if ( $error ) {
 703     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 704            $self->custnum. ": $error";
 705   }
 706   '';
 707 }
 708
 709 =item unexpire
 710
 711 Cancels any pending expiration (sets the expire field to null).
 712
 713 If there is an error, returns the error, otherwise returns false.
 714
 715 =cut
 716
 717 sub unexpire {
 718   my( $self, %options ) = @_;
 719   my $error;
 720
 721   local $SIG{HUP} = 'IGNORE';
 722   local $SIG{INT} = 'IGNORE';
 723   local $SIG{QUIT} = 'IGNORE';
 724   local $SIG{TERM} = 'IGNORE';
 725   local $SIG{TSTP} = 'IGNORE';
 726   local $SIG{PIPE} = 'IGNORE';
 727
 728   my $oldAutoCommit = $FS::UID::AutoCommit;
 729   local $FS::UID::AutoCommit = 0;
 730   my $dbh = dbh;
 731
 732   my $old = $self->select_for_update;
 733
 734   my $pkgnum = $old->pkgnum;
 735   if ( $old->get('cancel') || $self->get('cancel') ) {
 736     dbh->rollback if $oldAutoCommit;
 737     return "Can't unexpire cancelled package $pkgnum";
 738     # or at least it's pointless
 739   }
 740
 741   unless ( $old->get('expire') && $self->get('expire') ) {
 742     dbh->rollback if $oldAutoCommit;
 743     return "";  # no error
 744   }
 745
 746   my %hash = $self->hash;
 747   $hash{'expire'} = '';
 748   my $new = new FS::cust_pkg ( \%hash );
 749   $error = $new->replace( $self, options => { $self->options } );
 750   if ( $error ) {
 751     $dbh->rollback if $oldAutoCommit;
 752     return $error;
 753   }
 754
 755   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 756
 757   ''; #no errors
 758
 759 }
 760
 761 =item suspend [ OPTION => VALUE ... ]
 762
 763 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 764 package, then suspends the package itself (sets the susp field to now).
 765
 766 Available options are:
 767
 768 =over 4
 769
 770 =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.
 771
 772 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 773
 774 =back
 775
 776 If there is an error, returns the error, otherwise returns false.
 777
 778 =cut
 779
 780 sub suspend {
 781   my( $self, %options ) = @_;
 782   my $error;
 783
 784   local $SIG{HUP} = 'IGNORE';
 785   local $SIG{INT} = 'IGNORE';
 786   local $SIG{QUIT} = 'IGNORE';
 787   local $SIG{TERM} = 'IGNORE';
 788   local $SIG{TSTP} = 'IGNORE';
 789   local $SIG{PIPE} = 'IGNORE';
 790
 791   my $oldAutoCommit = $FS::UID::AutoCommit;
 792   local $FS::UID::AutoCommit = 0;
 793   my $dbh = dbh;
 794
 795   my $old = $self->select_for_update;
 796
 797   my $pkgnum = $old->pkgnum;
 798   if ( $old->get('cancel') || $self->get('cancel') ) {
 799     dbh->rollback if $oldAutoCommit;
 800     return "Can't suspend cancelled package $pkgnum";
 801   }
 802
 803   if ( $old->get('susp') || $self->get('susp') ) {
 804     dbh->rollback if $oldAutoCommit;
 805     return "";  # no error                     # complain on adjourn?
 806   }
 807
 808   my $date = $options{date} if $options{date}; # adjourn/suspend later
 809   $date = '' if ($date && $date <= time);      # complain instead?
 810
 811   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 812     dbh->rollback if $oldAutoCommit;
 813     return "Package $pkgnum expires before it would be suspended.";
 814   }
 815
 816   my $suspend_time = $options{'time'} || time;
 817
 818   if ( $options{'reason'} ) {
 819     $error = $self->insert_reason( 'reason' => $options{'reason'},
 820                                    'action' => $date ? 'adjourn' : 'suspend',
 821                                    'date'   => $date ? $date : $suspend_time,
 822                                    'reason_otaker' => $options{'reason_otaker'},
 823                                  );
 824     if ( $error ) {
 825       dbh->rollback if $oldAutoCommit;
 826       return "Error inserting cust_pkg_reason: $error";
 827     }
 828   }
 829
 830   unless ( $date ) {
 831
 832     my @labels = ();
 833
 834     foreach my $cust_svc (
 835       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 836     ) {
 837       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 838
 839       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 840         $dbh->rollback if $oldAutoCommit;
 841         return "Illegal svcdb value in part_svc!";
 842       };
 843       my $svcdb = $1;
 844       require "FS/$svcdb.pm";
 845
 846       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 847       if ($svc) {
 848         $error = $svc->suspend;
 849         if ( $error ) {
 850           $dbh->rollback if $oldAutoCommit;
 851           return $error;
 852         }
 853         my( $label, $value ) = $cust_svc->label;
 854         push @labels, "$label: $value";
 855       }
 856     }
 857
 858     my $conf = new FS::Conf;
 859     if ( $conf->config('suspend_email_admin') ) {
 860
 861       my $error = send_email(
 862         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 863                                    #invoice_from ??? well as good as any
 864         'to'      => $conf->config('suspend_email_admin'),
 865         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 866         'body'    => [
 867           "This is an automatic message from your Freeside installation\n",
 868           "informing you that the following customer package has been suspended:\n",
 869           "\n",
 870           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 871           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 872           ( map { "Service : $_\n" } @labels ),
 873         ],
 874       );
 875
 876       if ( $error ) {
 877         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 878              "$error\n";
 879       }
 880
 881     }
 882
 883   }
 884
 885   my %hash = $self->hash;
 886   if ( $date ) {
 887     $hash{'adjourn'} = $date;
 888   } else {
 889     $hash{'susp'} = $suspend_time;
 890   }
 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 =item unsuspend [ OPTION => VALUE ... ]
 904
 905 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 906 package, then unsuspends the package itself (clears the susp field and the
 907 adjourn field if it is in the past).
 908
 909 Available options are:
 910
 911 =over 4
 912
 913 =item adjust_next_bill
 914
 915 Can be set true to adjust the next bill date forward by
 916 the amount of time the account was inactive.  This was set true by default
 917 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 918 explicitly requested.  Price plans for which this makes sense (anniversary-date
 919 based than prorate or subscription) could have an option to enable this
 920 behaviour?
 921
 922 =back
 923
 924 If there is an error, returns the error, otherwise returns false.
 925
 926 =cut
 927
 928 sub unsuspend {
 929   my( $self, %opt ) = @_;
 930   my $error;
 931
 932   local $SIG{HUP} = 'IGNORE';
 933   local $SIG{INT} = 'IGNORE';
 934   local $SIG{QUIT} = 'IGNORE';
 935   local $SIG{TERM} = 'IGNORE';
 936   local $SIG{TSTP} = 'IGNORE';
 937   local $SIG{PIPE} = 'IGNORE';
 938
 939   my $oldAutoCommit = $FS::UID::AutoCommit;
 940   local $FS::UID::AutoCommit = 0;
 941   my $dbh = dbh;
 942
 943   my $old = $self->select_for_update;
 944
 945   my $pkgnum = $old->pkgnum;
 946   if ( $old->get('cancel') || $self->get('cancel') ) {
 947     dbh->rollback if $oldAutoCommit;
 948     return "Can't unsuspend cancelled package $pkgnum";
 949   }
 950
 951   unless ( $old->get('susp') && $self->get('susp') ) {
 952     dbh->rollback if $oldAutoCommit;
 953     return "";  # no error                     # complain instead?
 954   }
 955
 956   foreach my $cust_svc (
 957     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 958   ) {
 959     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 960
 961     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 962       $dbh->rollback if $oldAutoCommit;
 963       return "Illegal svcdb value in part_svc!";
 964     };
 965     my $svcdb = $1;
 966     require "FS/$svcdb.pm";
 967
 968     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 969     if ($svc) {
 970       $error = $svc->unsuspend;
 971       if ( $error ) {
 972         $dbh->rollback if $oldAutoCommit;
 973         return $error;
 974       }
 975     }
 976
 977   }
 978
 979   my %hash = $self->hash;
 980   my $inactive = time - $hash{'susp'};
 981
 982   my $conf = new FS::Conf;
 983
 984   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 985     if ( $opt{'adjust_next_bill'}
 986          || $conf->exists('unsuspend-always_adjust_next_bill_date') )
 987     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 988
 989   $hash{'susp'} = '';
 990   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
 991   my $new = new FS::cust_pkg ( \%hash );
 992   $error = $new->replace( $self, options => { $self->options } );
 993   if ( $error ) {
 994     $dbh->rollback if $oldAutoCommit;
 995     return $error;
 996   }
 997
 998   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 999
1000   ''; #no errors
1001 }
1002
1003 =item unadjourn
1004
1005 Cancels any pending suspension (sets the adjourn field to null).
1006
1007 If there is an error, returns the error, otherwise returns false.
1008
1009 =cut
1010
1011 sub unadjourn {
1012   my( $self, %options ) = @_;
1013   my $error;
1014
1015   local $SIG{HUP} = 'IGNORE';
1016   local $SIG{INT} = 'IGNORE';
1017   local $SIG{QUIT} = 'IGNORE';
1018   local $SIG{TERM} = 'IGNORE';
1019   local $SIG{TSTP} = 'IGNORE';
1020   local $SIG{PIPE} = 'IGNORE';
1021
1022   my $oldAutoCommit = $FS::UID::AutoCommit;
1023   local $FS::UID::AutoCommit = 0;
1024   my $dbh = dbh;
1025
1026   my $old = $self->select_for_update;
1027
1028   my $pkgnum = $old->pkgnum;
1029   if ( $old->get('cancel') || $self->get('cancel') ) {
1030     dbh->rollback if $oldAutoCommit;
1031     return "Can't unadjourn cancelled package $pkgnum";
1032     # or at least it's pointless
1033   }
1034
1035   if ( $old->get('susp') || $self->get('susp') ) {
1036     dbh->rollback if $oldAutoCommit;
1037     return "Can't unadjourn suspended package $pkgnum";
1038     # perhaps this is arbitrary
1039   }
1040
1041   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1042     dbh->rollback if $oldAutoCommit;
1043     return "";  # no error
1044   }
1045
1046   my %hash = $self->hash;
1047   $hash{'adjourn'} = '';
1048   my $new = new FS::cust_pkg ( \%hash );
1049   $error = $new->replace( $self, options => { $self->options } );
1050   if ( $error ) {
1051     $dbh->rollback if $oldAutoCommit;
1052     return $error;
1053   }
1054
1055   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1056
1057   ''; #no errors
1058
1059 }
1060
1061
1062 =item change HASHREF | OPTION => VALUE ...
1063
1064 Changes this package: cancels it and creates a new one, with a different
1065 pkgpart or locationnum or both.  All services are transferred to the new
1066 package (no change will be made if this is not possible).
1067
1068 Options may be passed as a list of key/value pairs or as a hash reference.
1069 Options are:
1070
1071 =over 4
1072
1073 =item locaitonnum
1074
1075 New locationnum, to change the location for this package.
1076
1077 =item cust_location
1078
1079 New FS::cust_location object, to create a new location and assign it
1080 to this package.
1081
1082 =item pkgpart
1083
1084 New pkgpart (see L<FS::part_pkg>).
1085
1086 =item refnum
1087
1088 New refnum (see L<FS::part_referral>).
1089
1090 =back
1091
1092 At least one option must be specified (otherwise, what's the point?)
1093
1094 Returns either the new FS::cust_pkg object or a scalar error.
1095
1096 For example:
1097
1098   my $err_or_new_cust_pkg = $old_cust_pkg->change
1099
1100 =cut
1101
1102 #some false laziness w/order
1103 sub change {
1104   my $self = shift;
1105   my $opt = ref($_[0]) ? shift : { @_ };
1106
1107 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1108 #
1109
1110   my $conf = new FS::Conf;
1111
1112   # Transactionize this whole mess
1113   local $SIG{HUP} = 'IGNORE';
1114   local $SIG{INT} = 'IGNORE';
1115   local $SIG{QUIT} = 'IGNORE';
1116   local $SIG{TERM} = 'IGNORE';
1117   local $SIG{TSTP} = 'IGNORE';
1118   local $SIG{PIPE} = 'IGNORE';
1119
1120   my $oldAutoCommit = $FS::UID::AutoCommit;
1121   local $FS::UID::AutoCommit = 0;
1122   my $dbh = dbh;
1123
1124   my $error;
1125
1126   my %hash = ();
1127
1128   my $time = time;
1129
1130   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1131
1132   #$hash{$_} = $self->$_() foreach qw( setup );
1133
1134   $hash{'setup'} = $time if $self->setup;
1135
1136   $hash{'change_date'} = $time;
1137   $hash{"change_$_"}  = $self->$_()
1138     foreach qw( pkgnum pkgpart locationnum );
1139
1140   if ( $opt->{'cust_location'} &&
1141        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1142     $error = $opt->{'cust_location'}->insert;
1143     if ( $error ) {
1144       $dbh->rollback if $oldAutoCommit;
1145       return "inserting cust_location (transaction rolled back): $error";
1146     }
1147     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1148   }
1149
1150   # Create the new package.
1151   my $cust_pkg = new FS::cust_pkg {
1152     custnum      => $self->custnum,
1153     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1154     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1155     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1156     %hash,
1157   };
1158
1159   $error = $cust_pkg->insert( 'change' => 1 );
1160   if ($error) {
1161     $dbh->rollback if $oldAutoCommit;
1162     return $error;
1163   }
1164
1165   # Transfer services and cancel old package.
1166
1167   $error = $self->transfer($cust_pkg);
1168   if ($error and $error == 0) {
1169     # $old_pkg->transfer failed.
1170     $dbh->rollback if $oldAutoCommit;
1171     return $error;
1172   }
1173
1174   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1175     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1176     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1177     if ($error and $error == 0) {
1178       # $old_pkg->transfer failed.
1179       $dbh->rollback if $oldAutoCommit;
1180       return $error;
1181     }
1182   }
1183
1184   if ($error > 0) {
1185     # Transfers were successful, but we still had services left on the old
1186     # package.  We can't change the package under this circumstances, so abort.
1187     $dbh->rollback if $oldAutoCommit;
1188     return "Unable to transfer all services from package ". $self->pkgnum;
1189   }
1190
1191   #reset usage if changing pkgpart
1192   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1193   if ($self->pkgpart != $cust_pkg->pkgpart) {
1194     my $part_pkg = $cust_pkg->part_pkg;
1195     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1196                                                  ? ()
1197                                                  : ( 'null' => 1 )
1198                                    )
1199       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1200
1201     if ($error) {
1202       $dbh->rollback if $oldAutoCommit;
1203       return "Error setting usage values: $error";
1204     }
1205   }
1206
1207   #Good to go, cancel old package.
1208   $error = $self->cancel( quiet=>1 );
1209   if ($error) {
1210     $dbh->rollback;
1211     return $error;
1212   }
1213
1214   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1215   $cust_pkg;
1216
1217 }
1218
1219 =item last_bill
1220
1221 Returns the last bill date, or if there is no last bill date, the setup date.
1222 Useful for billing metered services.
1223
1224 =cut
1225
1226 sub last_bill {
1227   my $self = shift;
1228   return $self->setfield('last_bill', $_[0]) if @_;
1229   return $self->getfield('last_bill') if $self->getfield('last_bill');
1230   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1231                                                   'edate'  => $self->bill,  } );
1232   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1233 }
1234
1235 =item last_cust_pkg_reason ACTION
1236
1237 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1238 Returns false if there is no reason or the package is not currenly ACTION'd
1239 ACTION is one of adjourn, susp, cancel, or expire.
1240
1241 =cut
1242
1243 sub last_cust_pkg_reason {
1244   my ( $self, $action ) = ( shift, shift );
1245   my $date = $self->get($action);
1246   qsearchs( {
1247               'table' => 'cust_pkg_reason',
1248               'hashref' => { 'pkgnum' => $self->pkgnum,
1249                              'action' => substr(uc($action), 0, 1),
1250                              'date'   => $date,
1251                            },
1252               'order_by' => 'ORDER BY num DESC LIMIT 1',
1253            } );
1254 }
1255
1256 =item last_reason ACTION
1257
1258 Returns the most recent ACTION FS::reason associated with the package.
1259 Returns false if there is no reason or the package is not currenly ACTION'd
1260 ACTION is one of adjourn, susp, cancel, or expire.
1261
1262 =cut
1263
1264 sub last_reason {
1265   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1266   $cust_pkg_reason->reason
1267     if $cust_pkg_reason;
1268 }
1269
1270 =item part_pkg
1271
1272 Returns the definition for this billing item, as an FS::part_pkg object (see
1273 L<FS::part_pkg>).
1274
1275 =cut
1276
1277 sub part_pkg {
1278   my $self = shift;
1279   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1280   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1281   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1282 }
1283
1284 =item old_cust_pkg
1285
1286 Returns the cancelled package this package was changed from, if any.
1287
1288 =cut
1289
1290 sub old_cust_pkg {
1291   my $self = shift;
1292   return '' unless $self->change_pkgnum;
1293   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1294 }
1295
1296 =item calc_setup
1297
1298 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1299 item.
1300
1301 =cut
1302
1303 sub calc_setup {
1304   my $self = shift;
1305   $self->part_pkg->calc_setup($self, @_);
1306 }
1307
1308 =item calc_recur
1309
1310 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1311 item.
1312
1313 =cut
1314
1315 sub calc_recur {
1316   my $self = shift;
1317   $self->part_pkg->calc_recur($self, @_);
1318 }
1319
1320 =item calc_remain
1321
1322 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1323 billing item.
1324
1325 =cut
1326
1327 sub calc_remain {
1328   my $self = shift;
1329   $self->part_pkg->calc_remain($self, @_);
1330 }
1331
1332 =item calc_cancel
1333
1334 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1335 billing item.
1336
1337 =cut
1338
1339 sub calc_cancel {
1340   my $self = shift;
1341   $self->part_pkg->calc_cancel($self, @_);
1342 }
1343
1344 =item cust_bill_pkg
1345
1346 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1347
1348 =cut
1349
1350 sub cust_bill_pkg {
1351   my $self = shift;
1352   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1353 }
1354
1355 =item cust_pkg_detail [ DETAILTYPE ]
1356
1357 Returns any customer package details for this package (see
1358 L<FS::cust_pkg_detail>).
1359
1360 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1361
1362 =cut
1363
1364 sub cust_pkg_detail {
1365   my $self = shift;
1366   my %hash = ( 'pkgnum' => $self->pkgnum );
1367   $hash{detailtype} = shift if @_;
1368   qsearch({
1369     'table'    => 'cust_pkg_detail',
1370     'hashref'  => \%hash,
1371     'order_by' => 'ORDER BY weight, pkgdetailnum',
1372   });
1373 }
1374
1375 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1376
1377 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1378
1379 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1380
1381 If there is an error, returns the error, otherwise returns false.
1382
1383 =cut
1384
1385 sub set_cust_pkg_detail {
1386   my( $self, $detailtype, @details ) = @_;
1387
1388   local $SIG{HUP} = 'IGNORE';
1389   local $SIG{INT} = 'IGNORE';
1390   local $SIG{QUIT} = 'IGNORE';
1391   local $SIG{TERM} = 'IGNORE';
1392   local $SIG{TSTP} = 'IGNORE';
1393   local $SIG{PIPE} = 'IGNORE';
1394
1395   my $oldAutoCommit = $FS::UID::AutoCommit;
1396   local $FS::UID::AutoCommit = 0;
1397   my $dbh = dbh;
1398
1399   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1400     my $error = $current->delete;
1401     if ( $error ) {
1402       $dbh->rollback if $oldAutoCommit;
1403       return "error removing old detail: $error";
1404     }
1405   }
1406
1407   foreach my $detail ( @details ) {
1408     my $cust_pkg_detail = new FS::cust_pkg_detail {
1409       'pkgnum'     => $self->pkgnum,
1410       'detailtype' => $detailtype,
1411       'detail'     => $detail,
1412     };
1413     my $error = $cust_pkg_detail->insert;
1414     if ( $error ) {
1415       $dbh->rollback if $oldAutoCommit;
1416       return "error adding new detail: $error";
1417     }
1418
1419   }
1420
1421   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1422   '';
1423
1424 }
1425
1426 =item cust_event
1427
1428 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1429
1430 =cut
1431
1432 #false laziness w/cust_bill.pm
1433 sub cust_event {
1434   my $self = shift;
1435   qsearch({
1436     'table'     => 'cust_event',
1437     'addl_from' => 'JOIN part_event USING ( eventpart )',
1438     'hashref'   => { 'tablenum' => $self->pkgnum },
1439     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1440   });
1441 }
1442
1443 =item num_cust_event
1444
1445 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1446
1447 =cut
1448
1449 #false laziness w/cust_bill.pm
1450 sub num_cust_event {
1451   my $self = shift;
1452   my $sql =
1453     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1454     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1455   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1456   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1457   $sth->fetchrow_arrayref->[0];
1458 }
1459
1460 =item cust_svc [ SVCPART ]
1461
1462 Returns the services for this package, as FS::cust_svc objects (see
1463 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1464 services.
1465
1466 =cut
1467
1468 sub cust_svc {
1469   my $self = shift;
1470
1471   return () unless $self->num_cust_svc(@_);
1472
1473   if ( @_ ) {
1474     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1475                                   'svcpart' => shift,          } );
1476   }
1477
1478   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1479
1480   #if ( $self->{'_svcnum'} ) {
1481   #  values %{ $self->{'_svcnum'}->cache };
1482   #} else {
1483     $self->_sort_cust_svc(
1484       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1485     );
1486   #}
1487
1488 }
1489
1490 =item overlimit [ SVCPART ]
1491
1492 Returns the services for this package which have exceeded their
1493 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1494 is specified, return only the matching services.
1495
1496 =cut
1497
1498 sub overlimit {
1499   my $self = shift;
1500   return () unless $self->num_cust_svc(@_);
1501   grep { $_->overlimit } $self->cust_svc(@_);
1502 }
1503
1504 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1505
1506 Returns historical services for this package created before END TIMESTAMP and
1507 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1508 (see L<FS::h_cust_svc>).
1509
1510 =cut
1511
1512 sub h_cust_svc {
1513   my $self = shift;
1514
1515   $self->_sort_cust_svc(
1516     [ qsearch( 'h_cust_svc',
1517                { 'pkgnum' => $self->pkgnum, },
1518                FS::h_cust_svc->sql_h_search(@_),
1519              )
1520     ]
1521   );
1522 }
1523
1524 sub _sort_cust_svc {
1525   my( $self, $arrayref ) = @_;
1526
1527   map  { $_->[0] }
1528   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1529   map {
1530         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1531                                              'svcpart' => $_->svcpart     } );
1532         [ $_,
1533           $pkg_svc ? $pkg_svc->primary_svc : '',
1534           $pkg_svc ? $pkg_svc->quantity : 0,
1535         ];
1536       }
1537   @$arrayref;
1538
1539 }
1540
1541 =item num_cust_svc [ SVCPART ]
1542
1543 Returns the number of provisioned services for this package.  If a svcpart is
1544 specified, counts only the matching services.
1545
1546 =cut
1547
1548 sub num_cust_svc {
1549   my $self = shift;
1550
1551   return $self->{'_num_cust_svc'}
1552     if !scalar(@_)
1553        && exists($self->{'_num_cust_svc'})
1554        && $self->{'_num_cust_svc'} =~ /\d/;
1555
1556   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1557     if $DEBUG > 2;
1558
1559   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1560   $sql .= ' AND svcpart = ?' if @_;
1561
1562   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1563   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1564   $sth->fetchrow_arrayref->[0];
1565 }
1566
1567 =item available_part_svc
1568
1569 Returns a list of FS::part_svc objects representing services included in this
1570 package but not yet provisioned.  Each FS::part_svc object also has an extra
1571 field, I<num_avail>, which specifies the number of available services.
1572
1573 =cut
1574
1575 sub available_part_svc {
1576   my $self = shift;
1577   grep { $_->num_avail > 0 }
1578     map {
1579           my $part_svc = $_->part_svc;
1580           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1581             $_->quantity - $self->num_cust_svc($_->svcpart);
1582           $part_svc;
1583         }
1584       $self->part_pkg->pkg_svc;
1585 }
1586
1587 =item part_svc
1588
1589 Returns a list of FS::part_svc objects representing provisioned and available
1590 services included in this package.  Each FS::part_svc object also has the
1591 following extra fields:
1592
1593 =over 4
1594
1595 =item num_cust_svc  (count)
1596
1597 =item num_avail     (quantity - count)
1598
1599 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1600
1601 svcnum
1602 label -> ($cust_svc->label)[1]
1603
1604 =back
1605
1606 =cut
1607
1608 sub part_svc {
1609   my $self = shift;
1610
1611   #XXX some sort of sort order besides numeric by svcpart...
1612   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1613     my $pkg_svc = $_;
1614     my $part_svc = $pkg_svc->part_svc;
1615     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1616     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1617     $part_svc->{'Hash'}{'num_avail'}    =
1618       max( 0, $pkg_svc->quantity - $num_cust_svc );
1619     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1620       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1621     $part_svc;
1622   } $self->part_pkg->pkg_svc;
1623
1624   #extras
1625   push @part_svc, map {
1626     my $part_svc = $_;
1627     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1628     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1629     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1630     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1631       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1632     $part_svc;
1633   } $self->extra_part_svc;
1634
1635   @part_svc;
1636
1637 }
1638
1639 =item extra_part_svc
1640
1641 Returns a list of FS::part_svc objects corresponding to services in this
1642 package which are still provisioned but not (any longer) available in the
1643 package definition.
1644
1645 =cut
1646
1647 sub extra_part_svc {
1648   my $self = shift;
1649
1650   my $pkgnum  = $self->pkgnum;
1651   my $pkgpart = $self->pkgpart;
1652
1653 #  qsearch( {
1654 #    'table'     => 'part_svc',
1655 #    'hashref'   => {},
1656 #    'extra_sql' =>
1657 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1658 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1659 #                       AND pkg_svc.pkgpart = ?
1660 #                       AND quantity > 0
1661 #                 )
1662 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1663 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1664 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1665 #                       AND pkgnum = ?
1666 #                 )",
1667 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1668 #  } );
1669
1670 #seems to benchmark slightly faster...
1671   qsearch( {
1672     'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1673     'table'       => 'part_svc',
1674     'addl_from'   =>
1675       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1676                                AND pkg_svc.pkgpart   = ?
1677                                AND quantity > 0
1678                              )
1679        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1680        LEFT JOIN cust_pkg USING ( pkgnum )
1681       ',
1682     'hashref'     => {},
1683     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1684     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1685   } );
1686 }
1687
1688 =item status
1689
1690 Returns a short status string for this package, currently:
1691
1692 =over 4
1693
1694 =item not yet billed
1695
1696 =item one-time charge
1697
1698 =item active
1699
1700 =item suspended
1701
1702 =item cancelled
1703
1704 =back
1705
1706 =cut
1707
1708 sub status {
1709   my $self = shift;
1710
1711   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1712
1713   return 'cancelled' if $self->get('cancel');
1714   return 'suspended' if $self->susp;
1715   return 'not yet billed' unless $self->setup;
1716   return 'one-time charge' if $freq =~ /^(0|$)/;
1717   return 'active';
1718 }
1719
1720 =item statuses
1721
1722 Class method that returns the list of possible status strings for packages
1723 (see L<the status method|/status>).  For example:
1724
1725   @statuses = FS::cust_pkg->statuses();
1726
1727 =cut
1728
1729 tie my %statuscolor, 'Tie::IxHash',
1730   'not yet billed'  => '000000',
1731   'one-time charge' => '000000',
1732   'active'          => '00CC00',
1733   'suspended'       => 'FF9900',
1734   'cancelled'       => 'FF0000',
1735 ;
1736
1737 sub statuses {
1738   my $self = shift; #could be class...
1739   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1740   #                                    # mayble split btw one-time vs. recur
1741     keys %statuscolor;
1742 }
1743
1744 =item statuscolor
1745
1746 Returns a hex triplet color string for this package's status.
1747
1748 =cut
1749
1750 sub statuscolor {
1751   my $self = shift;
1752   $statuscolor{$self->status};
1753 }
1754
1755 =item pkg_label
1756
1757 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1758 "pkg-comment" depending on user preference).
1759
1760 =cut
1761
1762 sub pkg_label {
1763   my $self = shift;
1764   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1765   $label = $self->pkgnum. ": $label"
1766     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1767   $label;
1768 }
1769
1770 =item pkg_label_long
1771
1772 Returns a long label for this package, adding the primary service's label to
1773 pkg_label.
1774
1775 =cut
1776
1777 sub pkg_label_long {
1778   my $self = shift;
1779   my $label = $self->pkg_label;
1780   my $cust_svc = $self->primary_cust_svc;
1781   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1782   $label;
1783 }
1784
1785 =item primary_cust_svc
1786
1787 Returns a primary service (as FS::cust_svc object) if one can be identified.
1788
1789 =cut
1790
1791 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1792
1793 sub primary_cust_svc {
1794   my $self = shift;
1795
1796   my @cust_svc = $self->cust_svc;
1797
1798   return '' unless @cust_svc; #no serivces - irrelevant then
1799
1800   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1801
1802   # primary service as specified in the package definition
1803   # or exactly one service definition with quantity one
1804   my $svcpart = $self->part_pkg->svcpart;
1805   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1806   return $cust_svc[0] if scalar(@cust_svc) == 1;
1807
1808   #couldn't identify one thing..
1809   return '';
1810 }
1811
1812 =item labels
1813
1814 Returns a list of lists, calling the label method for all services
1815 (see L<FS::cust_svc>) of this billing item.
1816
1817 =cut
1818
1819 sub labels {
1820   my $self = shift;
1821   map { [ $_->label ] } $self->cust_svc;
1822 }
1823
1824 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1825
1826 Like the labels method, but returns historical information on services that
1827 were active as of END_TIMESTAMP and (optionally) not cancelled before
1828 START_TIMESTAMP.
1829
1830 Returns a list of lists, calling the label method for all (historical) services
1831 (see L<FS::h_cust_svc>) of this billing item.
1832
1833 =cut
1834
1835 sub h_labels {
1836   my $self = shift;
1837   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1838 }
1839
1840 =item labels_short
1841
1842 Like labels, except returns a simple flat list, and shortens long
1843 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1844 identical services to one line that lists the service label and the number of
1845 individual services rather than individual items.
1846
1847 =cut
1848
1849 sub labels_short {
1850   shift->_labels_short( 'labels', @_ );
1851 }
1852
1853 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1854
1855 Like h_labels, except returns a simple flat list, and shortens long
1856 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1857 identical services to one line that lists the service label and the number of
1858 individual services rather than individual items.
1859
1860 =cut
1861
1862 sub h_labels_short {
1863   shift->_labels_short( 'h_labels', @_ );
1864 }
1865
1866 sub _labels_short {
1867   my( $self, $method ) = ( shift, shift );
1868
1869   my $conf = new FS::Conf;
1870   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1871
1872   my %labels;
1873   #tie %labels, 'Tie::IxHash';
1874   push @{ $labels{$_->[0]} }, $_->[1]
1875     foreach $self->h_labels(@_);
1876   my @labels;
1877   foreach my $label ( keys %labels ) {
1878     my %seen = ();
1879     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1880     my $num = scalar(@values);
1881     if ( $num > $max_same_services ) {
1882       push @labels, "$label ($num)";
1883     } else {
1884       if ( $conf->exists('cust_bill-consolidate_services') ) {
1885         # push @labels, "$label: ". join(', ', @values);
1886         while ( @values ) {
1887           my $detail = "$label: ";
1888           $detail .= shift(@values). ', '
1889             while @values && length($detail.$values[0]) < 78;
1890           $detail =~ s/, $//;
1891           push @labels, $detail;
1892         }
1893       } else {
1894         push @labels, map { "$label: $_" } @values;
1895       }
1896     }
1897   }
1898
1899  @labels;
1900
1901 }
1902
1903 =item cust_main
1904
1905 Returns the parent customer object (see L<FS::cust_main>).
1906
1907 =cut
1908
1909 sub cust_main {
1910   my $self = shift;
1911   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1912 }
1913
1914 =item cust_location
1915
1916 Returns the location object, if any (see L<FS::cust_location>).
1917
1918 =cut
1919
1920 sub cust_location {
1921   my $self = shift;
1922   return '' unless $self->locationnum;
1923   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1924 }
1925
1926 =item cust_location_or_main
1927
1928 If this package is associated with a location, returns the locaiton (see
1929 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1930
1931 =cut
1932
1933 sub cust_location_or_main {
1934   my $self = shift;
1935   $self->cust_location || $self->cust_main;
1936 }
1937
1938 =item seconds_since TIMESTAMP
1939
1940 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1941 package have been online since TIMESTAMP, according to the session monitor.
1942
1943 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1944 L<Time::Local> and L<Date::Parse> for conversion functions.
1945
1946 =cut
1947
1948 sub seconds_since {
1949   my($self, $since) = @_;
1950   my $seconds = 0;
1951
1952   foreach my $cust_svc (
1953     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1954   ) {
1955     $seconds += $cust_svc->seconds_since($since);
1956   }
1957
1958   $seconds;
1959
1960 }
1961
1962 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1963
1964 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1965 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1966 (exclusive).
1967
1968 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1969 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1970 functions.
1971
1972
1973 =cut
1974
1975 sub seconds_since_sqlradacct {
1976   my($self, $start, $end) = @_;
1977
1978   my $seconds = 0;
1979
1980   foreach my $cust_svc (
1981     grep {
1982       my $part_svc = $_->part_svc;
1983       $part_svc->svcdb eq 'svc_acct'
1984         && scalar($part_svc->part_export('sqlradius'));
1985     } $self->cust_svc
1986   ) {
1987     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1988   }
1989
1990   $seconds;
1991
1992 }
1993
1994 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1995
1996 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1997 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1998 TIMESTAMP_END
1999 (exclusive).
2000
2001 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2002 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2003 functions.
2004
2005 =cut
2006
2007 sub attribute_since_sqlradacct {
2008   my($self, $start, $end, $attrib) = @_;
2009
2010   my $sum = 0;
2011
2012   foreach my $cust_svc (
2013     grep {
2014       my $part_svc = $_->part_svc;
2015       $part_svc->svcdb eq 'svc_acct'
2016         && scalar($part_svc->part_export('sqlradius'));
2017     } $self->cust_svc
2018   ) {
2019     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2020   }
2021
2022   $sum;
2023
2024 }
2025
2026 =item quantity
2027
2028 =cut
2029
2030 sub quantity {
2031   my( $self, $value ) = @_;
2032   if ( defined($value) ) {
2033     $self->setfield('quantity', $value);
2034   }
2035   $self->getfield('quantity') || 1;
2036 }
2037
2038 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2039
2040 Transfers as many services as possible from this package to another package.
2041
2042 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2043 object.  The destination package must already exist.
2044
2045 Services are moved only if the destination allows services with the correct
2046 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2047 this option with caution!  No provision is made for export differences
2048 between the old and new service definitions.  Probably only should be used
2049 when your exports for all service definitions of a given svcdb are identical.
2050 (attempt a transfer without it first, to move all possible svcpart-matching
2051 services)
2052
2053 Any services that can't be moved remain in the original package.
2054
2055 Returns an error, if there is one; otherwise, returns the number of services
2056 that couldn't be moved.
2057
2058 =cut
2059
2060 sub transfer {
2061   my ($self, $dest_pkgnum, %opt) = @_;
2062
2063   my $remaining = 0;
2064   my $dest;
2065   my %target;
2066
2067   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2068     $dest = $dest_pkgnum;
2069     $dest_pkgnum = $dest->pkgnum;
2070   } else {
2071     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2072   }
2073
2074   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2075
2076   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2077     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2078   }
2079
2080   foreach my $cust_svc ($dest->cust_svc) {
2081     $target{$cust_svc->svcpart}--;
2082   }
2083
2084   my %svcpart2svcparts = ();
2085   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2086     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2087     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2088       next if exists $svcpart2svcparts{$svcpart};
2089       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2090       $svcpart2svcparts{$svcpart} = [
2091         map  { $_->[0] }
2092         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2093         map {
2094               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2095                                                    'svcpart' => $_          } );
2096               [ $_,
2097                 $pkg_svc ? $pkg_svc->primary_svc : '',
2098                 $pkg_svc ? $pkg_svc->quantity : 0,
2099               ];
2100             }
2101
2102         grep { $_ != $svcpart }
2103         map  { $_->svcpart }
2104         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2105       ];
2106       warn "alternates for svcpart $svcpart: ".
2107            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2108         if $DEBUG;
2109     }
2110   }
2111
2112   foreach my $cust_svc ($self->cust_svc) {
2113     if($target{$cust_svc->svcpart} > 0) {
2114       $target{$cust_svc->svcpart}--;
2115       my $new = new FS::cust_svc { $cust_svc->hash };
2116       $new->pkgnum($dest_pkgnum);
2117       my $error = $new->replace($cust_svc);
2118       return $error if $error;
2119     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2120       if ( $DEBUG ) {
2121         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2122         warn "alternates to consider: ".
2123              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2124       }
2125       my @alternate = grep {
2126                              warn "considering alternate svcpart $_: ".
2127                                   "$target{$_} available in new package\n"
2128                                if $DEBUG;
2129                              $target{$_} > 0;
2130                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2131       if ( @alternate ) {
2132         warn "alternate(s) found\n" if $DEBUG;
2133         my $change_svcpart = $alternate[0];
2134         $target{$change_svcpart}--;
2135         my $new = new FS::cust_svc { $cust_svc->hash };
2136         $new->svcpart($change_svcpart);
2137         $new->pkgnum($dest_pkgnum);
2138         my $error = $new->replace($cust_svc);
2139         return $error if $error;
2140       } else {
2141         $remaining++;
2142       }
2143     } else {
2144       $remaining++
2145     }
2146   }
2147   return $remaining;
2148 }
2149
2150 =item reexport
2151
2152 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2153 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2154
2155 =cut
2156
2157 sub reexport {
2158   my $self = shift;
2159
2160   local $SIG{HUP} = 'IGNORE';
2161   local $SIG{INT} = 'IGNORE';
2162   local $SIG{QUIT} = 'IGNORE';
2163   local $SIG{TERM} = 'IGNORE';
2164   local $SIG{TSTP} = 'IGNORE';
2165   local $SIG{PIPE} = 'IGNORE';
2166
2167   my $oldAutoCommit = $FS::UID::AutoCommit;
2168   local $FS::UID::AutoCommit = 0;
2169   my $dbh = dbh;
2170
2171   foreach my $cust_svc ( $self->cust_svc ) {
2172     #false laziness w/svc_Common::insert
2173     my $svc_x = $cust_svc->svc_x;
2174     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2175       my $error = $part_export->export_insert($svc_x);
2176       if ( $error ) {
2177         $dbh->rollback if $oldAutoCommit;
2178         return $error;
2179       }
2180     }
2181   }
2182
2183   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2184   '';
2185
2186 }
2187
2188 =back
2189
2190 =head1 CLASS METHODS
2191
2192 =over 4
2193
2194 =item recurring_sql
2195
2196 Returns an SQL expression identifying recurring packages.
2197
2198 =cut
2199
2200 sub recurring_sql { "
2201   '0' != ( select freq from part_pkg
2202              where cust_pkg.pkgpart = part_pkg.pkgpart )
2203 "; }
2204
2205 =item onetime_sql
2206
2207 Returns an SQL expression identifying one-time packages.
2208
2209 =cut
2210
2211 sub onetime_sql { "
2212   '0' = ( select freq from part_pkg
2213             where cust_pkg.pkgpart = part_pkg.pkgpart )
2214 "; }
2215
2216 =item active_sql
2217
2218 Returns an SQL expression identifying active packages.
2219
2220 =cut
2221
2222 sub active_sql { "
2223   ". $_[0]->recurring_sql(). "
2224   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2225   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2226 "; }
2227
2228 =item not_yet_billed_sql
2229
2230 Returns an SQL expression identifying packages which have not yet been billed.
2231
2232 =cut
2233
2234 sub not_yet_billed_sql { "
2235       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2236   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2237   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2238 "; }
2239
2240 =item inactive_sql
2241
2242 Returns an SQL expression identifying inactive packages (one-time packages
2243 that are otherwise unsuspended/uncancelled).
2244
2245 =cut
2246
2247 sub inactive_sql { "
2248   ". $_[0]->onetime_sql(). "
2249   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2250   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2251   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2252 "; }
2253
2254 =item susp_sql
2255 =item suspended_sql
2256
2257 Returns an SQL expression identifying suspended packages.
2258
2259 =cut
2260
2261 sub suspended_sql { susp_sql(@_); }
2262 sub susp_sql {
2263   #$_[0]->recurring_sql(). ' AND '.
2264   "
2265         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2266     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2267   ";
2268 }
2269
2270 =item cancel_sql
2271 =item cancelled_sql
2272
2273 Returns an SQL exprression identifying cancelled packages.
2274
2275 =cut
2276
2277 sub cancelled_sql { cancel_sql(@_); }
2278 sub cancel_sql {
2279   #$_[0]->recurring_sql(). ' AND '.
2280   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2281 }
2282
2283 =item search_sql HASHREF
2284
2285 (Class method)
2286
2287 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2288 Valid parameters are
2289
2290 =over 4
2291
2292 =item agentnum
2293
2294 =item magic
2295
2296 active, inactive, suspended, cancel (or cancelled)
2297
2298 =item status
2299
2300 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2301
2302 =item custom
2303
2304  boolean selects custom packages
2305
2306 =item classnum
2307
2308 =item pkgpart
2309
2310 pkgpart or arrayref or hashref of pkgparts
2311
2312 =item setup
2313
2314 arrayref of beginning and ending epoch date
2315
2316 =item last_bill
2317
2318 arrayref of beginning and ending epoch date
2319
2320 =item bill
2321
2322 arrayref of beginning and ending epoch date
2323
2324 =item adjourn
2325
2326 arrayref of beginning and ending epoch date
2327
2328 =item susp
2329
2330 arrayref of beginning and ending epoch date
2331
2332 =item expire
2333
2334 arrayref of beginning and ending epoch date
2335
2336 =item cancel
2337
2338 arrayref of beginning and ending epoch date
2339
2340 =item query
2341
2342 pkgnum or APKG_pkgnum
2343
2344 =item cust_fields
2345
2346 a value suited to passing to FS::UI::Web::cust_header
2347
2348 =item CurrentUser
2349
2350 specifies the user for agent virtualization
2351
2352 =back
2353
2354 =cut
2355
2356 sub search_sql {
2357   my ($class, $params) = @_;
2358   my @where = ();
2359
2360   ##
2361   # parse agent
2362   ##
2363
2364   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2365     push @where,
2366       "cust_main.agentnum = $1";
2367   }
2368
2369   ##
2370   # parse status
2371   ##
2372
2373   if (    $params->{'magic'}  eq 'active'
2374        || $params->{'status'} eq 'active' ) {
2375
2376     push @where, FS::cust_pkg->active_sql();
2377
2378   } elsif (    $params->{'magic'}  eq 'not yet billed'
2379             || $params->{'status'} eq 'not yet billed' ) {
2380
2381     push @where, FS::cust_pkg->not_yet_billed_sql();
2382
2383   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2384             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2385
2386     push @where, FS::cust_pkg->inactive_sql();
2387
2388   } elsif (    $params->{'magic'}  eq 'suspended'
2389             || $params->{'status'} eq 'suspended'  ) {
2390
2391     push @where, FS::cust_pkg->suspended_sql();
2392
2393   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2394             || $params->{'status'} =~ /^cancell?ed$/ ) {
2395
2396     push @where, FS::cust_pkg->cancelled_sql();
2397
2398   }
2399
2400   ###
2401   # parse package class
2402   ###
2403
2404   #false lazinessish w/graph/cust_bill_pkg.cgi
2405   my $classnum = 0;
2406   my @pkg_class = ();
2407   if ( exists($params->{'classnum'})
2408        && $params->{'classnum'} =~ /^(\d*)$/
2409      )
2410   {
2411     $classnum = $1;
2412     if ( $classnum ) { #a specific class
2413       push @where, "classnum = $classnum";
2414
2415       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2416       #die "classnum $classnum not found!" unless $pkg_class[0];
2417       #$title .= $pkg_class[0]->classname.' ';
2418
2419     } elsif ( $classnum eq '' ) { #the empty class
2420
2421       push @where, "classnum IS NULL";
2422       #$title .= 'Empty class ';
2423       #@pkg_class = ( '(empty class)' );
2424     } elsif ( $classnum eq '0' ) {
2425       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2426       #push @pkg_class, '(empty class)';
2427     } else {
2428       die "illegal classnum";
2429     }
2430   }
2431   #eslaf
2432
2433   ###
2434   # parse package report options
2435   ###
2436
2437   my @report_option = ();
2438   if ( exists($params->{'report_option'})
2439        && $params->{'report_option'} =~ /^([,\d]*)$/
2440      )
2441   {
2442     @report_option = split(',', $1);
2443   }
2444
2445   if (@report_option) {
2446     # this will result in the empty set for the dangling comma case as it should
2447     push @where,
2448       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2449                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2450                     AND optionname = 'report_option_$_'
2451                     AND optionvalue = '1' )"
2452          } @report_option;
2453   }
2454
2455   #eslaf
2456
2457   ###
2458   # parse custom
2459   ###
2460
2461   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2462
2463   ###
2464   # parse censustract
2465   ###
2466
2467   if ( exists($params->{'censustract'}) ) {
2468     $params->{'censustract'} =~ /^([.\d]*)$/;
2469     my $censustract = "cust_main.censustract = '$1'";
2470     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2471     push @where,  "( $censustract )";
2472   }
2473
2474   ###
2475   # parse part_pkg
2476   ###
2477
2478   if ( ref($params->{'pkgpart'}) ) {
2479
2480     my @pkgpart = ();
2481     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2482       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2483     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2484       @pkgpart = @{ $params->{'pkgpart'} };
2485     } else {
2486       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2487     }
2488
2489     @pkgpart = grep /^(\d+)$/, @pkgpart;
2490
2491     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2492
2493   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2494     push @where, "pkgpart = $1";
2495   }
2496
2497   ###
2498   # parse dates
2499   ###
2500
2501   my $orderby = '';
2502
2503   #false laziness w/report_cust_pkg.html
2504   my %disable = (
2505     'all'             => {},
2506     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2507     'active'          => { 'susp'=>1, 'cancel'=>1 },
2508     'suspended'       => { 'cancel' => 1 },
2509     'cancelled'       => {},
2510     ''                => {},
2511   );
2512
2513   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2514
2515     next unless exists($params->{$field});
2516
2517     my($beginning, $ending) = @{$params->{$field}};
2518
2519     next if $beginning == 0 && $ending == 4294967295;
2520
2521     push @where,
2522       "cust_pkg.$field IS NOT NULL",
2523       "cust_pkg.$field >= $beginning",
2524       "cust_pkg.$field <= $ending";
2525
2526     $orderby ||= "ORDER BY cust_pkg.$field";
2527
2528   }
2529
2530   $orderby ||= 'ORDER BY bill';
2531
2532   ###
2533   # parse magic, legacy, etc.
2534   ###
2535
2536   if ( $params->{'magic'} &&
2537        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2538   ) {
2539
2540     $orderby = 'ORDER BY pkgnum';
2541
2542     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2543       push @where, "pkgpart = $1";
2544     }
2545
2546   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2547
2548     $orderby = 'ORDER BY pkgnum';
2549
2550   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2551
2552     $orderby = 'ORDER BY pkgnum';
2553
2554     push @where, '0 < (
2555       SELECT count(*) FROM pkg_svc
2556        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2557          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2558                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2559                                      AND cust_svc.svcpart = pkg_svc.svcpart
2560                                 )
2561     )';
2562
2563   }
2564
2565   ##
2566   # setup queries, links, subs, etc. for the search
2567   ##
2568
2569   # here is the agent virtualization
2570   if ($params->{CurrentUser}) {
2571     my $access_user =
2572       qsearchs('access_user', { username => $params->{CurrentUser} });
2573
2574     if ($access_user) {
2575       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2576     }else{
2577       push @where, "1=0";
2578     }
2579   }else{
2580     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2581   }
2582
2583   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2584
2585   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2586                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2587                   'LEFT JOIN pkg_class USING ( classnum ) ';
2588
2589   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2590
2591   my $sql_query = {
2592     'table'       => 'cust_pkg',
2593     'hashref'     => {},
2594     'select'      => join(', ',
2595                                 'cust_pkg.*',
2596                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2597                                 'pkg_class.classname',
2598                                 'cust_main.custnum as cust_main_custnum',
2599                                 FS::UI::Web::cust_sql_fields(
2600                                   $params->{'cust_fields'}
2601                                 ),
2602                      ),
2603     'extra_sql'   => "$extra_sql $orderby",
2604     'addl_from'   => $addl_from,
2605     'count_query' => $count_query,
2606   };
2607
2608 }
2609
2610 =item location_sql
2611
2612 Returns a list: the first item is an SQL fragment identifying matching
2613 packages/customers via location (taking into account shipping and package
2614 address taxation, if enabled), and subsequent items are the parameters to
2615 substitute for the placeholders in that fragment.
2616
2617 =cut
2618
2619 sub location_sql {
2620   my($class, %opt) = @_;
2621   my $ornull = $opt{'ornull'};
2622
2623   my $conf = new FS::Conf;
2624
2625   # '?' placeholders in _location_sql_where
2626   my @bill_param;
2627   if ( $ornull ) {
2628     @bill_param = qw( county county state state state country );
2629   } else {
2630     @bill_param = qw( county state state country );
2631   }
2632   unshift @bill_param, 'county'; # unless $nec;
2633
2634   my $main_where;
2635   my @main_param;
2636   if ( $conf->exists('tax-ship_address') ) {
2637
2638     $main_where = "(
2639          (     ( ship_last IS NULL     OR  ship_last  = '' )
2640            AND ". _location_sql_where('cust_main', '', $ornull ). "
2641          )
2642       OR (       ship_last IS NOT NULL AND ship_last != ''
2643            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2644          )
2645     )";
2646     #    AND payby != 'COMP'
2647
2648     @main_param = ( @bill_param, @bill_param );
2649
2650   } else {
2651
2652     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2653     @main_param = @bill_param;
2654
2655   }
2656
2657   my $where;
2658   my @param;
2659   if ( $conf->exists('tax-pkg_address') ) {
2660
2661     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2662
2663     $where = " (
2664                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2665                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2666                )
2667              ";
2668     @param = ( @main_param, @bill_param );
2669
2670   } else {
2671
2672     $where = $main_where;
2673     @param = @main_param;
2674
2675   }
2676
2677   ( $where, @param );
2678
2679 }
2680
2681 #subroutine, helper for location_sql
2682 sub _location_sql_where {
2683   my $table  = shift;
2684   my $prefix = @_ ? shift : '';
2685   my $ornull = @_ ? shift : '';
2686
2687 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2688
2689   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2690
2691   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2692   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2693
2694   "
2695         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2696     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2697     AND   $table.${prefix}country = ?
2698   ";
2699 }
2700
2701 =head1 SUBROUTINES
2702
2703 =over 4
2704
2705 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2706
2707 CUSTNUM is a customer (see L<FS::cust_main>)
2708
2709 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2710 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2711 permitted.
2712
2713 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2714 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2715 new billing items.  An error is returned if this is not possible (see
2716 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2717 parameter.
2718
2719 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2720 newly-created cust_pkg objects.
2721
2722 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2723 and inserted.  Multiple FS::pkg_referral records can be created by
2724 setting I<refnum> to an array reference of refnums or a hash reference with
2725 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2726 record will be created corresponding to cust_main.refnum.
2727
2728 =cut
2729
2730 sub order {
2731   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2732
2733   my $conf = new FS::Conf;
2734
2735   # Transactionize this whole mess
2736   local $SIG{HUP} = 'IGNORE';
2737   local $SIG{INT} = 'IGNORE';
2738   local $SIG{QUIT} = 'IGNORE';
2739   local $SIG{TERM} = 'IGNORE';
2740   local $SIG{TSTP} = 'IGNORE';
2741   local $SIG{PIPE} = 'IGNORE';
2742
2743   my $oldAutoCommit = $FS::UID::AutoCommit;
2744   local $FS::UID::AutoCommit = 0;
2745   my $dbh = dbh;
2746
2747   my $error;
2748 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2749 #  return "Customer not found: $custnum" unless $cust_main;
2750
2751   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2752                          @$remove_pkgnum;
2753
2754   my $change = scalar(@old_cust_pkg) != 0;
2755
2756   my %hash = ();
2757   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2758
2759     my $err_or_cust_pkg =
2760       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2761                                 'refnum'  => $refnum,
2762                               );
2763
2764     unless (ref($err_or_cust_pkg)) {
2765       $dbh->rollback if $oldAutoCommit;
2766       return $err_or_cust_pkg;
2767     }
2768
2769     push @$return_cust_pkg, $err_or_cust_pkg;
2770     return '';
2771
2772   }
2773
2774   # Create the new packages.
2775   foreach my $pkgpart (@$pkgparts) {
2776     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2777                                       pkgpart => $pkgpart,
2778                                       refnum  => $refnum,
2779                                       %hash,
2780                                     };
2781     $error = $cust_pkg->insert( 'change' => $change );
2782     if ($error) {
2783       $dbh->rollback if $oldAutoCommit;
2784       return $error;
2785     }
2786     push @$return_cust_pkg, $cust_pkg;
2787   }
2788   # $return_cust_pkg now contains refs to all of the newly
2789   # created packages.
2790
2791   # Transfer services and cancel old packages.
2792   foreach my $old_pkg (@old_cust_pkg) {
2793
2794     foreach my $new_pkg (@$return_cust_pkg) {
2795       $error = $old_pkg->transfer($new_pkg);
2796       if ($error and $error == 0) {
2797         # $old_pkg->transfer failed.
2798         $dbh->rollback if $oldAutoCommit;
2799         return $error;
2800       }
2801     }
2802
2803     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2804       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2805       foreach my $new_pkg (@$return_cust_pkg) {
2806         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2807         if ($error and $error == 0) {
2808           # $old_pkg->transfer failed.
2809         $dbh->rollback if $oldAutoCommit;
2810         return $error;
2811         }
2812       }
2813     }
2814
2815     if ($error > 0) {
2816       # Transfers were successful, but we went through all of the
2817       # new packages and still had services left on the old package.
2818       # We can't cancel the package under the circumstances, so abort.
2819       $dbh->rollback if $oldAutoCommit;
2820       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2821     }
2822     $error = $old_pkg->cancel( quiet=>1 );
2823     if ($error) {
2824       $dbh->rollback;
2825       return $error;
2826     }
2827   }
2828   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2829   '';
2830 }
2831
2832 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2833
2834 A bulk change method to change packages for multiple customers.
2835
2836 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2837 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2838 permitted.
2839
2840 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2841 replace.  The services (see L<FS::cust_svc>) are moved to the
2842 new billing items.  An error is returned if this is not possible (see
2843 L<FS::pkg_svc>).
2844
2845 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2846 newly-created cust_pkg objects.
2847
2848 =cut
2849
2850 sub bulk_change {
2851   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2852
2853   # Transactionize this whole mess
2854   local $SIG{HUP} = 'IGNORE';
2855   local $SIG{INT} = 'IGNORE';
2856   local $SIG{QUIT} = 'IGNORE';
2857   local $SIG{TERM} = 'IGNORE';
2858   local $SIG{TSTP} = 'IGNORE';
2859   local $SIG{PIPE} = 'IGNORE';
2860
2861   my $oldAutoCommit = $FS::UID::AutoCommit;
2862   local $FS::UID::AutoCommit = 0;
2863   my $dbh = dbh;
2864
2865   my @errors;
2866   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2867                          @$remove_pkgnum;
2868
2869   while(scalar(@old_cust_pkg)) {
2870     my @return = ();
2871     my $custnum = $old_cust_pkg[0]->custnum;
2872     my (@remove) = map { $_->pkgnum }
2873                    grep { $_->custnum == $custnum } @old_cust_pkg;
2874     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2875
2876     my $error = order $custnum, $pkgparts, \@remove, \@return;
2877
2878     push @errors, $error
2879       if $error;
2880     push @$return_cust_pkg, @return;
2881   }
2882
2883   if (scalar(@errors)) {
2884     $dbh->rollback if $oldAutoCommit;
2885     return join(' / ', @errors);
2886   }
2887
2888   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2889   '';
2890 }
2891
2892 =item insert_reason
2893
2894 Associates this package with a (suspension or cancellation) reason (see
2895 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2896 L<FS::reason>).
2897
2898 Available options are:
2899
2900 =over 4
2901
2902 =item reason
2903
2904 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.
2905
2906 =item reason_otaker
2907
2908 the access_user (see L<FS::access_user>) providing the reason
2909
2910 =item date
2911
2912 a unix timestamp
2913
2914 =item action
2915
2916 the action (cancel, susp, adjourn, expire) associated with the reason
2917
2918 =back
2919
2920 If there is an error, returns the error, otherwise returns false.
2921
2922 =cut
2923
2924 sub insert_reason {
2925   my ($self, %options) = @_;
2926
2927   my $otaker = $options{reason_otaker} ||
2928                $FS::CurrentUser::CurrentUser->username;
2929
2930   my $reasonnum;
2931   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2932
2933     $reasonnum = $1;
2934
2935   } elsif ( ref($options{'reason'}) ) {
2936
2937     return 'Enter a new reason (or select an existing one)'
2938       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2939
2940     my $reason = new FS::reason({
2941       'reason_type' => $options{'reason'}->{'typenum'},
2942       'reason'      => $options{'reason'}->{'reason'},
2943     });
2944     my $error = $reason->insert;
2945     return $error if $error;
2946
2947     $reasonnum = $reason->reasonnum;
2948
2949   } else {
2950     return "Unparsable reason: ". $options{'reason'};
2951   }
2952
2953   my $cust_pkg_reason =
2954     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2955                               'reasonnum' => $reasonnum,
2956                               'otaker'    => $otaker,
2957                               'action'    => substr(uc($options{'action'}),0,1),
2958                               'date'      => $options{'date'}
2959                                                ? $options{'date'}
2960                                                : time,
2961                             });
2962
2963   $cust_pkg_reason->insert;
2964 }
2965
2966 =item set_usage USAGE_VALUE_HASHREF
2967
2968 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2969 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2970 upbytes, downbytes, and totalbytes are appropriate keys.
2971
2972 All svc_accts which are part of this package have their values reset.
2973
2974 =cut
2975
2976 sub set_usage {
2977   my ($self, $valueref, %opt) = @_;
2978
2979   foreach my $cust_svc ($self->cust_svc){
2980     my $svc_x = $cust_svc->svc_x;
2981     $svc_x->set_usage($valueref, %opt)
2982       if $svc_x->can("set_usage");
2983   }
2984 }
2985
2986 =item recharge USAGE_VALUE_HASHREF
2987
2988 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2989 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2990 upbytes, downbytes, and totalbytes are appropriate keys.
2991
2992 All svc_accts which are part of this package have their values incremented.
2993
2994 =cut
2995
2996 sub recharge {
2997   my ($self, $valueref) = @_;
2998
2999   foreach my $cust_svc ($self->cust_svc){
3000     my $svc_x = $cust_svc->svc_x;
3001     $svc_x->recharge($valueref)
3002       if $svc_x->can("recharge");
3003   }
3004 }
3005
3006 =back
3007
3008 =head1 BUGS
3009
3010 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3011
3012 In sub order, the @pkgparts array (passed by reference) is clobbered.
3013
3014 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3015 method to pass dates to the recur_prog expression, it should do so.
3016
3017 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3018 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3019 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3020 configuration values.  Probably need a subroutine which decides what to do
3021 based on whether or not we've fetched the user yet, rather than a hash.  See
3022 FS::UID and the TODO.
3023
3024 Now that things are transactional should the check in the insert method be
3025 moved to check ?
3026
3027 =head1 SEE ALSO
3028
3029 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3030 L<FS::pkg_svc>, schema.html from the base documentation
3031
3032 =cut
3033
3034 1;
3035