FS/FS/cust_pkg.pm

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