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