FS/FS/cust_pkg.pm

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