FS/FS/cust_pkg.pm

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