FS/FS/cust_pkg.pm

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