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