FS/FS/cust_pkg.pm

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