FS/FS/cust_pkg.pm

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