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       push @labels, map { "$label: $_" } @values;
1885     }
1886   }
1887
1888  @labels;
1889
1890 }
1891
1892 =item cust_main
1893
1894 Returns the parent customer object (see L<FS::cust_main>).
1895
1896 =cut
1897
1898 sub cust_main {
1899   my $self = shift;
1900   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1901 }
1902
1903 =item cust_location
1904
1905 Returns the location object, if any (see L<FS::cust_location>).
1906
1907 =cut
1908
1909 sub cust_location {
1910   my $self = shift;
1911   return '' unless $self->locationnum;
1912   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1913 }
1914
1915 =item cust_location_or_main
1916
1917 If this package is associated with a location, returns the locaiton (see
1918 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1919
1920 =cut
1921
1922 sub cust_location_or_main {
1923   my $self = shift;
1924   $self->cust_location || $self->cust_main;
1925 }
1926
1927 =item seconds_since TIMESTAMP
1928
1929 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1930 package have been online since TIMESTAMP, according to the session monitor.
1931
1932 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1933 L<Time::Local> and L<Date::Parse> for conversion functions.
1934
1935 =cut
1936
1937 sub seconds_since {
1938   my($self, $since) = @_;
1939   my $seconds = 0;
1940
1941   foreach my $cust_svc (
1942     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1943   ) {
1944     $seconds += $cust_svc->seconds_since($since);
1945   }
1946
1947   $seconds;
1948
1949 }
1950
1951 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1952
1953 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1954 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1955 (exclusive).
1956
1957 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1958 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1959 functions.
1960
1961
1962 =cut
1963
1964 sub seconds_since_sqlradacct {
1965   my($self, $start, $end) = @_;
1966
1967   my $seconds = 0;
1968
1969   foreach my $cust_svc (
1970     grep {
1971       my $part_svc = $_->part_svc;
1972       $part_svc->svcdb eq 'svc_acct'
1973         && scalar($part_svc->part_export('sqlradius'));
1974     } $self->cust_svc
1975   ) {
1976     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1977   }
1978
1979   $seconds;
1980
1981 }
1982
1983 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1984
1985 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1986 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1987 TIMESTAMP_END
1988 (exclusive).
1989
1990 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1991 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1992 functions.
1993
1994 =cut
1995
1996 sub attribute_since_sqlradacct {
1997   my($self, $start, $end, $attrib) = @_;
1998
1999   my $sum = 0;
2000
2001   foreach my $cust_svc (
2002     grep {
2003       my $part_svc = $_->part_svc;
2004       $part_svc->svcdb eq 'svc_acct'
2005         && scalar($part_svc->part_export('sqlradius'));
2006     } $self->cust_svc
2007   ) {
2008     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2009   }
2010
2011   $sum;
2012
2013 }
2014
2015 =item quantity
2016
2017 =cut
2018
2019 sub quantity {
2020   my( $self, $value ) = @_;
2021   if ( defined($value) ) {
2022     $self->setfield('quantity', $value);
2023   }
2024   $self->getfield('quantity') || 1;
2025 }
2026
2027 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2028
2029 Transfers as many services as possible from this package to another package.
2030
2031 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2032 object.  The destination package must already exist.
2033
2034 Services are moved only if the destination allows services with the correct
2035 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2036 this option with caution!  No provision is made for export differences
2037 between the old and new service definitions.  Probably only should be used
2038 when your exports for all service definitions of a given svcdb are identical.
2039 (attempt a transfer without it first, to move all possible svcpart-matching
2040 services)
2041
2042 Any services that can't be moved remain in the original package.
2043
2044 Returns an error, if there is one; otherwise, returns the number of services
2045 that couldn't be moved.
2046
2047 =cut
2048
2049 sub transfer {
2050   my ($self, $dest_pkgnum, %opt) = @_;
2051
2052   my $remaining = 0;
2053   my $dest;
2054   my %target;
2055
2056   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2057     $dest = $dest_pkgnum;
2058     $dest_pkgnum = $dest->pkgnum;
2059   } else {
2060     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2061   }
2062
2063   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2064
2065   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2066     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2067   }
2068
2069   foreach my $cust_svc ($dest->cust_svc) {
2070     $target{$cust_svc->svcpart}--;
2071   }
2072
2073   my %svcpart2svcparts = ();
2074   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2075     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2076     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2077       next if exists $svcpart2svcparts{$svcpart};
2078       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2079       $svcpart2svcparts{$svcpart} = [
2080         map  { $_->[0] }
2081         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2082         map {
2083               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2084                                                    'svcpart' => $_          } );
2085               [ $_,
2086                 $pkg_svc ? $pkg_svc->primary_svc : '',
2087                 $pkg_svc ? $pkg_svc->quantity : 0,
2088               ];
2089             }
2090
2091         grep { $_ != $svcpart }
2092         map  { $_->svcpart }
2093         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2094       ];
2095       warn "alternates for svcpart $svcpart: ".
2096            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2097         if $DEBUG;
2098     }
2099   }
2100
2101   foreach my $cust_svc ($self->cust_svc) {
2102     if($target{$cust_svc->svcpart} > 0) {
2103       $target{$cust_svc->svcpart}--;
2104       my $new = new FS::cust_svc { $cust_svc->hash };
2105       $new->pkgnum($dest_pkgnum);
2106       my $error = $new->replace($cust_svc);
2107       return $error if $error;
2108     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2109       if ( $DEBUG ) {
2110         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2111         warn "alternates to consider: ".
2112              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2113       }
2114       my @alternate = grep {
2115                              warn "considering alternate svcpart $_: ".
2116                                   "$target{$_} available in new package\n"
2117                                if $DEBUG;
2118                              $target{$_} > 0;
2119                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2120       if ( @alternate ) {
2121         warn "alternate(s) found\n" if $DEBUG;
2122         my $change_svcpart = $alternate[0];
2123         $target{$change_svcpart}--;
2124         my $new = new FS::cust_svc { $cust_svc->hash };
2125         $new->svcpart($change_svcpart);
2126         $new->pkgnum($dest_pkgnum);
2127         my $error = $new->replace($cust_svc);
2128         return $error if $error;
2129       } else {
2130         $remaining++;
2131       }
2132     } else {
2133       $remaining++
2134     }
2135   }
2136   return $remaining;
2137 }
2138
2139 =item reexport
2140
2141 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2142 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2143
2144 =cut
2145
2146 sub reexport {
2147   my $self = shift;
2148
2149   local $SIG{HUP} = 'IGNORE';
2150   local $SIG{INT} = 'IGNORE';
2151   local $SIG{QUIT} = 'IGNORE';
2152   local $SIG{TERM} = 'IGNORE';
2153   local $SIG{TSTP} = 'IGNORE';
2154   local $SIG{PIPE} = 'IGNORE';
2155
2156   my $oldAutoCommit = $FS::UID::AutoCommit;
2157   local $FS::UID::AutoCommit = 0;
2158   my $dbh = dbh;
2159
2160   foreach my $cust_svc ( $self->cust_svc ) {
2161     #false laziness w/svc_Common::insert
2162     my $svc_x = $cust_svc->svc_x;
2163     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2164       my $error = $part_export->export_insert($svc_x);
2165       if ( $error ) {
2166         $dbh->rollback if $oldAutoCommit;
2167         return $error;
2168       }
2169     }
2170   }
2171
2172   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2173   '';
2174
2175 }
2176
2177 =back
2178
2179 =head1 CLASS METHODS
2180
2181 =over 4
2182
2183 =item recurring_sql
2184
2185 Returns an SQL expression identifying recurring packages.
2186
2187 =cut
2188
2189 sub recurring_sql { "
2190   '0' != ( select freq from part_pkg
2191              where cust_pkg.pkgpart = part_pkg.pkgpart )
2192 "; }
2193
2194 =item onetime_sql
2195
2196 Returns an SQL expression identifying one-time packages.
2197
2198 =cut
2199
2200 sub onetime_sql { "
2201   '0' = ( select freq from part_pkg
2202             where cust_pkg.pkgpart = part_pkg.pkgpart )
2203 "; }
2204
2205 =item active_sql
2206
2207 Returns an SQL expression identifying active packages.
2208
2209 =cut
2210
2211 sub active_sql { "
2212   ". $_[0]->recurring_sql(). "
2213   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2214   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2215 "; }
2216
2217 =item not_yet_billed_sql
2218
2219 Returns an SQL expression identifying packages which have not yet been billed.
2220
2221 =cut
2222
2223 sub not_yet_billed_sql { "
2224       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2225   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2226   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2227 "; }
2228
2229 =item inactive_sql
2230
2231 Returns an SQL expression identifying inactive packages (one-time packages
2232 that are otherwise unsuspended/uncancelled).
2233
2234 =cut
2235
2236 sub inactive_sql { "
2237   ". $_[0]->onetime_sql(). "
2238   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2239   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2240   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2241 "; }
2242
2243 =item susp_sql
2244 =item suspended_sql
2245
2246 Returns an SQL expression identifying suspended packages.
2247
2248 =cut
2249
2250 sub suspended_sql { susp_sql(@_); }
2251 sub susp_sql {
2252   #$_[0]->recurring_sql(). ' AND '.
2253   "
2254         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2255     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2256   ";
2257 }
2258
2259 =item cancel_sql
2260 =item cancelled_sql
2261
2262 Returns an SQL exprression identifying cancelled packages.
2263
2264 =cut
2265
2266 sub cancelled_sql { cancel_sql(@_); }
2267 sub cancel_sql {
2268   #$_[0]->recurring_sql(). ' AND '.
2269   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2270 }
2271
2272 =item search_sql HASHREF
2273
2274 (Class method)
2275
2276 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2277 Valid parameters are
2278
2279 =over 4
2280
2281 =item agentnum
2282
2283 =item magic
2284
2285 active, inactive, suspended, cancel (or cancelled)
2286
2287 =item status
2288
2289 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2290
2291 =item custom
2292
2293  boolean selects custom packages
2294
2295 =item classnum
2296
2297 =item pkgpart
2298
2299 pkgpart or arrayref or hashref of pkgparts
2300
2301 =item setup
2302
2303 arrayref of beginning and ending epoch date
2304
2305 =item last_bill
2306
2307 arrayref of beginning and ending epoch date
2308
2309 =item bill
2310
2311 arrayref of beginning and ending epoch date
2312
2313 =item adjourn
2314
2315 arrayref of beginning and ending epoch date
2316
2317 =item susp
2318
2319 arrayref of beginning and ending epoch date
2320
2321 =item expire
2322
2323 arrayref of beginning and ending epoch date
2324
2325 =item cancel
2326
2327 arrayref of beginning and ending epoch date
2328
2329 =item query
2330
2331 pkgnum or APKG_pkgnum
2332
2333 =item cust_fields
2334
2335 a value suited to passing to FS::UI::Web::cust_header
2336
2337 =item CurrentUser
2338
2339 specifies the user for agent virtualization
2340
2341 =back
2342
2343 =cut
2344
2345 sub search_sql {
2346   my ($class, $params) = @_;
2347   my @where = ();
2348
2349   ##
2350   # parse agent
2351   ##
2352
2353   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2354     push @where,
2355       "cust_main.agentnum = $1";
2356   }
2357
2358   ##
2359   # parse status
2360   ##
2361
2362   if (    $params->{'magic'}  eq 'active'
2363        || $params->{'status'} eq 'active' ) {
2364
2365     push @where, FS::cust_pkg->active_sql();
2366
2367   } elsif (    $params->{'magic'}  eq 'not yet billed'
2368             || $params->{'status'} eq 'not yet billed' ) {
2369
2370     push @where, FS::cust_pkg->not_yet_billed_sql();
2371
2372   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2373             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2374
2375     push @where, FS::cust_pkg->inactive_sql();
2376
2377   } elsif (    $params->{'magic'}  eq 'suspended'
2378             || $params->{'status'} eq 'suspended'  ) {
2379
2380     push @where, FS::cust_pkg->suspended_sql();
2381
2382   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2383             || $params->{'status'} =~ /^cancell?ed$/ ) {
2384
2385     push @where, FS::cust_pkg->cancelled_sql();
2386
2387   }
2388
2389   ###
2390   # parse package class
2391   ###
2392
2393   #false lazinessish w/graph/cust_bill_pkg.cgi
2394   my $classnum = 0;
2395   my @pkg_class = ();
2396   if ( exists($params->{'classnum'})
2397        && $params->{'classnum'} =~ /^(\d*)$/
2398      )
2399   {
2400     $classnum = $1;
2401     if ( $classnum ) { #a specific class
2402       push @where, "classnum = $classnum";
2403
2404       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2405       #die "classnum $classnum not found!" unless $pkg_class[0];
2406       #$title .= $pkg_class[0]->classname.' ';
2407
2408     } elsif ( $classnum eq '' ) { #the empty class
2409
2410       push @where, "classnum IS NULL";
2411       #$title .= 'Empty class ';
2412       #@pkg_class = ( '(empty class)' );
2413     } elsif ( $classnum eq '0' ) {
2414       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2415       #push @pkg_class, '(empty class)';
2416     } else {
2417       die "illegal classnum";
2418     }
2419   }
2420   #eslaf
2421
2422   ###
2423   # parse package report options
2424   ###
2425
2426   my @report_option = ();
2427   if ( exists($params->{'report_option'})
2428        && $params->{'report_option'} =~ /^([,\d]*)$/
2429      )
2430   {
2431     @report_option = split(',', $1);
2432   }
2433
2434   if (@report_option) {
2435     # this will result in the empty set for the dangling comma case as it should
2436     push @where,
2437       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2438                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2439                     AND optionname = 'report_option_$_'
2440                     AND optionvalue = '1' )"
2441          } @report_option;
2442   }
2443
2444   #eslaf
2445
2446   ###
2447   # parse custom
2448   ###
2449
2450   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2451
2452   ###
2453   # parse censustract
2454   ###
2455
2456   if ( exists($params->{'censustract'}) ) {
2457     $params->{'censustract'} =~ /^([.\d]*)$/;
2458     my $censustract = "cust_main.censustract = '$1'";
2459     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2460     push @where,  "( $censustract )";
2461   }
2462
2463   ###
2464   # parse part_pkg
2465   ###
2466
2467   if ( ref($params->{'pkgpart'}) ) {
2468
2469     my @pkgpart = ();
2470     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2471       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2472     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2473       @pkgpart = @{ $params->{'pkgpart'} };
2474     } else {
2475       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2476     }
2477
2478     @pkgpart = grep /^(\d+)$/, @pkgpart;
2479
2480     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2481
2482   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2483     push @where, "pkgpart = $1";
2484   }
2485
2486   ###
2487   # parse dates
2488   ###
2489
2490   my $orderby = '';
2491
2492   #false laziness w/report_cust_pkg.html
2493   my %disable = (
2494     'all'             => {},
2495     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2496     'active'          => { 'susp'=>1, 'cancel'=>1 },
2497     'suspended'       => { 'cancel' => 1 },
2498     'cancelled'       => {},
2499     ''                => {},
2500   );
2501
2502   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2503
2504     next unless exists($params->{$field});
2505
2506     my($beginning, $ending) = @{$params->{$field}};
2507
2508     next if $beginning == 0 && $ending == 4294967295;
2509
2510     push @where,
2511       "cust_pkg.$field IS NOT NULL",
2512       "cust_pkg.$field >= $beginning",
2513       "cust_pkg.$field <= $ending";
2514
2515     $orderby ||= "ORDER BY cust_pkg.$field";
2516
2517   }
2518
2519   $orderby ||= 'ORDER BY bill';
2520
2521   ###
2522   # parse magic, legacy, etc.
2523   ###
2524
2525   if ( $params->{'magic'} &&
2526        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2527   ) {
2528
2529     $orderby = 'ORDER BY pkgnum';
2530
2531     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2532       push @where, "pkgpart = $1";
2533     }
2534
2535   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2536
2537     $orderby = 'ORDER BY pkgnum';
2538
2539   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2540
2541     $orderby = 'ORDER BY pkgnum';
2542
2543     push @where, '0 < (
2544       SELECT count(*) FROM pkg_svc
2545        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2546          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2547                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2548                                      AND cust_svc.svcpart = pkg_svc.svcpart
2549                                 )
2550     )';
2551
2552   }
2553
2554   ##
2555   # setup queries, links, subs, etc. for the search
2556   ##
2557
2558   # here is the agent virtualization
2559   if ($params->{CurrentUser}) {
2560     my $access_user =
2561       qsearchs('access_user', { username => $params->{CurrentUser} });
2562
2563     if ($access_user) {
2564       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2565     }else{
2566       push @where, "1=0";
2567     }
2568   }else{
2569     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2570   }
2571
2572   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2573
2574   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2575                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2576                   'LEFT JOIN pkg_class USING ( classnum ) ';
2577
2578   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2579
2580   my $sql_query = {
2581     'table'       => 'cust_pkg',
2582     'hashref'     => {},
2583     'select'      => join(', ',
2584                                 'cust_pkg.*',
2585                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2586                                 'pkg_class.classname',
2587                                 'cust_main.custnum as cust_main_custnum',
2588                                 FS::UI::Web::cust_sql_fields(
2589                                   $params->{'cust_fields'}
2590                                 ),
2591                      ),
2592     'extra_sql'   => "$extra_sql $orderby",
2593     'addl_from'   => $addl_from,
2594     'count_query' => $count_query,
2595   };
2596
2597 }
2598
2599 =item location_sql
2600
2601 Returns a list: the first item is an SQL fragment identifying matching
2602 packages/customers via location (taking into account shipping and package
2603 address taxation, if enabled), and subsequent items are the parameters to
2604 substitute for the placeholders in that fragment.
2605
2606 =cut
2607
2608 sub location_sql {
2609   my($class, %opt) = @_;
2610   my $ornull = $opt{'ornull'};
2611
2612   my $conf = new FS::Conf;
2613
2614   # '?' placeholders in _location_sql_where
2615   my @bill_param;
2616   if ( $ornull ) {
2617     @bill_param = qw( county county state state state country );
2618   } else {
2619     @bill_param = qw( county state state country );
2620   }
2621   unshift @bill_param, 'county'; # unless $nec;
2622
2623   my $main_where;
2624   my @main_param;
2625   if ( $conf->exists('tax-ship_address') ) {
2626
2627     $main_where = "(
2628          (     ( ship_last IS NULL     OR  ship_last  = '' )
2629            AND ". _location_sql_where('cust_main', '', $ornull ). "
2630          )
2631       OR (       ship_last IS NOT NULL AND ship_last != ''
2632            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2633          )
2634     )";
2635     #    AND payby != 'COMP'
2636
2637     @main_param = ( @bill_param, @bill_param );
2638
2639   } else {
2640
2641     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2642     @main_param = @bill_param;
2643
2644   }
2645
2646   my $where;
2647   my @param;
2648   if ( $conf->exists('tax-pkg_address') ) {
2649
2650     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2651
2652     $where = " (
2653                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2654                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2655                )
2656              ";
2657     @param = ( @main_param, @bill_param );
2658
2659   } else {
2660
2661     $where = $main_where;
2662     @param = @main_param;
2663
2664   }
2665
2666   ( $where, @param );
2667
2668 }
2669
2670 #subroutine, helper for location_sql
2671 sub _location_sql_where {
2672   my $table  = shift;
2673   my $prefix = @_ ? shift : '';
2674   my $ornull = @_ ? shift : '';
2675
2676 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2677
2678   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2679
2680   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2681   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2682
2683   "
2684         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2685     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2686     AND   $table.${prefix}country = ?
2687   ";
2688 }
2689
2690 =head1 SUBROUTINES
2691
2692 =over 4
2693
2694 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2695
2696 CUSTNUM is a customer (see L<FS::cust_main>)
2697
2698 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2699 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2700 permitted.
2701
2702 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2703 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2704 new billing items.  An error is returned if this is not possible (see
2705 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2706 parameter.
2707
2708 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2709 newly-created cust_pkg objects.
2710
2711 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2712 and inserted.  Multiple FS::pkg_referral records can be created by
2713 setting I<refnum> to an array reference of refnums or a hash reference with
2714 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2715 record will be created corresponding to cust_main.refnum.
2716
2717 =cut
2718
2719 sub order {
2720   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2721
2722   my $conf = new FS::Conf;
2723
2724   # Transactionize this whole mess
2725   local $SIG{HUP} = 'IGNORE';
2726   local $SIG{INT} = 'IGNORE';
2727   local $SIG{QUIT} = 'IGNORE';
2728   local $SIG{TERM} = 'IGNORE';
2729   local $SIG{TSTP} = 'IGNORE';
2730   local $SIG{PIPE} = 'IGNORE';
2731
2732   my $oldAutoCommit = $FS::UID::AutoCommit;
2733   local $FS::UID::AutoCommit = 0;
2734   my $dbh = dbh;
2735
2736   my $error;
2737 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2738 #  return "Customer not found: $custnum" unless $cust_main;
2739
2740   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2741                          @$remove_pkgnum;
2742
2743   my $change = scalar(@old_cust_pkg) != 0;
2744
2745   my %hash = ();
2746   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2747
2748     my $err_or_cust_pkg =
2749       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2750                                 'refnum'  => $refnum,
2751                               );
2752
2753     unless (ref($err_or_cust_pkg)) {
2754       $dbh->rollback if $oldAutoCommit;
2755       return $err_or_cust_pkg;
2756     }
2757
2758     push @$return_cust_pkg, $err_or_cust_pkg;
2759     return '';
2760
2761   }
2762
2763   # Create the new packages.
2764   foreach my $pkgpart (@$pkgparts) {
2765     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2766                                       pkgpart => $pkgpart,
2767                                       refnum  => $refnum,
2768                                       %hash,
2769                                     };
2770     $error = $cust_pkg->insert( 'change' => $change );
2771     if ($error) {
2772       $dbh->rollback if $oldAutoCommit;
2773       return $error;
2774     }
2775     push @$return_cust_pkg, $cust_pkg;
2776   }
2777   # $return_cust_pkg now contains refs to all of the newly
2778   # created packages.
2779
2780   # Transfer services and cancel old packages.
2781   foreach my $old_pkg (@old_cust_pkg) {
2782
2783     foreach my $new_pkg (@$return_cust_pkg) {
2784       $error = $old_pkg->transfer($new_pkg);
2785       if ($error and $error == 0) {
2786         # $old_pkg->transfer failed.
2787         $dbh->rollback if $oldAutoCommit;
2788         return $error;
2789       }
2790     }
2791
2792     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2793       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2794       foreach my $new_pkg (@$return_cust_pkg) {
2795         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2796         if ($error and $error == 0) {
2797           # $old_pkg->transfer failed.
2798         $dbh->rollback if $oldAutoCommit;
2799         return $error;
2800         }
2801       }
2802     }
2803
2804     if ($error > 0) {
2805       # Transfers were successful, but we went through all of the
2806       # new packages and still had services left on the old package.
2807       # We can't cancel the package under the circumstances, so abort.
2808       $dbh->rollback if $oldAutoCommit;
2809       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2810     }
2811     $error = $old_pkg->cancel( quiet=>1 );
2812     if ($error) {
2813       $dbh->rollback;
2814       return $error;
2815     }
2816   }
2817   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2818   '';
2819 }
2820
2821 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2822
2823 A bulk change method to change packages for multiple customers.
2824
2825 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2826 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2827 permitted.
2828
2829 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2830 replace.  The services (see L<FS::cust_svc>) are moved to the
2831 new billing items.  An error is returned if this is not possible (see
2832 L<FS::pkg_svc>).
2833
2834 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2835 newly-created cust_pkg objects.
2836
2837 =cut
2838
2839 sub bulk_change {
2840   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2841
2842   # Transactionize this whole mess
2843   local $SIG{HUP} = 'IGNORE';
2844   local $SIG{INT} = 'IGNORE';
2845   local $SIG{QUIT} = 'IGNORE';
2846   local $SIG{TERM} = 'IGNORE';
2847   local $SIG{TSTP} = 'IGNORE';
2848   local $SIG{PIPE} = 'IGNORE';
2849
2850   my $oldAutoCommit = $FS::UID::AutoCommit;
2851   local $FS::UID::AutoCommit = 0;
2852   my $dbh = dbh;
2853
2854   my @errors;
2855   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2856                          @$remove_pkgnum;
2857
2858   while(scalar(@old_cust_pkg)) {
2859     my @return = ();
2860     my $custnum = $old_cust_pkg[0]->custnum;
2861     my (@remove) = map { $_->pkgnum }
2862                    grep { $_->custnum == $custnum } @old_cust_pkg;
2863     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2864
2865     my $error = order $custnum, $pkgparts, \@remove, \@return;
2866
2867     push @errors, $error
2868       if $error;
2869     push @$return_cust_pkg, @return;
2870   }
2871
2872   if (scalar(@errors)) {
2873     $dbh->rollback if $oldAutoCommit;
2874     return join(' / ', @errors);
2875   }
2876
2877   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2878   '';
2879 }
2880
2881 =item insert_reason
2882
2883 Associates this package with a (suspension or cancellation) reason (see
2884 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2885 L<FS::reason>).
2886
2887 Available options are:
2888
2889 =over 4
2890
2891 =item reason
2892
2893 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.
2894
2895 =item reason_otaker
2896
2897 the access_user (see L<FS::access_user>) providing the reason
2898
2899 =item date
2900
2901 a unix timestamp
2902
2903 =item action
2904
2905 the action (cancel, susp, adjourn, expire) associated with the reason
2906
2907 =back
2908
2909 If there is an error, returns the error, otherwise returns false.
2910
2911 =cut
2912
2913 sub insert_reason {
2914   my ($self, %options) = @_;
2915
2916   my $otaker = $options{reason_otaker} ||
2917                $FS::CurrentUser::CurrentUser->username;
2918
2919   my $reasonnum;
2920   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2921
2922     $reasonnum = $1;
2923
2924   } elsif ( ref($options{'reason'}) ) {
2925
2926     return 'Enter a new reason (or select an existing one)'
2927       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2928
2929     my $reason = new FS::reason({
2930       'reason_type' => $options{'reason'}->{'typenum'},
2931       'reason'      => $options{'reason'}->{'reason'},
2932     });
2933     my $error = $reason->insert;
2934     return $error if $error;
2935
2936     $reasonnum = $reason->reasonnum;
2937
2938   } else {
2939     return "Unparsable reason: ". $options{'reason'};
2940   }
2941
2942   my $cust_pkg_reason =
2943     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2944                               'reasonnum' => $reasonnum,
2945                               'otaker'    => $otaker,
2946                               'action'    => substr(uc($options{'action'}),0,1),
2947                               'date'      => $options{'date'}
2948                                                ? $options{'date'}
2949                                                : time,
2950                             });
2951
2952   $cust_pkg_reason->insert;
2953 }
2954
2955 =item set_usage USAGE_VALUE_HASHREF
2956
2957 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2958 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2959 upbytes, downbytes, and totalbytes are appropriate keys.
2960
2961 All svc_accts which are part of this package have their values reset.
2962
2963 =cut
2964
2965 sub set_usage {
2966   my ($self, $valueref, %opt) = @_;
2967
2968   foreach my $cust_svc ($self->cust_svc){
2969     my $svc_x = $cust_svc->svc_x;
2970     $svc_x->set_usage($valueref, %opt)
2971       if $svc_x->can("set_usage");
2972   }
2973 }
2974
2975 =item recharge USAGE_VALUE_HASHREF
2976
2977 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2978 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2979 upbytes, downbytes, and totalbytes are appropriate keys.
2980
2981 All svc_accts which are part of this package have their values incremented.
2982
2983 =cut
2984
2985 sub recharge {
2986   my ($self, $valueref) = @_;
2987
2988   foreach my $cust_svc ($self->cust_svc){
2989     my $svc_x = $cust_svc->svc_x;
2990     $svc_x->recharge($valueref)
2991       if $svc_x->can("recharge");
2992   }
2993 }
2994
2995 =back
2996
2997 =head1 BUGS
2998
2999 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3000
3001 In sub order, the @pkgparts array (passed by reference) is clobbered.
3002
3003 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3004 method to pass dates to the recur_prog expression, it should do so.
3005
3006 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3007 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3008 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3009 configuration values.  Probably need a subroutine which decides what to do
3010 based on whether or not we've fetched the user yet, rather than a hash.  See
3011 FS::UID and the TODO.
3012
3013 Now that things are transactional should the check in the insert method be
3014 moved to check ?
3015
3016 =head1 SEE ALSO
3017
3018 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3019 L<FS::pkg_svc>, schema.html from the base documentation
3020
3021 =cut
3022
3023 1;
3024