FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::Sales_Mixin
   3              FS::contact_Mixin FS::location_Mixin
   4              FS::m2m_Common FS::option_Common );
   5
   6 use strict;
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(min max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( dbh driver_name );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs fields );
  16 use FS::CurrentUser;
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::contact;
  21 use FS::cust_location;
  22 use FS::pkg_svc;
  23 use FS::cust_bill_pkg;
  24 use FS::cust_pkg_detail;
  25 use FS::cust_pkg_usage;
  26 use FS::cdr_cust_pkg_usage;
  27 use FS::cust_event;
  28 use FS::h_cust_svc;
  29 use FS::reg_code;
  30 use FS::part_svc;
  31 use FS::cust_pkg_reason;
  32 use FS::reason;
  33 use FS::cust_pkg_discount;
  34 use FS::discount;
  35 use FS::UI::Web;
  36 use FS::sales;
  37 # for modify_charge
  38 use FS::cust_credit;
  39
  40 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  41 # setup }
  42 # because they load configuration by setting FS::UID::callback (see TODO)
  43 use FS::svc_acct;
  44 use FS::svc_domain;
  45 use FS::svc_www;
  46 use FS::svc_forward;
  47
  48 # for sending cancel emails in sub cancel
  49 use FS::Conf;
  50
  51 our ($disable_agentcheck, $DEBUG, $me) = (0, 0, '[FS::cust_pkg]');
  52
  53 sub _cache {
  54   my $self = shift;
  55   my ( $hashref, $cache ) = @_;
  56   #if ( $hashref->{'pkgpart'} ) {
  57   if ( $hashref->{'pkg'} ) {
  58     # #@{ $self->{'_pkgnum'} } = ();
  59     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  60     # $self->{'_pkgpart'} = $subcache;
  61     # #push @{ $self->{'_pkgnum'} },
  62     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  63     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  64   }
  65   if ( exists $hashref->{'svcnum'} ) {
  66     #@{ $self->{'_pkgnum'} } = ();
  67     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  68     $self->{'_svcnum'} = $subcache;
  69     #push @{ $self->{'_pkgnum'} },
  70     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  71   }
  72 }
  73
  74 =head1 NAME
  75
  76 FS::cust_pkg - Object methods for cust_pkg objects
  77
  78 =head1 SYNOPSIS
  79
  80   use FS::cust_pkg;
  81
  82   $record = new FS::cust_pkg \%hash;
  83   $record = new FS::cust_pkg { 'column' => 'value' };
  84
  85   $error = $record->insert;
  86
  87   $error = $new_record->replace($old_record);
  88
  89   $error = $record->delete;
  90
  91   $error = $record->check;
  92
  93   $error = $record->cancel;
  94
  95   $error = $record->suspend;
  96
  97   $error = $record->unsuspend;
  98
  99   $part_pkg = $record->part_pkg;
 100
 101   @labels = $record->labels;
 102
 103   $seconds = $record->seconds_since($timestamp);
 104
 105   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 106   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 107
 108 =head1 DESCRIPTION
 109
 110 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 111 inherits from FS::Record.  The following fields are currently supported:
 112
 113 =over 4
 114
 115 =item pkgnum
 116
 117 Primary key (assigned automatically for new billing items)
 118
 119 =item custnum
 120
 121 Customer (see L<FS::cust_main>)
 122
 123 =item pkgpart
 124
 125 Billing item definition (see L<FS::part_pkg>)
 126
 127 =item locationnum
 128
 129 Optional link to package location (see L<FS::location>)
 130
 131 =item order_date
 132
 133 date package was ordered (also remains same on changes)
 134
 135 =item start_date
 136
 137 date
 138
 139 =item setup
 140
 141 date
 142
 143 =item bill
 144
 145 date (next bill date)
 146
 147 =item last_bill
 148
 149 last bill date
 150
 151 =item adjourn
 152
 153 date
 154
 155 =item susp
 156
 157 date
 158
 159 =item expire
 160
 161 date
 162
 163 =item contract_end
 164
 165 date
 166
 167 =item cancel
 168
 169 date
 170
 171 =item usernum
 172
 173 order taker (see L<FS::access_user>)
 174
 175 =item manual_flag
 176
 177 If this field is set to 1, disables the automatic
 178 unsuspension of this package when using the B<unsuspendauto> config option.
 179
 180 =item quantity
 181
 182 If not set, defaults to 1
 183
 184 =item change_date
 185
 186 Date of change from previous package
 187
 188 =item change_pkgnum
 189
 190 Previous pkgnum
 191
 192 =item change_pkgpart
 193
 194 Previous pkgpart
 195
 196 =item change_locationnum
 197
 198 Previous locationnum
 199
 200 =item waive_setup
 201
 202 =item main_pkgnum
 203
 204 The pkgnum of the package that this package is supplemental to, if any.
 205
 206 =item pkglinknum
 207
 208 The package link (L<FS::part_pkg_link>) that defines this supplemental
 209 package, if it is one.
 210
 211 =item change_to_pkgnum
 212
 213 The pkgnum of the package this one will be "changed to" in the future
 214 (on its expiration date).
 215
 216 =back
 217
 218 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 219 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 220 L<Time::Local> and L<Date::Parse> for conversion functions.
 221
 222 =head1 METHODS
 223
 224 =over 4
 225
 226 =item new HASHREF
 227
 228 Create a new billing item.  To add the item to the database, see L<"insert">.
 229
 230 =cut
 231
 232 sub table { 'cust_pkg'; }
 233 sub cust_linked { $_[0]->cust_main_custnum || $_[0]->custnum }
 234 sub cust_unlinked_msg {
 235   my $self = shift;
 236   "WARNING: can't find cust_main.custnum ". $self->custnum.
 237   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 238 }
 239
 240 =item insert [ OPTION => VALUE ... ]
 241
 242 Adds this billing item to the database ("Orders" the item).  If there is an
 243 error, returns the error, otherwise returns false.
 244
 245 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 246 will be used to look up the package definition and agent restrictions will be
 247 ignored.
 248
 249 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 250 be created and inserted.  Multiple FS::pkg_referral records can be created by
 251 setting I<refnum> to an array reference of refnums or a hash reference with
 252 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 253 record will be created corresponding to cust_main.refnum.
 254
 255 The following options are available:
 256
 257 =over 4
 258
 259 =item change
 260
 261 If set true, supresses actions that should only be taken for new package
 262 orders.  (Currently this includes: intro periods when delay_setup is on.)
 263
 264 =item options
 265
 266 cust_pkg_option records will be created
 267
 268 =item ticket_subject
 269
 270 a ticket will be added to this customer with this subject
 271
 272 =item ticket_queue
 273
 274 an optional queue name for ticket additions
 275
 276 =item allow_pkgpart
 277
 278 Don't check the legality of the package definition.  This should be used
 279 when performing a package change that doesn't change the pkgpart (i.e.
 280 a location change).
 281
 282 =back
 283
 284 =cut
 285
 286 sub insert {
 287   my( $self, %options ) = @_;
 288
 289   my $error;
 290   $error = $self->check_pkgpart unless $options{'allow_pkgpart'};
 291   return $error if $error;
 292
 293   my $part_pkg = $self->part_pkg;
 294
 295   if (! $options{'import'}) {
 296     # if the package def says to start only on the first of the month:
 297     if ( $part_pkg->option('start_1st', 1) && !$self->start_date ) {
 298       my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 299       $mon += 1 unless $mday == 1;
 300       until ( $mon < 12 ) { $mon -= 12; $year++; }
 301       $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 302     }
 303
 304     # set up any automatic expire/adjourn/contract_end timers
 305     # based on the start date
 306     foreach my $action ( qw(expire adjourn contract_end) ) {
 307       my $months = $part_pkg->option("${action}_months",1);
 308       if($months and !$self->$action) {
 309         my $start = $self->start_date || $self->setup || time;
 310         $self->$action( $part_pkg->add_freq($start, $months) );
 311       }
 312     }
 313
 314     # if this package has "free days" and delayed setup fee, tehn
 315     # set start date that many days in the future.
 316     # (this should have been set in the UI, but enforce it here)
 317     if (    ! $options{'change'}
 318          && ( my $free_days = $part_pkg->option('free_days',1) )
 319          && $part_pkg->option('delay_setup',1)
 320          #&& ! $self->start_date
 321        )
 322     {
 323       $self->start_date( $part_pkg->default_start_date );
 324     }
 325   }
 326
 327   # set order date unless it was specified as part of an import
 328   $self->order_date(time) unless $options{'import'} && $self->order_date;
 329
 330   local $SIG{HUP} = 'IGNORE';
 331   local $SIG{INT} = 'IGNORE';
 332   local $SIG{QUIT} = 'IGNORE';
 333   local $SIG{TERM} = 'IGNORE';
 334   local $SIG{TSTP} = 'IGNORE';
 335   local $SIG{PIPE} = 'IGNORE';
 336
 337   my $oldAutoCommit = $FS::UID::AutoCommit;
 338   local $FS::UID::AutoCommit = 0;
 339   my $dbh = dbh;
 340
 341   $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 342   if ( $error ) {
 343     $dbh->rollback if $oldAutoCommit;
 344     return $error;
 345   }
 346
 347   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 348   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 349   $self->process_m2m( 'link_table'   => 'pkg_referral',
 350                       'target_table' => 'part_referral',
 351                       'params'       => $self->refnum,
 352                     );
 353
 354   if ( $self->discountnum ) {
 355     my $error = $self->insert_discount();
 356     if ( $error ) {
 357       $dbh->rollback if $oldAutoCommit;
 358       return $error;
 359     }
 360   }
 361
 362   my $conf = new FS::Conf;
 363
 364   if ( ! $options{'import'} && $conf->config('ticket_system') && $options{ticket_subject} ) {
 365
 366     #this init stuff is still inefficient, but at least its limited to
 367     # the small number (any?) folks using ticket emailing on pkg order
 368
 369     #eval '
 370     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 371     #  use RT;
 372     #';
 373     #die $@ if $@;
 374     #
 375     #RT::LoadConfig();
 376     #RT::Init();
 377     use FS::TicketSystem;
 378     FS::TicketSystem->init();
 379
 380     my $q = new RT::Queue($RT::SystemUser);
 381     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 382     my $t = new RT::Ticket($RT::SystemUser);
 383     my $mime = new MIME::Entity;
 384     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 385     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 386                 Subject => $options{ticket_subject},
 387                 MIMEObj => $mime,
 388               );
 389     $t->AddLink( Type   => 'MemberOf',
 390                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 391                );
 392   }
 393
 394   if (! $options{'import'} && $conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 395     my $queue = new FS::queue {
 396       'job'     => 'FS::cust_main::queueable_print',
 397     };
 398     $error = $queue->insert(
 399       'custnum'  => $self->custnum,
 400       'template' => 'welcome_letter',
 401     );
 402
 403     if ($error) {
 404       warn "can't send welcome letter: $error";
 405     }
 406
 407   }
 408
 409   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 410   '';
 411
 412 }
 413
 414 =item delete
 415
 416 This method now works but you probably shouldn't use it.
 417
 418 You don't want to delete packages, because there would then be no record
 419 the customer ever purchased the package.  Instead, see the cancel method and
 420 hide cancelled packages.
 421
 422 =cut
 423
 424 sub delete {
 425   my $self = shift;
 426
 427   local $SIG{HUP} = 'IGNORE';
 428   local $SIG{INT} = 'IGNORE';
 429   local $SIG{QUIT} = 'IGNORE';
 430   local $SIG{TERM} = 'IGNORE';
 431   local $SIG{TSTP} = 'IGNORE';
 432   local $SIG{PIPE} = 'IGNORE';
 433
 434   my $oldAutoCommit = $FS::UID::AutoCommit;
 435   local $FS::UID::AutoCommit = 0;
 436   my $dbh = dbh;
 437
 438   foreach my $cust_pkg_discount ($self->cust_pkg_discount) {
 439     my $error = $cust_pkg_discount->delete;
 440     if ( $error ) {
 441       $dbh->rollback if $oldAutoCommit;
 442       return $error;
 443     }
 444   }
 445   #cust_bill_pkg_discount?
 446
 447   foreach my $cust_pkg_detail ($self->cust_pkg_detail) {
 448     my $error = $cust_pkg_detail->delete;
 449     if ( $error ) {
 450       $dbh->rollback if $oldAutoCommit;
 451       return $error;
 452     }
 453   }
 454
 455   foreach my $cust_pkg_reason (
 456     qsearchs( {
 457                 'table' => 'cust_pkg_reason',
 458                 'hashref' => { 'pkgnum' => $self->pkgnum },
 459               }
 460             )
 461   ) {
 462     my $error = $cust_pkg_reason->delete;
 463     if ( $error ) {
 464       $dbh->rollback if $oldAutoCommit;
 465       return $error;
 466     }
 467   }
 468
 469   #pkg_referral?
 470
 471   my $error = $self->SUPER::delete(@_);
 472   if ( $error ) {
 473     $dbh->rollback if $oldAutoCommit;
 474     return $error;
 475   }
 476
 477   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 478
 479   '';
 480
 481 }
 482
 483 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 484
 485 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 486 returns the error, otherwise returns false.
 487
 488 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 489
 490 Changing pkgpart may have disasterous effects.  See the order subroutine.
 491
 492 setup and bill are normally updated by calling the bill method of a customer
 493 object (see L<FS::cust_main>).
 494
 495 suspend is normally updated by the suspend and unsuspend methods.
 496
 497 cancel is normally updated by the cancel method (and also the order subroutine
 498 in some cases).
 499
 500 Available options are:
 501
 502 =over 4
 503
 504 =item reason
 505
 506 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.
 507
 508 =item reason_otaker
 509
 510 the access_user (see L<FS::access_user>) providing the reason
 511
 512 =item options
 513
 514 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 515
 516 =back
 517
 518 =cut
 519
 520 sub replace {
 521   my $new = shift;
 522
 523   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 524               ? shift
 525               : $new->replace_old;
 526
 527   my $options =
 528     ( ref($_[0]) eq 'HASH' )
 529       ? shift
 530       : { @_ };
 531
 532   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 533   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 534
 535   #allow this *sigh*
 536   #return "Can't change setup once it exists!"
 537   #  if $old->getfield('setup') &&
 538   #     $old->getfield('setup') != $new->getfield('setup');
 539
 540   #some logic for bill, susp, cancel?
 541
 542   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 543
 544   local $SIG{HUP} = 'IGNORE';
 545   local $SIG{INT} = 'IGNORE';
 546   local $SIG{QUIT} = 'IGNORE';
 547   local $SIG{TERM} = 'IGNORE';
 548   local $SIG{TSTP} = 'IGNORE';
 549   local $SIG{PIPE} = 'IGNORE';
 550
 551   my $oldAutoCommit = $FS::UID::AutoCommit;
 552   local $FS::UID::AutoCommit = 0;
 553   my $dbh = dbh;
 554
 555   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 556     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 557       my $error = $new->insert_reason(
 558         'reason'        => $options->{'reason'},
 559         'date'          => $new->$method,
 560         'action'        => $method,
 561         'reason_otaker' => $options->{'reason_otaker'},
 562       );
 563       if ( $error ) {
 564         dbh->rollback if $oldAutoCommit;
 565         return "Error inserting cust_pkg_reason: $error";
 566       }
 567     }
 568   }
 569
 570   #save off and freeze RADIUS attributes for any associated svc_acct records
 571   my @svc_acct = ();
 572   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 573
 574                 #also check for specific exports?
 575                 # to avoid spurious modify export events
 576     @svc_acct = map  { $_->svc_x }
 577                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 578                      $old->cust_svc;
 579
 580     $_->snapshot foreach @svc_acct;
 581
 582   }
 583
 584   my $error =  $new->export_pkg_change($old)
 585             || $new->SUPER::replace( $old,
 586                                      $options->{options}
 587                                        ? $options->{options}
 588                                        : ()
 589                                    );
 590   if ( $error ) {
 591     $dbh->rollback if $oldAutoCommit;
 592     return $error;
 593   }
 594
 595   #for prepaid packages,
 596   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 597   foreach my $old_svc_acct ( @svc_acct ) {
 598     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 599     my $s_error =
 600       $new_svc_acct->replace( $old_svc_acct,
 601                               'depend_jobnum' => $options->{depend_jobnum},
 602                             );
 603     if ( $s_error ) {
 604       $dbh->rollback if $oldAutoCommit;
 605       return $s_error;
 606     }
 607   }
 608
 609   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 610   '';
 611
 612 }
 613
 614 =item check
 615
 616 Checks all fields to make sure this is a valid billing item.  If there is an
 617 error, returns the error, otherwise returns false.  Called by the insert and
 618 replace methods.
 619
 620 =cut
 621
 622 sub check {
 623   my $self = shift;
 624
 625   if ( !$self->locationnum or $self->locationnum == -1 ) {
 626     $self->set('locationnum', $self->cust_main->ship_locationnum);
 627   }
 628
 629   my $error =
 630     $self->ut_numbern('pkgnum')
 631     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 632     || $self->ut_numbern('pkgpart')
 633     || $self->ut_foreign_keyn('contactnum',  'contact',       'contactnum' )
 634     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 635     || $self->ut_foreign_keyn('salesnum', 'sales', 'salesnum')
 636     || $self->ut_numbern('quantity')
 637     || $self->ut_numbern('start_date')
 638     || $self->ut_numbern('setup')
 639     || $self->ut_numbern('bill')
 640     || $self->ut_numbern('susp')
 641     || $self->ut_numbern('cancel')
 642     || $self->ut_numbern('adjourn')
 643     || $self->ut_numbern('resume')
 644     || $self->ut_numbern('expire')
 645     || $self->ut_numbern('dundate')
 646     || $self->ut_enum('no_auto', [ '', 'Y' ])
 647     || $self->ut_enum('waive_setup', [ '', 'Y' ])
 648     || $self->ut_numbern('agent_pkgid')
 649     || $self->ut_enum('recur_show_zero', [ '', 'Y', 'N', ])
 650     || $self->ut_enum('setup_show_zero', [ '', 'Y', 'N', ])
 651     || $self->ut_foreign_keyn('main_pkgnum', 'cust_pkg', 'pkgnum')
 652     || $self->ut_foreign_keyn('pkglinknum', 'part_pkg_link', 'pkglinknum')
 653     || $self->ut_foreign_keyn('change_to_pkgnum', 'cust_pkg', 'pkgnum')
 654   ;
 655   return $error if $error;
 656
 657   return "A package with both start date (future start) and setup date (already started) will never bill"
 658     if $self->start_date && $self->setup;
 659
 660   return "A future unsuspend date can only be set for a package with a suspend date"
 661     if $self->resume and !$self->susp and !$self->adjourn;
 662
 663   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 664
 665   if ( $self->dbdef_table->column('manual_flag') ) {
 666     $self->manual_flag('') if $self->manual_flag eq ' ';
 667     $self->manual_flag =~ /^([01]?)$/
 668       or return "Illegal manual_flag ". $self->manual_flag;
 669     $self->manual_flag($1);
 670   }
 671
 672   $self->SUPER::check;
 673 }
 674
 675 =item check_pkgpart
 676
 677 Check the pkgpart to make sure it's allowed with the reg_code and/or
 678 promo_code of the package (if present) and with the customer's agent.
 679 Called from C<insert>, unless we are doing a package change that doesn't
 680 affect pkgpart.
 681
 682 =cut
 683
 684 sub check_pkgpart {
 685   my $self = shift;
 686
 687   # my $error = $self->ut_numbern('pkgpart'); # already done
 688
 689   my $error;
 690   if ( $self->reg_code ) {
 691
 692     unless ( grep { $self->pkgpart == $_->pkgpart }
 693              map  { $_->reg_code_pkg }
 694              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 695                                      'agentnum' => $self->cust_main->agentnum })
 696            ) {
 697       return "Unknown registration code";
 698     }
 699
 700   } elsif ( $self->promo_code ) {
 701
 702     my $promo_part_pkg =
 703       qsearchs('part_pkg', {
 704         'pkgpart'    => $self->pkgpart,
 705         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 706       } );
 707     return 'Unknown promotional code' unless $promo_part_pkg;
 708
 709   } else {
 710
 711     unless ( $disable_agentcheck ) {
 712       my $agent =
 713         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 714       return "agent ". $agent->agentnum. ':'. $agent->agent.
 715              " can't purchase pkgpart ". $self->pkgpart
 716         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 717             || $agent->agentnum == $self->part_pkg->agentnum;
 718     }
 719
 720     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 721     return $error if $error;
 722
 723   }
 724
 725   '';
 726
 727 }
 728
 729 =item cancel [ OPTION => VALUE ... ]
 730
 731 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 732 in this package, then cancels the package itself (sets the cancel field to
 733 now).
 734
 735 Available options are:
 736
 737 =over 4
 738
 739 =item quiet - can be set true to supress email cancellation notices.
 740
 741 =item time -  can be set to cancel the package based on a specific future or
 742 historical date.  Using time ensures that the remaining amount is calculated
 743 correctly.  Note however that this is an immediate cancel and just changes
 744 the date.  You are PROBABLY looking to expire the account instead of using
 745 this.
 746
 747 =item reason - can be set to a cancellation reason (see L<FS:reason>),
 748 either a reasonnum of an existing reason, or passing a hashref will create
 749 a new reason.  The hashref should have the following keys: typenum - Reason
 750 type (see L<FS::reason_type>, reason - Text of the new reason.
 751
 752 =item date - can be set to a unix style timestamp to specify when to
 753 cancel (expire)
 754
 755 =item nobill - can be set true to skip billing if it might otherwise be done.
 756
 757 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
 758 not credit it.  This must be set (by change()) when changing the package
 759 to a different pkgpart or location, and probably shouldn't be in any other
 760 case.  If it's not set, the 'unused_credit_cancel' part_pkg option will
 761 be used.
 762
 763 =back
 764
 765 If there is an error, returns the error, otherwise returns false.
 766
 767 =cut
 768
 769 sub cancel {
 770   my( $self, %options ) = @_;
 771   my $error;
 772
 773   # pass all suspend/cancel actions to the main package
 774   if ( $self->main_pkgnum and !$options{'from_main'} ) {
 775     return $self->main_pkg->cancel(%options);
 776   }
 777
 778   my $conf = new FS::Conf;
 779
 780   warn "cust_pkg::cancel called with options".
 781        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 782     if $DEBUG;
 783
 784   local $SIG{HUP} = 'IGNORE';
 785   local $SIG{INT} = 'IGNORE';
 786   local $SIG{QUIT} = 'IGNORE';
 787   local $SIG{TERM} = 'IGNORE';
 788   local $SIG{TSTP} = 'IGNORE';
 789   local $SIG{PIPE} = 'IGNORE';
 790
 791   my $oldAutoCommit = $FS::UID::AutoCommit;
 792   local $FS::UID::AutoCommit = 0;
 793   my $dbh = dbh;
 794
 795   my $old = $self->select_for_update;
 796
 797   if ( $old->get('cancel') || $self->get('cancel') ) {
 798     dbh->rollback if $oldAutoCommit;
 799     return "";  # no error
 800   }
 801
 802   # XXX possibly set cancel_time to the expire date?
 803   my $cancel_time = $options{'time'} || time;
 804   my $date = $options{'date'} if $options{'date'}; # expire/cancel later
 805   $date = '' if ($date && $date <= $cancel_time);      # complain instead?
 806
 807   #race condition: usage could be ongoing until unprovisioned
 808   #resolved by performing a change package instead (which unprovisions) and
 809   #later cancelling
 810   if ( !$options{nobill} && !$date ) {
 811     # && $conf->exists('bill_usage_on_cancel') ) { #calc_cancel checks this
 812       my $copy = $self->new({$self->hash});
 813       my $error =
 814         $copy->cust_main->bill( 'pkg_list' => [ $copy ],
 815                                 'cancel'   => 1,
 816                                 'time'     => $cancel_time );
 817       warn "Error billing during cancel, custnum ".
 818         #$self->cust_main->custnum. ": $error"
 819         ": $error"
 820         if $error;
 821   }
 822
 823   if ( $options{'reason'} ) {
 824     $error = $self->insert_reason( 'reason' => $options{'reason'},
 825                                    'action' => $date ? 'expire' : 'cancel',
 826                                    'date'   => $date ? $date : $cancel_time,
 827                                    'reason_otaker' => $options{'reason_otaker'},
 828                                  );
 829     if ( $error ) {
 830       dbh->rollback if $oldAutoCommit;
 831       return "Error inserting cust_pkg_reason: $error";
 832     }
 833   }
 834
 835   my %svc_cancel_opt = ();
 836   $svc_cancel_opt{'date'} = $date if $date;
 837   foreach my $cust_svc (
 838     #schwartz
 839     map  { $_->[0] }
 840     sort { $a->[1] <=> $b->[1] }
 841     map  { [ $_, $_->svc_x ? $_->svc_x->table_info->{'cancel_weight'} : -1 ]; }
 842     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 843   ) {
 844     my $part_svc = $cust_svc->part_svc;
 845     next if ( defined($part_svc) and $part_svc->preserve );
 846     my $error = $cust_svc->cancel( %svc_cancel_opt );
 847
 848     if ( $error ) {
 849       $dbh->rollback if $oldAutoCommit;
 850       return 'Error '. ($svc_cancel_opt{'date'} ? 'expiring' : 'canceling' ).
 851              " cust_svc: $error";
 852     }
 853   }
 854
 855   unless ($date) {
 856     # credit remaining time if appropriate
 857     my $do_credit;
 858     if ( exists($options{'unused_credit'}) ) {
 859       $do_credit = $options{'unused_credit'};
 860     }
 861     else {
 862       $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
 863     }
 864     if ( $do_credit ) {
 865       my $error = $self->credit_remaining('cancel', $cancel_time);
 866       if ($error) {
 867         $dbh->rollback if $oldAutoCommit;
 868         return $error;
 869       }
 870     }
 871
 872   } #unless $date
 873
 874   my %hash = $self->hash;
 875   if ( $date ) {
 876     $hash{'expire'} = $date;
 877   } else {
 878     $hash{'cancel'} = $cancel_time;
 879   }
 880   $hash{'change_custnum'} = $options{'change_custnum'};
 881
 882   my $new = new FS::cust_pkg ( \%hash );
 883   $error = $new->replace( $self, options => { $self->options } );
 884   if ( $self->change_to_pkgnum ) {
 885     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
 886     $error ||= $change_to->cancel || $change_to->delete;
 887   }
 888   if ( $error ) {
 889     $dbh->rollback if $oldAutoCommit;
 890     return $error;
 891   }
 892
 893   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
 894     $error = $supp_pkg->cancel(%options, 'from_main' => 1);
 895     if ( $error ) {
 896       $dbh->rollback if $oldAutoCommit;
 897       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
 898     }
 899   }
 900
 901   foreach my $usage ( $self->cust_pkg_usage ) {
 902     $error = $usage->delete;
 903     if ( $error ) {
 904       $dbh->rollback if $oldAutoCommit;
 905       return "deleting usage pools: $error";
 906     }
 907   }
 908
 909   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 910   return '' if $date; #no errors
 911
 912   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 913   if ( !$options{'quiet'} &&
 914         $conf->exists('emailcancel', $self->cust_main->agentnum) &&
 915         @invoicing_list ) {
 916     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 917     my $error = '';
 918     if ( $msgnum ) {
 919       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 920       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 921                                     'object'    => $self );
 922     }
 923     else {
 924       $error = send_email(
 925         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 926         'to'      => \@invoicing_list,
 927         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 928         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 929       );
 930     }
 931     #should this do something on errors?
 932   }
 933
 934   ''; #no errors
 935
 936 }
 937
 938 =item cancel_if_expired [ NOW_TIMESTAMP ]
 939
 940 Cancels this package if its expire date has been reached.
 941
 942 =cut
 943
 944 sub cancel_if_expired {
 945   my $self = shift;
 946   my $time = shift || time;
 947   return '' unless $self->expire && $self->expire <= $time;
 948   my $error = $self->cancel;
 949   if ( $error ) {
 950     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 951            $self->custnum. ": $error";
 952   }
 953   '';
 954 }
 955
 956 =item uncancel
 957
 958 "Un-cancels" this package: Orders a new package with the same custnum, pkgpart,
 959 locationnum, (other fields?).  Attempts to re-provision cancelled services
 960 using history information (errors at this stage are not fatal).
 961
 962 cust_pkg: pass a scalar reference, will be filled in with the new cust_pkg object
 963
 964 svc_fatal: service provisioning errors are fatal
 965
 966 svc_errors: pass an array reference, will be filled in with any provisioning errors
 967
 968 main_pkgnum: link the package as a supplemental package of this one.  For
 969 internal use only.
 970
 971 =cut
 972
 973 sub uncancel {
 974   my( $self, %options ) = @_;
 975
 976   #in case you try do do $uncancel-date = $cust_pkg->uncacel
 977   return '' unless $self->get('cancel');
 978
 979   if ( $self->main_pkgnum and !$options{'main_pkgnum'} ) {
 980     return $self->main_pkg->uncancel(%options);
 981   }
 982
 983   ##
 984   # Transaction-alize
 985   ##
 986
 987   local $SIG{HUP} = 'IGNORE';
 988   local $SIG{INT} = 'IGNORE';
 989   local $SIG{QUIT} = 'IGNORE';
 990   local $SIG{TERM} = 'IGNORE';
 991   local $SIG{TSTP} = 'IGNORE';
 992   local $SIG{PIPE} = 'IGNORE';
 993
 994   my $oldAutoCommit = $FS::UID::AutoCommit;
 995   local $FS::UID::AutoCommit = 0;
 996   my $dbh = dbh;
 997
 998   ##
 999   # insert the new package
1000   ##
1001
1002   my $cust_pkg = new FS::cust_pkg {
1003     last_bill       => ( $options{'last_bill'} || $self->get('last_bill') ),
1004     bill            => ( $options{'bill'}      || $self->get('bill')      ),
1005     uncancel        => time,
1006     uncancel_pkgnum => $self->pkgnum,
1007     main_pkgnum     => ($options{'main_pkgnum'} || ''),
1008     map { $_ => $self->get($_) } qw(
1009       custnum pkgpart locationnum
1010       setup
1011       susp adjourn resume expire start_date contract_end dundate
1012       change_date change_pkgpart change_locationnum
1013       manual_flag no_auto quantity agent_pkgid recur_show_zero setup_show_zero
1014     ),
1015   };
1016
1017   my $error = $cust_pkg->insert(
1018     'change' => 1, #supresses any referral credit to a referring customer
1019     'allow_pkgpart' => 1, # allow this even if the package def is disabled
1020   );
1021   if ($error) {
1022     $dbh->rollback if $oldAutoCommit;
1023     return $error;
1024   }
1025
1026   ##
1027   # insert services
1028   ##
1029
1030   #find historical services within this timeframe before the package cancel
1031   # (incompatible with "time" option to cust_pkg->cancel?)
1032   my $fuzz = 2 * 60; #2 minutes?  too much?   (might catch separate unprovision)
1033                      #            too little? (unprovisioing export delay?)
1034   my($end, $start) = ( $self->get('cancel'), $self->get('cancel') - $fuzz );
1035   my @h_cust_svc = $self->h_cust_svc( $end, $start );
1036
1037   my @svc_errors;
1038   foreach my $h_cust_svc (@h_cust_svc) {
1039     my $h_svc_x = $h_cust_svc->h_svc_x( $end, $start );
1040     #next unless $h_svc_x; #should this happen?
1041     (my $table = $h_svc_x->table) =~ s/^h_//;
1042     require "FS/$table.pm";
1043     my $class = "FS::$table";
1044     my $svc_x = $class->new( {
1045       'pkgnum'  => $cust_pkg->pkgnum,
1046       'svcpart' => $h_cust_svc->svcpart,
1047       map { $_ => $h_svc_x->get($_) } fields($table)
1048     } );
1049
1050     # radius_usergroup
1051     if ( $h_svc_x->isa('FS::h_svc_Radius_Mixin') ) {
1052       $svc_x->usergroup( [ $h_svc_x->h_usergroup($end, $start) ] );
1053     }
1054
1055     my $svc_error = $svc_x->insert;
1056     if ( $svc_error ) {
1057       if ( $options{svc_fatal} ) {
1058         $dbh->rollback if $oldAutoCommit;
1059         return $svc_error;
1060       } else {
1061         # if we've failed to insert the svc_x object, svc_Common->insert
1062         # will have removed the cust_svc already.  if not, then both records
1063         # were inserted but we failed for some other reason (export, most
1064         # likely).  in that case, report the error and delete the records.
1065         push @svc_errors, $svc_error;
1066         my $cust_svc = qsearchs('cust_svc', { 'svcnum' => $svc_x->svcnum });
1067         if ( $cust_svc ) {
1068           # except if export_insert failed, export_delete probably won't be
1069           # much better
1070           local $FS::svc_Common::noexport_hack = 1;
1071           my $cleanup_error = $svc_x->delete; # also deletes cust_svc
1072           if ( $cleanup_error ) { # and if THAT fails, then run away
1073             $dbh->rollback if $oldAutoCommit;
1074             return $cleanup_error;
1075           }
1076         }
1077       } # svc_fatal
1078     } # svc_error
1079   } #foreach $h_cust_svc
1080
1081   #these are pretty rare, but should handle them
1082   # - dsl_device (mac addresses)
1083   # - phone_device (mac addresses)
1084   # - dsl_note (ikano notes)
1085   # - domain_record (i.e. restore DNS information w/domains)
1086   # - inventory_item(?) (inventory w/un-cancelling service?)
1087   # - nas (svc_broaband nas stuff)
1088   #this stuff is unused in the wild afaik
1089   # - mailinglistmember
1090   # - router.svcnum?
1091   # - svc_domain.parent_svcnum?
1092   # - acct_snarf (ancient mail fetching config)
1093   # - cgp_rule (communigate)
1094   # - cust_svc_option (used by our Tron stuff)
1095   # - acct_rt_transaction (used by our time worked stuff)
1096
1097   ##
1098   # also move over any services that didn't unprovision at cancellation
1099   ##
1100
1101   foreach my $cust_svc ( qsearch('cust_svc', { pkgnum => $self->pkgnum } ) ) {
1102     $cust_svc->pkgnum( $cust_pkg->pkgnum );
1103     my $error = $cust_svc->replace;
1104     if ( $error ) {
1105       $dbh->rollback if $oldAutoCommit;
1106       return $error;
1107     }
1108   }
1109
1110   ##
1111   # Uncancel any supplemental packages, and make them supplemental to the
1112   # new one.
1113   ##
1114
1115   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1116     my $new_pkg;
1117     $error = $supp_pkg->uncancel(%options, 'main_pkgnum' => $cust_pkg->pkgnum);
1118     if ( $error ) {
1119       $dbh->rollback if $oldAutoCommit;
1120       return "canceling supplemental pkg#".$supp_pkg->pkgnum.": $error";
1121     }
1122   }
1123
1124   ##
1125   # Finish
1126   ##
1127
1128   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1129
1130   ${ $options{cust_pkg} }   = $cust_pkg   if ref($options{cust_pkg});
1131   @{ $options{svc_errors} } = @svc_errors if ref($options{svc_errors});
1132
1133   '';
1134 }
1135
1136 =item unexpire
1137
1138 Cancels any pending expiration (sets the expire field to null).
1139
1140 If there is an error, returns the error, otherwise returns false.
1141
1142 =cut
1143
1144 sub unexpire {
1145   my( $self, %options ) = @_;
1146   my $error;
1147
1148   local $SIG{HUP} = 'IGNORE';
1149   local $SIG{INT} = 'IGNORE';
1150   local $SIG{QUIT} = 'IGNORE';
1151   local $SIG{TERM} = 'IGNORE';
1152   local $SIG{TSTP} = 'IGNORE';
1153   local $SIG{PIPE} = 'IGNORE';
1154
1155   my $oldAutoCommit = $FS::UID::AutoCommit;
1156   local $FS::UID::AutoCommit = 0;
1157   my $dbh = dbh;
1158
1159   my $old = $self->select_for_update;
1160
1161   my $pkgnum = $old->pkgnum;
1162   if ( $old->get('cancel') || $self->get('cancel') ) {
1163     dbh->rollback if $oldAutoCommit;
1164     return "Can't unexpire cancelled package $pkgnum";
1165     # or at least it's pointless
1166   }
1167
1168   unless ( $old->get('expire') && $self->get('expire') ) {
1169     dbh->rollback if $oldAutoCommit;
1170     return "";  # no error
1171   }
1172
1173   my %hash = $self->hash;
1174   $hash{'expire'} = '';
1175   my $new = new FS::cust_pkg ( \%hash );
1176   $error = $new->replace( $self, options => { $self->options } );
1177   if ( $error ) {
1178     $dbh->rollback if $oldAutoCommit;
1179     return $error;
1180   }
1181
1182   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1183
1184   ''; #no errors
1185
1186 }
1187
1188 =item suspend [ OPTION => VALUE ... ]
1189
1190 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1191 package, then suspends the package itself (sets the susp field to now).
1192
1193 Available options are:
1194
1195 =over 4
1196
1197 =item reason - can be set to a cancellation reason (see L<FS:reason>),
1198 either a reasonnum of an existing reason, or passing a hashref will create
1199 a new reason.  The hashref should have the following keys:
1200 - typenum - Reason type (see L<FS::reason_type>
1201 - reason - Text of the new reason.
1202
1203 =item date - can be set to a unix style timestamp to specify when to
1204 suspend (adjourn)
1205
1206 =item time - can be set to override the current time, for calculation
1207 of final invoices or unused-time credits
1208
1209 =item resume_date - can be set to a time when the package should be
1210 unsuspended.  This may be more convenient than calling C<unsuspend()>
1211 separately.
1212
1213 =item from_main - allows a supplemental package to be suspended, rather
1214 than redirecting the method call to its main package.  For internal use.
1215
1216 =back
1217
1218 If there is an error, returns the error, otherwise returns false.
1219
1220 =cut
1221
1222 sub suspend {
1223   my( $self, %options ) = @_;
1224   my $error;
1225
1226   # pass all suspend/cancel actions to the main package
1227   if ( $self->main_pkgnum and !$options{'from_main'} ) {
1228     return $self->main_pkg->suspend(%options);
1229   }
1230
1231   local $SIG{HUP} = 'IGNORE';
1232   local $SIG{INT} = 'IGNORE';
1233   local $SIG{QUIT} = 'IGNORE';
1234   local $SIG{TERM} = 'IGNORE';
1235   local $SIG{TSTP} = 'IGNORE';
1236   local $SIG{PIPE} = 'IGNORE';
1237
1238   my $oldAutoCommit = $FS::UID::AutoCommit;
1239   local $FS::UID::AutoCommit = 0;
1240   my $dbh = dbh;
1241
1242   my $old = $self->select_for_update;
1243
1244   my $pkgnum = $old->pkgnum;
1245   if ( $old->get('cancel') || $self->get('cancel') ) {
1246     dbh->rollback if $oldAutoCommit;
1247     return "Can't suspend cancelled package $pkgnum";
1248   }
1249
1250   if ( $old->get('susp') || $self->get('susp') ) {
1251     dbh->rollback if $oldAutoCommit;
1252     return "";  # no error                     # complain on adjourn?
1253   }
1254
1255   my $suspend_time = $options{'time'} || time;
1256   my $date = $options{date} if $options{date}; # adjourn/suspend later
1257   $date = '' if ($date && $date <= $suspend_time); # complain instead?
1258
1259   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
1260     dbh->rollback if $oldAutoCommit;
1261     return "Package $pkgnum expires before it would be suspended.";
1262   }
1263
1264   # some false laziness with sub cancel
1265   if ( !$options{nobill} && !$date &&
1266        $self->part_pkg->option('bill_suspend_as_cancel',1) ) {
1267     # kind of a kludge--'bill_suspend_as_cancel' to avoid having to
1268     # make the entire cust_main->bill path recognize 'suspend' and
1269     # 'cancel' separately.
1270     warn "Billing $pkgnum on suspension (at $suspend_time)\n" if $DEBUG;
1271     my $copy = $self->new({$self->hash});
1272     my $error =
1273       $copy->cust_main->bill( 'pkg_list' => [ $copy ],
1274                               'cancel'   => 1,
1275                               'time'     => $suspend_time );
1276     warn "Error billing during suspend, custnum ".
1277       #$self->cust_main->custnum. ": $error"
1278       ": $error"
1279       if $error;
1280   }
1281
1282   if ( $options{'reason'} ) {
1283     $error = $self->insert_reason( 'reason' => $options{'reason'},
1284                                    'action' => $date ? 'adjourn' : 'suspend',
1285                                    'date'   => $date ? $date : $suspend_time,
1286                                    'reason_otaker' => $options{'reason_otaker'},
1287                                  );
1288     if ( $error ) {
1289       dbh->rollback if $oldAutoCommit;
1290       return "Error inserting cust_pkg_reason: $error";
1291     }
1292   }
1293
1294   my %hash = $self->hash;
1295   if ( $date ) {
1296     $hash{'adjourn'} = $date;
1297   } else {
1298     $hash{'susp'} = $suspend_time;
1299   }
1300
1301   my $resume_date = $options{'resume_date'} || 0;
1302   if ( $resume_date > ($date || $suspend_time) ) {
1303     $hash{'resume'} = $resume_date;
1304   }
1305
1306   $options{options} ||= {};
1307
1308   my $new = new FS::cust_pkg ( \%hash );
1309   $error = $new->replace( $self, options => { $self->options,
1310                                               %{ $options{options} },
1311                                             }
1312                         );
1313   if ( $error ) {
1314     $dbh->rollback if $oldAutoCommit;
1315     return $error;
1316   }
1317
1318   unless ( $date ) {
1319     # credit remaining time if appropriate
1320     if ( $self->part_pkg->option('unused_credit_suspend', 1) ) {
1321       my $error = $self->credit_remaining('suspend', $suspend_time);
1322       if ($error) {
1323         $dbh->rollback if $oldAutoCommit;
1324         return $error;
1325       }
1326     }
1327
1328     my @labels = ();
1329
1330     foreach my $cust_svc (
1331       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
1332     ) {
1333       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1334
1335       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1336         $dbh->rollback if $oldAutoCommit;
1337         return "Illegal svcdb value in part_svc!";
1338       };
1339       my $svcdb = $1;
1340       require "FS/$svcdb.pm";
1341
1342       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1343       if ($svc) {
1344         $error = $svc->suspend;
1345         if ( $error ) {
1346           $dbh->rollback if $oldAutoCommit;
1347           return $error;
1348         }
1349         my( $label, $value ) = $cust_svc->label;
1350         push @labels, "$label: $value";
1351       }
1352     }
1353
1354     my $conf = new FS::Conf;
1355     if ( $conf->config('suspend_email_admin') ) {
1356
1357       my $error = send_email(
1358         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1359                                    #invoice_from ??? well as good as any
1360         'to'      => $conf->config('suspend_email_admin'),
1361         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
1362         'body'    => [
1363           "This is an automatic message from your Freeside installation\n",
1364           "informing you that the following customer package has been suspended:\n",
1365           "\n",
1366           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1367           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1368           ( map { "Service : $_\n" } @labels ),
1369         ],
1370       );
1371
1372       if ( $error ) {
1373         warn "WARNING: can't send suspension admin email (suspending anyway): ".
1374              "$error\n";
1375       }
1376
1377     }
1378
1379   }
1380
1381   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1382     $error = $supp_pkg->suspend(%options, 'from_main' => 1);
1383     if ( $error ) {
1384       $dbh->rollback if $oldAutoCommit;
1385       return "suspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1386     }
1387   }
1388
1389   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1390
1391   ''; #no errors
1392 }
1393
1394 =item credit_remaining MODE TIME
1395
1396 Generate a credit for this package for the time remaining in the current
1397 billing period.  MODE is either "suspend" or "cancel" (determines the
1398 credit type).  TIME is the time of suspension/cancellation.  Both arguments
1399 are mandatory.
1400
1401 =cut
1402
1403 sub credit_remaining {
1404   # Add a credit for remaining service
1405   my ($self, $mode, $time) = @_;
1406   die 'credit_remaining requires suspend or cancel'
1407     unless $mode eq 'suspend' or $mode eq 'cancel';
1408   die 'no suspend/cancel time' unless $time > 0;
1409
1410   my $conf = FS::Conf->new;
1411   my $reason_type = $conf->config($mode.'_credit_type');
1412
1413   my $last_bill = $self->getfield('last_bill') || 0;
1414   my $next_bill = $self->getfield('bill') || 0;
1415   if ( $last_bill > 0         # the package has been billed
1416       and $next_bill > 0      # the package has a next bill date
1417       and $next_bill >= $time # which is in the future
1418   ) {
1419     my $remaining_value = $self->calc_remain('time' => $time);
1420     if ( $remaining_value > 0 ) {
1421       warn "Crediting for $remaining_value on package ".$self->pkgnum."\n"
1422         if $DEBUG;
1423       my $error = $self->cust_main->credit(
1424         $remaining_value,
1425         'Credit for unused time on '. $self->part_pkg->pkg,
1426         'reason_type' => $reason_type,
1427       );
1428       return "Error crediting customer \$$remaining_value for unused time".
1429         " on ". $self->part_pkg->pkg. ": $error"
1430         if $error;
1431     } #if $remaining_value
1432   } #if $last_bill, etc.
1433   '';
1434 }
1435
1436 =item unsuspend [ OPTION => VALUE ... ]
1437
1438 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
1439 package, then unsuspends the package itself (clears the susp field and the
1440 adjourn field if it is in the past).  If the suspend reason includes an
1441 unsuspension package, that package will be ordered.
1442
1443 Available options are:
1444
1445 =over 4
1446
1447 =item date
1448
1449 Can be set to a date to unsuspend the package in the future (the 'resume'
1450 field).
1451
1452 =item adjust_next_bill
1453
1454 Can be set true to adjust the next bill date forward by
1455 the amount of time the account was inactive.  This was set true by default
1456 in the past (from 1.4.2 and 1.5.0pre6 through 1.7.0), but now needs to be
1457 explicitly requested with this option or in the price plan.
1458
1459 =back
1460
1461 If there is an error, returns the error, otherwise returns false.
1462
1463 =cut
1464
1465 sub unsuspend {
1466   my( $self, %opt ) = @_;
1467   my $error;
1468
1469   # pass all suspend/cancel actions to the main package
1470   if ( $self->main_pkgnum and !$opt{'from_main'} ) {
1471     return $self->main_pkg->unsuspend(%opt);
1472   }
1473
1474   local $SIG{HUP} = 'IGNORE';
1475   local $SIG{INT} = 'IGNORE';
1476   local $SIG{QUIT} = 'IGNORE';
1477   local $SIG{TERM} = 'IGNORE';
1478   local $SIG{TSTP} = 'IGNORE';
1479   local $SIG{PIPE} = 'IGNORE';
1480
1481   my $oldAutoCommit = $FS::UID::AutoCommit;
1482   local $FS::UID::AutoCommit = 0;
1483   my $dbh = dbh;
1484
1485   my $old = $self->select_for_update;
1486
1487   my $pkgnum = $old->pkgnum;
1488   if ( $old->get('cancel') || $self->get('cancel') ) {
1489     $dbh->rollback if $oldAutoCommit;
1490     return "Can't unsuspend cancelled package $pkgnum";
1491   }
1492
1493   unless ( $old->get('susp') && $self->get('susp') ) {
1494     $dbh->rollback if $oldAutoCommit;
1495     return "";  # no error                     # complain instead?
1496   }
1497
1498   my $date = $opt{'date'};
1499   if ( $date and $date > time ) { # return an error if $date <= time?
1500
1501     if ( $old->get('expire') && $old->get('expire') < $date ) {
1502       $dbh->rollback if $oldAutoCommit;
1503       return "Package $pkgnum expires before it would be unsuspended.";
1504     }
1505
1506     my $new = new FS::cust_pkg { $self->hash };
1507     $new->set('resume', $date);
1508     $error = $new->replace($self, options => $self->options);
1509
1510     if ( $error ) {
1511       $dbh->rollback if $oldAutoCommit;
1512       return $error;
1513     }
1514     else {
1515       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1516       return '';
1517     }
1518
1519   } #if $date
1520
1521   my @labels = ();
1522
1523   foreach my $cust_svc (
1524     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1525   ) {
1526     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1527
1528     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1529       $dbh->rollback if $oldAutoCommit;
1530       return "Illegal svcdb value in part_svc!";
1531     };
1532     my $svcdb = $1;
1533     require "FS/$svcdb.pm";
1534
1535     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1536     if ($svc) {
1537       $error = $svc->unsuspend;
1538       if ( $error ) {
1539         $dbh->rollback if $oldAutoCommit;
1540         return $error;
1541       }
1542       my( $label, $value ) = $cust_svc->label;
1543       push @labels, "$label: $value";
1544     }
1545
1546   }
1547
1548   my $cust_pkg_reason = $self->last_cust_pkg_reason('susp');
1549   my $reason = $cust_pkg_reason ? $cust_pkg_reason->reason : '';
1550
1551   my %hash = $self->hash;
1552   my $inactive = time - $hash{'susp'};
1553
1554   my $conf = new FS::Conf;
1555
1556   if ( $inactive > 0 &&
1557        ( $hash{'bill'} || $hash{'setup'} ) &&
1558        ( $opt{'adjust_next_bill'} ||
1559          $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1560          $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1561      ) {
1562
1563     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1564
1565   }
1566
1567   $hash{'susp'} = '';
1568   $hash{'adjourn'} = '' if $hash{'adjourn'} and $hash{'adjourn'} < time;
1569   $hash{'resume'} = '' if !$hash{'adjourn'};
1570   my $new = new FS::cust_pkg ( \%hash );
1571   $error = $new->replace( $self, options => { $self->options } );
1572   if ( $error ) {
1573     $dbh->rollback if $oldAutoCommit;
1574     return $error;
1575   }
1576
1577   my $unsusp_pkg;
1578
1579   if ( $reason && $reason->unsuspend_pkgpart ) {
1580     my $part_pkg = FS::part_pkg->by_key($reason->unsuspend_pkgpart)
1581       or $error = "Unsuspend package definition ".$reason->unsuspend_pkgpart.
1582                   " not found.";
1583     my $start_date = $self->cust_main->next_bill_date
1584       if $reason->unsuspend_hold;
1585
1586     if ( $part_pkg ) {
1587       $unsusp_pkg = FS::cust_pkg->new({
1588           'custnum'     => $self->custnum,
1589           'pkgpart'     => $reason->unsuspend_pkgpart,
1590           'start_date'  => $start_date,
1591           'locationnum' => $self->locationnum,
1592           # discount? probably not...
1593       });
1594
1595       $error ||= $self->cust_main->order_pkg( 'cust_pkg' => $unsusp_pkg );
1596     }
1597
1598     if ( $error ) {
1599       $dbh->rollback if $oldAutoCommit;
1600       return $error;
1601     }
1602   }
1603
1604   if ( $conf->config('unsuspend_email_admin') ) {
1605
1606     my $error = send_email(
1607       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
1608                                  #invoice_from ??? well as good as any
1609       'to'      => $conf->config('unsuspend_email_admin'),
1610       'subject' => 'FREESIDE NOTIFICATION: Customer package unsuspended',       'body'    => [
1611         "This is an automatic message from your Freeside installation\n",
1612         "informing you that the following customer package has been unsuspended:\n",
1613         "\n",
1614         'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
1615         'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
1616         ( map { "Service : $_\n" } @labels ),
1617         ($unsusp_pkg ?
1618           "An unsuspension fee was charged: ".
1619             $unsusp_pkg->part_pkg->pkg_comment."\n"
1620           : ''
1621         ),
1622       ],
1623     );
1624
1625     if ( $error ) {
1626       warn "WARNING: can't send unsuspension admin email (unsuspending anyway): ".
1627            "$error\n";
1628     }
1629
1630   }
1631
1632   foreach my $supp_pkg ( $self->supplemental_pkgs ) {
1633     $error = $supp_pkg->unsuspend(%opt, 'from_main' => 1);
1634     if ( $error ) {
1635       $dbh->rollback if $oldAutoCommit;
1636       return "unsuspending supplemental pkg#".$supp_pkg->pkgnum.": $error";
1637     }
1638   }
1639
1640   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1641
1642   ''; #no errors
1643 }
1644
1645 =item unadjourn
1646
1647 Cancels any pending suspension (sets the adjourn field to null).
1648
1649 If there is an error, returns the error, otherwise returns false.
1650
1651 =cut
1652
1653 sub unadjourn {
1654   my( $self, %options ) = @_;
1655   my $error;
1656
1657   local $SIG{HUP} = 'IGNORE';
1658   local $SIG{INT} = 'IGNORE';
1659   local $SIG{QUIT} = 'IGNORE';
1660   local $SIG{TERM} = 'IGNORE';
1661   local $SIG{TSTP} = 'IGNORE';
1662   local $SIG{PIPE} = 'IGNORE';
1663
1664   my $oldAutoCommit = $FS::UID::AutoCommit;
1665   local $FS::UID::AutoCommit = 0;
1666   my $dbh = dbh;
1667
1668   my $old = $self->select_for_update;
1669
1670   my $pkgnum = $old->pkgnum;
1671   if ( $old->get('cancel') || $self->get('cancel') ) {
1672     dbh->rollback if $oldAutoCommit;
1673     return "Can't unadjourn cancelled package $pkgnum";
1674     # or at least it's pointless
1675   }
1676
1677   if ( $old->get('susp') || $self->get('susp') ) {
1678     dbh->rollback if $oldAutoCommit;
1679     return "Can't unadjourn suspended package $pkgnum";
1680     # perhaps this is arbitrary
1681   }
1682
1683   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1684     dbh->rollback if $oldAutoCommit;
1685     return "";  # no error
1686   }
1687
1688   my %hash = $self->hash;
1689   $hash{'adjourn'} = '';
1690   $hash{'resume'}  = '';
1691   my $new = new FS::cust_pkg ( \%hash );
1692   $error = $new->replace( $self, options => { $self->options } );
1693   if ( $error ) {
1694     $dbh->rollback if $oldAutoCommit;
1695     return $error;
1696   }
1697
1698   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1699
1700   ''; #no errors
1701
1702 }
1703
1704
1705 =item change HASHREF | OPTION => VALUE ...
1706
1707 Changes this package: cancels it and creates a new one, with a different
1708 pkgpart or locationnum or both.  All services are transferred to the new
1709 package (no change will be made if this is not possible).
1710
1711 Options may be passed as a list of key/value pairs or as a hash reference.
1712 Options are:
1713
1714 =over 4
1715
1716 =item locationnum
1717
1718 New locationnum, to change the location for this package.
1719
1720 =item cust_location
1721
1722 New FS::cust_location object, to create a new location and assign it
1723 to this package.
1724
1725 =item cust_main
1726
1727 New FS::cust_main object, to create a new customer and assign the new package
1728 to it.
1729
1730 =item pkgpart
1731
1732 New pkgpart (see L<FS::part_pkg>).
1733
1734 =item refnum
1735
1736 New refnum (see L<FS::part_referral>).
1737
1738 =item quantity
1739
1740 New quantity; if unspecified, the new package will have the same quantity
1741 as the old.
1742
1743 =item cust_pkg
1744
1745 "New" (existing) FS::cust_pkg object.  The package's services and other
1746 attributes will be transferred to this package.
1747
1748 =item keep_dates
1749
1750 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1751 susp, adjourn, cancel, expire, and contract_end) to the new package.
1752
1753 =item unprotect_svcs
1754
1755 Normally, change() will rollback and return an error if some services
1756 can't be transferred (also see the I<cust_pkg-change_svcpart> config option).
1757 If unprotect_svcs is true, this method will transfer as many services as
1758 it can and then unconditionally cancel the old package.
1759
1760 =back
1761
1762 At least one of locationnum, cust_location, pkgpart, refnum, cust_main, or
1763 cust_pkg must be specified (otherwise, what's the point?)
1764
1765 Returns either the new FS::cust_pkg object or a scalar error.
1766
1767 For example:
1768
1769   my $err_or_new_cust_pkg = $old_cust_pkg->change
1770
1771 =cut
1772
1773 #some false laziness w/order
1774 sub change {
1775   my $self = shift;
1776   my $opt = ref($_[0]) ? shift : { @_ };
1777
1778   my $conf = new FS::Conf;
1779
1780   # Transactionize this whole mess
1781   local $SIG{HUP} = 'IGNORE';
1782   local $SIG{INT} = 'IGNORE';
1783   local $SIG{QUIT} = 'IGNORE';
1784   local $SIG{TERM} = 'IGNORE';
1785   local $SIG{TSTP} = 'IGNORE';
1786   local $SIG{PIPE} = 'IGNORE';
1787
1788   my $oldAutoCommit = $FS::UID::AutoCommit;
1789   local $FS::UID::AutoCommit = 0;
1790   my $dbh = dbh;
1791
1792   my $error;
1793
1794   my %hash = ();
1795
1796   my $time = time;
1797
1798   $hash{'setup'} = $time if $self->setup;
1799
1800   $hash{'change_date'} = $time;
1801   $hash{"change_$_"}  = $self->$_()
1802     foreach qw( pkgnum pkgpart locationnum );
1803
1804   if ( $opt->{'cust_location'} ) {
1805     $error = $opt->{'cust_location'}->find_or_insert;
1806     if ( $error ) {
1807       $dbh->rollback if $oldAutoCommit;
1808       return "inserting cust_location (transaction rolled back): $error";
1809     }
1810     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1811   }
1812
1813   if ( $opt->{'cust_pkg'} ) {
1814     # treat changing to a package with a different pkgpart as a
1815     # pkgpart change (because it is)
1816     $opt->{'pkgpart'} = $opt->{'cust_pkg'}->pkgpart;
1817   }
1818
1819   # whether to override pkgpart checking on the new package
1820   my $same_pkgpart = 1;
1821   if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1822     $same_pkgpart = 0;
1823   }
1824
1825   my $unused_credit = 0;
1826   my $keep_dates = $opt->{'keep_dates'};
1827   # Special case.  If the pkgpart is changing, and the customer is
1828   # going to be credited for remaining time, don't keep setup, bill,
1829   # or last_bill dates, and DO pass the flag to cancel() to credit
1830   # the customer.
1831   if ( $opt->{'pkgpart'}
1832        and $opt->{'pkgpart'} != $self->pkgpart
1833        and $self->part_pkg->option('unused_credit_change', 1) ) {
1834     $unused_credit = 1;
1835     $keep_dates = 0;
1836     $hash{$_} = '' foreach qw(setup bill last_bill);
1837   }
1838
1839   if ( $keep_dates ) {
1840     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1841                           resume start_date contract_end ) ) {
1842       $hash{$date} = $self->getfield($date);
1843     }
1844   }
1845
1846   # allow $opt->{'locationnum'} = '' to specifically set it to null
1847   # (i.e. customer default location)
1848   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1849
1850   # usually this doesn't matter.  the two cases where it does are:
1851   # 1. unused_credit_change + pkgpart change + setup fee on the new package
1852   # and
1853   # 2. (more importantly) changing a package before it's billed
1854   $hash{'waive_setup'} = $self->waive_setup;
1855
1856   my $custnum = $self->custnum;
1857   if ( $opt->{cust_main} ) {
1858     my $cust_main = $opt->{cust_main};
1859     unless ( $cust_main->custnum ) {
1860       my $error = $cust_main->insert;
1861       if ( $error ) {
1862         $dbh->rollback if $oldAutoCommit;
1863         return "inserting cust_main (transaction rolled back): $error";
1864       }
1865     }
1866     $custnum = $cust_main->custnum;
1867   }
1868
1869   $hash{'contactnum'} = $opt->{'contactnum'} if $opt->{'contactnum'};
1870
1871   my $cust_pkg;
1872   if ( $opt->{'cust_pkg'} ) {
1873     # The target package already exists; update it to show that it was
1874     # changed from this package.
1875     $cust_pkg = $opt->{'cust_pkg'};
1876
1877     foreach ( qw( pkgnum pkgpart locationnum ) ) {
1878       $cust_pkg->set("change_$_", $self->get($_));
1879     }
1880     $cust_pkg->set('change_date', $time);
1881     $error = $cust_pkg->replace;
1882
1883   } else {
1884     # Create the new package.
1885     $cust_pkg = new FS::cust_pkg {
1886       custnum     => $custnum,
1887       locationnum => $opt->{'locationnum'},
1888       ( map {  $_ => ( $opt->{$_} || $self->$_() )  }
1889           qw( pkgpart quantity refnum salesnum )
1890       ),
1891       %hash,
1892     };
1893     $error = $cust_pkg->insert( 'change' => 1,
1894                                 'allow_pkgpart' => $same_pkgpart );
1895   }
1896   if ($error) {
1897     $dbh->rollback if $oldAutoCommit;
1898     return $error;
1899   }
1900
1901   # Transfer services and cancel old package.
1902
1903   $error = $self->transfer($cust_pkg);
1904   if ($error and $error == 0) {
1905     # $old_pkg->transfer failed.
1906     $dbh->rollback if $oldAutoCommit;
1907     return $error;
1908   }
1909
1910   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1911     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1912     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1913     if ($error and $error == 0) {
1914       # $old_pkg->transfer failed.
1915       $dbh->rollback if $oldAutoCommit;
1916       return $error;
1917     }
1918   }
1919
1920   # We set unprotect_svcs when executing a "future package change".  It's
1921   # not a user-interactive operation, so returning an error means the
1922   # package change will just fail.  Rather than have that happen, we'll
1923   # let leftover services be deleted.
1924   if ($error > 0 and !$opt->{'unprotect_svcs'}) {
1925     # Transfers were successful, but we still had services left on the old
1926     # package.  We can't change the package under this circumstances, so abort.
1927     $dbh->rollback if $oldAutoCommit;
1928     return "Unable to transfer all services from package ". $self->pkgnum;
1929   }
1930
1931   #reset usage if changing pkgpart
1932   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1933   if ($self->pkgpart != $cust_pkg->pkgpart) {
1934     my $part_pkg = $cust_pkg->part_pkg;
1935     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1936                                                  ? ()
1937                                                  : ( 'null' => 1 )
1938                                    )
1939       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1940
1941     if ($error) {
1942       $dbh->rollback if $oldAutoCommit;
1943       return "Error setting usage values: $error";
1944     }
1945   } else {
1946     # if NOT changing pkgpart, transfer any usage pools over
1947     foreach my $usage ($self->cust_pkg_usage) {
1948       $usage->set('pkgnum', $cust_pkg->pkgnum);
1949       $error = $usage->replace;
1950       if ( $error ) {
1951         $dbh->rollback if $oldAutoCommit;
1952         return "Error transferring usage pools: $error";
1953       }
1954     }
1955   }
1956
1957   # transfer discounts, if we're not changing pkgpart
1958   if ( $same_pkgpart ) {
1959     foreach my $old_discount ($self->cust_pkg_discount_active) {
1960       # don't remove the old discount, we may still need to bill that package.
1961       my $new_discount = new FS::cust_pkg_discount {
1962         'pkgnum'      => $cust_pkg->pkgnum,
1963         'discountnum' => $old_discount->discountnum,
1964         'months_used' => $old_discount->months_used,
1965       };
1966       $error = $new_discount->insert;
1967       if ( $error ) {
1968         $dbh->rollback if $oldAutoCommit;
1969         return "Error transferring discounts: $error";
1970       }
1971     }
1972   }
1973
1974   # transfer (copy) invoice details
1975   foreach my $detail ($self->cust_pkg_detail) {
1976     my $new_detail = FS::cust_pkg_detail->new({ $detail->hash });
1977     $new_detail->set('pkgdetailnum', '');
1978     $new_detail->set('pkgnum', $cust_pkg->pkgnum);
1979     $error = $new_detail->insert;
1980     if ( $error ) {
1981       $dbh->rollback if $oldAutoCommit;
1982       return "Error transferring package notes: $error";
1983     }
1984   }
1985
1986   my @new_supp_pkgs;
1987
1988   if ( !$opt->{'cust_pkg'} ) {
1989     # Order any supplemental packages.
1990     my $part_pkg = $cust_pkg->part_pkg;
1991     my @old_supp_pkgs = $self->supplemental_pkgs;
1992     foreach my $link ($part_pkg->supp_part_pkg_link) {
1993       my $old;
1994       foreach (@old_supp_pkgs) {
1995         if ($_->pkgpart == $link->dst_pkgpart) {
1996           $old = $_;
1997           $_->pkgpart(0); # so that it can't match more than once
1998         }
1999         last if $old;
2000       }
2001       # false laziness with FS::cust_main::Packages::order_pkg
2002       my $new = FS::cust_pkg->new({
2003           pkgpart       => $link->dst_pkgpart,
2004           pkglinknum    => $link->pkglinknum,
2005           custnum       => $custnum,
2006           main_pkgnum   => $cust_pkg->pkgnum,
2007           locationnum   => $cust_pkg->locationnum,
2008           start_date    => $cust_pkg->start_date,
2009           order_date    => $cust_pkg->order_date,
2010           expire        => $cust_pkg->expire,
2011           adjourn       => $cust_pkg->adjourn,
2012           contract_end  => $cust_pkg->contract_end,
2013           refnum        => $cust_pkg->refnum,
2014           discountnum   => $cust_pkg->discountnum,
2015           waive_setup   => $cust_pkg->waive_setup,
2016       });
2017       if ( $old and $opt->{'keep_dates'} ) {
2018         foreach (qw(setup bill last_bill)) {
2019           $new->set($_, $old->get($_));
2020         }
2021       }
2022       $error = $new->insert( allow_pkgpart => $same_pkgpart );
2023       # transfer services
2024       if ( $old ) {
2025         $error ||= $old->transfer($new);
2026       }
2027       if ( $error and $error > 0 ) {
2028         # no reason why this should ever fail, but still...
2029         $error = "Unable to transfer all services from supplemental package ".
2030           $old->pkgnum;
2031       }
2032       if ( $error ) {
2033         $dbh->rollback if $oldAutoCommit;
2034         return $error;
2035       }
2036       push @new_supp_pkgs, $new;
2037     }
2038   } # if !$opt->{'cust_pkg'}
2039     # because if there is one, then supplemental packages would already
2040     # have been created for it.
2041
2042   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
2043   #remaining time.
2044   #Don't allow billing the package (preceding period packages and/or
2045   #outstanding usage) if we are keeping dates (i.e. location changing),
2046   #because the new package will be billed for the same date range.
2047   #Supplemental packages are also canceled here.
2048
2049   # during scheduled changes, avoid canceling the package we just
2050   # changed to (duh)
2051   $self->set('change_to_pkgnum' => '');
2052
2053   $error = $self->cancel(
2054     quiet          => 1,
2055     unused_credit  => $unused_credit,
2056     nobill         => $keep_dates,
2057     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
2058   );
2059   if ($error) {
2060     $dbh->rollback if $oldAutoCommit;
2061     return $error;
2062   }
2063
2064   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
2065     #$self->cust_main
2066     my $error = $cust_pkg->cust_main->bill(
2067       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2068     );
2069     if ( $error ) {
2070       $dbh->rollback if $oldAutoCommit;
2071       return $error;
2072     }
2073   }
2074
2075   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2076
2077   $cust_pkg;
2078
2079 }
2080
2081 =item change_later OPTION => VALUE...
2082
2083 Schedule a package change for a later date.  This actually orders the new
2084 package immediately, but sets its start date for a future date, and sets
2085 the current package to expire on the same date.
2086
2087 If the package is already scheduled for a change, this can be called with
2088 'start_date' to change the scheduled date, or with pkgpart and/or
2089 locationnum to modify the package change.  To cancel the scheduled change
2090 entirely, see C<abort_change>.
2091
2092 Options include:
2093
2094 =over 4
2095
2096 =item start_date
2097
2098 The date for the package change.  Required, and must be in the future.
2099
2100 =item pkgpart
2101
2102 =item locationnum
2103
2104 =item quantity
2105
2106 The pkgpart. locationnum, and quantity of the new package, with the same
2107 meaning as in C<change>.
2108
2109 =back
2110
2111 =cut
2112
2113 sub change_later {
2114   my $self = shift;
2115   my $opt = ref($_[0]) ? shift : { @_ };
2116
2117   my $oldAutoCommit = $FS::UID::AutoCommit;
2118   local $FS::UID::AutoCommit = 0;
2119   my $dbh = dbh;
2120
2121   my $cust_main = $self->cust_main;
2122
2123   my $date = delete $opt->{'start_date'} or return 'start_date required';
2124
2125   if ( $date <= time ) {
2126     $dbh->rollback if $oldAutoCommit;
2127     return "start_date $date is in the past";
2128   }
2129
2130   my $error;
2131
2132   if ( $self->change_to_pkgnum ) {
2133     my $change_to = FS::cust_pkg->by_key($self->change_to_pkgnum);
2134     my $new_pkgpart = $opt->{'pkgpart'}
2135         if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $change_to->pkgpart;
2136     my $new_locationnum = $opt->{'locationnum'}
2137         if $opt->{'locationnum'} and $opt->{'locationnum'} != $change_to->locationnum;
2138     my $new_quantity = $opt->{'quantity'}
2139         if $opt->{'quantity'} and $opt->{'quantity'} != $change_to->quantity;
2140     if ( $new_pkgpart or $new_locationnum or $new_quantity ) {
2141       # it hasn't been billed yet, so in principle we could just edit
2142       # it in place (w/o a package change), but that's bad form.
2143       # So change the package according to the new options...
2144       my $err_or_pkg = $change_to->change(%$opt);
2145       if ( ref $err_or_pkg ) {
2146         # Then set that package up for a future start.
2147         $self->set('change_to_pkgnum', $err_or_pkg->pkgnum);
2148         $self->set('expire', $date); # in case it's different
2149         $err_or_pkg->set('start_date', $date);
2150         $err_or_pkg->set('change_date', '');
2151         $err_or_pkg->set('change_pkgnum', '');
2152
2153         $error = $self->replace       ||
2154                  $err_or_pkg->replace ||
2155                  $change_to->cancel   ||
2156                  $change_to->delete;
2157       } else {
2158         $error = $err_or_pkg;
2159       }
2160     } else { # change the start date only.
2161       $self->set('expire', $date);
2162       $change_to->set('start_date', $date);
2163       $error = $self->replace || $change_to->replace;
2164     }
2165     if ( $error ) {
2166       $dbh->rollback if $oldAutoCommit;
2167       return $error;
2168     } else {
2169       $dbh->commit if $oldAutoCommit;
2170       return '';
2171     }
2172   } # if $self->change_to_pkgnum
2173
2174   my $new_pkgpart = $opt->{'pkgpart'}
2175       if $opt->{'pkgpart'} and $opt->{'pkgpart'} != $self->pkgpart;
2176   my $new_locationnum = $opt->{'locationnum'}
2177       if $opt->{'locationnum'} and $opt->{'locationnum'} != $self->locationnum;
2178   my $new_quantity = $opt->{'quantity'}
2179       if $opt->{'quantity'} and $opt->{'quantity'} != $self->quantity;
2180
2181   return '' unless $new_pkgpart or $new_locationnum or $new_quantity; # wouldn't do anything
2182
2183   # allow $opt->{'locationnum'} = '' to specifically set it to null
2184   # (i.e. customer default location)
2185   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
2186
2187   my $new = FS::cust_pkg->new( {
2188     custnum     => $self->custnum,
2189     locationnum => $opt->{'locationnum'},
2190     start_date  => $date,
2191     map   {  $_ => ( $opt->{$_} || $self->$_() )  }
2192       qw( pkgpart quantity refnum salesnum )
2193   } );
2194   $error = $new->insert('change' => 1,
2195                         'allow_pkgpart' => ($new_pkgpart ? 0 : 1));
2196   if ( !$error ) {
2197     $self->set('change_to_pkgnum', $new->pkgnum);
2198     $self->set('expire', $date);
2199     $error = $self->replace;
2200   }
2201   if ( $error ) {
2202     $dbh->rollback if $oldAutoCommit;
2203   } else {
2204     $dbh->commit if $oldAutoCommit;
2205   }
2206
2207   $error;
2208 }
2209
2210 =item abort_change
2211
2212 Cancels a future package change scheduled by C<change_later>.
2213
2214 =cut
2215
2216 sub abort_change {
2217   my $self = shift;
2218   my $pkgnum = $self->change_to_pkgnum;
2219   my $change_to = FS::cust_pkg->by_key($pkgnum) if $pkgnum;
2220   my $error;
2221   if ( $change_to ) {
2222     $error = $change_to->cancel || $change_to->delete;
2223     return $error if $error;
2224   }
2225   $self->set('change_to_pkgnum', '');
2226   $self->set('expire', '');
2227   $self->replace;
2228 }
2229
2230 =item set_quantity QUANTITY
2231
2232 Change the package's quantity field.  This is one of the few package properties
2233 that can safely be changed without canceling and reordering the package
2234 (because it doesn't affect tax eligibility).  Returns an error or an
2235 empty string.
2236
2237 =cut
2238
2239 sub set_quantity {
2240   my $self = shift;
2241   $self = $self->replace_old; # just to make sure
2242   $self->quantity(shift);
2243   $self->replace;
2244 }
2245
2246 =item set_salesnum SALESNUM
2247
2248 Change the package's salesnum (sales person) field.  This is one of the few
2249 package properties that can safely be changed without canceling and reordering
2250 the package (because it doesn't affect tax eligibility).  Returns an error or
2251 an empty string.
2252
2253 =cut
2254
2255 sub set_salesnum {
2256   my $self = shift;
2257   $self = $self->replace_old; # just to make sure
2258   $self->salesnum(shift);
2259   $self->replace;
2260   # XXX this should probably reassign any credit that's already been given
2261 }
2262
2263 =item modify_charge OPTIONS
2264
2265 Change the properties of a one-time charge.  Currently the only properties
2266 that can be changed this way are those that have no impact on billing
2267 calculations:
2268 - pkg: the package description
2269 - classnum: the package class
2270 - additional: arrayref of additional invoice details to add to this package
2271
2272 If you pass 'adjust_commission' => 1, and the classnum changes, and there are
2273 commission credits linked to this charge, they will be recalculated.
2274
2275 =cut
2276
2277 sub modify_charge {
2278   my $self = shift;
2279   my %opt = @_;
2280   my $part_pkg = $self->part_pkg;
2281   my $pkgnum = $self->pkgnum;
2282
2283   my $dbh = dbh;
2284   my $oldAutoCommit = $FS::UID::AutoCommit;
2285   local $FS::UID::AutoCommit = 0;
2286
2287   return "Can't use modify_charge except on one-time charges"
2288     unless $part_pkg->freq eq '0';
2289
2290   if ( length($opt{'pkg'}) and $part_pkg->pkg ne $opt{'pkg'} ) {
2291     $part_pkg->set('pkg', $opt{'pkg'});
2292   }
2293
2294   my %pkg_opt = $part_pkg->options;
2295   if ( ref($opt{'additional'}) ) {
2296     delete $pkg_opt{$_} foreach grep /^additional/, keys %pkg_opt;
2297     my $i;
2298     for ( $i = 0; exists($opt{'additional'}->[$i]); $i++ ) {
2299       $pkg_opt{ "additional_info$i" } = $opt{'additional'}->[$i];
2300     }
2301     $pkg_opt{'additional_count'} = $i if $i > 0;
2302   }
2303
2304   my $old_classnum;
2305   if ( exists($opt{'classnum'}) and $part_pkg->classnum ne $opt{'classnum'} ) {
2306     # remember it
2307     $old_classnum = $part_pkg->classnum;
2308     $part_pkg->set('classnum', $opt{'classnum'});
2309   }
2310
2311   my $error = $part_pkg->replace( options => \%pkg_opt );
2312   return $error if $error;
2313
2314   if (defined $old_classnum) {
2315     # fix invoice grouping records
2316     my $old_catname = $old_classnum
2317                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2318                       : '';
2319     my $new_catname = $opt{'classnum'}
2320                       ? $part_pkg->pkg_class->categoryname
2321                       : '';
2322     if ( $old_catname ne $new_catname ) {
2323       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2324         # (there should only be one...)
2325         my @display = qsearch( 'cust_bill_pkg_display', {
2326             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2327             'section'     => $old_catname,
2328         });
2329         foreach (@display) {
2330           $_->set('section', $new_catname);
2331           $error = $_->replace;
2332           if ( $error ) {
2333             $dbh->rollback if $oldAutoCommit;
2334             return $error;
2335           }
2336         }
2337       } # foreach $cust_bill_pkg
2338     }
2339
2340     if ( $opt{'adjust_commission'} ) {
2341       # fix commission credits...tricky.
2342       foreach my $cust_event ($self->cust_event) {
2343         my $part_event = $cust_event->part_event;
2344         foreach my $table (qw(sales agent)) {
2345           my $class =
2346             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2347           my $credit = qsearchs('cust_credit', {
2348               'eventnum' => $cust_event->eventnum,
2349           });
2350           if ( $part_event->isa($class) ) {
2351             # Yes, this results in current commission rates being applied
2352             # retroactively to a one-time charge.  For accounting purposes
2353             # there ought to be some kind of time limit on doing this.
2354             my $amount = $part_event->_calc_credit($self);
2355             if ( $credit and $credit->amount ne $amount ) {
2356               # Void the old credit.
2357               $error = $credit->void('Package class changed');
2358               if ( $error ) {
2359                 $dbh->rollback if $oldAutoCommit;
2360                 return "$error (adjusting commission credit)";
2361               }
2362             }
2363             # redo the event action to recreate the credit.
2364             local $@ = '';
2365             eval { $part_event->do_action( $self, $cust_event ) };
2366             if ( $@ ) {
2367               $dbh->rollback if $oldAutoCommit;
2368               return $@;
2369             }
2370           } # if $part_event->isa($class)
2371         } # foreach $table
2372       } # foreach $cust_event
2373     } # if $opt{'adjust_commission'}
2374   } # if defined $old_classnum
2375
2376   $dbh->commit if $oldAutoCommit;
2377   '';
2378 }
2379
2380
2381
2382 use Storable 'thaw';
2383 use MIME::Base64;
2384 use Data::Dumper;
2385 sub process_bulk_cust_pkg {
2386   my $job = shift;
2387   my $param = thaw(decode_base64(shift));
2388   warn Dumper($param) if $DEBUG;
2389
2390   my $old_part_pkg = qsearchs('part_pkg',
2391                               { pkgpart => $param->{'old_pkgpart'} });
2392   my $new_part_pkg = qsearchs('part_pkg',
2393                               { pkgpart => $param->{'new_pkgpart'} });
2394   die "Must select a new package type\n" unless $new_part_pkg;
2395   #my $keep_dates = $param->{'keep_dates'} || 0;
2396   my $keep_dates = 1; # there is no good reason to turn this off
2397
2398   local $SIG{HUP} = 'IGNORE';
2399   local $SIG{INT} = 'IGNORE';
2400   local $SIG{QUIT} = 'IGNORE';
2401   local $SIG{TERM} = 'IGNORE';
2402   local $SIG{TSTP} = 'IGNORE';
2403   local $SIG{PIPE} = 'IGNORE';
2404
2405   my $oldAutoCommit = $FS::UID::AutoCommit;
2406   local $FS::UID::AutoCommit = 0;
2407   my $dbh = dbh;
2408
2409   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2410
2411   my $i = 0;
2412   foreach my $old_cust_pkg ( @cust_pkgs ) {
2413     $i++;
2414     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2415     if ( $old_cust_pkg->getfield('cancel') ) {
2416       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2417         $old_cust_pkg->pkgnum."\n"
2418         if $DEBUG;
2419       next;
2420     }
2421     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2422       if $DEBUG;
2423     my $error = $old_cust_pkg->change(
2424       'pkgpart'     => $param->{'new_pkgpart'},
2425       'keep_dates'  => $keep_dates
2426     );
2427     if ( !ref($error) ) { # change returns the cust_pkg on success
2428       $dbh->rollback;
2429       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2430     }
2431   }
2432   $dbh->commit if $oldAutoCommit;
2433   return;
2434 }
2435
2436 =item last_bill
2437
2438 Returns the last bill date, or if there is no last bill date, the setup date.
2439 Useful for billing metered services.
2440
2441 =cut
2442
2443 sub last_bill {
2444   my $self = shift;
2445   return $self->setfield('last_bill', $_[0]) if @_;
2446   return $self->getfield('last_bill') if $self->getfield('last_bill');
2447   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2448                                                   'edate'  => $self->bill,  } );
2449   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2450 }
2451
2452 =item last_cust_pkg_reason ACTION
2453
2454 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2455 Returns false if there is no reason or the package is not currenly ACTION'd
2456 ACTION is one of adjourn, susp, cancel, or expire.
2457
2458 =cut
2459
2460 sub last_cust_pkg_reason {
2461   my ( $self, $action ) = ( shift, shift );
2462   my $date = $self->get($action);
2463   qsearchs( {
2464               'table' => 'cust_pkg_reason',
2465               'hashref' => { 'pkgnum' => $self->pkgnum,
2466                              'action' => substr(uc($action), 0, 1),
2467                              'date'   => $date,
2468                            },
2469               'order_by' => 'ORDER BY num DESC LIMIT 1',
2470            } );
2471 }
2472
2473 =item last_reason ACTION
2474
2475 Returns the most recent ACTION FS::reason associated with the package.
2476 Returns false if there is no reason or the package is not currenly ACTION'd
2477 ACTION is one of adjourn, susp, cancel, or expire.
2478
2479 =cut
2480
2481 sub last_reason {
2482   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2483   $cust_pkg_reason->reason
2484     if $cust_pkg_reason;
2485 }
2486
2487 =item part_pkg
2488
2489 Returns the definition for this billing item, as an FS::part_pkg object (see
2490 L<FS::part_pkg>).
2491
2492 =cut
2493
2494 sub part_pkg {
2495   my $self = shift;
2496   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2497   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2498   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2499 }
2500
2501 =item old_cust_pkg
2502
2503 Returns the cancelled package this package was changed from, if any.
2504
2505 =cut
2506
2507 sub old_cust_pkg {
2508   my $self = shift;
2509   return '' unless $self->change_pkgnum;
2510   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2511 }
2512
2513 =item change_cust_main
2514
2515 Returns the customter this package was detached to, if any.
2516
2517 =cut
2518
2519 sub change_cust_main {
2520   my $self = shift;
2521   return '' unless $self->change_custnum;
2522   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2523 }
2524
2525 =item calc_setup
2526
2527 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2528 item.
2529
2530 =cut
2531
2532 sub calc_setup {
2533   my $self = shift;
2534   $self->part_pkg->calc_setup($self, @_);
2535 }
2536
2537 =item calc_recur
2538
2539 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2540 item.
2541
2542 =cut
2543
2544 sub calc_recur {
2545   my $self = shift;
2546   $self->part_pkg->calc_recur($self, @_);
2547 }
2548
2549 =item base_setup
2550
2551 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2552 item.
2553
2554 =cut
2555
2556 sub base_setup {
2557   my $self = shift;
2558   $self->part_pkg->base_setup($self, @_);
2559 }
2560
2561 =item base_recur
2562
2563 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2564 item.
2565
2566 =cut
2567
2568 sub base_recur {
2569   my $self = shift;
2570   $self->part_pkg->base_recur($self, @_);
2571 }
2572
2573 =item calc_remain
2574
2575 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2576 billing item.
2577
2578 =cut
2579
2580 sub calc_remain {
2581   my $self = shift;
2582   $self->part_pkg->calc_remain($self, @_);
2583 }
2584
2585 =item calc_cancel
2586
2587 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2588 billing item.
2589
2590 =cut
2591
2592 sub calc_cancel {
2593   my $self = shift;
2594   $self->part_pkg->calc_cancel($self, @_);
2595 }
2596
2597 =item cust_bill_pkg
2598
2599 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2600
2601 =cut
2602
2603 sub cust_bill_pkg {
2604   my $self = shift;
2605   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2606 }
2607
2608 =item cust_pkg_detail [ DETAILTYPE ]
2609
2610 Returns any customer package details for this package (see
2611 L<FS::cust_pkg_detail>).
2612
2613 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2614
2615 =cut
2616
2617 sub cust_pkg_detail {
2618   my $self = shift;
2619   my %hash = ( 'pkgnum' => $self->pkgnum );
2620   $hash{detailtype} = shift if @_;
2621   qsearch({
2622     'table'    => 'cust_pkg_detail',
2623     'hashref'  => \%hash,
2624     'order_by' => 'ORDER BY weight, pkgdetailnum',
2625   });
2626 }
2627
2628 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2629
2630 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2631
2632 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2633
2634 If there is an error, returns the error, otherwise returns false.
2635
2636 =cut
2637
2638 sub set_cust_pkg_detail {
2639   my( $self, $detailtype, @details ) = @_;
2640
2641   local $SIG{HUP} = 'IGNORE';
2642   local $SIG{INT} = 'IGNORE';
2643   local $SIG{QUIT} = 'IGNORE';
2644   local $SIG{TERM} = 'IGNORE';
2645   local $SIG{TSTP} = 'IGNORE';
2646   local $SIG{PIPE} = 'IGNORE';
2647
2648   my $oldAutoCommit = $FS::UID::AutoCommit;
2649   local $FS::UID::AutoCommit = 0;
2650   my $dbh = dbh;
2651
2652   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2653     my $error = $current->delete;
2654     if ( $error ) {
2655       $dbh->rollback if $oldAutoCommit;
2656       return "error removing old detail: $error";
2657     }
2658   }
2659
2660   foreach my $detail ( @details ) {
2661     my $cust_pkg_detail = new FS::cust_pkg_detail {
2662       'pkgnum'     => $self->pkgnum,
2663       'detailtype' => $detailtype,
2664       'detail'     => $detail,
2665     };
2666     my $error = $cust_pkg_detail->insert;
2667     if ( $error ) {
2668       $dbh->rollback if $oldAutoCommit;
2669       return "error adding new detail: $error";
2670     }
2671
2672   }
2673
2674   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2675   '';
2676
2677 }
2678
2679 =item cust_event
2680
2681 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2682
2683 =cut
2684
2685 #false laziness w/cust_bill.pm
2686 sub cust_event {
2687   my $self = shift;
2688   qsearch({
2689     'table'     => 'cust_event',
2690     'addl_from' => 'JOIN part_event USING ( eventpart )',
2691     'hashref'   => { 'tablenum' => $self->pkgnum },
2692     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2693   });
2694 }
2695
2696 =item num_cust_event
2697
2698 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2699
2700 =cut
2701
2702 #false laziness w/cust_bill.pm
2703 sub num_cust_event {
2704   my $self = shift;
2705   my $sql =
2706     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2707     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2708   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2709   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2710   $sth->fetchrow_arrayref->[0];
2711 }
2712
2713 =item part_pkg_currency_option OPTIONNAME
2714
2715 Returns a two item list consisting of the currency of this customer, if any,
2716 and a value for the provided option.  If the customer has a currency, the value
2717 is the option value the given name and the currency (see
2718 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
2719 regular option value for the given name (see L<FS::part_pkg_option>).
2720
2721 =cut
2722
2723 sub part_pkg_currency_option {
2724   my( $self, $optionname ) = @_;
2725   my $part_pkg = $self->part_pkg;
2726   if ( my $currency = $self->cust_main->currency ) {
2727     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2728   } else {
2729     ('', $part_pkg->option($optionname) );
2730   }
2731 }
2732
2733 =item cust_svc [ SVCPART ] (old, deprecated usage)
2734
2735 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2736
2737 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2738
2739 Returns the services for this package, as FS::cust_svc objects (see
2740 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2741 spcififed, returns only the matching services.
2742
2743 As an optimization, use the cust_svc_unsorted version if you are not displaying
2744 the results.
2745
2746 =cut
2747
2748 sub cust_svc {
2749   my $self = shift;
2750   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2751   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref );
2752 }
2753
2754 sub cust_svc_unsorted {
2755   my $self = shift;
2756   @{ $self->cust_svc_unsorted_arrayref };
2757 }
2758
2759 sub cust_svc_unsorted_arrayref {
2760   my $self = shift;
2761
2762   return () unless $self->num_cust_svc(@_);
2763
2764   my %opt = ();
2765   if ( @_ && $_[0] =~ /^\d+/ ) {
2766     $opt{svcpart} = shift;
2767   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2768     %opt = %{ $_[0] };
2769   } elsif ( @_ ) {
2770     %opt = @_;
2771   }
2772
2773   my %search = (
2774     'table'   => 'cust_svc',
2775     'hashref' => { 'pkgnum' => $self->pkgnum },
2776   );
2777   if ( $opt{svcpart} ) {
2778     $search{hashref}->{svcpart} = $opt{'svcpart'};
2779   }
2780   if ( $opt{'svcdb'} ) {
2781     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2782     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2783   }
2784
2785   [ qsearch(\%search) ];
2786
2787 }
2788
2789 =item overlimit [ SVCPART ]
2790
2791 Returns the services for this package which have exceeded their
2792 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2793 is specified, return only the matching services.
2794
2795 =cut
2796
2797 sub overlimit {
2798   my $self = shift;
2799   return () unless $self->num_cust_svc(@_);
2800   grep { $_->overlimit } $self->cust_svc(@_);
2801 }
2802
2803 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2804
2805 Returns historical services for this package created before END TIMESTAMP and
2806 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2807 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2808 I<pkg_svc.hidden> flag will be omitted.
2809
2810 =cut
2811
2812 sub h_cust_svc {
2813   my $self = shift;
2814   warn "$me _h_cust_svc called on $self\n"
2815     if $DEBUG;
2816
2817   my ($end, $start, $mode) = @_;
2818   my @cust_svc = $self->_sort_cust_svc(
2819     [ qsearch( 'h_cust_svc',
2820       { 'pkgnum' => $self->pkgnum, },
2821       FS::h_cust_svc->sql_h_search(@_),
2822     ) ]
2823   );
2824   if ( defined($mode) && $mode eq 'I' ) {
2825     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2826     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2827   } else {
2828     return @cust_svc;
2829   }
2830 }
2831
2832 sub _sort_cust_svc {
2833   my( $self, $arrayref ) = @_;
2834
2835   my $sort =
2836     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2837
2838   my %pkg_svc = map { $_->svcpart => $_ }
2839                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2840
2841   map  { $_->[0] }
2842   sort $sort
2843   map {
2844         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2845         [ $_,
2846           $pkg_svc ? $pkg_svc->primary_svc : '',
2847           $pkg_svc ? $pkg_svc->quantity : 0,
2848         ];
2849       }
2850   @$arrayref;
2851
2852 }
2853
2854 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2855
2856 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2857
2858 Returns the number of services for this package.  Available options are svcpart
2859 and svcdb.  If either is spcififed, returns only the matching services.
2860
2861 =cut
2862
2863 sub num_cust_svc {
2864   my $self = shift;
2865
2866   return $self->{'_num_cust_svc'}
2867     if !scalar(@_)
2868        && exists($self->{'_num_cust_svc'})
2869        && $self->{'_num_cust_svc'} =~ /\d/;
2870
2871   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2872     if $DEBUG > 2;
2873
2874   my %opt = ();
2875   if ( @_ && $_[0] =~ /^\d+/ ) {
2876     $opt{svcpart} = shift;
2877   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2878     %opt = %{ $_[0] };
2879   } elsif ( @_ ) {
2880     %opt = @_;
2881   }
2882
2883   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2884   my $where = ' WHERE pkgnum = ? ';
2885   my @param = ($self->pkgnum);
2886
2887   if ( $opt{'svcpart'} ) {
2888     $where .= ' AND svcpart = ? ';
2889     push @param, $opt{'svcpart'};
2890   }
2891   if ( $opt{'svcdb'} ) {
2892     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2893     $where .= ' AND svcdb = ? ';
2894     push @param, $opt{'svcdb'};
2895   }
2896
2897   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2898   $sth->execute(@param) or die $sth->errstr;
2899   $sth->fetchrow_arrayref->[0];
2900 }
2901
2902 =item available_part_svc
2903
2904 Returns a list of FS::part_svc objects representing services included in this
2905 package but not yet provisioned.  Each FS::part_svc object also has an extra
2906 field, I<num_avail>, which specifies the number of available services.
2907
2908 =cut
2909
2910 sub available_part_svc {
2911   my $self = shift;
2912
2913   my $pkg_quantity = $self->quantity || 1;
2914
2915   grep { $_->num_avail > 0 }
2916     map {
2917           my $part_svc = $_->part_svc;
2918           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2919             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2920
2921           # more evil encapsulation breakage
2922           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2923             my @exports = $part_svc->part_export_did;
2924             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2925           }
2926
2927           $part_svc;
2928         }
2929       $self->part_pkg->pkg_svc;
2930 }
2931
2932 =item part_svc [ OPTION => VALUE ... ]
2933
2934 Returns a list of FS::part_svc objects representing provisioned and available
2935 services included in this package.  Each FS::part_svc object also has the
2936 following extra fields:
2937
2938 =over 4
2939
2940 =item num_cust_svc  (count)
2941
2942 =item num_avail     (quantity - count)
2943
2944 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2945
2946 =back
2947
2948 Accepts one option: summarize_size.  If specified and non-zero, will omit the
2949 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2950 greater.
2951
2952 =cut
2953
2954 #svcnum
2955 #label -> ($cust_svc->label)[1]
2956
2957 sub part_svc {
2958   my $self = shift;
2959   my %opt = @_;
2960
2961   my $pkg_quantity = $self->quantity || 1;
2962
2963   #XXX some sort of sort order besides numeric by svcpart...
2964   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2965     my $pkg_svc = $_;
2966     my $part_svc = $pkg_svc->part_svc;
2967     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2968     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2969     $part_svc->{'Hash'}{'num_avail'}    =
2970       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2971     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2972         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2973       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2974           && $num_cust_svc >= $opt{summarize_size};
2975     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2976     $part_svc;
2977   } $self->part_pkg->pkg_svc;
2978
2979   #extras
2980   push @part_svc, map {
2981     my $part_svc = $_;
2982     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2983     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2984     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
2985     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2986       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2987     $part_svc;
2988   } $self->extra_part_svc;
2989
2990   @part_svc;
2991
2992 }
2993
2994 =item extra_part_svc
2995
2996 Returns a list of FS::part_svc objects corresponding to services in this
2997 package which are still provisioned but not (any longer) available in the
2998 package definition.
2999
3000 =cut
3001
3002 sub extra_part_svc {
3003   my $self = shift;
3004
3005   my $pkgnum  = $self->pkgnum;
3006   #my $pkgpart = $self->pkgpart;
3007
3008 #  qsearch( {
3009 #    'table'     => 'part_svc',
3010 #    'hashref'   => {},
3011 #    'extra_sql' =>
3012 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3013 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3014 #                       AND pkg_svc.pkgpart = ?
3015 #                       AND quantity > 0
3016 #                 )
3017 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3018 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3019 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3020 #                       AND pkgnum = ?
3021 #                 )",
3022 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3023 #  } );
3024
3025 #seems to benchmark slightly faster... (or did?)
3026
3027   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3028   my $pkgparts = join(',', @pkgparts);
3029
3030   qsearch( {
3031     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3032     #MySQL doesn't grok DISINCT ON
3033     'select'      => 'DISTINCT part_svc.*',
3034     'table'       => 'part_svc',
3035     'addl_from'   =>
3036       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3037                                AND pkg_svc.pkgpart IN ($pkgparts)
3038                                AND quantity > 0
3039                              )
3040        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3041        LEFT JOIN cust_pkg USING ( pkgnum )
3042       ",
3043     'hashref'     => {},
3044     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3045     'extra_param' => [ [$self->pkgnum=>'int'] ],
3046   } );
3047 }
3048
3049 =item status
3050
3051 Returns a short status string for this package, currently:
3052
3053 =over 4
3054
3055 =item not yet billed
3056
3057 =item one-time charge
3058
3059 =item active
3060
3061 =item suspended
3062
3063 =item cancelled
3064
3065 =back
3066
3067 =cut
3068
3069 sub status {
3070   my $self = shift;
3071
3072   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3073
3074   return 'cancelled' if $self->get('cancel');
3075   return 'suspended' if $self->susp;
3076   return 'not yet billed' unless $self->setup;
3077   return 'one-time charge' if $freq =~ /^(0|$)/;
3078   return 'active';
3079 }
3080
3081 =item ucfirst_status
3082
3083 Returns the status with the first character capitalized.
3084
3085 =cut
3086
3087 sub ucfirst_status {
3088   ucfirst(shift->status);
3089 }
3090
3091 =item statuses
3092
3093 Class method that returns the list of possible status strings for packages
3094 (see L<the status method|/status>).  For example:
3095
3096   @statuses = FS::cust_pkg->statuses();
3097
3098 =cut
3099
3100 tie my %statuscolor, 'Tie::IxHash',
3101   'not yet billed'  => '009999', #teal? cyan?
3102   'one-time charge' => '000000',
3103   'active'          => '00CC00',
3104   'suspended'       => 'FF9900',
3105   'cancelled'       => 'FF0000',
3106 ;
3107
3108 sub statuses {
3109   my $self = shift; #could be class...
3110   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3111   #                                    # mayble split btw one-time vs. recur
3112     keys %statuscolor;
3113 }
3114
3115 =item statuscolor
3116
3117 Returns a hex triplet color string for this package's status.
3118
3119 =cut
3120
3121 sub statuscolor {
3122   my $self = shift;
3123   $statuscolor{$self->status};
3124 }
3125
3126 =item pkg_label
3127
3128 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3129 "pkg - comment" depending on user preference).
3130
3131 =cut
3132
3133 sub pkg_label {
3134   my $self = shift;
3135   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3136   $label = $self->pkgnum. ": $label"
3137     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3138   $label;
3139 }
3140
3141 =item pkg_label_long
3142
3143 Returns a long label for this package, adding the primary service's label to
3144 pkg_label.
3145
3146 =cut
3147
3148 sub pkg_label_long {
3149   my $self = shift;
3150   my $label = $self->pkg_label;
3151   my $cust_svc = $self->primary_cust_svc;
3152   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3153   $label;
3154 }
3155
3156 =item pkg_locale
3157
3158 Returns a customer-localized label for this package.
3159
3160 =cut
3161
3162 sub pkg_locale {
3163   my $self = shift;
3164   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3165 }
3166
3167 =item primary_cust_svc
3168
3169 Returns a primary service (as FS::cust_svc object) if one can be identified.
3170
3171 =cut
3172
3173 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3174
3175 sub primary_cust_svc {
3176   my $self = shift;
3177
3178   my @cust_svc = $self->cust_svc;
3179
3180   return '' unless @cust_svc; #no serivces - irrelevant then
3181
3182   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3183
3184   # primary service as specified in the package definition
3185   # or exactly one service definition with quantity one
3186   my $svcpart = $self->part_pkg->svcpart;
3187   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3188   return $cust_svc[0] if scalar(@cust_svc) == 1;
3189
3190   #couldn't identify one thing..
3191   return '';
3192 }
3193
3194 =item labels
3195
3196 Returns a list of lists, calling the label method for all services
3197 (see L<FS::cust_svc>) of this billing item.
3198
3199 =cut
3200
3201 sub labels {
3202   my $self = shift;
3203   map { [ $_->label ] } $self->cust_svc;
3204 }
3205
3206 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3207
3208 Like the labels method, but returns historical information on services that
3209 were active as of END_TIMESTAMP and (optionally) not cancelled before
3210 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3211 I<pkg_svc.hidden> flag will be omitted.
3212
3213 Returns a list of lists, calling the label method for all (historical) services
3214 (see L<FS::h_cust_svc>) of this billing item.
3215
3216 =cut
3217
3218 sub h_labels {
3219   my $self = shift;
3220   warn "$me _h_labels called on $self\n"
3221     if $DEBUG;
3222   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3223 }
3224
3225 =item labels_short
3226
3227 Like labels, except returns a simple flat list, and shortens long
3228 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3229 identical services to one line that lists the service label and the number of
3230 individual services rather than individual items.
3231
3232 =cut
3233
3234 sub labels_short {
3235   shift->_labels_short( 'labels', @_ );
3236 }
3237
3238 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3239
3240 Like h_labels, except returns a simple flat list, and shortens long
3241 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3242 identical services to one line that lists the service label and the number of
3243 individual services rather than individual items.
3244
3245 =cut
3246
3247 sub h_labels_short {
3248   shift->_labels_short( 'h_labels', @_ );
3249 }
3250
3251 sub _labels_short {
3252   my( $self, $method ) = ( shift, shift );
3253
3254   warn "$me _labels_short called on $self with $method method\n"
3255     if $DEBUG;
3256
3257   my $conf = new FS::Conf;
3258   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3259
3260   warn "$me _labels_short populating \%labels\n"
3261     if $DEBUG;
3262
3263   my %labels;
3264   #tie %labels, 'Tie::IxHash';
3265   push @{ $labels{$_->[0]} }, $_->[1]
3266     foreach $self->$method(@_);
3267
3268   warn "$me _labels_short populating \@labels\n"
3269     if $DEBUG;
3270
3271   my @labels;
3272   foreach my $label ( keys %labels ) {
3273     my %seen = ();
3274     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3275     my $num = scalar(@values);
3276     warn "$me _labels_short $num items for $label\n"
3277       if $DEBUG;
3278
3279     if ( $num > $max_same_services ) {
3280       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3281         if $DEBUG;
3282       push @labels, "$label ($num)";
3283     } else {
3284       if ( $conf->exists('cust_bill-consolidate_services') ) {
3285         warn "$me _labels_short   consolidating services\n"
3286           if $DEBUG;
3287         # push @labels, "$label: ". join(', ', @values);
3288         while ( @values ) {
3289           my $detail = "$label: ";
3290           $detail .= shift(@values). ', '
3291             while @values
3292                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3293           $detail =~ s/, $//;
3294           push @labels, $detail;
3295         }
3296         warn "$me _labels_short   done consolidating services\n"
3297           if $DEBUG;
3298       } else {
3299         warn "$me _labels_short   adding service data\n"
3300           if $DEBUG;
3301         push @labels, map { "$label: $_" } @values;
3302       }
3303     }
3304   }
3305
3306  @labels;
3307
3308 }
3309
3310 =item cust_main
3311
3312 Returns the parent customer object (see L<FS::cust_main>).
3313
3314 =cut
3315
3316 sub cust_main {
3317   my $self = shift;
3318   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3319 }
3320
3321 =item balance
3322
3323 Returns the balance for this specific package, when using
3324 experimental package balance.
3325
3326 =cut
3327
3328 sub balance {
3329   my $self = shift;
3330   $self->cust_main->balance_pkgnum( $self->pkgnum );
3331 }
3332
3333 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3334
3335 =item cust_location
3336
3337 Returns the location object, if any (see L<FS::cust_location>).
3338
3339 =item cust_location_or_main
3340
3341 If this package is associated with a location, returns the locaiton (see
3342 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3343
3344 =item location_label [ OPTION => VALUE ... ]
3345
3346 Returns the label of the location object (see L<FS::cust_location>).
3347
3348 =cut
3349
3350 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3351
3352 =item tax_locationnum
3353
3354 Returns the foreign key to a L<FS::cust_location> object for calculating
3355 tax on this package, as determined by the C<tax-pkg_address> and
3356 C<tax-ship_address> configuration flags.
3357
3358 =cut
3359
3360 sub tax_locationnum {
3361   my $self = shift;
3362   my $conf = FS::Conf->new;
3363   if ( $conf->exists('tax-pkg_address') ) {
3364     return $self->locationnum;
3365   }
3366   elsif ( $conf->exists('tax-ship_address') ) {
3367     return $self->cust_main->ship_locationnum;
3368   }
3369   else {
3370     return $self->cust_main->bill_locationnum;
3371   }
3372 }
3373
3374 =item tax_location
3375
3376 Returns the L<FS::cust_location> object for tax_locationnum.
3377
3378 =cut
3379
3380 sub tax_location {
3381   my $self = shift;
3382   FS::cust_location->by_key( $self->tax_locationnum )
3383 }
3384
3385 =item seconds_since TIMESTAMP
3386
3387 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3388 package have been online since TIMESTAMP, according to the session monitor.
3389
3390 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3391 L<Time::Local> and L<Date::Parse> for conversion functions.
3392
3393 =cut
3394
3395 sub seconds_since {
3396   my($self, $since) = @_;
3397   my $seconds = 0;
3398
3399   foreach my $cust_svc (
3400     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3401   ) {
3402     $seconds += $cust_svc->seconds_since($since);
3403   }
3404
3405   $seconds;
3406
3407 }
3408
3409 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3410
3411 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3412 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3413 (exclusive).
3414
3415 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3416 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3417 functions.
3418
3419
3420 =cut
3421
3422 sub seconds_since_sqlradacct {
3423   my($self, $start, $end) = @_;
3424
3425   my $seconds = 0;
3426
3427   foreach my $cust_svc (
3428     grep {
3429       my $part_svc = $_->part_svc;
3430       $part_svc->svcdb eq 'svc_acct'
3431         && scalar($part_svc->part_export_usage);
3432     } $self->cust_svc
3433   ) {
3434     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3435   }
3436
3437   $seconds;
3438
3439 }
3440
3441 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3442
3443 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3444 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3445 TIMESTAMP_END
3446 (exclusive).
3447
3448 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3449 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3450 functions.
3451
3452 =cut
3453
3454 sub attribute_since_sqlradacct {
3455   my($self, $start, $end, $attrib) = @_;
3456
3457   my $sum = 0;
3458
3459   foreach my $cust_svc (
3460     grep {
3461       my $part_svc = $_->part_svc;
3462       $part_svc->svcdb eq 'svc_acct'
3463         && scalar($part_svc->part_export_usage);
3464     } $self->cust_svc
3465   ) {
3466     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3467   }
3468
3469   $sum;
3470
3471 }
3472
3473 =item quantity
3474
3475 =cut
3476
3477 sub quantity {
3478   my( $self, $value ) = @_;
3479   if ( defined($value) ) {
3480     $self->setfield('quantity', $value);
3481   }
3482   $self->getfield('quantity') || 1;
3483 }
3484
3485 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3486
3487 Transfers as many services as possible from this package to another package.
3488
3489 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3490 object.  The destination package must already exist.
3491
3492 Services are moved only if the destination allows services with the correct
3493 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3494 this option with caution!  No provision is made for export differences
3495 between the old and new service definitions.  Probably only should be used
3496 when your exports for all service definitions of a given svcdb are identical.
3497 (attempt a transfer without it first, to move all possible svcpart-matching
3498 services)
3499
3500 Any services that can't be moved remain in the original package.
3501
3502 Returns an error, if there is one; otherwise, returns the number of services
3503 that couldn't be moved.
3504
3505 =cut
3506
3507 sub transfer {
3508   my ($self, $dest_pkgnum, %opt) = @_;
3509
3510   my $remaining = 0;
3511   my $dest;
3512   my %target;
3513
3514   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3515     $dest = $dest_pkgnum;
3516     $dest_pkgnum = $dest->pkgnum;
3517   } else {
3518     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3519   }
3520
3521   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3522
3523   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3524     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3525   }
3526
3527   foreach my $cust_svc ($dest->cust_svc) {
3528     $target{$cust_svc->svcpart}--;
3529   }
3530
3531   my %svcpart2svcparts = ();
3532   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3533     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3534     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3535       next if exists $svcpart2svcparts{$svcpart};
3536       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3537       $svcpart2svcparts{$svcpart} = [
3538         map  { $_->[0] }
3539         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3540         map {
3541               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3542                                                    'svcpart' => $_          } );
3543               [ $_,
3544                 $pkg_svc ? $pkg_svc->primary_svc : '',
3545                 $pkg_svc ? $pkg_svc->quantity : 0,
3546               ];
3547             }
3548
3549         grep { $_ != $svcpart }
3550         map  { $_->svcpart }
3551         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3552       ];
3553       warn "alternates for svcpart $svcpart: ".
3554            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3555         if $DEBUG;
3556     }
3557   }
3558
3559   foreach my $cust_svc ($self->cust_svc) {
3560     if($target{$cust_svc->svcpart} > 0
3561        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3562       $target{$cust_svc->svcpart}--;
3563       my $new = new FS::cust_svc { $cust_svc->hash };
3564       $new->pkgnum($dest_pkgnum);
3565       my $error = $new->replace($cust_svc);
3566       return $error if $error;
3567     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3568       if ( $DEBUG ) {
3569         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3570         warn "alternates to consider: ".
3571              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3572       }
3573       my @alternate = grep {
3574                              warn "considering alternate svcpart $_: ".
3575                                   "$target{$_} available in new package\n"
3576                                if $DEBUG;
3577                              $target{$_} > 0;
3578                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3579       if ( @alternate ) {
3580         warn "alternate(s) found\n" if $DEBUG;
3581         my $change_svcpart = $alternate[0];
3582         $target{$change_svcpart}--;
3583         my $new = new FS::cust_svc { $cust_svc->hash };
3584         $new->svcpart($change_svcpart);
3585         $new->pkgnum($dest_pkgnum);
3586         my $error = $new->replace($cust_svc);
3587         return $error if $error;
3588       } else {
3589         $remaining++;
3590       }
3591     } else {
3592       $remaining++
3593     }
3594   }
3595   return $remaining;
3596 }
3597
3598 =item grab_svcnums SVCNUM, SVCNUM ...
3599
3600 Change the pkgnum for the provided services to this packages.  If there is an
3601 error, returns the error, otherwise returns false.
3602
3603 =cut
3604
3605 sub grab_svcnums {
3606   my $self = shift;
3607   my @svcnum = @_;
3608
3609   local $SIG{HUP} = 'IGNORE';
3610   local $SIG{INT} = 'IGNORE';
3611   local $SIG{QUIT} = 'IGNORE';
3612   local $SIG{TERM} = 'IGNORE';
3613   local $SIG{TSTP} = 'IGNORE';
3614   local $SIG{PIPE} = 'IGNORE';
3615
3616   my $oldAutoCommit = $FS::UID::AutoCommit;
3617   local $FS::UID::AutoCommit = 0;
3618   my $dbh = dbh;
3619
3620   foreach my $svcnum (@svcnum) {
3621     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3622       $dbh->rollback if $oldAutoCommit;
3623       return "unknown svcnum $svcnum";
3624     };
3625     $cust_svc->pkgnum( $self->pkgnum );
3626     my $error = $cust_svc->replace;
3627     if ( $error ) {
3628       $dbh->rollback if $oldAutoCommit;
3629       return $error;
3630     }
3631   }
3632
3633   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3634   '';
3635
3636 }
3637
3638 =item reexport
3639
3640 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3641 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3642
3643 =cut
3644
3645 #looks like this is still used by the order_pkg and change_pkg methods in
3646 # ClientAPI/MyAccount, need to look into those before removing
3647 sub reexport {
3648   my $self = shift;
3649
3650   local $SIG{HUP} = 'IGNORE';
3651   local $SIG{INT} = 'IGNORE';
3652   local $SIG{QUIT} = 'IGNORE';
3653   local $SIG{TERM} = 'IGNORE';
3654   local $SIG{TSTP} = 'IGNORE';
3655   local $SIG{PIPE} = 'IGNORE';
3656
3657   my $oldAutoCommit = $FS::UID::AutoCommit;
3658   local $FS::UID::AutoCommit = 0;
3659   my $dbh = dbh;
3660
3661   foreach my $cust_svc ( $self->cust_svc ) {
3662     #false laziness w/svc_Common::insert
3663     my $svc_x = $cust_svc->svc_x;
3664     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3665       my $error = $part_export->export_insert($svc_x);
3666       if ( $error ) {
3667         $dbh->rollback if $oldAutoCommit;
3668         return $error;
3669       }
3670     }
3671   }
3672
3673   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3674   '';
3675
3676 }
3677
3678 =item export_pkg_change OLD_CUST_PKG
3679
3680 Calls the "pkg_change" export action for all services attached to this package.
3681
3682 =cut
3683
3684 sub export_pkg_change {
3685   my( $self, $old )  = ( shift, shift );
3686
3687   local $SIG{HUP} = 'IGNORE';
3688   local $SIG{INT} = 'IGNORE';
3689   local $SIG{QUIT} = 'IGNORE';
3690   local $SIG{TERM} = 'IGNORE';
3691   local $SIG{TSTP} = 'IGNORE';
3692   local $SIG{PIPE} = 'IGNORE';
3693
3694   my $oldAutoCommit = $FS::UID::AutoCommit;
3695   local $FS::UID::AutoCommit = 0;
3696   my $dbh = dbh;
3697
3698   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3699     my $error = $svc_x->export('pkg_change', $self, $old);
3700     if ( $error ) {
3701       $dbh->rollback if $oldAutoCommit;
3702       return $error;
3703     }
3704   }
3705
3706   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3707   '';
3708
3709 }
3710
3711 =item insert_reason
3712
3713 Associates this package with a (suspension or cancellation) reason (see
3714 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3715 L<FS::reason>).
3716
3717 Available options are:
3718
3719 =over 4
3720
3721 =item reason
3722
3723 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.
3724
3725 =item reason_otaker
3726
3727 the access_user (see L<FS::access_user>) providing the reason
3728
3729 =item date
3730
3731 a unix timestamp
3732
3733 =item action
3734
3735 the action (cancel, susp, adjourn, expire) associated with the reason
3736
3737 =back
3738
3739 If there is an error, returns the error, otherwise returns false.
3740
3741 =cut
3742
3743 sub insert_reason {
3744   my ($self, %options) = @_;
3745
3746   my $otaker = $options{reason_otaker} ||
3747                $FS::CurrentUser::CurrentUser->username;
3748
3749   my $reasonnum;
3750   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3751
3752     $reasonnum = $1;
3753
3754   } elsif ( ref($options{'reason'}) ) {
3755
3756     return 'Enter a new reason (or select an existing one)'
3757       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3758
3759     my $reason = new FS::reason({
3760       'reason_type' => $options{'reason'}->{'typenum'},
3761       'reason'      => $options{'reason'}->{'reason'},
3762     });
3763     my $error = $reason->insert;
3764     return $error if $error;
3765
3766     $reasonnum = $reason->reasonnum;
3767
3768   } else {
3769     return "Unparsable reason: ". $options{'reason'};
3770   }
3771
3772   my $cust_pkg_reason =
3773     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3774                               'reasonnum' => $reasonnum,
3775                               'otaker'    => $otaker,
3776                               'action'    => substr(uc($options{'action'}),0,1),
3777                               'date'      => $options{'date'}
3778                                                ? $options{'date'}
3779                                                : time,
3780                             });
3781
3782   $cust_pkg_reason->insert;
3783 }
3784
3785 =item insert_discount
3786
3787 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3788 inserting a new discount on the fly (see L<FS::discount>).
3789
3790 Available options are:
3791
3792 =over 4
3793
3794 =item discountnum
3795
3796 =back
3797
3798 If there is an error, returns the error, otherwise returns false.
3799
3800 =cut
3801
3802 sub insert_discount {
3803   #my ($self, %options) = @_;
3804   my $self = shift;
3805
3806   my $cust_pkg_discount = new FS::cust_pkg_discount {
3807     'pkgnum'      => $self->pkgnum,
3808     'discountnum' => $self->discountnum,
3809     'months_used' => 0,
3810     'end_date'    => '', #XXX
3811     #for the create a new discount case
3812     '_type'       => $self->discountnum__type,
3813     'amount'      => $self->discountnum_amount,
3814     'percent'     => $self->discountnum_percent,
3815     'months'      => $self->discountnum_months,
3816     'setup'      => $self->discountnum_setup,
3817     #'disabled'    => $self->discountnum_disabled,
3818   };
3819
3820   $cust_pkg_discount->insert;
3821 }
3822
3823 =item set_usage USAGE_VALUE_HASHREF
3824
3825 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3826 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3827 upbytes, downbytes, and totalbytes are appropriate keys.
3828
3829 All svc_accts which are part of this package have their values reset.
3830
3831 =cut
3832
3833 sub set_usage {
3834   my ($self, $valueref, %opt) = @_;
3835
3836   #only svc_acct can set_usage for now
3837   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3838     my $svc_x = $cust_svc->svc_x;
3839     $svc_x->set_usage($valueref, %opt)
3840       if $svc_x->can("set_usage");
3841   }
3842 }
3843
3844 =item recharge USAGE_VALUE_HASHREF
3845
3846 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3847 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3848 upbytes, downbytes, and totalbytes are appropriate keys.
3849
3850 All svc_accts which are part of this package have their values incremented.
3851
3852 =cut
3853
3854 sub recharge {
3855   my ($self, $valueref) = @_;
3856
3857   #only svc_acct can set_usage for now
3858   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3859     my $svc_x = $cust_svc->svc_x;
3860     $svc_x->recharge($valueref)
3861       if $svc_x->can("recharge");
3862   }
3863 }
3864
3865 =item cust_pkg_discount
3866
3867 =cut
3868
3869 sub cust_pkg_discount {
3870   my $self = shift;
3871   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3872 }
3873
3874 =item cust_pkg_discount_active
3875
3876 =cut
3877
3878 sub cust_pkg_discount_active {
3879   my $self = shift;
3880   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3881 }
3882
3883 =item cust_pkg_usage
3884
3885 Returns a list of all voice usage counters attached to this package.
3886
3887 =cut
3888
3889 sub cust_pkg_usage {
3890   my $self = shift;
3891   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3892 }
3893
3894 =item apply_usage OPTIONS
3895
3896 Takes the following options:
3897 - cdr: a call detail record (L<FS::cdr>)
3898 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3899 - minutes: the maximum number of minutes to be charged
3900
3901 Finds available usage minutes for a call of this class, and subtracts
3902 up to that many minutes from the usage pool.  If the usage pool is empty,
3903 and the C<cdr-minutes_priority> global config option is set, minutes may
3904 be taken from other calls as well.  Either way, an allocation record will
3905 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3906 number of minutes of usage applied to the call.
3907
3908 =cut
3909
3910 sub apply_usage {
3911   my ($self, %opt) = @_;
3912   my $cdr = $opt{cdr};
3913   my $rate_detail = $opt{rate_detail};
3914   my $minutes = $opt{minutes};
3915   my $classnum = $rate_detail->classnum;
3916   my $pkgnum = $self->pkgnum;
3917   my $custnum = $self->custnum;
3918
3919   local $SIG{HUP} = 'IGNORE';
3920   local $SIG{INT} = 'IGNORE';
3921   local $SIG{QUIT} = 'IGNORE';
3922   local $SIG{TERM} = 'IGNORE';
3923   local $SIG{TSTP} = 'IGNORE';
3924   local $SIG{PIPE} = 'IGNORE';
3925
3926   my $oldAutoCommit = $FS::UID::AutoCommit;
3927   local $FS::UID::AutoCommit = 0;
3928   my $dbh = dbh;
3929   my $order = FS::Conf->new->config('cdr-minutes_priority');
3930
3931   my $is_classnum;
3932   if ( $classnum ) {
3933     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3934   } else {
3935     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3936   }
3937   my @usage_recs = qsearch({
3938       'table'     => 'cust_pkg_usage',
3939       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3940                      ' JOIN cust_pkg             USING (pkgnum)'.
3941                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3942       'select'    => 'cust_pkg_usage.*',
3943       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3944                      " ( cust_pkg.custnum = $custnum AND ".
3945                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3946                      $is_classnum . ' AND '.
3947                      " cust_pkg_usage.minutes > 0",
3948       'order_by'  => " ORDER BY priority ASC",
3949   });
3950
3951   my $orig_minutes = $minutes;
3952   my $error;
3953   while (!$error and $minutes > 0 and @usage_recs) {
3954     my $cust_pkg_usage = shift @usage_recs;
3955     $cust_pkg_usage->select_for_update;
3956     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3957         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3958         acctid      => $cdr->acctid,
3959         minutes     => min($cust_pkg_usage->minutes, $minutes),
3960     });
3961     $cust_pkg_usage->set('minutes',
3962       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3963     );
3964     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3965     $minutes -= $cdr_cust_pkg_usage->minutes;
3966   }
3967   if ( $order and $minutes > 0 and !$error ) {
3968     # then try to steal minutes from another call
3969     my %search = (
3970         'table'     => 'cdr_cust_pkg_usage',
3971         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3972                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3973                        ' JOIN cust_pkg              USING (pkgnum)'.
3974                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3975                        ' JOIN cdr                   USING (acctid)',
3976         'select'    => 'cdr_cust_pkg_usage.*',
3977         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3978                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3979                        " ( cust_pkg.custnum = $custnum AND ".
3980                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3981                        " part_pkg_usage_class.classnum = $classnum",
3982         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3983     );
3984     if ( $order eq 'time' ) {
3985       # find CDRs that are using minutes, but have a later startdate
3986       # than this call
3987       my $startdate = $cdr->startdate;
3988       if ($startdate !~ /^\d+$/) {
3989         die "bad cdr startdate '$startdate'";
3990       }
3991       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3992       # minimize needless reshuffling
3993       $search{'order_by'} .= ', cdr.startdate DESC';
3994     } else {
3995       # XXX may not work correctly with rate_time schedules.  Could
3996       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3997       # think...
3998       $search{'addl_from'} .=
3999         ' JOIN rate_detail'.
4000         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4001       if ( $order eq 'rate_high' ) {
4002         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4003                                 $rate_detail->min_charge;
4004         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4005       } elsif ( $order eq 'rate_low' ) {
4006         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4007                                 $rate_detail->min_charge;
4008         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4009       } else {
4010         #  this should really never happen
4011         die "invalid cdr-minutes_priority value '$order'\n";
4012       }
4013     }
4014     my @cdr_usage_recs = qsearch(\%search);
4015     my %reproc_cdrs;
4016     while (!$error and @cdr_usage_recs and $minutes > 0) {
4017       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4018       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4019       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4020       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4021       $cdr_cust_pkg_usage->select_for_update;
4022       $old_cdr->select_for_update;
4023       $cust_pkg_usage->select_for_update;
4024       # in case someone else stole the usage from this CDR
4025       # while waiting for the lock...
4026       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4027       # steal the usage allocation and flag the old CDR for reprocessing
4028       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4029       # if the allocation is more minutes than we need, adjust it...
4030       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4031       if ( $delta > 0 ) {
4032         $cdr_cust_pkg_usage->set('minutes', $minutes);
4033         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4034         $error = $cust_pkg_usage->replace;
4035       }
4036       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4037       $error ||= $cdr_cust_pkg_usage->replace;
4038       # deduct the stolen minutes
4039       $minutes -= $cdr_cust_pkg_usage->minutes;
4040     }
4041     # after all minute-stealing is done, reset the affected CDRs
4042     foreach (values %reproc_cdrs) {
4043       $error ||= $_->set_status('');
4044       # XXX or should we just call $cdr->rate right here?
4045       # it's not like we can create a loop this way, since the min_charge
4046       # or call time has to go monotonically in one direction.
4047       # we COULD get some very deep recursions going, though...
4048     }
4049   } # if $order and $minutes
4050   if ( $error ) {
4051     $dbh->rollback;
4052     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4053   } else {
4054     $dbh->commit if $oldAutoCommit;
4055     return $orig_minutes - $minutes;
4056   }
4057 }
4058
4059 =item supplemental_pkgs
4060
4061 Returns a list of all packages supplemental to this one.
4062
4063 =cut
4064
4065 sub supplemental_pkgs {
4066   my $self = shift;
4067   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4068 }
4069
4070 =item main_pkg
4071
4072 Returns the package that this one is supplemental to, if any.
4073
4074 =cut
4075
4076 sub main_pkg {
4077   my $self = shift;
4078   if ( $self->main_pkgnum ) {
4079     return FS::cust_pkg->by_key($self->main_pkgnum);
4080   }
4081   return;
4082 }
4083
4084 =back
4085
4086 =head1 CLASS METHODS
4087
4088 =over 4
4089
4090 =item recurring_sql
4091
4092 Returns an SQL expression identifying recurring packages.
4093
4094 =cut
4095
4096 sub recurring_sql { "
4097   '0' != ( select freq from part_pkg
4098              where cust_pkg.pkgpart = part_pkg.pkgpart )
4099 "; }
4100
4101 =item onetime_sql
4102
4103 Returns an SQL expression identifying one-time packages.
4104
4105 =cut
4106
4107 sub onetime_sql { "
4108   '0' = ( select freq from part_pkg
4109             where cust_pkg.pkgpart = part_pkg.pkgpart )
4110 "; }
4111
4112 =item ordered_sql
4113
4114 Returns an SQL expression identifying ordered packages (recurring packages not
4115 yet billed).
4116
4117 =cut
4118
4119 sub ordered_sql {
4120    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4121 }
4122
4123 =item active_sql
4124
4125 Returns an SQL expression identifying active packages.
4126
4127 =cut
4128
4129 sub active_sql {
4130   $_[0]->recurring_sql. "
4131   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4132   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4133   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4134 "; }
4135
4136 =item not_yet_billed_sql
4137
4138 Returns an SQL expression identifying packages which have not yet been billed.
4139
4140 =cut
4141
4142 sub not_yet_billed_sql { "
4143       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4144   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4145   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4146 "; }
4147
4148 =item inactive_sql
4149
4150 Returns an SQL expression identifying inactive packages (one-time packages
4151 that are otherwise unsuspended/uncancelled).
4152
4153 =cut
4154
4155 sub inactive_sql { "
4156   ". $_[0]->onetime_sql(). "
4157   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4158   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4159   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4160 "; }
4161
4162 =item susp_sql
4163 =item suspended_sql
4164
4165 Returns an SQL expression identifying suspended packages.
4166
4167 =cut
4168
4169 sub suspended_sql { susp_sql(@_); }
4170 sub susp_sql {
4171   #$_[0]->recurring_sql(). ' AND '.
4172   "
4173         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4174     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4175   ";
4176 }
4177
4178 =item cancel_sql
4179 =item cancelled_sql
4180
4181 Returns an SQL exprression identifying cancelled packages.
4182
4183 =cut
4184
4185 sub cancelled_sql { cancel_sql(@_); }
4186 sub cancel_sql {
4187   #$_[0]->recurring_sql(). ' AND '.
4188   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4189 }
4190
4191 =item status_sql
4192
4193 Returns an SQL expression to give the package status as a string.
4194
4195 =cut
4196
4197 sub status_sql {
4198 "CASE
4199   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4200   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4201   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4202   WHEN ".onetime_sql()." THEN 'one-time charge'
4203   ELSE 'active'
4204 END"
4205 }
4206
4207 =item search HASHREF
4208
4209 (Class method)
4210
4211 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4212 Valid parameters are
4213
4214 =over 4
4215
4216 =item agentnum
4217
4218 =item magic
4219
4220 active, inactive, suspended, cancel (or cancelled)
4221
4222 =item status
4223
4224 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
4225
4226 =item custom
4227
4228  boolean selects custom packages
4229
4230 =item classnum
4231
4232 =item pkgpart
4233
4234 pkgpart or arrayref or hashref of pkgparts
4235
4236 =item setup
4237
4238 arrayref of beginning and ending epoch date
4239
4240 =item last_bill
4241
4242 arrayref of beginning and ending epoch date
4243
4244 =item bill
4245
4246 arrayref of beginning and ending epoch date
4247
4248 =item adjourn
4249
4250 arrayref of beginning and ending epoch date
4251
4252 =item susp
4253
4254 arrayref of beginning and ending epoch date
4255
4256 =item expire
4257
4258 arrayref of beginning and ending epoch date
4259
4260 =item cancel
4261
4262 arrayref of beginning and ending epoch date
4263
4264 =item query
4265
4266 pkgnum or APKG_pkgnum
4267
4268 =item cust_fields
4269
4270 a value suited to passing to FS::UI::Web::cust_header
4271
4272 =item CurrentUser
4273
4274 specifies the user for agent virtualization
4275
4276 =item fcc_line
4277
4278 boolean; if true, returns only packages with more than 0 FCC phone lines.
4279
4280 =item state, country
4281
4282 Limit to packages with a service location in the specified state and country.
4283 For FCC 477 reporting, mostly.
4284
4285 =back
4286
4287 =cut
4288
4289 sub search {
4290   my ($class, $params) = @_;
4291   my @where = ();
4292
4293   ##
4294   # parse agent
4295   ##
4296
4297   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4298     push @where,
4299       "cust_main.agentnum = $1";
4300   }
4301
4302   ##
4303   # parse cust_status
4304   ##
4305
4306   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4307     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4308   }
4309
4310   ##
4311   # parse customer sales person
4312   ##
4313
4314   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4315     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4316                           : 'cust_main.salesnum IS NULL';
4317   }
4318
4319
4320   ##
4321   # parse sales person
4322   ##
4323
4324   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4325     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4326                           : 'cust_pkg.salesnum IS NULL';
4327   }
4328
4329   ##
4330   # parse custnum
4331   ##
4332
4333   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4334     push @where,
4335       "cust_pkg.custnum = $1";
4336   }
4337
4338   ##
4339   # custbatch
4340   ##
4341
4342   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4343     push @where,
4344       "cust_pkg.pkgbatch = '$1'";
4345   }
4346
4347   ##
4348   # parse status
4349   ##
4350
4351   if (    $params->{'magic'}  eq 'active'
4352        || $params->{'status'} eq 'active' ) {
4353
4354     push @where, FS::cust_pkg->active_sql();
4355
4356   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4357             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4358
4359     push @where, FS::cust_pkg->not_yet_billed_sql();
4360
4361   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4362             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4363
4364     push @where, FS::cust_pkg->inactive_sql();
4365
4366   } elsif (    $params->{'magic'}  eq 'suspended'
4367             || $params->{'status'} eq 'suspended'  ) {
4368
4369     push @where, FS::cust_pkg->suspended_sql();
4370
4371   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4372             || $params->{'status'} =~ /^cancell?ed$/ ) {
4373
4374     push @where, FS::cust_pkg->cancelled_sql();
4375
4376   }
4377
4378   ###
4379   # parse package class
4380   ###
4381
4382   if ( exists($params->{'classnum'}) ) {
4383
4384     my @classnum = ();
4385     if ( ref($params->{'classnum'}) ) {
4386
4387       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4388         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4389       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4390         @classnum = @{ $params->{'classnum'} };
4391       } else {
4392         die 'unhandled classnum ref '. $params->{'classnum'};
4393       }
4394
4395
4396     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4397       @classnum = ( $1 );
4398     }
4399
4400     if ( @classnum ) {
4401
4402       my @c_where = ();
4403       my @nums = grep $_, @classnum;
4404       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4405       my $null = scalar( grep { $_ eq '' } @classnum );
4406       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4407
4408       if ( scalar(@c_where) == 1 ) {
4409         push @where, @c_where;
4410       } elsif ( @c_where ) {
4411         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4412       }
4413
4414     }
4415
4416
4417   }
4418
4419   ###
4420   # parse package report options
4421   ###
4422
4423   my @report_option = ();
4424   if ( exists($params->{'report_option'}) ) {
4425     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4426       @report_option = @{ $params->{'report_option'} };
4427     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4428       @report_option = split(',', $1);
4429     }
4430
4431   }
4432
4433   if (@report_option) {
4434     # this will result in the empty set for the dangling comma case as it should
4435     push @where,
4436       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4437                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4438                     AND optionname = 'report_option_$_'
4439                     AND optionvalue = '1' )"
4440          } @report_option;
4441   }
4442
4443   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4444
4445     my @report_option_any = ();
4446     if ( ref($params->{$any}) eq 'ARRAY' ) {
4447       @report_option_any = @{ $params->{$any} };
4448     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4449       @report_option_any = split(',', $1);
4450     }
4451
4452     if (@report_option_any) {
4453       # this will result in the empty set for the dangling comma case as it should
4454       push @where, ' ( '. join(' OR ',
4455         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4456                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4457                       AND optionname = 'report_option_$_'
4458                       AND optionvalue = '1' )"
4459            } @report_option_any
4460       ). ' ) ';
4461     }
4462
4463   }
4464
4465   ###
4466   # parse custom
4467   ###
4468
4469   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4470
4471   ###
4472   # parse fcc_line
4473   ###
4474
4475   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4476                                                         if $params->{fcc_line};
4477
4478   ###
4479   # parse censustract
4480   ###
4481
4482   if ( exists($params->{'censustract'}) ) {
4483     $params->{'censustract'} =~ /^([.\d]*)$/;
4484     my $censustract = "cust_location.censustract = '$1'";
4485     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4486     push @where,  "( $censustract )";
4487   }
4488
4489   ###
4490   # parse censustract2
4491   ###
4492   if ( exists($params->{'censustract2'})
4493        && $params->{'censustract2'} =~ /^(\d*)$/
4494      )
4495   {
4496     if ($1) {
4497       push @where, "cust_location.censustract LIKE '$1%'";
4498     } else {
4499       push @where,
4500         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4501     }
4502   }
4503
4504   ###
4505   # parse country/state
4506   ###
4507   for (qw(state country)) { # parsing rules are the same for these
4508   if ( exists($params->{$_})
4509     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4510     {
4511       # XXX post-2.3 only--before that, state/country may be in cust_main
4512       push @where, "cust_location.$_ = '$1'";
4513     }
4514   }
4515
4516   ###
4517   # parse part_pkg
4518   ###
4519
4520   if ( ref($params->{'pkgpart'}) ) {
4521
4522     my @pkgpart = ();
4523     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4524       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4525     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4526       @pkgpart = @{ $params->{'pkgpart'} };
4527     } else {
4528       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4529     }
4530
4531     @pkgpart = grep /^(\d+)$/, @pkgpart;
4532
4533     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4534
4535   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4536     push @where, "pkgpart = $1";
4537   }
4538
4539   ###
4540   # parse dates
4541   ###
4542
4543   my $orderby = '';
4544
4545   #false laziness w/report_cust_pkg.html
4546   my %disable = (
4547     'all'             => {},
4548     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4549     'active'          => { 'susp'=>1, 'cancel'=>1 },
4550     'suspended'       => { 'cancel' => 1 },
4551     'cancelled'       => {},
4552     ''                => {},
4553   );
4554
4555   if( exists($params->{'active'} ) ) {
4556     # This overrides all the other date-related fields
4557     my($beginning, $ending) = @{$params->{'active'}};
4558     push @where,
4559       "cust_pkg.setup IS NOT NULL",
4560       "cust_pkg.setup <= $ending",
4561       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4562       "NOT (".FS::cust_pkg->onetime_sql . ")";
4563   }
4564   else {
4565     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4566
4567       next unless exists($params->{$field});
4568
4569       my($beginning, $ending) = @{$params->{$field}};
4570
4571       next if $beginning == 0 && $ending == 4294967295;
4572
4573       push @where,
4574         "cust_pkg.$field IS NOT NULL",
4575         "cust_pkg.$field >= $beginning",
4576         "cust_pkg.$field <= $ending";
4577
4578       $orderby ||= "ORDER BY cust_pkg.$field";
4579
4580     }
4581   }
4582
4583   $orderby ||= 'ORDER BY bill';
4584
4585   ###
4586   # parse magic, legacy, etc.
4587   ###
4588
4589   if ( $params->{'magic'} &&
4590        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4591   ) {
4592
4593     $orderby = 'ORDER BY pkgnum';
4594
4595     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4596       push @where, "pkgpart = $1";
4597     }
4598
4599   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4600
4601     $orderby = 'ORDER BY pkgnum';
4602
4603   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4604
4605     $orderby = 'ORDER BY pkgnum';
4606
4607     push @where, '0 < (
4608       SELECT count(*) FROM pkg_svc
4609        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4610          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4611                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4612                                      AND cust_svc.svcpart = pkg_svc.svcpart
4613                                 )
4614     )';
4615
4616   }
4617
4618   ##
4619   # setup queries, links, subs, etc. for the search
4620   ##
4621
4622   # here is the agent virtualization
4623   if ($params->{CurrentUser}) {
4624     my $access_user =
4625       qsearchs('access_user', { username => $params->{CurrentUser} });
4626
4627     if ($access_user) {
4628       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4629     } else {
4630       push @where, "1=0";
4631     }
4632   } else {
4633     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4634   }
4635
4636   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4637
4638   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4639                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4640                   'LEFT JOIN cust_location USING ( locationnum ) '.
4641                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4642
4643   my $select;
4644   my $count_query;
4645   if ( $params->{'select_zip5'} ) {
4646     my $zip = 'cust_location.zip';
4647
4648     $select = "DISTINCT substr($zip,1,5) as zip";
4649     $orderby = "ORDER BY substr($zip,1,5)";
4650     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4651   } else {
4652     $select = join(', ',
4653                          'cust_pkg.*',
4654                          ( map "part_pkg.$_", qw( pkg freq ) ),
4655                          'pkg_class.classname',
4656                          'cust_main.custnum AS cust_main_custnum',
4657                          FS::UI::Web::cust_sql_fields(
4658                            $params->{'cust_fields'}
4659                          ),
4660                   );
4661     $count_query = 'SELECT COUNT(*)';
4662   }
4663
4664   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4665
4666   my $sql_query = {
4667     'table'       => 'cust_pkg',
4668     'hashref'     => {},
4669     'select'      => $select,
4670     'extra_sql'   => $extra_sql,
4671     'order_by'    => $orderby,
4672     'addl_from'   => $addl_from,
4673     'count_query' => $count_query,
4674   };
4675
4676 }
4677
4678 =item fcc_477_count
4679
4680 Returns a list of two package counts.  The first is a count of packages
4681 based on the supplied criteria and the second is the count of residential
4682 packages with those same criteria.  Criteria are specified as in the search
4683 method.
4684
4685 =cut
4686
4687 sub fcc_477_count {
4688   my ($class, $params) = @_;
4689
4690   my $sql_query = $class->search( $params );
4691
4692   my $count_sql = delete($sql_query->{'count_query'});
4693   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4694     or die "couldn't parse count_sql";
4695
4696   my $count_sth = dbh->prepare($count_sql)
4697     or die "Error preparing $count_sql: ". dbh->errstr;
4698   $count_sth->execute
4699     or die "Error executing $count_sql: ". $count_sth->errstr;
4700   my $count_arrayref = $count_sth->fetchrow_arrayref;
4701
4702   return ( @$count_arrayref );
4703
4704 }
4705
4706 =item tax_locationnum_sql
4707
4708 Returns an SQL expression for the tax location for a package, based
4709 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4710
4711 =cut
4712
4713 sub tax_locationnum_sql {
4714   my $conf = FS::Conf->new;
4715   if ( $conf->exists('tax-pkg_address') ) {
4716     'cust_pkg.locationnum';
4717   }
4718   elsif ( $conf->exists('tax-ship_address') ) {
4719     'cust_main.ship_locationnum';
4720   }
4721   else {
4722     'cust_main.bill_locationnum';
4723   }
4724 }
4725
4726 =item location_sql
4727
4728 Returns a list: the first item is an SQL fragment identifying matching
4729 packages/customers via location (taking into account shipping and package
4730 address taxation, if enabled), and subsequent items are the parameters to
4731 substitute for the placeholders in that fragment.
4732
4733 =cut
4734
4735 sub location_sql {
4736   my($class, %opt) = @_;
4737   my $ornull = $opt{'ornull'};
4738
4739   my $conf = new FS::Conf;
4740
4741   # '?' placeholders in _location_sql_where
4742   my $x = $ornull ? 3 : 2;
4743   my @bill_param = (
4744     ('district')x3,
4745     ('city')x3,
4746     ('county')x$x,
4747     ('state')x$x,
4748     'country'
4749   );
4750
4751   my $main_where;
4752   my @main_param;
4753   if ( $conf->exists('tax-ship_address') ) {
4754
4755     $main_where = "(
4756          (     ( ship_last IS NULL     OR  ship_last  = '' )
4757            AND ". _location_sql_where('cust_main', '', $ornull ). "
4758          )
4759       OR (       ship_last IS NOT NULL AND ship_last != ''
4760            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4761          )
4762     )";
4763     #    AND payby != 'COMP'
4764
4765     @main_param = ( @bill_param, @bill_param );
4766
4767   } else {
4768
4769     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4770     @main_param = @bill_param;
4771
4772   }
4773
4774   my $where;
4775   my @param;
4776   if ( $conf->exists('tax-pkg_address') ) {
4777
4778     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4779
4780     $where = " (
4781                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4782                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4783                )
4784              ";
4785     @param = ( @main_param, @bill_param );
4786
4787   } else {
4788
4789     $where = $main_where;
4790     @param = @main_param;
4791
4792   }
4793
4794   ( $where, @param );
4795
4796 }
4797
4798 #subroutine, helper for location_sql
4799 sub _location_sql_where {
4800   my $table  = shift;
4801   my $prefix = @_ ? shift : '';
4802   my $ornull = @_ ? shift : '';
4803
4804 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4805
4806   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4807
4808   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4809   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4810   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4811
4812   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4813
4814 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4815   "
4816         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4817     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4818     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4819     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4820     AND   $table.${prefix}country  = ?
4821   ";
4822 }
4823
4824 sub _X_show_zero {
4825   my( $self, $what ) = @_;
4826
4827   my $what_show_zero = $what. '_show_zero';
4828   length($self->$what_show_zero())
4829     ? ($self->$what_show_zero() eq 'Y')
4830     : $self->part_pkg->$what_show_zero();
4831 }
4832
4833 =head1 SUBROUTINES
4834
4835 =over 4
4836
4837 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4838
4839 CUSTNUM is a customer (see L<FS::cust_main>)
4840
4841 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4842 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4843 permitted.
4844
4845 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4846 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4847 new billing items.  An error is returned if this is not possible (see
4848 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4849 parameter.
4850
4851 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4852 newly-created cust_pkg objects.
4853
4854 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4855 and inserted.  Multiple FS::pkg_referral records can be created by
4856 setting I<refnum> to an array reference of refnums or a hash reference with
4857 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4858 record will be created corresponding to cust_main.refnum.
4859
4860 =cut
4861
4862 sub order {
4863   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4864
4865   my $conf = new FS::Conf;
4866
4867   # Transactionize this whole mess
4868   local $SIG{HUP} = 'IGNORE';
4869   local $SIG{INT} = 'IGNORE';
4870   local $SIG{QUIT} = 'IGNORE';
4871   local $SIG{TERM} = 'IGNORE';
4872   local $SIG{TSTP} = 'IGNORE';
4873   local $SIG{PIPE} = 'IGNORE';
4874
4875   my $oldAutoCommit = $FS::UID::AutoCommit;
4876   local $FS::UID::AutoCommit = 0;
4877   my $dbh = dbh;
4878
4879   my $error;
4880 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4881 #  return "Customer not found: $custnum" unless $cust_main;
4882
4883   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4884     if $DEBUG;
4885
4886   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4887                          @$remove_pkgnum;
4888
4889   my $change = scalar(@old_cust_pkg) != 0;
4890
4891   my %hash = ();
4892   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4893
4894     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4895          " to pkgpart ". $pkgparts->[0]. "\n"
4896       if $DEBUG;
4897
4898     my $err_or_cust_pkg =
4899       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4900                                 'refnum'  => $refnum,
4901                               );
4902
4903     unless (ref($err_or_cust_pkg)) {
4904       $dbh->rollback if $oldAutoCommit;
4905       return $err_or_cust_pkg;
4906     }
4907
4908     push @$return_cust_pkg, $err_or_cust_pkg;
4909     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4910     return '';
4911
4912   }
4913
4914   # Create the new packages.
4915   foreach my $pkgpart (@$pkgparts) {
4916
4917     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4918
4919     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4920                                       pkgpart => $pkgpart,
4921                                       refnum  => $refnum,
4922                                       %hash,
4923                                     };
4924     $error = $cust_pkg->insert( 'change' => $change );
4925     push @$return_cust_pkg, $cust_pkg;
4926
4927     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4928       my $supp_pkg = FS::cust_pkg->new({
4929           custnum => $custnum,
4930           pkgpart => $link->dst_pkgpart,
4931           refnum  => $refnum,
4932           main_pkgnum => $cust_pkg->pkgnum,
4933           %hash,
4934       });
4935       $error ||= $supp_pkg->insert( 'change' => $change );
4936       push @$return_cust_pkg, $supp_pkg;
4937     }
4938
4939     if ($error) {
4940       $dbh->rollback if $oldAutoCommit;
4941       return $error;
4942     }
4943
4944   }
4945   # $return_cust_pkg now contains refs to all of the newly
4946   # created packages.
4947
4948   # Transfer services and cancel old packages.
4949   foreach my $old_pkg (@old_cust_pkg) {
4950
4951     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4952       if $DEBUG;
4953
4954     foreach my $new_pkg (@$return_cust_pkg) {
4955       $error = $old_pkg->transfer($new_pkg);
4956       if ($error and $error == 0) {
4957         # $old_pkg->transfer failed.
4958         $dbh->rollback if $oldAutoCommit;
4959         return $error;
4960       }
4961     }
4962
4963     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4964       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4965       foreach my $new_pkg (@$return_cust_pkg) {
4966         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4967         if ($error and $error == 0) {
4968           # $old_pkg->transfer failed.
4969         $dbh->rollback if $oldAutoCommit;
4970         return $error;
4971         }
4972       }
4973     }
4974
4975     if ($error > 0) {
4976       # Transfers were successful, but we went through all of the
4977       # new packages and still had services left on the old package.
4978       # We can't cancel the package under the circumstances, so abort.
4979       $dbh->rollback if $oldAutoCommit;
4980       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4981     }
4982     $error = $old_pkg->cancel( quiet=>1 );
4983     if ($error) {
4984       $dbh->rollback;
4985       return $error;
4986     }
4987   }
4988   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4989   '';
4990 }
4991
4992 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4993
4994 A bulk change method to change packages for multiple customers.
4995
4996 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4997 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4998 permitted.
4999
5000 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5001 replace.  The services (see L<FS::cust_svc>) are moved to the
5002 new billing items.  An error is returned if this is not possible (see
5003 L<FS::pkg_svc>).
5004
5005 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5006 newly-created cust_pkg objects.
5007
5008 =cut
5009
5010 sub bulk_change {
5011   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5012
5013   # Transactionize this whole mess
5014   local $SIG{HUP} = 'IGNORE';
5015   local $SIG{INT} = 'IGNORE';
5016   local $SIG{QUIT} = 'IGNORE';
5017   local $SIG{TERM} = 'IGNORE';
5018   local $SIG{TSTP} = 'IGNORE';
5019   local $SIG{PIPE} = 'IGNORE';
5020
5021   my $oldAutoCommit = $FS::UID::AutoCommit;
5022   local $FS::UID::AutoCommit = 0;
5023   my $dbh = dbh;
5024
5025   my @errors;
5026   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5027                          @$remove_pkgnum;
5028
5029   while(scalar(@old_cust_pkg)) {
5030     my @return = ();
5031     my $custnum = $old_cust_pkg[0]->custnum;
5032     my (@remove) = map { $_->pkgnum }
5033                    grep { $_->custnum == $custnum } @old_cust_pkg;
5034     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5035
5036     my $error = order $custnum, $pkgparts, \@remove, \@return;
5037
5038     push @errors, $error
5039       if $error;
5040     push @$return_cust_pkg, @return;
5041   }
5042
5043   if (scalar(@errors)) {
5044     $dbh->rollback if $oldAutoCommit;
5045     return join(' / ', @errors);
5046   }
5047
5048   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5049   '';
5050 }
5051
5052 # Used by FS::Upgrade to migrate to a new database.
5053 sub _upgrade_data {  # class method
5054   my ($class, %opts) = @_;
5055   $class->_upgrade_otaker(%opts);
5056   my @statements = (
5057     # RT#10139, bug resulting in contract_end being set when it shouldn't
5058   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5059     # RT#10830, bad calculation of prorate date near end of year
5060     # the date range for bill is December 2009, and we move it forward
5061     # one year if it's before the previous bill date (which it should
5062     # never be)
5063   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5064   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5065   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5066     # RT6628, add order_date to cust_pkg
5067     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5068         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5069         history_action = \'insert\') where order_date is null',
5070   );
5071   foreach my $sql (@statements) {
5072     my $sth = dbh->prepare($sql);
5073     $sth->execute or die $sth->errstr;
5074   }
5075 }
5076
5077 =back
5078
5079 =head1 BUGS
5080
5081 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5082
5083 In sub order, the @pkgparts array (passed by reference) is clobbered.
5084
5085 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5086 method to pass dates to the recur_prog expression, it should do so.
5087
5088 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5089 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5090 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5091 configuration values.  Probably need a subroutine which decides what to do
5092 based on whether or not we've fetched the user yet, rather than a hash.  See
5093 FS::UID and the TODO.
5094
5095 Now that things are transactional should the check in the insert method be
5096 moved to check ?
5097
5098 =head1 SEE ALSO
5099
5100 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5101 L<FS::pkg_svc>, schema.html from the base documentation
5102
5103 =cut
5104
5105 1;
5106