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