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