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   if ($self->pkgpart != $cust_pkg->pkgpart) {
1192     my $part_pkg = $cust_pkg->part_pkg;
1193     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1194                                                  ? ()
1195                                                  : ( 'null' => 1 )
1196                                    )
1197       if $part_pkg->can('reset_usage');
1198
1199     if ($error) {
1200       $dbh->rollback if $oldAutoCommit;
1201       return "Error setting usage values: $error";
1202     }
1203   }
1204
1205   #Good to go, cancel old package.
1206   $error = $self->cancel( quiet=>1 );
1207   if ($error) {
1208     $dbh->rollback;
1209     return $error;
1210   }
1211
1212   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1213   $cust_pkg;
1214
1215 }
1216
1217 =item last_bill
1218
1219 Returns the last bill date, or if there is no last bill date, the setup date.
1220 Useful for billing metered services.
1221
1222 =cut
1223
1224 sub last_bill {
1225   my $self = shift;
1226   return $self->setfield('last_bill', $_[0]) if @_;
1227   return $self->getfield('last_bill') if $self->getfield('last_bill');
1228   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1229                                                   'edate'  => $self->bill,  } );
1230   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1231 }
1232
1233 =item last_cust_pkg_reason ACTION
1234
1235 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1236 Returns false if there is no reason or the package is not currenly ACTION'd
1237 ACTION is one of adjourn, susp, cancel, or expire.
1238
1239 =cut
1240
1241 sub last_cust_pkg_reason {
1242   my ( $self, $action ) = ( shift, shift );
1243   my $date = $self->get($action);
1244   qsearchs( {
1245               'table' => 'cust_pkg_reason',
1246               'hashref' => { 'pkgnum' => $self->pkgnum,
1247                              'action' => substr(uc($action), 0, 1),
1248                              'date'   => $date,
1249                            },
1250               'order_by' => 'ORDER BY num DESC LIMIT 1',
1251            } );
1252 }
1253
1254 =item last_reason ACTION
1255
1256 Returns the most recent ACTION FS::reason associated with the package.
1257 Returns false if there is no reason or the package is not currenly ACTION'd
1258 ACTION is one of adjourn, susp, cancel, or expire.
1259
1260 =cut
1261
1262 sub last_reason {
1263   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1264   $cust_pkg_reason->reason
1265     if $cust_pkg_reason;
1266 }
1267
1268 =item part_pkg
1269
1270 Returns the definition for this billing item, as an FS::part_pkg object (see
1271 L<FS::part_pkg>).
1272
1273 =cut
1274
1275 sub part_pkg {
1276   my $self = shift;
1277   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1278   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1279   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1280 }
1281
1282 =item old_cust_pkg
1283
1284 Returns the cancelled package this package was changed from, if any.
1285
1286 =cut
1287
1288 sub old_cust_pkg {
1289   my $self = shift;
1290   return '' unless $self->change_pkgnum;
1291   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1292 }
1293
1294 =item calc_setup
1295
1296 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1297 item.
1298
1299 =cut
1300
1301 sub calc_setup {
1302   my $self = shift;
1303   $self->part_pkg->calc_setup($self, @_);
1304 }
1305
1306 =item calc_recur
1307
1308 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1309 item.
1310
1311 =cut
1312
1313 sub calc_recur {
1314   my $self = shift;
1315   $self->part_pkg->calc_recur($self, @_);
1316 }
1317
1318 =item calc_remain
1319
1320 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1321 billing item.
1322
1323 =cut
1324
1325 sub calc_remain {
1326   my $self = shift;
1327   $self->part_pkg->calc_remain($self, @_);
1328 }
1329
1330 =item calc_cancel
1331
1332 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1333 billing item.
1334
1335 =cut
1336
1337 sub calc_cancel {
1338   my $self = shift;
1339   $self->part_pkg->calc_cancel($self, @_);
1340 }
1341
1342 =item cust_bill_pkg
1343
1344 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1345
1346 =cut
1347
1348 sub cust_bill_pkg {
1349   my $self = shift;
1350   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1351 }
1352
1353 =item cust_pkg_detail [ DETAILTYPE ]
1354
1355 Returns any customer package details for this package (see
1356 L<FS::cust_pkg_detail>).
1357
1358 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1359
1360 =cut
1361
1362 sub cust_pkg_detail {
1363   my $self = shift;
1364   my %hash = ( 'pkgnum' => $self->pkgnum );
1365   $hash{detailtype} = shift if @_;
1366   qsearch({
1367     'table'    => 'cust_pkg_detail',
1368     'hashref'  => \%hash,
1369     'order_by' => 'ORDER BY weight, pkgdetailnum',
1370   });
1371 }
1372
1373 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1374
1375 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1376
1377 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1378
1379 If there is an error, returns the error, otherwise returns false.
1380
1381 =cut
1382
1383 sub set_cust_pkg_detail {
1384   my( $self, $detailtype, @details ) = @_;
1385
1386   local $SIG{HUP} = 'IGNORE';
1387   local $SIG{INT} = 'IGNORE';
1388   local $SIG{QUIT} = 'IGNORE';
1389   local $SIG{TERM} = 'IGNORE';
1390   local $SIG{TSTP} = 'IGNORE';
1391   local $SIG{PIPE} = 'IGNORE';
1392
1393   my $oldAutoCommit = $FS::UID::AutoCommit;
1394   local $FS::UID::AutoCommit = 0;
1395   my $dbh = dbh;
1396
1397   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1398     my $error = $current->delete;
1399     if ( $error ) {
1400       $dbh->rollback if $oldAutoCommit;
1401       return "error removing old detail: $error";
1402     }
1403   }
1404
1405   foreach my $detail ( @details ) {
1406     my $cust_pkg_detail = new FS::cust_pkg_detail {
1407       'pkgnum'     => $self->pkgnum,
1408       'detailtype' => $detailtype,
1409       'detail'     => $detail,
1410     };
1411     my $error = $cust_pkg_detail->insert;
1412     if ( $error ) {
1413       $dbh->rollback if $oldAutoCommit;
1414       return "error adding new detail: $error";
1415     }
1416
1417   }
1418
1419   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1420   '';
1421
1422 }
1423
1424 =item cust_event
1425
1426 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1427
1428 =cut
1429
1430 #false laziness w/cust_bill.pm
1431 sub cust_event {
1432   my $self = shift;
1433   qsearch({
1434     'table'     => 'cust_event',
1435     'addl_from' => 'JOIN part_event USING ( eventpart )',
1436     'hashref'   => { 'tablenum' => $self->pkgnum },
1437     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1438   });
1439 }
1440
1441 =item num_cust_event
1442
1443 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1444
1445 =cut
1446
1447 #false laziness w/cust_bill.pm
1448 sub num_cust_event {
1449   my $self = shift;
1450   my $sql =
1451     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1452     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1453   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1454   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1455   $sth->fetchrow_arrayref->[0];
1456 }
1457
1458 =item cust_svc [ SVCPART ]
1459
1460 Returns the services for this package, as FS::cust_svc objects (see
1461 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1462 services.
1463
1464 =cut
1465
1466 sub cust_svc {
1467   my $self = shift;
1468
1469   return () unless $self->num_cust_svc(@_);
1470
1471   if ( @_ ) {
1472     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1473                                   'svcpart' => shift,          } );
1474   }
1475
1476   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1477
1478   #if ( $self->{'_svcnum'} ) {
1479   #  values %{ $self->{'_svcnum'}->cache };
1480   #} else {
1481     $self->_sort_cust_svc(
1482       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1483     );
1484   #}
1485
1486 }
1487
1488 =item overlimit [ SVCPART ]
1489
1490 Returns the services for this package which have exceeded their
1491 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1492 is specified, return only the matching services.
1493
1494 =cut
1495
1496 sub overlimit {
1497   my $self = shift;
1498   return () unless $self->num_cust_svc(@_);
1499   grep { $_->overlimit } $self->cust_svc(@_);
1500 }
1501
1502 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1503
1504 Returns historical services for this package created before END TIMESTAMP and
1505 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1506 (see L<FS::h_cust_svc>).
1507
1508 =cut
1509
1510 sub h_cust_svc {
1511   my $self = shift;
1512
1513   $self->_sort_cust_svc(
1514     [ qsearch( 'h_cust_svc',
1515                { 'pkgnum' => $self->pkgnum, },
1516                FS::h_cust_svc->sql_h_search(@_),
1517              )
1518     ]
1519   );
1520 }
1521
1522 sub _sort_cust_svc {
1523   my( $self, $arrayref ) = @_;
1524
1525   map  { $_->[0] }
1526   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1527   map {
1528         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1529                                              'svcpart' => $_->svcpart     } );
1530         [ $_,
1531           $pkg_svc ? $pkg_svc->primary_svc : '',
1532           $pkg_svc ? $pkg_svc->quantity : 0,
1533         ];
1534       }
1535   @$arrayref;
1536
1537 }
1538
1539 =item num_cust_svc [ SVCPART ]
1540
1541 Returns the number of provisioned services for this package.  If a svcpart is
1542 specified, counts only the matching services.
1543
1544 =cut
1545
1546 sub num_cust_svc {
1547   my $self = shift;
1548
1549   return $self->{'_num_cust_svc'}
1550     if !scalar(@_)
1551        && exists($self->{'_num_cust_svc'})
1552        && $self->{'_num_cust_svc'} =~ /\d/;
1553
1554   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1555     if $DEBUG > 2;
1556
1557   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1558   $sql .= ' AND svcpart = ?' if @_;
1559
1560   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1561   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1562   $sth->fetchrow_arrayref->[0];
1563 }
1564
1565 =item available_part_svc
1566
1567 Returns a list of FS::part_svc objects representing services included in this
1568 package but not yet provisioned.  Each FS::part_svc object also has an extra
1569 field, I<num_avail>, which specifies the number of available services.
1570
1571 =cut
1572
1573 sub available_part_svc {
1574   my $self = shift;
1575   grep { $_->num_avail > 0 }
1576     map {
1577           my $part_svc = $_->part_svc;
1578           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1579             $_->quantity - $self->num_cust_svc($_->svcpart);
1580           $part_svc;
1581         }
1582       $self->part_pkg->pkg_svc;
1583 }
1584
1585 =item part_svc
1586
1587 Returns a list of FS::part_svc objects representing provisioned and available
1588 services included in this package.  Each FS::part_svc object also has the
1589 following extra fields:
1590
1591 =over 4
1592
1593 =item num_cust_svc  (count)
1594
1595 =item num_avail     (quantity - count)
1596
1597 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1598
1599 svcnum
1600 label -> ($cust_svc->label)[1]
1601
1602 =back
1603
1604 =cut
1605
1606 sub part_svc {
1607   my $self = shift;
1608
1609   #XXX some sort of sort order besides numeric by svcpart...
1610   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1611     my $pkg_svc = $_;
1612     my $part_svc = $pkg_svc->part_svc;
1613     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1614     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1615     $part_svc->{'Hash'}{'num_avail'}    =
1616       max( 0, $pkg_svc->quantity - $num_cust_svc );
1617     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1618       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1619     $part_svc;
1620   } $self->part_pkg->pkg_svc;
1621
1622   #extras
1623   push @part_svc, map {
1624     my $part_svc = $_;
1625     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1626     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1627     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1628     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1629       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1630     $part_svc;
1631   } $self->extra_part_svc;
1632
1633   @part_svc;
1634
1635 }
1636
1637 =item extra_part_svc
1638
1639 Returns a list of FS::part_svc objects corresponding to services in this
1640 package which are still provisioned but not (any longer) available in the
1641 package definition.
1642
1643 =cut
1644
1645 sub extra_part_svc {
1646   my $self = shift;
1647
1648   my $pkgnum  = $self->pkgnum;
1649   my $pkgpart = $self->pkgpart;
1650
1651 #  qsearch( {
1652 #    'table'     => 'part_svc',
1653 #    'hashref'   => {},
1654 #    'extra_sql' =>
1655 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1656 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1657 #                       AND pkg_svc.pkgpart = ?
1658 #                       AND quantity > 0
1659 #                 )
1660 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1661 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1662 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1663 #                       AND pkgnum = ?
1664 #                 )",
1665 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1666 #  } );
1667
1668 #seems to benchmark slightly faster...
1669   qsearch( {
1670     'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1671     'table'       => 'part_svc',
1672     'addl_from'   =>
1673       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1674                                AND pkg_svc.pkgpart   = ?
1675                                AND quantity > 0
1676                              )
1677        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1678        LEFT JOIN cust_pkg USING ( pkgnum )
1679       ',
1680     'hashref'     => {},
1681     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1682     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1683   } );
1684 }
1685
1686 =item status
1687
1688 Returns a short status string for this package, currently:
1689
1690 =over 4
1691
1692 =item not yet billed
1693
1694 =item one-time charge
1695
1696 =item active
1697
1698 =item suspended
1699
1700 =item cancelled
1701
1702 =back
1703
1704 =cut
1705
1706 sub status {
1707   my $self = shift;
1708
1709   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1710
1711   return 'cancelled' if $self->get('cancel');
1712   return 'suspended' if $self->susp;
1713   return 'not yet billed' unless $self->setup;
1714   return 'one-time charge' if $freq =~ /^(0|$)/;
1715   return 'active';
1716 }
1717
1718 =item statuses
1719
1720 Class method that returns the list of possible status strings for packages
1721 (see L<the status method|/status>).  For example:
1722
1723   @statuses = FS::cust_pkg->statuses();
1724
1725 =cut
1726
1727 tie my %statuscolor, 'Tie::IxHash',
1728   'not yet billed'  => '000000',
1729   'one-time charge' => '000000',
1730   'active'          => '00CC00',
1731   'suspended'       => 'FF9900',
1732   'cancelled'       => 'FF0000',
1733 ;
1734
1735 sub statuses {
1736   my $self = shift; #could be class...
1737   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1738   #                                    # mayble split btw one-time vs. recur
1739     keys %statuscolor;
1740 }
1741
1742 =item statuscolor
1743
1744 Returns a hex triplet color string for this package's status.
1745
1746 =cut
1747
1748 sub statuscolor {
1749   my $self = shift;
1750   $statuscolor{$self->status};
1751 }
1752
1753 =item pkg_label
1754
1755 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1756 "pkg-comment" depending on user preference).
1757
1758 =cut
1759
1760 sub pkg_label {
1761   my $self = shift;
1762   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1763   $label = $self->pkgnum. ": $label"
1764     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1765   $label;
1766 }
1767
1768 =item pkg_label_long
1769
1770 Returns a long label for this package, adding the primary service's label to
1771 pkg_label.
1772
1773 =cut
1774
1775 sub pkg_label_long {
1776   my $self = shift;
1777   my $label = $self->pkg_label;
1778   my $cust_svc = $self->primary_cust_svc;
1779   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1780   $label;
1781 }
1782
1783 =item primary_cust_svc
1784
1785 Returns a primary service (as FS::cust_svc object) if one can be identified.
1786
1787 =cut
1788
1789 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1790
1791 sub primary_cust_svc {
1792   my $self = shift;
1793
1794   my @cust_svc = $self->cust_svc;
1795
1796   return '' unless @cust_svc; #no serivces - irrelevant then
1797
1798   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1799
1800   # primary service as specified in the package definition
1801   # or exactly one service definition with quantity one
1802   my $svcpart = $self->part_pkg->svcpart;
1803   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1804   return $cust_svc[0] if scalar(@cust_svc) == 1;
1805
1806   #couldn't identify one thing..
1807   return '';
1808 }
1809
1810 =item labels
1811
1812 Returns a list of lists, calling the label method for all services
1813 (see L<FS::cust_svc>) of this billing item.
1814
1815 =cut
1816
1817 sub labels {
1818   my $self = shift;
1819   map { [ $_->label ] } $self->cust_svc;
1820 }
1821
1822 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1823
1824 Like the labels method, but returns historical information on services that
1825 were active as of END_TIMESTAMP and (optionally) not cancelled before
1826 START_TIMESTAMP.
1827
1828 Returns a list of lists, calling the label method for all (historical) services
1829 (see L<FS::h_cust_svc>) of this billing item.
1830
1831 =cut
1832
1833 sub h_labels {
1834   my $self = shift;
1835   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1836 }
1837
1838 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1839
1840 Like h_labels, except returns a simple flat list, and shortens long
1841 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1842 identical services to one line that lists the service label and the number of
1843 individual services rather than individual items.
1844
1845 =cut
1846
1847 sub h_labels_short {
1848   my $self = shift;
1849
1850   my $conf = new FS::Conf;
1851   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1852
1853   my %labels;
1854   #tie %labels, 'Tie::IxHash';
1855   push @{ $labels{$_->[0]} }, $_->[1]
1856     foreach $self->h_labels(@_);
1857   my @labels;
1858   foreach my $label ( keys %labels ) {
1859     my %seen = ();
1860     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1861     my $num = scalar(@values);
1862     if ( $num > $max_same_services ) {
1863       push @labels, "$label ($num)";
1864     } else {
1865       push @labels, map { "$label: $_" } @values;
1866     }
1867   }
1868
1869  @labels;
1870
1871 }
1872
1873 =item cust_main
1874
1875 Returns the parent customer object (see L<FS::cust_main>).
1876
1877 =cut
1878
1879 sub cust_main {
1880   my $self = shift;
1881   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1882 }
1883
1884 =item cust_location
1885
1886 Returns the location object, if any (see L<FS::cust_location>).
1887
1888 =cut
1889
1890 sub cust_location {
1891   my $self = shift;
1892   return '' unless $self->locationnum;
1893   qsearchs( 'cust_location', { 'locationnum' => $self->locationnum } );
1894 }
1895
1896 =item cust_location_or_main
1897
1898 If this package is associated with a location, returns the locaiton (see
1899 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1900
1901 =cut
1902
1903 sub cust_location_or_main {
1904   my $self = shift;
1905   $self->cust_location || $self->cust_main;
1906 }
1907
1908 =item seconds_since TIMESTAMP
1909
1910 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1911 package have been online since TIMESTAMP, according to the session monitor.
1912
1913 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1914 L<Time::Local> and L<Date::Parse> for conversion functions.
1915
1916 =cut
1917
1918 sub seconds_since {
1919   my($self, $since) = @_;
1920   my $seconds = 0;
1921
1922   foreach my $cust_svc (
1923     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
1924   ) {
1925     $seconds += $cust_svc->seconds_since($since);
1926   }
1927
1928   $seconds;
1929
1930 }
1931
1932 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1933
1934 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
1935 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
1936 (exclusive).
1937
1938 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1939 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1940 functions.
1941
1942
1943 =cut
1944
1945 sub seconds_since_sqlradacct {
1946   my($self, $start, $end) = @_;
1947
1948   my $seconds = 0;
1949
1950   foreach my $cust_svc (
1951     grep {
1952       my $part_svc = $_->part_svc;
1953       $part_svc->svcdb eq 'svc_acct'
1954         && scalar($part_svc->part_export('sqlradius'));
1955     } $self->cust_svc
1956   ) {
1957     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
1958   }
1959
1960   $seconds;
1961
1962 }
1963
1964 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1965
1966 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1967 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1968 TIMESTAMP_END
1969 (exclusive).
1970
1971 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1972 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1973 functions.
1974
1975 =cut
1976
1977 sub attribute_since_sqlradacct {
1978   my($self, $start, $end, $attrib) = @_;
1979
1980   my $sum = 0;
1981
1982   foreach my $cust_svc (
1983     grep {
1984       my $part_svc = $_->part_svc;
1985       $part_svc->svcdb eq 'svc_acct'
1986         && scalar($part_svc->part_export('sqlradius'));
1987     } $self->cust_svc
1988   ) {
1989     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1990   }
1991
1992   $sum;
1993
1994 }
1995
1996 =item quantity
1997
1998 =cut
1999
2000 sub quantity {
2001   my( $self, $value ) = @_;
2002   if ( defined($value) ) {
2003     $self->setfield('quantity', $value);
2004   }
2005   $self->getfield('quantity') || 1;
2006 }
2007
2008 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2009
2010 Transfers as many services as possible from this package to another package.
2011
2012 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2013 object.  The destination package must already exist.
2014
2015 Services are moved only if the destination allows services with the correct
2016 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2017 this option with caution!  No provision is made for export differences
2018 between the old and new service definitions.  Probably only should be used
2019 when your exports for all service definitions of a given svcdb are identical.
2020 (attempt a transfer without it first, to move all possible svcpart-matching
2021 services)
2022
2023 Any services that can't be moved remain in the original package.
2024
2025 Returns an error, if there is one; otherwise, returns the number of services
2026 that couldn't be moved.
2027
2028 =cut
2029
2030 sub transfer {
2031   my ($self, $dest_pkgnum, %opt) = @_;
2032
2033   my $remaining = 0;
2034   my $dest;
2035   my %target;
2036
2037   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2038     $dest = $dest_pkgnum;
2039     $dest_pkgnum = $dest->pkgnum;
2040   } else {
2041     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2042   }
2043
2044   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2045
2046   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2047     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2048   }
2049
2050   foreach my $cust_svc ($dest->cust_svc) {
2051     $target{$cust_svc->svcpart}--;
2052   }
2053
2054   my %svcpart2svcparts = ();
2055   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2056     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2057     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2058       next if exists $svcpart2svcparts{$svcpart};
2059       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2060       $svcpart2svcparts{$svcpart} = [
2061         map  { $_->[0] }
2062         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2063         map {
2064               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2065                                                    'svcpart' => $_          } );
2066               [ $_,
2067                 $pkg_svc ? $pkg_svc->primary_svc : '',
2068                 $pkg_svc ? $pkg_svc->quantity : 0,
2069               ];
2070             }
2071
2072         grep { $_ != $svcpart }
2073         map  { $_->svcpart }
2074         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2075       ];
2076       warn "alternates for svcpart $svcpart: ".
2077            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2078         if $DEBUG;
2079     }
2080   }
2081
2082   foreach my $cust_svc ($self->cust_svc) {
2083     if($target{$cust_svc->svcpart} > 0) {
2084       $target{$cust_svc->svcpart}--;
2085       my $new = new FS::cust_svc { $cust_svc->hash };
2086       $new->pkgnum($dest_pkgnum);
2087       my $error = $new->replace($cust_svc);
2088       return $error if $error;
2089     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2090       if ( $DEBUG ) {
2091         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2092         warn "alternates to consider: ".
2093              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2094       }
2095       my @alternate = grep {
2096                              warn "considering alternate svcpart $_: ".
2097                                   "$target{$_} available in new package\n"
2098                                if $DEBUG;
2099                              $target{$_} > 0;
2100                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2101       if ( @alternate ) {
2102         warn "alternate(s) found\n" if $DEBUG;
2103         my $change_svcpart = $alternate[0];
2104         $target{$change_svcpart}--;
2105         my $new = new FS::cust_svc { $cust_svc->hash };
2106         $new->svcpart($change_svcpart);
2107         $new->pkgnum($dest_pkgnum);
2108         my $error = $new->replace($cust_svc);
2109         return $error if $error;
2110       } else {
2111         $remaining++;
2112       }
2113     } else {
2114       $remaining++
2115     }
2116   }
2117   return $remaining;
2118 }
2119
2120 =item reexport
2121
2122 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2123 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2124
2125 =cut
2126
2127 sub reexport {
2128   my $self = shift;
2129
2130   local $SIG{HUP} = 'IGNORE';
2131   local $SIG{INT} = 'IGNORE';
2132   local $SIG{QUIT} = 'IGNORE';
2133   local $SIG{TERM} = 'IGNORE';
2134   local $SIG{TSTP} = 'IGNORE';
2135   local $SIG{PIPE} = 'IGNORE';
2136
2137   my $oldAutoCommit = $FS::UID::AutoCommit;
2138   local $FS::UID::AutoCommit = 0;
2139   my $dbh = dbh;
2140
2141   foreach my $cust_svc ( $self->cust_svc ) {
2142     #false laziness w/svc_Common::insert
2143     my $svc_x = $cust_svc->svc_x;
2144     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2145       my $error = $part_export->export_insert($svc_x);
2146       if ( $error ) {
2147         $dbh->rollback if $oldAutoCommit;
2148         return $error;
2149       }
2150     }
2151   }
2152
2153   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2154   '';
2155
2156 }
2157
2158 =back
2159
2160 =head1 CLASS METHODS
2161
2162 =over 4
2163
2164 =item recurring_sql
2165
2166 Returns an SQL expression identifying recurring packages.
2167
2168 =cut
2169
2170 sub recurring_sql { "
2171   '0' != ( select freq from part_pkg
2172              where cust_pkg.pkgpart = part_pkg.pkgpart )
2173 "; }
2174
2175 =item onetime_sql
2176
2177 Returns an SQL expression identifying one-time packages.
2178
2179 =cut
2180
2181 sub onetime_sql { "
2182   '0' = ( select freq from part_pkg
2183             where cust_pkg.pkgpart = part_pkg.pkgpart )
2184 "; }
2185
2186 =item active_sql
2187
2188 Returns an SQL expression identifying active packages.
2189
2190 =cut
2191
2192 sub active_sql { "
2193   ". $_[0]->recurring_sql(). "
2194   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2195   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2196 "; }
2197
2198 =item not_yet_billed_sql
2199
2200 Returns an SQL expression identifying packages which have not yet been billed.
2201
2202 =cut
2203
2204 sub not_yet_billed_sql { "
2205       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2206   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2207   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2208 "; }
2209
2210 =item inactive_sql
2211
2212 Returns an SQL expression identifying inactive packages (one-time packages
2213 that are otherwise unsuspended/uncancelled).
2214
2215 =cut
2216
2217 sub inactive_sql { "
2218   ". $_[0]->onetime_sql(). "
2219   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2220   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2221   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2222 "; }
2223
2224 =item susp_sql
2225 =item suspended_sql
2226
2227 Returns an SQL expression identifying suspended packages.
2228
2229 =cut
2230
2231 sub suspended_sql { susp_sql(@_); }
2232 sub susp_sql {
2233   #$_[0]->recurring_sql(). ' AND '.
2234   "
2235         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2236     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2237   ";
2238 }
2239
2240 =item cancel_sql
2241 =item cancelled_sql
2242
2243 Returns an SQL exprression identifying cancelled packages.
2244
2245 =cut
2246
2247 sub cancelled_sql { cancel_sql(@_); }
2248 sub cancel_sql {
2249   #$_[0]->recurring_sql(). ' AND '.
2250   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2251 }
2252
2253 =item search_sql HASHREF
2254
2255 (Class method)
2256
2257 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2258 Valid parameters are
2259
2260 =over 4
2261
2262 =item agentnum
2263
2264 =item magic
2265
2266 active, inactive, suspended, cancel (or cancelled)
2267
2268 =item status
2269
2270 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2271
2272 =item custom
2273
2274  boolean selects custom packages
2275
2276 =item classnum
2277
2278 =item pkgpart
2279
2280 list specified how?
2281
2282 =item setup
2283
2284 arrayref of beginning and ending epoch date
2285
2286 =item last_bill
2287
2288 arrayref of beginning and ending epoch date
2289
2290 =item bill
2291
2292 arrayref of beginning and ending epoch date
2293
2294 =item adjourn
2295
2296 arrayref of beginning and ending epoch date
2297
2298 =item susp
2299
2300 arrayref of beginning and ending epoch date
2301
2302 =item expire
2303
2304 arrayref of beginning and ending epoch date
2305
2306 =item cancel
2307
2308 arrayref of beginning and ending epoch date
2309
2310 =item query
2311
2312 pkgnum or APKG_pkgnum
2313
2314 =item cust_fields
2315
2316 a value suited to passing to FS::UI::Web::cust_header
2317
2318 =item CurrentUser
2319
2320 specifies the user for agent virtualization
2321
2322 =back
2323
2324 =cut
2325
2326 sub search_sql {
2327   my ($class, $params) = @_;
2328   my @where = ();
2329
2330   ##
2331   # parse agent
2332   ##
2333
2334   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2335     push @where,
2336       "cust_main.agentnum = $1";
2337   }
2338
2339   ##
2340   # parse status
2341   ##
2342
2343   if (    $params->{'magic'}  eq 'active'
2344        || $params->{'status'} eq 'active' ) {
2345
2346     push @where, FS::cust_pkg->active_sql();
2347
2348   } elsif (    $params->{'magic'}  eq 'not yet billed'
2349             || $params->{'status'} eq 'not yet billed' ) {
2350
2351     push @where, FS::cust_pkg->not_yet_billed_sql();
2352
2353   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2354             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2355
2356     push @where, FS::cust_pkg->inactive_sql();
2357
2358   } elsif (    $params->{'magic'}  eq 'suspended'
2359             || $params->{'status'} eq 'suspended'  ) {
2360
2361     push @where, FS::cust_pkg->suspended_sql();
2362
2363   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2364             || $params->{'status'} =~ /^cancell?ed$/ ) {
2365
2366     push @where, FS::cust_pkg->cancelled_sql();
2367
2368   }
2369
2370   ###
2371   # parse package class
2372   ###
2373
2374   #false lazinessish w/graph/cust_bill_pkg.cgi
2375   my $classnum = 0;
2376   my @pkg_class = ();
2377   if ( exists($params->{'classnum'})
2378        && $params->{'classnum'} =~ /^(\d*)$/
2379      )
2380   {
2381     $classnum = $1;
2382     if ( $classnum ) { #a specific class
2383       push @where, "classnum = $classnum";
2384
2385       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2386       #die "classnum $classnum not found!" unless $pkg_class[0];
2387       #$title .= $pkg_class[0]->classname.' ';
2388
2389     } elsif ( $classnum eq '' ) { #the empty class
2390
2391       push @where, "classnum IS NULL";
2392       #$title .= 'Empty class ';
2393       #@pkg_class = ( '(empty class)' );
2394     } elsif ( $classnum eq '0' ) {
2395       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2396       #push @pkg_class, '(empty class)';
2397     } else {
2398       die "illegal classnum";
2399     }
2400   }
2401   #eslaf
2402
2403   ###
2404   # parse package report options
2405   ###
2406
2407   my @report_option = ();
2408   if ( exists($params->{'report_option'})
2409        && $params->{'report_option'} =~ /^([,\d]*)$/
2410      )
2411   {
2412     @report_option = split(',', $1);
2413   }
2414
2415   if (@report_option) {
2416     # this will result in the empty set for the dangling comma case as it should
2417     push @where,
2418       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2419                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2420                     AND optionname = 'report_option_$_'
2421                     AND optionvalue = '1' )"
2422          } @report_option;
2423   }
2424
2425   #eslaf
2426
2427   ###
2428   # parse custom
2429   ###
2430
2431   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2432
2433   ###
2434   # parse censustract
2435   ###
2436
2437   if ( exists($params->{'censustract'}) ) {
2438     $params->{'censustract'} =~ /^([.\d]*)$/;
2439     my $censustract = "cust_main.censustract = '$1'";
2440     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2441     push @where,  "( $censustract )";
2442   }
2443
2444   ###
2445   # parse part_pkg
2446   ###
2447
2448   my $pkgpart = join (' OR pkgpart=',
2449                       grep {$_} map { /^(\d+)$/; } ($params->{'pkgpart'}));
2450   push @where,  '(pkgpart=' . $pkgpart . ')' if $pkgpart;
2451
2452   ###
2453   # parse dates
2454   ###
2455
2456   my $orderby = '';
2457
2458   #false laziness w/report_cust_pkg.html
2459   my %disable = (
2460     'all'             => {},
2461     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2462     'active'          => { 'susp'=>1, 'cancel'=>1 },
2463     'suspended'       => { 'cancel' => 1 },
2464     'cancelled'       => {},
2465     ''                => {},
2466   );
2467
2468   foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2469
2470     next unless exists($params->{$field});
2471
2472     my($beginning, $ending) = @{$params->{$field}};
2473
2474     next if $beginning == 0 && $ending == 4294967295;
2475
2476     push @where,
2477       "cust_pkg.$field IS NOT NULL",
2478       "cust_pkg.$field >= $beginning",
2479       "cust_pkg.$field <= $ending";
2480
2481     $orderby ||= "ORDER BY cust_pkg.$field";
2482
2483   }
2484
2485   $orderby ||= 'ORDER BY bill';
2486
2487   ###
2488   # parse magic, legacy, etc.
2489   ###
2490
2491   if ( $params->{'magic'} &&
2492        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2493   ) {
2494
2495     $orderby = 'ORDER BY pkgnum';
2496
2497     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2498       push @where, "pkgpart = $1";
2499     }
2500
2501   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2502
2503     $orderby = 'ORDER BY pkgnum';
2504
2505   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2506
2507     $orderby = 'ORDER BY pkgnum';
2508
2509     push @where, '0 < (
2510       SELECT count(*) FROM pkg_svc
2511        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2512          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2513                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2514                                      AND cust_svc.svcpart = pkg_svc.svcpart
2515                                 )
2516     )';
2517
2518   }
2519
2520   ##
2521   # setup queries, links, subs, etc. for the search
2522   ##
2523
2524   # here is the agent virtualization
2525   if ($params->{CurrentUser}) {
2526     my $access_user =
2527       qsearchs('access_user', { username => $params->{CurrentUser} });
2528
2529     if ($access_user) {
2530       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2531     }else{
2532       push @where, "1=0";
2533     }
2534   }else{
2535     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2536   }
2537
2538   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2539
2540   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2541                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2542                   'LEFT JOIN pkg_class USING ( classnum ) ';
2543
2544   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2545
2546   my $sql_query = {
2547     'table'       => 'cust_pkg',
2548     'hashref'     => {},
2549     'select'      => join(', ',
2550                                 'cust_pkg.*',
2551                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2552                                 'pkg_class.classname',
2553                                 'cust_main.custnum as cust_main_custnum',
2554                                 FS::UI::Web::cust_sql_fields(
2555                                   $params->{'cust_fields'}
2556                                 ),
2557                      ),
2558     'extra_sql'   => "$extra_sql $orderby",
2559     'addl_from'   => $addl_from,
2560     'count_query' => $count_query,
2561   };
2562
2563 }
2564
2565 =item location_sql
2566
2567 Returns a list: the first item is an SQL fragment identifying matching
2568 packages/customers via location (taking into account shipping and package
2569 address taxation, if enabled), and subsequent items are the parameters to
2570 substitute for the placeholders in that fragment.
2571
2572 =cut
2573
2574 sub location_sql {
2575   my($class, %opt) = @_;
2576   my $ornull = $opt{'ornull'};
2577
2578   my $conf = new FS::Conf;
2579
2580   # '?' placeholders in _location_sql_where
2581   my @bill_param;
2582   if ( $ornull ) {
2583     @bill_param = qw( county county state state state country );
2584   } else {
2585     @bill_param = qw( county state state country );
2586   }
2587   unshift @bill_param, 'county'; # unless $nec;
2588
2589   my $main_where;
2590   my @main_param;
2591   if ( $conf->exists('tax-ship_address') ) {
2592
2593     $main_where = "(
2594          (     ( ship_last IS NULL     OR  ship_last  = '' )
2595            AND ". _location_sql_where('cust_main', '', $ornull ). "
2596          )
2597       OR (       ship_last IS NOT NULL AND ship_last != ''
2598            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2599          )
2600     )";
2601     #    AND payby != 'COMP'
2602
2603     @main_param = ( @bill_param, @bill_param );
2604
2605   } else {
2606
2607     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2608     @main_param = @bill_param;
2609
2610   }
2611
2612   my $where;
2613   my @param;
2614   if ( $conf->exists('tax-pkg_address') ) {
2615
2616     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2617
2618     $where = " (
2619                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2620                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2621                )
2622              ";
2623     @param = ( @main_param, @bill_param );
2624
2625   } else {
2626
2627     $where = $main_where;
2628     @param = @main_param;
2629
2630   }
2631
2632   ( $where, @param );
2633
2634 }
2635
2636 #subroutine, helper for location_sql
2637 sub _location_sql_where {
2638   my $table  = shift;
2639   my $prefix = @_ ? shift : '';
2640   my $ornull = @_ ? shift : '';
2641
2642 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2643
2644   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2645
2646   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2647   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2648
2649   "
2650         ( $table.${prefix}county  = ? $or_empty_county $ornull )
2651     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2652     AND   $table.${prefix}country = ?
2653   ";
2654 }
2655
2656 =head1 SUBROUTINES
2657
2658 =over 4
2659
2660 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2661
2662 CUSTNUM is a customer (see L<FS::cust_main>)
2663
2664 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2665 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
2666 permitted.
2667
2668 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
2669 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
2670 new billing items.  An error is returned if this is not possible (see
2671 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
2672 parameter.
2673
2674 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2675 newly-created cust_pkg objects.
2676
2677 REFNUM, if specified, will specify the FS::pkg_referral record to be created
2678 and inserted.  Multiple FS::pkg_referral records can be created by
2679 setting I<refnum> to an array reference of refnums or a hash reference with
2680 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
2681 record will be created corresponding to cust_main.refnum.
2682
2683 =cut
2684
2685 sub order {
2686   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
2687
2688   my $conf = new FS::Conf;
2689
2690   # Transactionize this whole mess
2691   local $SIG{HUP} = 'IGNORE';
2692   local $SIG{INT} = 'IGNORE';
2693   local $SIG{QUIT} = 'IGNORE';
2694   local $SIG{TERM} = 'IGNORE';
2695   local $SIG{TSTP} = 'IGNORE';
2696   local $SIG{PIPE} = 'IGNORE';
2697
2698   my $oldAutoCommit = $FS::UID::AutoCommit;
2699   local $FS::UID::AutoCommit = 0;
2700   my $dbh = dbh;
2701
2702   my $error;
2703 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
2704 #  return "Customer not found: $custnum" unless $cust_main;
2705
2706   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2707                          @$remove_pkgnum;
2708
2709   my $change = scalar(@old_cust_pkg) != 0;
2710
2711   my %hash = ();
2712   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
2713
2714     my $err_or_cust_pkg =
2715       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
2716                                 'refnum'  => $refnum,
2717                               );
2718
2719     unless (ref($err_or_cust_pkg)) {
2720       $dbh->rollback if $oldAutoCommit;
2721       return $err_or_cust_pkg;
2722     }
2723
2724     push @$return_cust_pkg, $err_or_cust_pkg;
2725     return '';
2726
2727   }
2728
2729   # Create the new packages.
2730   foreach my $pkgpart (@$pkgparts) {
2731     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
2732                                       pkgpart => $pkgpart,
2733                                       refnum  => $refnum,
2734                                       %hash,
2735                                     };
2736     $error = $cust_pkg->insert( 'change' => $change );
2737     if ($error) {
2738       $dbh->rollback if $oldAutoCommit;
2739       return $error;
2740     }
2741     push @$return_cust_pkg, $cust_pkg;
2742   }
2743   # $return_cust_pkg now contains refs to all of the newly
2744   # created packages.
2745
2746   # Transfer services and cancel old packages.
2747   foreach my $old_pkg (@old_cust_pkg) {
2748
2749     foreach my $new_pkg (@$return_cust_pkg) {
2750       $error = $old_pkg->transfer($new_pkg);
2751       if ($error and $error == 0) {
2752         # $old_pkg->transfer failed.
2753         $dbh->rollback if $oldAutoCommit;
2754         return $error;
2755       }
2756     }
2757
2758     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
2759       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
2760       foreach my $new_pkg (@$return_cust_pkg) {
2761         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
2762         if ($error and $error == 0) {
2763           # $old_pkg->transfer failed.
2764         $dbh->rollback if $oldAutoCommit;
2765         return $error;
2766         }
2767       }
2768     }
2769
2770     if ($error > 0) {
2771       # Transfers were successful, but we went through all of the
2772       # new packages and still had services left on the old package.
2773       # We can't cancel the package under the circumstances, so abort.
2774       $dbh->rollback if $oldAutoCommit;
2775       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
2776     }
2777     $error = $old_pkg->cancel( quiet=>1 );
2778     if ($error) {
2779       $dbh->rollback;
2780       return $error;
2781     }
2782   }
2783   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2784   '';
2785 }
2786
2787 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
2788
2789 A bulk change method to change packages for multiple customers.
2790
2791 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
2792 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
2793 permitted.
2794
2795 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
2796 replace.  The services (see L<FS::cust_svc>) are moved to the
2797 new billing items.  An error is returned if this is not possible (see
2798 L<FS::pkg_svc>).
2799
2800 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
2801 newly-created cust_pkg objects.
2802
2803 =cut
2804
2805 sub bulk_change {
2806   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
2807
2808   # Transactionize this whole mess
2809   local $SIG{HUP} = 'IGNORE';
2810   local $SIG{INT} = 'IGNORE';
2811   local $SIG{QUIT} = 'IGNORE';
2812   local $SIG{TERM} = 'IGNORE';
2813   local $SIG{TSTP} = 'IGNORE';
2814   local $SIG{PIPE} = 'IGNORE';
2815
2816   my $oldAutoCommit = $FS::UID::AutoCommit;
2817   local $FS::UID::AutoCommit = 0;
2818   my $dbh = dbh;
2819
2820   my @errors;
2821   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
2822                          @$remove_pkgnum;
2823
2824   while(scalar(@old_cust_pkg)) {
2825     my @return = ();
2826     my $custnum = $old_cust_pkg[0]->custnum;
2827     my (@remove) = map { $_->pkgnum }
2828                    grep { $_->custnum == $custnum } @old_cust_pkg;
2829     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
2830
2831     my $error = order $custnum, $pkgparts, \@remove, \@return;
2832
2833     push @errors, $error
2834       if $error;
2835     push @$return_cust_pkg, @return;
2836   }
2837
2838   if (scalar(@errors)) {
2839     $dbh->rollback if $oldAutoCommit;
2840     return join(' / ', @errors);
2841   }
2842
2843   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2844   '';
2845 }
2846
2847 =item insert_reason
2848
2849 Associates this package with a (suspension or cancellation) reason (see
2850 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2851 L<FS::reason>).
2852
2853 Available options are:
2854
2855 =over 4
2856
2857 =item reason
2858
2859 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.
2860
2861 =item reason_otaker
2862
2863 the access_user (see L<FS::access_user>) providing the reason
2864
2865 =item date
2866
2867 a unix timestamp
2868
2869 =item action
2870
2871 the action (cancel, susp, adjourn, expire) associated with the reason
2872
2873 =back
2874
2875 If there is an error, returns the error, otherwise returns false.
2876
2877 =cut
2878
2879 sub insert_reason {
2880   my ($self, %options) = @_;
2881
2882   my $otaker = $options{reason_otaker} ||
2883                $FS::CurrentUser::CurrentUser->username;
2884
2885   my $reasonnum;
2886   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2887
2888     $reasonnum = $1;
2889
2890   } elsif ( ref($options{'reason'}) ) {
2891
2892     return 'Enter a new reason (or select an existing one)'
2893       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2894
2895     my $reason = new FS::reason({
2896       'reason_type' => $options{'reason'}->{'typenum'},
2897       'reason'      => $options{'reason'}->{'reason'},
2898     });
2899     my $error = $reason->insert;
2900     return $error if $error;
2901
2902     $reasonnum = $reason->reasonnum;
2903
2904   } else {
2905     return "Unparsable reason: ". $options{'reason'};
2906   }
2907
2908   my $cust_pkg_reason =
2909     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2910                               'reasonnum' => $reasonnum,
2911                               'otaker'    => $otaker,
2912                               'action'    => substr(uc($options{'action'}),0,1),
2913                               'date'      => $options{'date'}
2914                                                ? $options{'date'}
2915                                                : time,
2916                             });
2917
2918   $cust_pkg_reason->insert;
2919 }
2920
2921 =item set_usage USAGE_VALUE_HASHREF
2922
2923 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2924 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2925 upbytes, downbytes, and totalbytes are appropriate keys.
2926
2927 All svc_accts which are part of this package have their values reset.
2928
2929 =cut
2930
2931 sub set_usage {
2932   my ($self, $valueref, %opt) = @_;
2933
2934   foreach my $cust_svc ($self->cust_svc){
2935     my $svc_x = $cust_svc->svc_x;
2936     $svc_x->set_usage($valueref, %opt)
2937       if $svc_x->can("set_usage");
2938   }
2939 }
2940
2941 =item recharge USAGE_VALUE_HASHREF
2942
2943 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2944 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2945 upbytes, downbytes, and totalbytes are appropriate keys.
2946
2947 All svc_accts which are part of this package have their values incremented.
2948
2949 =cut
2950
2951 sub recharge {
2952   my ($self, $valueref) = @_;
2953
2954   foreach my $cust_svc ($self->cust_svc){
2955     my $svc_x = $cust_svc->svc_x;
2956     $svc_x->recharge($valueref)
2957       if $svc_x->can("recharge");
2958   }
2959 }
2960
2961 =back
2962
2963 =head1 BUGS
2964
2965 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
2966
2967 In sub order, the @pkgparts array (passed by reference) is clobbered.
2968
2969 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
2970 method to pass dates to the recur_prog expression, it should do so.
2971
2972 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
2973 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
2974 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
2975 configuration values.  Probably need a subroutine which decides what to do
2976 based on whether or not we've fetched the user yet, rather than a hash.  See
2977 FS::UID and the TODO.
2978
2979 Now that things are transactional should the check in the insert method be
2980 moved to check ?
2981
2982 =head1 SEE ALSO
2983
2984 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
2985 L<FS::pkg_svc>, schema.html from the base documentation
2986
2987 =cut
2988
2989 1;
2990