FS/FS/cust_pkg.pm

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