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