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 =item balance
3317
3318 Returns the balance for this specific package, when using
3319 experimental package balance.
3320
3321 =cut
3322
3323 sub balance {
3324   my $self = shift;
3325   $self->cust_main->balance_pkgnum( $self->pkgnum );
3326 }
3327
3328 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3329
3330 =item cust_location
3331
3332 Returns the location object, if any (see L<FS::cust_location>).
3333
3334 =item cust_location_or_main
3335
3336 If this package is associated with a location, returns the locaiton (see
3337 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3338
3339 =item location_label [ OPTION => VALUE ... ]
3340
3341 Returns the label of the location object (see L<FS::cust_location>).
3342
3343 =cut
3344
3345 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3346
3347 =item tax_locationnum
3348
3349 Returns the foreign key to a L<FS::cust_location> object for calculating
3350 tax on this package, as determined by the C<tax-pkg_address> and
3351 C<tax-ship_address> configuration flags.
3352
3353 =cut
3354
3355 sub tax_locationnum {
3356   my $self = shift;
3357   my $conf = FS::Conf->new;
3358   if ( $conf->exists('tax-pkg_address') ) {
3359     return $self->locationnum;
3360   }
3361   elsif ( $conf->exists('tax-ship_address') ) {
3362     return $self->cust_main->ship_locationnum;
3363   }
3364   else {
3365     return $self->cust_main->bill_locationnum;
3366   }
3367 }
3368
3369 =item tax_location
3370
3371 Returns the L<FS::cust_location> object for tax_locationnum.
3372
3373 =cut
3374
3375 sub tax_location {
3376   my $self = shift;
3377   FS::cust_location->by_key( $self->tax_locationnum )
3378 }
3379
3380 =item seconds_since TIMESTAMP
3381
3382 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3383 package have been online since TIMESTAMP, according to the session monitor.
3384
3385 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3386 L<Time::Local> and L<Date::Parse> for conversion functions.
3387
3388 =cut
3389
3390 sub seconds_since {
3391   my($self, $since) = @_;
3392   my $seconds = 0;
3393
3394   foreach my $cust_svc (
3395     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3396   ) {
3397     $seconds += $cust_svc->seconds_since($since);
3398   }
3399
3400   $seconds;
3401
3402 }
3403
3404 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3405
3406 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3407 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3408 (exclusive).
3409
3410 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3411 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3412 functions.
3413
3414
3415 =cut
3416
3417 sub seconds_since_sqlradacct {
3418   my($self, $start, $end) = @_;
3419
3420   my $seconds = 0;
3421
3422   foreach my $cust_svc (
3423     grep {
3424       my $part_svc = $_->part_svc;
3425       $part_svc->svcdb eq 'svc_acct'
3426         && scalar($part_svc->part_export_usage);
3427     } $self->cust_svc
3428   ) {
3429     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3430   }
3431
3432   $seconds;
3433
3434 }
3435
3436 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3437
3438 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3439 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3440 TIMESTAMP_END
3441 (exclusive).
3442
3443 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3444 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3445 functions.
3446
3447 =cut
3448
3449 sub attribute_since_sqlradacct {
3450   my($self, $start, $end, $attrib) = @_;
3451
3452   my $sum = 0;
3453
3454   foreach my $cust_svc (
3455     grep {
3456       my $part_svc = $_->part_svc;
3457       scalar($part_svc->part_export_usage);
3458     } $self->cust_svc
3459   ) {
3460     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3461   }
3462
3463   $sum;
3464
3465 }
3466
3467 =item quantity
3468
3469 =cut
3470
3471 sub quantity {
3472   my( $self, $value ) = @_;
3473   if ( defined($value) ) {
3474     $self->setfield('quantity', $value);
3475   }
3476   $self->getfield('quantity') || 1;
3477 }
3478
3479 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3480
3481 Transfers as many services as possible from this package to another package.
3482
3483 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3484 object.  The destination package must already exist.
3485
3486 Services are moved only if the destination allows services with the correct
3487 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3488 this option with caution!  No provision is made for export differences
3489 between the old and new service definitions.  Probably only should be used
3490 when your exports for all service definitions of a given svcdb are identical.
3491 (attempt a transfer without it first, to move all possible svcpart-matching
3492 services)
3493
3494 Any services that can't be moved remain in the original package.
3495
3496 Returns an error, if there is one; otherwise, returns the number of services
3497 that couldn't be moved.
3498
3499 =cut
3500
3501 sub transfer {
3502   my ($self, $dest_pkgnum, %opt) = @_;
3503
3504   my $remaining = 0;
3505   my $dest;
3506   my %target;
3507
3508   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3509     $dest = $dest_pkgnum;
3510     $dest_pkgnum = $dest->pkgnum;
3511   } else {
3512     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3513   }
3514
3515   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3516
3517   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3518     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3519   }
3520
3521   foreach my $cust_svc ($dest->cust_svc) {
3522     $target{$cust_svc->svcpart}--;
3523   }
3524
3525   my %svcpart2svcparts = ();
3526   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3527     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3528     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3529       next if exists $svcpart2svcparts{$svcpart};
3530       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3531       $svcpart2svcparts{$svcpart} = [
3532         map  { $_->[0] }
3533         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3534         map {
3535               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3536                                                    'svcpart' => $_          } );
3537               [ $_,
3538                 $pkg_svc ? $pkg_svc->primary_svc : '',
3539                 $pkg_svc ? $pkg_svc->quantity : 0,
3540               ];
3541             }
3542
3543         grep { $_ != $svcpart }
3544         map  { $_->svcpart }
3545         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3546       ];
3547       warn "alternates for svcpart $svcpart: ".
3548            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3549         if $DEBUG;
3550     }
3551   }
3552
3553   foreach my $cust_svc ($self->cust_svc) {
3554     if($target{$cust_svc->svcpart} > 0
3555        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3556       $target{$cust_svc->svcpart}--;
3557       my $new = new FS::cust_svc { $cust_svc->hash };
3558       $new->pkgnum($dest_pkgnum);
3559       my $error = $new->replace($cust_svc);
3560       return $error if $error;
3561     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3562       if ( $DEBUG ) {
3563         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3564         warn "alternates to consider: ".
3565              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3566       }
3567       my @alternate = grep {
3568                              warn "considering alternate svcpart $_: ".
3569                                   "$target{$_} available in new package\n"
3570                                if $DEBUG;
3571                              $target{$_} > 0;
3572                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3573       if ( @alternate ) {
3574         warn "alternate(s) found\n" if $DEBUG;
3575         my $change_svcpart = $alternate[0];
3576         $target{$change_svcpart}--;
3577         my $new = new FS::cust_svc { $cust_svc->hash };
3578         $new->svcpart($change_svcpart);
3579         $new->pkgnum($dest_pkgnum);
3580         my $error = $new->replace($cust_svc);
3581         return $error if $error;
3582       } else {
3583         $remaining++;
3584       }
3585     } else {
3586       $remaining++
3587     }
3588   }
3589   return $remaining;
3590 }
3591
3592 =item grab_svcnums SVCNUM, SVCNUM ...
3593
3594 Change the pkgnum for the provided services to this packages.  If there is an
3595 error, returns the error, otherwise returns false.
3596
3597 =cut
3598
3599 sub grab_svcnums {
3600   my $self = shift;
3601   my @svcnum = @_;
3602
3603   local $SIG{HUP} = 'IGNORE';
3604   local $SIG{INT} = 'IGNORE';
3605   local $SIG{QUIT} = 'IGNORE';
3606   local $SIG{TERM} = 'IGNORE';
3607   local $SIG{TSTP} = 'IGNORE';
3608   local $SIG{PIPE} = 'IGNORE';
3609
3610   my $oldAutoCommit = $FS::UID::AutoCommit;
3611   local $FS::UID::AutoCommit = 0;
3612   my $dbh = dbh;
3613
3614   foreach my $svcnum (@svcnum) {
3615     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3616       $dbh->rollback if $oldAutoCommit;
3617       return "unknown svcnum $svcnum";
3618     };
3619     $cust_svc->pkgnum( $self->pkgnum );
3620     my $error = $cust_svc->replace;
3621     if ( $error ) {
3622       $dbh->rollback if $oldAutoCommit;
3623       return $error;
3624     }
3625   }
3626
3627   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3628   '';
3629
3630 }
3631
3632 =item reexport
3633
3634 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3635 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3636
3637 =cut
3638
3639 #looks like this is still used by the order_pkg and change_pkg methods in
3640 # ClientAPI/MyAccount, need to look into those before removing
3641 sub reexport {
3642   my $self = shift;
3643
3644   local $SIG{HUP} = 'IGNORE';
3645   local $SIG{INT} = 'IGNORE';
3646   local $SIG{QUIT} = 'IGNORE';
3647   local $SIG{TERM} = 'IGNORE';
3648   local $SIG{TSTP} = 'IGNORE';
3649   local $SIG{PIPE} = 'IGNORE';
3650
3651   my $oldAutoCommit = $FS::UID::AutoCommit;
3652   local $FS::UID::AutoCommit = 0;
3653   my $dbh = dbh;
3654
3655   foreach my $cust_svc ( $self->cust_svc ) {
3656     #false laziness w/svc_Common::insert
3657     my $svc_x = $cust_svc->svc_x;
3658     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3659       my $error = $part_export->export_insert($svc_x);
3660       if ( $error ) {
3661         $dbh->rollback if $oldAutoCommit;
3662         return $error;
3663       }
3664     }
3665   }
3666
3667   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3668   '';
3669
3670 }
3671
3672 =item export_pkg_change OLD_CUST_PKG
3673
3674 Calls the "pkg_change" export action for all services attached to this package.
3675
3676 =cut
3677
3678 sub export_pkg_change {
3679   my( $self, $old )  = ( shift, shift );
3680
3681   local $SIG{HUP} = 'IGNORE';
3682   local $SIG{INT} = 'IGNORE';
3683   local $SIG{QUIT} = 'IGNORE';
3684   local $SIG{TERM} = 'IGNORE';
3685   local $SIG{TSTP} = 'IGNORE';
3686   local $SIG{PIPE} = 'IGNORE';
3687
3688   my $oldAutoCommit = $FS::UID::AutoCommit;
3689   local $FS::UID::AutoCommit = 0;
3690   my $dbh = dbh;
3691
3692   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3693     my $error = $svc_x->export('pkg_change', $self, $old);
3694     if ( $error ) {
3695       $dbh->rollback if $oldAutoCommit;
3696       return $error;
3697     }
3698   }
3699
3700   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3701   '';
3702
3703 }
3704
3705 =item insert_reason
3706
3707 Associates this package with a (suspension or cancellation) reason (see
3708 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3709 L<FS::reason>).
3710
3711 Available options are:
3712
3713 =over 4
3714
3715 =item reason
3716
3717 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.
3718
3719 =item reason_otaker
3720
3721 the access_user (see L<FS::access_user>) providing the reason
3722
3723 =item date
3724
3725 a unix timestamp
3726
3727 =item action
3728
3729 the action (cancel, susp, adjourn, expire) associated with the reason
3730
3731 =back
3732
3733 If there is an error, returns the error, otherwise returns false.
3734
3735 =cut
3736
3737 sub insert_reason {
3738   my ($self, %options) = @_;
3739
3740   my $otaker = $options{reason_otaker} ||
3741                $FS::CurrentUser::CurrentUser->username;
3742
3743   my $reasonnum;
3744   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3745
3746     $reasonnum = $1;
3747
3748   } elsif ( ref($options{'reason'}) ) {
3749
3750     return 'Enter a new reason (or select an existing one)'
3751       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3752
3753     my $reason = new FS::reason({
3754       'reason_type' => $options{'reason'}->{'typenum'},
3755       'reason'      => $options{'reason'}->{'reason'},
3756     });
3757     my $error = $reason->insert;
3758     return $error if $error;
3759
3760     $reasonnum = $reason->reasonnum;
3761
3762   } else {
3763     return "Unparsable reason: ". $options{'reason'};
3764   }
3765
3766   my $cust_pkg_reason =
3767     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3768                               'reasonnum' => $reasonnum,
3769                               'otaker'    => $otaker,
3770                               'action'    => substr(uc($options{'action'}),0,1),
3771                               'date'      => $options{'date'}
3772                                                ? $options{'date'}
3773                                                : time,
3774                             });
3775
3776   $cust_pkg_reason->insert;
3777 }
3778
3779 =item insert_discount
3780
3781 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3782 inserting a new discount on the fly (see L<FS::discount>).
3783
3784 Available options are:
3785
3786 =over 4
3787
3788 =item discountnum
3789
3790 =back
3791
3792 If there is an error, returns the error, otherwise returns false.
3793
3794 =cut
3795
3796 sub insert_discount {
3797   #my ($self, %options) = @_;
3798   my $self = shift;
3799
3800   my $cust_pkg_discount = new FS::cust_pkg_discount {
3801     'pkgnum'      => $self->pkgnum,
3802     'discountnum' => $self->discountnum,
3803     'months_used' => 0,
3804     'end_date'    => '', #XXX
3805     #for the create a new discount case
3806     '_type'       => $self->discountnum__type,
3807     'amount'      => $self->discountnum_amount,
3808     'percent'     => $self->discountnum_percent,
3809     'months'      => $self->discountnum_months,
3810     'setup'      => $self->discountnum_setup,
3811     #'disabled'    => $self->discountnum_disabled,
3812   };
3813
3814   $cust_pkg_discount->insert;
3815 }
3816
3817 =item set_usage USAGE_VALUE_HASHREF
3818
3819 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3820 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3821 upbytes, downbytes, and totalbytes are appropriate keys.
3822
3823 All svc_accts which are part of this package have their values reset.
3824
3825 =cut
3826
3827 sub set_usage {
3828   my ($self, $valueref, %opt) = @_;
3829
3830   #only svc_acct can set_usage for now
3831   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3832     my $svc_x = $cust_svc->svc_x;
3833     $svc_x->set_usage($valueref, %opt)
3834       if $svc_x->can("set_usage");
3835   }
3836 }
3837
3838 =item recharge USAGE_VALUE_HASHREF
3839
3840 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3841 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3842 upbytes, downbytes, and totalbytes are appropriate keys.
3843
3844 All svc_accts which are part of this package have their values incremented.
3845
3846 =cut
3847
3848 sub recharge {
3849   my ($self, $valueref) = @_;
3850
3851   #only svc_acct can set_usage for now
3852   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3853     my $svc_x = $cust_svc->svc_x;
3854     $svc_x->recharge($valueref)
3855       if $svc_x->can("recharge");
3856   }
3857 }
3858
3859 =item cust_pkg_discount
3860
3861 =item cust_pkg_discount_active
3862
3863 =cut
3864
3865 sub cust_pkg_discount_active {
3866   my $self = shift;
3867   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3868 }
3869
3870 =item cust_pkg_usage
3871
3872 Returns a list of all voice usage counters attached to this package.
3873
3874 =item apply_usage OPTIONS
3875
3876 Takes the following options:
3877 - cdr: a call detail record (L<FS::cdr>)
3878 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3879 - minutes: the maximum number of minutes to be charged
3880
3881 Finds available usage minutes for a call of this class, and subtracts
3882 up to that many minutes from the usage pool.  If the usage pool is empty,
3883 and the C<cdr-minutes_priority> global config option is set, minutes may
3884 be taken from other calls as well.  Either way, an allocation record will
3885 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3886 number of minutes of usage applied to the call.
3887
3888 =cut
3889
3890 sub apply_usage {
3891   my ($self, %opt) = @_;
3892   my $cdr = $opt{cdr};
3893   my $rate_detail = $opt{rate_detail};
3894   my $minutes = $opt{minutes};
3895   my $classnum = $rate_detail->classnum;
3896   my $pkgnum = $self->pkgnum;
3897   my $custnum = $self->custnum;
3898
3899   local $SIG{HUP} = 'IGNORE';
3900   local $SIG{INT} = 'IGNORE';
3901   local $SIG{QUIT} = 'IGNORE';
3902   local $SIG{TERM} = 'IGNORE';
3903   local $SIG{TSTP} = 'IGNORE';
3904   local $SIG{PIPE} = 'IGNORE';
3905
3906   my $oldAutoCommit = $FS::UID::AutoCommit;
3907   local $FS::UID::AutoCommit = 0;
3908   my $dbh = dbh;
3909   my $order = FS::Conf->new->config('cdr-minutes_priority');
3910
3911   my $is_classnum;
3912   if ( $classnum ) {
3913     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3914   } else {
3915     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3916   }
3917   my @usage_recs = qsearch({
3918       'table'     => 'cust_pkg_usage',
3919       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3920                      ' JOIN cust_pkg             USING (pkgnum)'.
3921                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3922       'select'    => 'cust_pkg_usage.*',
3923       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3924                      " ( cust_pkg.custnum = $custnum AND ".
3925                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3926                      $is_classnum . ' AND '.
3927                      " cust_pkg_usage.minutes > 0",
3928       'order_by'  => " ORDER BY priority ASC",
3929   });
3930
3931   my $orig_minutes = $minutes;
3932   my $error;
3933   while (!$error and $minutes > 0 and @usage_recs) {
3934     my $cust_pkg_usage = shift @usage_recs;
3935     $cust_pkg_usage->select_for_update;
3936     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3937         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3938         acctid      => $cdr->acctid,
3939         minutes     => min($cust_pkg_usage->minutes, $minutes),
3940     });
3941     $cust_pkg_usage->set('minutes',
3942       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3943     );
3944     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3945     $minutes -= $cdr_cust_pkg_usage->minutes;
3946   }
3947   if ( $order and $minutes > 0 and !$error ) {
3948     # then try to steal minutes from another call
3949     my %search = (
3950         'table'     => 'cdr_cust_pkg_usage',
3951         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3952                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3953                        ' JOIN cust_pkg              USING (pkgnum)'.
3954                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3955                        ' JOIN cdr                   USING (acctid)',
3956         'select'    => 'cdr_cust_pkg_usage.*',
3957         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3958                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3959                        " ( cust_pkg.custnum = $custnum AND ".
3960                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3961                        " part_pkg_usage_class.classnum = $classnum",
3962         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3963     );
3964     if ( $order eq 'time' ) {
3965       # find CDRs that are using minutes, but have a later startdate
3966       # than this call
3967       my $startdate = $cdr->startdate;
3968       if ($startdate !~ /^\d+$/) {
3969         die "bad cdr startdate '$startdate'";
3970       }
3971       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3972       # minimize needless reshuffling
3973       $search{'order_by'} .= ', cdr.startdate DESC';
3974     } else {
3975       # XXX may not work correctly with rate_time schedules.  Could
3976       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3977       # think...
3978       $search{'addl_from'} .=
3979         ' JOIN rate_detail'.
3980         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3981       if ( $order eq 'rate_high' ) {
3982         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3983                                 $rate_detail->min_charge;
3984         $search{'order_by'} .= ', rate_detail.min_charge ASC';
3985       } elsif ( $order eq 'rate_low' ) {
3986         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3987                                 $rate_detail->min_charge;
3988         $search{'order_by'} .= ', rate_detail.min_charge DESC';
3989       } else {
3990         #  this should really never happen
3991         die "invalid cdr-minutes_priority value '$order'\n";
3992       }
3993     }
3994     my @cdr_usage_recs = qsearch(\%search);
3995     my %reproc_cdrs;
3996     while (!$error and @cdr_usage_recs and $minutes > 0) {
3997       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3998       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3999       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4000       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4001       $cdr_cust_pkg_usage->select_for_update;
4002       $old_cdr->select_for_update;
4003       $cust_pkg_usage->select_for_update;
4004       # in case someone else stole the usage from this CDR
4005       # while waiting for the lock...
4006       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4007       # steal the usage allocation and flag the old CDR for reprocessing
4008       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4009       # if the allocation is more minutes than we need, adjust it...
4010       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4011       if ( $delta > 0 ) {
4012         $cdr_cust_pkg_usage->set('minutes', $minutes);
4013         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4014         $error = $cust_pkg_usage->replace;
4015       }
4016       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4017       $error ||= $cdr_cust_pkg_usage->replace;
4018       # deduct the stolen minutes
4019       $minutes -= $cdr_cust_pkg_usage->minutes;
4020     }
4021     # after all minute-stealing is done, reset the affected CDRs
4022     foreach (values %reproc_cdrs) {
4023       $error ||= $_->set_status('');
4024       # XXX or should we just call $cdr->rate right here?
4025       # it's not like we can create a loop this way, since the min_charge
4026       # or call time has to go monotonically in one direction.
4027       # we COULD get some very deep recursions going, though...
4028     }
4029   } # if $order and $minutes
4030   if ( $error ) {
4031     $dbh->rollback;
4032     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4033   } else {
4034     $dbh->commit if $oldAutoCommit;
4035     return $orig_minutes - $minutes;
4036   }
4037 }
4038
4039 =item supplemental_pkgs
4040
4041 Returns a list of all packages supplemental to this one.
4042
4043 =cut
4044
4045 sub supplemental_pkgs {
4046   my $self = shift;
4047   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4048 }
4049
4050 =item main_pkg
4051
4052 Returns the package that this one is supplemental to, if any.
4053
4054 =cut
4055
4056 sub main_pkg {
4057   my $self = shift;
4058   if ( $self->main_pkgnum ) {
4059     return FS::cust_pkg->by_key($self->main_pkgnum);
4060   }
4061   return;
4062 }
4063
4064 =back
4065
4066 =head1 CLASS METHODS
4067
4068 =over 4
4069
4070 =item recurring_sql
4071
4072 Returns an SQL expression identifying recurring packages.
4073
4074 =cut
4075
4076 sub recurring_sql { "
4077   '0' != ( select freq from part_pkg
4078              where cust_pkg.pkgpart = part_pkg.pkgpart )
4079 "; }
4080
4081 =item onetime_sql
4082
4083 Returns an SQL expression identifying one-time packages.
4084
4085 =cut
4086
4087 sub onetime_sql { "
4088   '0' = ( select freq from part_pkg
4089             where cust_pkg.pkgpart = part_pkg.pkgpart )
4090 "; }
4091
4092 =item ordered_sql
4093
4094 Returns an SQL expression identifying ordered packages (recurring packages not
4095 yet billed).
4096
4097 =cut
4098
4099 sub ordered_sql {
4100    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4101 }
4102
4103 =item active_sql
4104
4105 Returns an SQL expression identifying active packages.
4106
4107 =cut
4108
4109 sub active_sql {
4110   $_[0]->recurring_sql. "
4111   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4112   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4113   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4114 "; }
4115
4116 =item not_yet_billed_sql
4117
4118 Returns an SQL expression identifying packages which have not yet been billed.
4119
4120 =cut
4121
4122 sub not_yet_billed_sql { "
4123       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4124   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4125   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4126 "; }
4127
4128 =item inactive_sql
4129
4130 Returns an SQL expression identifying inactive packages (one-time packages
4131 that are otherwise unsuspended/uncancelled).
4132
4133 =cut
4134
4135 sub inactive_sql { "
4136   ". $_[0]->onetime_sql(). "
4137   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4138   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4139   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4140 "; }
4141
4142 =item susp_sql
4143 =item suspended_sql
4144
4145 Returns an SQL expression identifying suspended packages.
4146
4147 =cut
4148
4149 sub suspended_sql { susp_sql(@_); }
4150 sub susp_sql {
4151   #$_[0]->recurring_sql(). ' AND '.
4152   "
4153         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4154     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4155   ";
4156 }
4157
4158 =item cancel_sql
4159 =item cancelled_sql
4160
4161 Returns an SQL exprression identifying cancelled packages.
4162
4163 =cut
4164
4165 sub cancelled_sql { cancel_sql(@_); }
4166 sub cancel_sql {
4167   #$_[0]->recurring_sql(). ' AND '.
4168   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4169 }
4170
4171 =item status_sql
4172
4173 Returns an SQL expression to give the package status as a string.
4174
4175 =cut
4176
4177 sub status_sql {
4178 "CASE
4179   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4180   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4181   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4182   WHEN ".onetime_sql()." THEN 'one-time charge'
4183   ELSE 'active'
4184 END"
4185 }
4186
4187 =item search HASHREF
4188
4189 (Class method)
4190
4191 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4192 Valid parameters are
4193
4194 =over 4
4195
4196 =item agentnum
4197
4198 =item magic
4199
4200 active, inactive, suspended, cancel (or cancelled)
4201
4202 =item status
4203
4204 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
4205
4206 =item custom
4207
4208  boolean selects custom packages
4209
4210 =item classnum
4211
4212 =item pkgpart
4213
4214 pkgpart or arrayref or hashref of pkgparts
4215
4216 =item setup
4217
4218 arrayref of beginning and ending epoch date
4219
4220 =item last_bill
4221
4222 arrayref of beginning and ending epoch date
4223
4224 =item bill
4225
4226 arrayref of beginning and ending epoch date
4227
4228 =item adjourn
4229
4230 arrayref of beginning and ending epoch date
4231
4232 =item susp
4233
4234 arrayref of beginning and ending epoch date
4235
4236 =item expire
4237
4238 arrayref of beginning and ending epoch date
4239
4240 =item cancel
4241
4242 arrayref of beginning and ending epoch date
4243
4244 =item query
4245
4246 pkgnum or APKG_pkgnum
4247
4248 =item cust_fields
4249
4250 a value suited to passing to FS::UI::Web::cust_header
4251
4252 =item CurrentUser
4253
4254 specifies the user for agent virtualization
4255
4256 =item fcc_line
4257
4258 boolean; if true, returns only packages with more than 0 FCC phone lines.
4259
4260 =item state, country
4261
4262 Limit to packages with a service location in the specified state and country.
4263 For FCC 477 reporting, mostly.
4264
4265 =item location_cust
4266
4267 Limit to packages whose service locations are the same as the customer's
4268 default service location.
4269
4270 =item location_nocust
4271
4272 Limit to packages whose service locations are not the customer's default
4273 service location.
4274
4275 =item location_census
4276
4277 Limit to packages whose service locations have census tracts.
4278
4279 =item location_nocensus
4280
4281 Limit to packages whose service locations do not have a census tract.
4282
4283 =item location_geocode
4284
4285 Limit to packages whose locations have geocodes.
4286
4287 =item location_geocode
4288
4289 Limit to packages whose locations do not have geocodes.
4290
4291 =back
4292
4293 =cut
4294
4295 sub search {
4296   my ($class, $params) = @_;
4297   my @where = ();
4298
4299   ##
4300   # parse agent
4301   ##
4302
4303   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4304     push @where,
4305       "cust_main.agentnum = $1";
4306   }
4307
4308   ##
4309   # parse cust_status
4310   ##
4311
4312   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4313     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4314   }
4315
4316   ##
4317   # parse customer sales person
4318   ##
4319
4320   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4321     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4322                           : 'cust_main.salesnum IS NULL';
4323   }
4324
4325
4326   ##
4327   # parse sales person
4328   ##
4329
4330   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4331     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4332                           : 'cust_pkg.salesnum IS NULL';
4333   }
4334
4335   ##
4336   # parse custnum
4337   ##
4338
4339   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4340     push @where,
4341       "cust_pkg.custnum = $1";
4342   }
4343
4344   ##
4345   # custbatch
4346   ##
4347
4348   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4349     push @where,
4350       "cust_pkg.pkgbatch = '$1'";
4351   }
4352
4353   ##
4354   # parse status
4355   ##
4356
4357   if (    $params->{'magic'}  eq 'active'
4358        || $params->{'status'} eq 'active' ) {
4359
4360     push @where, FS::cust_pkg->active_sql();
4361
4362   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4363             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4364
4365     push @where, FS::cust_pkg->not_yet_billed_sql();
4366
4367   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4368             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4369
4370     push @where, FS::cust_pkg->inactive_sql();
4371
4372   } elsif (    $params->{'magic'}  eq 'suspended'
4373             || $params->{'status'} eq 'suspended'  ) {
4374
4375     push @where, FS::cust_pkg->suspended_sql();
4376
4377   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4378             || $params->{'status'} =~ /^cancell?ed$/ ) {
4379
4380     push @where, FS::cust_pkg->cancelled_sql();
4381
4382   }
4383
4384   ###
4385   # parse package class
4386   ###
4387
4388   if ( exists($params->{'classnum'}) ) {
4389
4390     my @classnum = ();
4391     if ( ref($params->{'classnum'}) ) {
4392
4393       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4394         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4395       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4396         @classnum = @{ $params->{'classnum'} };
4397       } else {
4398         die 'unhandled classnum ref '. $params->{'classnum'};
4399       }
4400
4401
4402     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4403       @classnum = ( $1 );
4404     }
4405
4406     if ( @classnum ) {
4407
4408       my @c_where = ();
4409       my @nums = grep $_, @classnum;
4410       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4411       my $null = scalar( grep { $_ eq '' } @classnum );
4412       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4413
4414       if ( scalar(@c_where) == 1 ) {
4415         push @where, @c_where;
4416       } elsif ( @c_where ) {
4417         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4418       }
4419
4420     }
4421
4422
4423   }
4424
4425   ###
4426   # parse package report options
4427   ###
4428
4429   my @report_option = ();
4430   if ( exists($params->{'report_option'}) ) {
4431     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4432       @report_option = @{ $params->{'report_option'} };
4433     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4434       @report_option = split(',', $1);
4435     }
4436
4437   }
4438
4439   if (@report_option) {
4440     # this will result in the empty set for the dangling comma case as it should
4441     push @where,
4442       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4443                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4444                     AND optionname = 'report_option_$_'
4445                     AND optionvalue = '1' )"
4446          } @report_option;
4447   }
4448
4449   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4450
4451     my @report_option_any = ();
4452     if ( ref($params->{$any}) eq 'ARRAY' ) {
4453       @report_option_any = @{ $params->{$any} };
4454     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4455       @report_option_any = split(',', $1);
4456     }
4457
4458     if (@report_option_any) {
4459       # this will result in the empty set for the dangling comma case as it should
4460       push @where, ' ( '. join(' OR ',
4461         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4462                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4463                       AND optionname = 'report_option_$_'
4464                       AND optionvalue = '1' )"
4465            } @report_option_any
4466       ). ' ) ';
4467     }
4468
4469   }
4470
4471   ###
4472   # parse custom
4473   ###
4474
4475   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4476
4477   ###
4478   # parse fcc_line
4479   ###
4480
4481   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4482                                                         if $params->{fcc_line};
4483
4484   ###
4485   # parse censustract
4486   ###
4487
4488   if ( exists($params->{'censustract'}) ) {
4489     $params->{'censustract'} =~ /^([.\d]*)$/;
4490     my $censustract = "cust_location.censustract = '$1'";
4491     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4492     push @where,  "( $censustract )";
4493   }
4494
4495   ###
4496   # parse censustract2
4497   ###
4498   if ( exists($params->{'censustract2'})
4499        && $params->{'censustract2'} =~ /^(\d*)$/
4500      )
4501   {
4502     if ($1) {
4503       push @where, "cust_location.censustract LIKE '$1%'";
4504     } else {
4505       push @where,
4506         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4507     }
4508   }
4509
4510   ###
4511   # parse country/state
4512   ###
4513   for (qw(state country)) { # parsing rules are the same for these
4514   if ( exists($params->{$_})
4515     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4516     {
4517       # XXX post-2.3 only--before that, state/country may be in cust_main
4518       push @where, "cust_location.$_ = '$1'";
4519     }
4520   }
4521
4522   ###
4523   # location_* flags
4524   ###
4525   if ( $params->{location_cust} xor $params->{location_nocust} ) {
4526     my $op = $params->{location_cust} ? '=' : '!=';
4527     push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4528   }
4529   if ( $params->{location_census} xor $params->{location_nocensus} ) {
4530     my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4531     push @where, "cust_location.censustract $op";
4532   }
4533   if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4534     my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4535     push @where, "cust_location.geocode $op";
4536   }
4537
4538   ###
4539   # parse part_pkg
4540   ###
4541
4542   if ( ref($params->{'pkgpart'}) ) {
4543
4544     my @pkgpart = ();
4545     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4546       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4547     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4548       @pkgpart = @{ $params->{'pkgpart'} };
4549     } else {
4550       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4551     }
4552
4553     @pkgpart = grep /^(\d+)$/, @pkgpart;
4554
4555     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4556
4557   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4558     push @where, "pkgpart = $1";
4559   }
4560
4561   ###
4562   # parse dates
4563   ###
4564
4565   my $orderby = '';
4566
4567   #false laziness w/report_cust_pkg.html
4568   my %disable = (
4569     'all'             => {},
4570     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4571     'active'          => { 'susp'=>1, 'cancel'=>1 },
4572     'suspended'       => { 'cancel' => 1 },
4573     'cancelled'       => {},
4574     ''                => {},
4575   );
4576
4577   if( exists($params->{'active'} ) ) {
4578     # This overrides all the other date-related fields
4579     my($beginning, $ending) = @{$params->{'active'}};
4580     push @where,
4581       "cust_pkg.setup IS NOT NULL",
4582       "cust_pkg.setup <= $ending",
4583       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4584       "NOT (".FS::cust_pkg->onetime_sql . ")";
4585   }
4586   else {
4587     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4588
4589       next unless exists($params->{$field});
4590
4591       my($beginning, $ending) = @{$params->{$field}};
4592
4593       next if $beginning == 0 && $ending == 4294967295;
4594
4595       push @where,
4596         "cust_pkg.$field IS NOT NULL",
4597         "cust_pkg.$field >= $beginning",
4598         "cust_pkg.$field <= $ending";
4599
4600       $orderby ||= "ORDER BY cust_pkg.$field";
4601
4602     }
4603   }
4604
4605   $orderby ||= 'ORDER BY bill';
4606
4607   ###
4608   # parse magic, legacy, etc.
4609   ###
4610
4611   if ( $params->{'magic'} &&
4612        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4613   ) {
4614
4615     $orderby = 'ORDER BY pkgnum';
4616
4617     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4618       push @where, "pkgpart = $1";
4619     }
4620
4621   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4622
4623     $orderby = 'ORDER BY pkgnum';
4624
4625   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4626
4627     $orderby = 'ORDER BY pkgnum';
4628
4629     push @where, '0 < (
4630       SELECT count(*) FROM pkg_svc
4631        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4632          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4633                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4634                                      AND cust_svc.svcpart = pkg_svc.svcpart
4635                                 )
4636     )';
4637
4638   }
4639
4640   ##
4641   # setup queries, links, subs, etc. for the search
4642   ##
4643
4644   # here is the agent virtualization
4645   if ($params->{CurrentUser}) {
4646     my $access_user =
4647       qsearchs('access_user', { username => $params->{CurrentUser} });
4648
4649     if ($access_user) {
4650       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4651     } else {
4652       push @where, "1=0";
4653     }
4654   } else {
4655     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4656   }
4657
4658   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4659
4660   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4661                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4662                   'LEFT JOIN cust_location USING ( locationnum ) '.
4663                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4664
4665   my $select;
4666   my $count_query;
4667   if ( $params->{'select_zip5'} ) {
4668     my $zip = 'cust_location.zip';
4669
4670     $select = "DISTINCT substr($zip,1,5) as zip";
4671     $orderby = "ORDER BY substr($zip,1,5)";
4672     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4673   } else {
4674     $select = join(', ',
4675                          'cust_pkg.*',
4676                          ( map "part_pkg.$_", qw( pkg freq ) ),
4677                          'pkg_class.classname',
4678                          'cust_main.custnum AS cust_main_custnum',
4679                          FS::UI::Web::cust_sql_fields(
4680                            $params->{'cust_fields'}
4681                          ),
4682                   );
4683     $count_query = 'SELECT COUNT(*)';
4684   }
4685
4686   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4687
4688   my $sql_query = {
4689     'table'       => 'cust_pkg',
4690     'hashref'     => {},
4691     'select'      => $select,
4692     'extra_sql'   => $extra_sql,
4693     'order_by'    => $orderby,
4694     'addl_from'   => $addl_from,
4695     'count_query' => $count_query,
4696   };
4697
4698 }
4699
4700 =item fcc_477_count
4701
4702 Returns a list of two package counts.  The first is a count of packages
4703 based on the supplied criteria and the second is the count of residential
4704 packages with those same criteria.  Criteria are specified as in the search
4705 method.
4706
4707 =cut
4708
4709 sub fcc_477_count {
4710   my ($class, $params) = @_;
4711
4712   my $sql_query = $class->search( $params );
4713
4714   my $count_sql = delete($sql_query->{'count_query'});
4715   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4716     or die "couldn't parse count_sql";
4717
4718   my $count_sth = dbh->prepare($count_sql)
4719     or die "Error preparing $count_sql: ". dbh->errstr;
4720   $count_sth->execute
4721     or die "Error executing $count_sql: ". $count_sth->errstr;
4722   my $count_arrayref = $count_sth->fetchrow_arrayref;
4723
4724   return ( @$count_arrayref );
4725
4726 }
4727
4728 =item tax_locationnum_sql
4729
4730 Returns an SQL expression for the tax location for a package, based
4731 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4732
4733 =cut
4734
4735 sub tax_locationnum_sql {
4736   my $conf = FS::Conf->new;
4737   if ( $conf->exists('tax-pkg_address') ) {
4738     'cust_pkg.locationnum';
4739   }
4740   elsif ( $conf->exists('tax-ship_address') ) {
4741     'cust_main.ship_locationnum';
4742   }
4743   else {
4744     'cust_main.bill_locationnum';
4745   }
4746 }
4747
4748 =item location_sql
4749
4750 Returns a list: the first item is an SQL fragment identifying matching
4751 packages/customers via location (taking into account shipping and package
4752 address taxation, if enabled), and subsequent items are the parameters to
4753 substitute for the placeholders in that fragment.
4754
4755 =cut
4756
4757 sub location_sql {
4758   my($class, %opt) = @_;
4759   my $ornull = $opt{'ornull'};
4760
4761   my $conf = new FS::Conf;
4762
4763   # '?' placeholders in _location_sql_where
4764   my $x = $ornull ? 3 : 2;
4765   my @bill_param = (
4766     ('district')x3,
4767     ('city')x3,
4768     ('county')x$x,
4769     ('state')x$x,
4770     'country'
4771   );
4772
4773   my $main_where;
4774   my @main_param;
4775   if ( $conf->exists('tax-ship_address') ) {
4776
4777     $main_where = "(
4778          (     ( ship_last IS NULL     OR  ship_last  = '' )
4779            AND ". _location_sql_where('cust_main', '', $ornull ). "
4780          )
4781       OR (       ship_last IS NOT NULL AND ship_last != ''
4782            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4783          )
4784     )";
4785     #    AND payby != 'COMP'
4786
4787     @main_param = ( @bill_param, @bill_param );
4788
4789   } else {
4790
4791     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4792     @main_param = @bill_param;
4793
4794   }
4795
4796   my $where;
4797   my @param;
4798   if ( $conf->exists('tax-pkg_address') ) {
4799
4800     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4801
4802     $where = " (
4803                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4804                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4805                )
4806              ";
4807     @param = ( @main_param, @bill_param );
4808
4809   } else {
4810
4811     $where = $main_where;
4812     @param = @main_param;
4813
4814   }
4815
4816   ( $where, @param );
4817
4818 }
4819
4820 #subroutine, helper for location_sql
4821 sub _location_sql_where {
4822   my $table  = shift;
4823   my $prefix = @_ ? shift : '';
4824   my $ornull = @_ ? shift : '';
4825
4826 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4827
4828   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4829
4830   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4831   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4832   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4833
4834   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4835
4836 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4837   "
4838         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4839     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4840     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4841     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4842     AND   $table.${prefix}country  = ?
4843   ";
4844 }
4845
4846 sub _X_show_zero {
4847   my( $self, $what ) = @_;
4848
4849   my $what_show_zero = $what. '_show_zero';
4850   length($self->$what_show_zero())
4851     ? ($self->$what_show_zero() eq 'Y')
4852     : $self->part_pkg->$what_show_zero();
4853 }
4854
4855 =head1 SUBROUTINES
4856
4857 =over 4
4858
4859 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4860
4861 CUSTNUM is a customer (see L<FS::cust_main>)
4862
4863 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4864 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4865 permitted.
4866
4867 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4868 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4869 new billing items.  An error is returned if this is not possible (see
4870 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4871 parameter.
4872
4873 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4874 newly-created cust_pkg objects.
4875
4876 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4877 and inserted.  Multiple FS::pkg_referral records can be created by
4878 setting I<refnum> to an array reference of refnums or a hash reference with
4879 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4880 record will be created corresponding to cust_main.refnum.
4881
4882 =cut
4883
4884 sub order {
4885   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4886
4887   my $conf = new FS::Conf;
4888
4889   # Transactionize this whole mess
4890   local $SIG{HUP} = 'IGNORE';
4891   local $SIG{INT} = 'IGNORE';
4892   local $SIG{QUIT} = 'IGNORE';
4893   local $SIG{TERM} = 'IGNORE';
4894   local $SIG{TSTP} = 'IGNORE';
4895   local $SIG{PIPE} = 'IGNORE';
4896
4897   my $oldAutoCommit = $FS::UID::AutoCommit;
4898   local $FS::UID::AutoCommit = 0;
4899   my $dbh = dbh;
4900
4901   my $error;
4902 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4903 #  return "Customer not found: $custnum" unless $cust_main;
4904
4905   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4906     if $DEBUG;
4907
4908   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4909                          @$remove_pkgnum;
4910
4911   my $change = scalar(@old_cust_pkg) != 0;
4912
4913   my %hash = ();
4914   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4915
4916     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4917          " to pkgpart ". $pkgparts->[0]. "\n"
4918       if $DEBUG;
4919
4920     my $err_or_cust_pkg =
4921       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4922                                 'refnum'  => $refnum,
4923                               );
4924
4925     unless (ref($err_or_cust_pkg)) {
4926       $dbh->rollback if $oldAutoCommit;
4927       return $err_or_cust_pkg;
4928     }
4929
4930     push @$return_cust_pkg, $err_or_cust_pkg;
4931     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4932     return '';
4933
4934   }
4935
4936   # Create the new packages.
4937   foreach my $pkgpart (@$pkgparts) {
4938
4939     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4940
4941     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4942                                       pkgpart => $pkgpart,
4943                                       refnum  => $refnum,
4944                                       %hash,
4945                                     };
4946     $error = $cust_pkg->insert( 'change' => $change );
4947     push @$return_cust_pkg, $cust_pkg;
4948
4949     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4950       my $supp_pkg = FS::cust_pkg->new({
4951           custnum => $custnum,
4952           pkgpart => $link->dst_pkgpart,
4953           refnum  => $refnum,
4954           main_pkgnum => $cust_pkg->pkgnum,
4955           %hash,
4956       });
4957       $error ||= $supp_pkg->insert( 'change' => $change );
4958       push @$return_cust_pkg, $supp_pkg;
4959     }
4960
4961     if ($error) {
4962       $dbh->rollback if $oldAutoCommit;
4963       return $error;
4964     }
4965
4966   }
4967   # $return_cust_pkg now contains refs to all of the newly
4968   # created packages.
4969
4970   # Transfer services and cancel old packages.
4971   foreach my $old_pkg (@old_cust_pkg) {
4972
4973     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4974       if $DEBUG;
4975
4976     foreach my $new_pkg (@$return_cust_pkg) {
4977       $error = $old_pkg->transfer($new_pkg);
4978       if ($error and $error == 0) {
4979         # $old_pkg->transfer failed.
4980         $dbh->rollback if $oldAutoCommit;
4981         return $error;
4982       }
4983     }
4984
4985     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4986       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4987       foreach my $new_pkg (@$return_cust_pkg) {
4988         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4989         if ($error and $error == 0) {
4990           # $old_pkg->transfer failed.
4991         $dbh->rollback if $oldAutoCommit;
4992         return $error;
4993         }
4994       }
4995     }
4996
4997     if ($error > 0) {
4998       # Transfers were successful, but we went through all of the
4999       # new packages and still had services left on the old package.
5000       # We can't cancel the package under the circumstances, so abort.
5001       $dbh->rollback if $oldAutoCommit;
5002       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5003     }
5004     $error = $old_pkg->cancel( quiet=>1 );
5005     if ($error) {
5006       $dbh->rollback;
5007       return $error;
5008     }
5009   }
5010   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5011   '';
5012 }
5013
5014 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5015
5016 A bulk change method to change packages for multiple customers.
5017
5018 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5019 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5020 permitted.
5021
5022 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5023 replace.  The services (see L<FS::cust_svc>) are moved to the
5024 new billing items.  An error is returned if this is not possible (see
5025 L<FS::pkg_svc>).
5026
5027 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5028 newly-created cust_pkg objects.
5029
5030 =cut
5031
5032 sub bulk_change {
5033   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5034
5035   # Transactionize this whole mess
5036   local $SIG{HUP} = 'IGNORE';
5037   local $SIG{INT} = 'IGNORE';
5038   local $SIG{QUIT} = 'IGNORE';
5039   local $SIG{TERM} = 'IGNORE';
5040   local $SIG{TSTP} = 'IGNORE';
5041   local $SIG{PIPE} = 'IGNORE';
5042
5043   my $oldAutoCommit = $FS::UID::AutoCommit;
5044   local $FS::UID::AutoCommit = 0;
5045   my $dbh = dbh;
5046
5047   my @errors;
5048   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5049                          @$remove_pkgnum;
5050
5051   while(scalar(@old_cust_pkg)) {
5052     my @return = ();
5053     my $custnum = $old_cust_pkg[0]->custnum;
5054     my (@remove) = map { $_->pkgnum }
5055                    grep { $_->custnum == $custnum } @old_cust_pkg;
5056     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5057
5058     my $error = order $custnum, $pkgparts, \@remove, \@return;
5059
5060     push @errors, $error
5061       if $error;
5062     push @$return_cust_pkg, @return;
5063   }
5064
5065   if (scalar(@errors)) {
5066     $dbh->rollback if $oldAutoCommit;
5067     return join(' / ', @errors);
5068   }
5069
5070   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5071   '';
5072 }
5073
5074 # Used by FS::Upgrade to migrate to a new database.
5075 sub _upgrade_data {  # class method
5076   my ($class, %opts) = @_;
5077   $class->_upgrade_otaker(%opts);
5078   my @statements = (
5079     # RT#10139, bug resulting in contract_end being set when it shouldn't
5080   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5081     # RT#10830, bad calculation of prorate date near end of year
5082     # the date range for bill is December 2009, and we move it forward
5083     # one year if it's before the previous bill date (which it should
5084     # never be)
5085   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5086   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5087   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5088     # RT6628, add order_date to cust_pkg
5089     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5090         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5091         history_action = \'insert\') where order_date is null',
5092   );
5093   foreach my $sql (@statements) {
5094     my $sth = dbh->prepare($sql);
5095     $sth->execute or die $sth->errstr;
5096   }
5097 }
5098
5099 =back
5100
5101 =head1 BUGS
5102
5103 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5104
5105 In sub order, the @pkgparts array (passed by reference) is clobbered.
5106
5107 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5108 method to pass dates to the recur_prog expression, it should do so.
5109
5110 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5111 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5112 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5113 configuration values.  Probably need a subroutine which decides what to do
5114 based on whether or not we've fetched the user yet, rather than a hash.  See
5115 FS::UID and the TODO.
5116
5117 Now that things are transactional should the check in the insert method be
5118 moved to check ?
5119
5120 =head1 SEE ALSO
5121
5122 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5123 L<FS::pkg_svc>, schema.html from the base documentation
5124
5125 =cut
5126
5127 1;
5128