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