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