FS/FS/cust_pkg.pm

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