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