FS/FS/cust_pkg.pm

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