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