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        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1778
1779     if ( ! $opt->{'cust_location'}->locationnum ) {
1780       # not inserted yet
1781       $error = $opt->{'cust_location'}->insert;
1782       if ( $error ) {
1783         $dbh->rollback if $oldAutoCommit;
1784         return "inserting cust_location (transaction rolled back): $error";
1785       }
1786     }
1787     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1788
1789   }
1790
1791   # whether to override pkgpart checking on the new package
1792   my $same_pkgpart = 1;
1793   if ( $opt->{'pkgpart'} and ( $opt->{'pkgpart'} != $self->pkgpart ) ) {
1794     $same_pkgpart = 0;
1795   }
1796
1797   my $unused_credit = 0;
1798   my $keep_dates = $opt->{'keep_dates'};
1799   # Special case.  If the pkgpart is changing, and the customer is
1800   # going to be credited for remaining time, don't keep setup, bill,
1801   # or last_bill dates, and DO pass the flag to cancel() to credit
1802   # the customer.
1803   if ( $opt->{'pkgpart'}
1804        and $opt->{'pkgpart'} != $self->pkgpart
1805        and $self->part_pkg->option('unused_credit_change', 1) ) {
1806     $unused_credit = 1;
1807     $keep_dates = 0;
1808     $hash{$_} = '' foreach qw(setup bill last_bill);
1809   }
1810
1811   if ( $keep_dates ) {
1812     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1813                           resume start_date contract_end ) ) {
1814       $hash{$date} = $self->getfield($date);
1815     }
1816   }
1817   # allow $opt->{'locationnum'} = '' to specifically set it to null
1818   # (i.e. customer default location)
1819   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1820
1821   # usually this doesn't matter.  the two cases where it does are:
1822   # 1. unused_credit_change + pkgpart change + setup fee on the new package
1823   # and
1824   # 2. (more importantly) changing a package before it's billed
1825   $hash{'waive_setup'} = $self->waive_setup;
1826
1827   my $custnum = $self->custnum;
1828   if ( $opt->{cust_main} ) {
1829     my $cust_main = $opt->{cust_main};
1830     unless ( $cust_main->custnum ) {
1831       my $error = $cust_main->insert;
1832       if ( $error ) {
1833         $dbh->rollback if $oldAutoCommit;
1834         return "inserting cust_main (transaction rolled back): $error";
1835       }
1836     }
1837     $custnum = $cust_main->custnum;
1838   }
1839
1840   # Create the new package.
1841   my $cust_pkg = new FS::cust_pkg {
1842     custnum        => $custnum,
1843     pkgpart        => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1844     refnum         => ( $opt->{'refnum'}      || $self->refnum       ),
1845     locationnum    => ( $opt->{'locationnum'}                        ),
1846     %hash,
1847   };
1848   $error = $cust_pkg->insert( 'change' => 1,
1849                               'allow_pkgpart' => $same_pkgpart );
1850   if ($error) {
1851     $dbh->rollback if $oldAutoCommit;
1852     return $error;
1853   }
1854
1855   # Transfer services and cancel old package.
1856
1857   $error = $self->transfer($cust_pkg);
1858   if ($error and $error == 0) {
1859     # $old_pkg->transfer failed.
1860     $dbh->rollback if $oldAutoCommit;
1861     return $error;
1862   }
1863
1864   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1865     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1866     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1867     if ($error and $error == 0) {
1868       # $old_pkg->transfer failed.
1869       $dbh->rollback if $oldAutoCommit;
1870       return $error;
1871     }
1872   }
1873
1874   if ($error > 0) {
1875     # Transfers were successful, but we still had services left on the old
1876     # package.  We can't change the package under this circumstances, so abort.
1877     $dbh->rollback if $oldAutoCommit;
1878     return "Unable to transfer all services from package ". $self->pkgnum;
1879   }
1880
1881   #reset usage if changing pkgpart
1882   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1883   if ($self->pkgpart != $cust_pkg->pkgpart) {
1884     my $part_pkg = $cust_pkg->part_pkg;
1885     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1886                                                  ? ()
1887                                                  : ( 'null' => 1 )
1888                                    )
1889       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1890
1891     if ($error) {
1892       $dbh->rollback if $oldAutoCommit;
1893       return "Error setting usage values: $error";
1894     }
1895   } else {
1896     # if NOT changing pkgpart, transfer any usage pools over
1897     foreach my $usage ($self->cust_pkg_usage) {
1898       $usage->set('pkgnum', $cust_pkg->pkgnum);
1899       $error = $usage->replace;
1900       if ( $error ) {
1901         $dbh->rollback if $oldAutoCommit;
1902         return "Error transferring usage pools: $error";
1903       }
1904     }
1905   }
1906
1907   # transfer discounts, if we're not changing pkgpart
1908   if ( $same_pkgpart ) {
1909     foreach my $old_discount ($self->cust_pkg_discount_active) {
1910       # don't remove the old discount, we may still need to bill that package.
1911       my $new_discount = new FS::cust_pkg_discount {
1912         'pkgnum'      => $cust_pkg->pkgnum,
1913         'discountnum' => $old_discount->discountnum,
1914         'months_used' => $old_discount->months_used,
1915       };
1916       $error = $new_discount->insert;
1917       if ( $error ) {
1918         $dbh->rollback if $oldAutoCommit;
1919         return "Error transferring discounts: $error";
1920       }
1921     }
1922   }
1923
1924   # Order any supplemental packages.
1925   my $part_pkg = $cust_pkg->part_pkg;
1926   my @old_supp_pkgs = $self->supplemental_pkgs;
1927   my @new_supp_pkgs;
1928   foreach my $link ($part_pkg->supp_part_pkg_link) {
1929     my $old;
1930     foreach (@old_supp_pkgs) {
1931       if ($_->pkgpart == $link->dst_pkgpart) {
1932         $old = $_;
1933         $_->pkgpart(0); # so that it can't match more than once
1934       }
1935       last if $old;
1936     }
1937     # false laziness with FS::cust_main::Packages::order_pkg
1938     my $new = FS::cust_pkg->new({
1939         pkgpart       => $link->dst_pkgpart,
1940         pkglinknum    => $link->pkglinknum,
1941         custnum       => $custnum,
1942         main_pkgnum   => $cust_pkg->pkgnum,
1943         locationnum   => $cust_pkg->locationnum,
1944         start_date    => $cust_pkg->start_date,
1945         order_date    => $cust_pkg->order_date,
1946         expire        => $cust_pkg->expire,
1947         adjourn       => $cust_pkg->adjourn,
1948         contract_end  => $cust_pkg->contract_end,
1949         refnum        => $cust_pkg->refnum,
1950         discountnum   => $cust_pkg->discountnum,
1951         waive_setup   => $cust_pkg->waive_setup,
1952     });
1953     if ( $old and $opt->{'keep_dates'} ) {
1954       foreach (qw(setup bill last_bill)) {
1955         $new->set($_, $old->get($_));
1956       }
1957     }
1958     $error = $new->insert( allow_pkgpart => $same_pkgpart );
1959     # transfer services
1960     if ( $old ) {
1961       $error ||= $old->transfer($new);
1962     }
1963     if ( $error and $error > 0 ) {
1964       # no reason why this should ever fail, but still...
1965       $error = "Unable to transfer all services from supplemental package ".
1966         $old->pkgnum;
1967     }
1968     if ( $error ) {
1969       $dbh->rollback if $oldAutoCommit;
1970       return $error;
1971     }
1972     push @new_supp_pkgs, $new;
1973   }
1974
1975   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
1976   #remaining time.
1977   #Don't allow billing the package (preceding period packages and/or
1978   #outstanding usage) if we are keeping dates (i.e. location changing),
1979   #because the new package will be billed for the same date range.
1980   #Supplemental packages are also canceled here.
1981   $error = $self->cancel(
1982     quiet          => 1,
1983     unused_credit  => $unused_credit,
1984     nobill         => $keep_dates,
1985     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
1986   );
1987   if ($error) {
1988     $dbh->rollback if $oldAutoCommit;
1989     return $error;
1990   }
1991
1992   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1993     #$self->cust_main
1994     my $error = $cust_pkg->cust_main->bill(
1995       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
1996     );
1997     if ( $error ) {
1998       $dbh->rollback if $oldAutoCommit;
1999       return $error;
2000     }
2001   }
2002
2003   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2004
2005   $cust_pkg;
2006
2007 }
2008
2009 =item set_quantity QUANTITY
2010
2011 Change the package's quantity field.  This is the one package property
2012 that can safely be changed without canceling and reordering the package
2013 (because it doesn't affect tax eligibility).  Returns an error or an
2014 empty string.
2015
2016 =cut
2017
2018 sub set_quantity {
2019   my $self = shift;
2020   $self = $self->replace_old; # just to make sure
2021   my $qty = shift;
2022   ($qty =~ /^\d+$/ and $qty > 0) or return "bad package quantity $qty";
2023   $self->set('quantity' => $qty);
2024   $self->replace;
2025 }
2026
2027 use Storable 'thaw';
2028 use MIME::Base64;
2029 sub process_bulk_cust_pkg {
2030   my $job = shift;
2031   my $param = thaw(decode_base64(shift));
2032   warn Dumper($param) if $DEBUG;
2033
2034   my $old_part_pkg = qsearchs('part_pkg',
2035                               { pkgpart => $param->{'old_pkgpart'} });
2036   my $new_part_pkg = qsearchs('part_pkg',
2037                               { pkgpart => $param->{'new_pkgpart'} });
2038   die "Must select a new package type\n" unless $new_part_pkg;
2039   #my $keep_dates = $param->{'keep_dates'} || 0;
2040   my $keep_dates = 1; # there is no good reason to turn this off
2041
2042   local $SIG{HUP} = 'IGNORE';
2043   local $SIG{INT} = 'IGNORE';
2044   local $SIG{QUIT} = 'IGNORE';
2045   local $SIG{TERM} = 'IGNORE';
2046   local $SIG{TSTP} = 'IGNORE';
2047   local $SIG{PIPE} = 'IGNORE';
2048
2049   my $oldAutoCommit = $FS::UID::AutoCommit;
2050   local $FS::UID::AutoCommit = 0;
2051   my $dbh = dbh;
2052
2053   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2054
2055   my $i = 0;
2056   foreach my $old_cust_pkg ( @cust_pkgs ) {
2057     $i++;
2058     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2059     if ( $old_cust_pkg->getfield('cancel') ) {
2060       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2061         $old_cust_pkg->pkgnum."\n"
2062         if $DEBUG;
2063       next;
2064     }
2065     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2066       if $DEBUG;
2067     my $error = $old_cust_pkg->change(
2068       'pkgpart'     => $param->{'new_pkgpart'},
2069       'keep_dates'  => $keep_dates
2070     );
2071     if ( !ref($error) ) { # change returns the cust_pkg on success
2072       $dbh->rollback;
2073       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2074     }
2075   }
2076   $dbh->commit if $oldAutoCommit;
2077   return;
2078 }
2079
2080 =item last_bill
2081
2082 Returns the last bill date, or if there is no last bill date, the setup date.
2083 Useful for billing metered services.
2084
2085 =cut
2086
2087 sub last_bill {
2088   my $self = shift;
2089   return $self->setfield('last_bill', $_[0]) if @_;
2090   return $self->getfield('last_bill') if $self->getfield('last_bill');
2091   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2092                                                   'edate'  => $self->bill,  } );
2093   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2094 }
2095
2096 =item last_cust_pkg_reason ACTION
2097
2098 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2099 Returns false if there is no reason or the package is not currenly ACTION'd
2100 ACTION is one of adjourn, susp, cancel, or expire.
2101
2102 =cut
2103
2104 sub last_cust_pkg_reason {
2105   my ( $self, $action ) = ( shift, shift );
2106   my $date = $self->get($action);
2107   qsearchs( {
2108               'table' => 'cust_pkg_reason',
2109               'hashref' => { 'pkgnum' => $self->pkgnum,
2110                              'action' => substr(uc($action), 0, 1),
2111                              'date'   => $date,
2112                            },
2113               'order_by' => 'ORDER BY num DESC LIMIT 1',
2114            } );
2115 }
2116
2117 =item last_reason ACTION
2118
2119 Returns the most recent ACTION FS::reason associated with the package.
2120 Returns false if there is no reason or the package is not currenly ACTION'd
2121 ACTION is one of adjourn, susp, cancel, or expire.
2122
2123 =cut
2124
2125 sub last_reason {
2126   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2127   $cust_pkg_reason->reason
2128     if $cust_pkg_reason;
2129 }
2130
2131 =item part_pkg
2132
2133 Returns the definition for this billing item, as an FS::part_pkg object (see
2134 L<FS::part_pkg>).
2135
2136 =cut
2137
2138 sub part_pkg {
2139   my $self = shift;
2140   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2141   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2142   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2143 }
2144
2145 =item old_cust_pkg
2146
2147 Returns the cancelled package this package was changed from, if any.
2148
2149 =cut
2150
2151 sub old_cust_pkg {
2152   my $self = shift;
2153   return '' unless $self->change_pkgnum;
2154   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2155 }
2156
2157 =item change_cust_main
2158
2159 Returns the customter this package was detached to, if any.
2160
2161 =cut
2162
2163 sub change_cust_main {
2164   my $self = shift;
2165   return '' unless $self->change_custnum;
2166   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2167 }
2168
2169 =item calc_setup
2170
2171 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2172 item.
2173
2174 =cut
2175
2176 sub calc_setup {
2177   my $self = shift;
2178   $self->part_pkg->calc_setup($self, @_);
2179 }
2180
2181 =item calc_recur
2182
2183 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2184 item.
2185
2186 =cut
2187
2188 sub calc_recur {
2189   my $self = shift;
2190   $self->part_pkg->calc_recur($self, @_);
2191 }
2192
2193 =item base_recur
2194
2195 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2196 item.
2197
2198 =cut
2199
2200 sub base_recur {
2201   my $self = shift;
2202   $self->part_pkg->base_recur($self, @_);
2203 }
2204
2205 =item calc_remain
2206
2207 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2208 billing item.
2209
2210 =cut
2211
2212 sub calc_remain {
2213   my $self = shift;
2214   $self->part_pkg->calc_remain($self, @_);
2215 }
2216
2217 =item calc_cancel
2218
2219 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2220 billing item.
2221
2222 =cut
2223
2224 sub calc_cancel {
2225   my $self = shift;
2226   $self->part_pkg->calc_cancel($self, @_);
2227 }
2228
2229 =item cust_bill_pkg
2230
2231 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2232
2233 =cut
2234
2235 sub cust_bill_pkg {
2236   my $self = shift;
2237   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2238 }
2239
2240 =item cust_pkg_detail [ DETAILTYPE ]
2241
2242 Returns any customer package details for this package (see
2243 L<FS::cust_pkg_detail>).
2244
2245 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2246
2247 =cut
2248
2249 sub cust_pkg_detail {
2250   my $self = shift;
2251   my %hash = ( 'pkgnum' => $self->pkgnum );
2252   $hash{detailtype} = shift if @_;
2253   qsearch({
2254     'table'    => 'cust_pkg_detail',
2255     'hashref'  => \%hash,
2256     'order_by' => 'ORDER BY weight, pkgdetailnum',
2257   });
2258 }
2259
2260 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2261
2262 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2263
2264 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2265
2266 If there is an error, returns the error, otherwise returns false.
2267
2268 =cut
2269
2270 sub set_cust_pkg_detail {
2271   my( $self, $detailtype, @details ) = @_;
2272
2273   local $SIG{HUP} = 'IGNORE';
2274   local $SIG{INT} = 'IGNORE';
2275   local $SIG{QUIT} = 'IGNORE';
2276   local $SIG{TERM} = 'IGNORE';
2277   local $SIG{TSTP} = 'IGNORE';
2278   local $SIG{PIPE} = 'IGNORE';
2279
2280   my $oldAutoCommit = $FS::UID::AutoCommit;
2281   local $FS::UID::AutoCommit = 0;
2282   my $dbh = dbh;
2283
2284   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2285     my $error = $current->delete;
2286     if ( $error ) {
2287       $dbh->rollback if $oldAutoCommit;
2288       return "error removing old detail: $error";
2289     }
2290   }
2291
2292   foreach my $detail ( @details ) {
2293     my $cust_pkg_detail = new FS::cust_pkg_detail {
2294       'pkgnum'     => $self->pkgnum,
2295       'detailtype' => $detailtype,
2296       'detail'     => $detail,
2297     };
2298     my $error = $cust_pkg_detail->insert;
2299     if ( $error ) {
2300       $dbh->rollback if $oldAutoCommit;
2301       return "error adding new detail: $error";
2302     }
2303
2304   }
2305
2306   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2307   '';
2308
2309 }
2310
2311 =item cust_event
2312
2313 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2314
2315 =cut
2316
2317 #false laziness w/cust_bill.pm
2318 sub cust_event {
2319   my $self = shift;
2320   qsearch({
2321     'table'     => 'cust_event',
2322     'addl_from' => 'JOIN part_event USING ( eventpart )',
2323     'hashref'   => { 'tablenum' => $self->pkgnum },
2324     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2325   });
2326 }
2327
2328 =item num_cust_event
2329
2330 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2331
2332 =cut
2333
2334 #false laziness w/cust_bill.pm
2335 sub num_cust_event {
2336   my $self = shift;
2337   my $sql =
2338     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2339     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2340   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2341   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2342   $sth->fetchrow_arrayref->[0];
2343 }
2344
2345 =item cust_svc [ SVCPART ] (old, deprecated usage)
2346
2347 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2348
2349 Returns the services for this package, as FS::cust_svc objects (see
2350 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2351 spcififed, returns only the matching services.
2352
2353 =cut
2354
2355 sub cust_svc {
2356   my $self = shift;
2357
2358   return () unless $self->num_cust_svc(@_);
2359
2360   my %opt = ();
2361   if ( @_ && $_[0] =~ /^\d+/ ) {
2362     $opt{svcpart} = shift;
2363   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2364     %opt = %{ $_[0] };
2365   } elsif ( @_ ) {
2366     %opt = @_;
2367   }
2368
2369   my %search = (
2370     'table'   => 'cust_svc',
2371     'hashref' => { 'pkgnum' => $self->pkgnum },
2372   );
2373   if ( $opt{svcpart} ) {
2374     $search{hashref}->{svcpart} = $opt{'svcpart'};
2375   }
2376   if ( $opt{'svcdb'} ) {
2377     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2378     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2379   }
2380
2381   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2382
2383   #if ( $self->{'_svcnum'} ) {
2384   #  values %{ $self->{'_svcnum'}->cache };
2385   #} else {
2386     $self->_sort_cust_svc( [ qsearch(\%search) ] );
2387   #}
2388
2389 }
2390
2391 =item overlimit [ SVCPART ]
2392
2393 Returns the services for this package which have exceeded their
2394 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2395 is specified, return only the matching services.
2396
2397 =cut
2398
2399 sub overlimit {
2400   my $self = shift;
2401   return () unless $self->num_cust_svc(@_);
2402   grep { $_->overlimit } $self->cust_svc(@_);
2403 }
2404
2405 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2406
2407 Returns historical services for this package created before END TIMESTAMP and
2408 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2409 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2410 I<pkg_svc.hidden> flag will be omitted.
2411
2412 =cut
2413
2414 sub h_cust_svc {
2415   my $self = shift;
2416   warn "$me _h_cust_svc called on $self\n"
2417     if $DEBUG;
2418
2419   my ($end, $start, $mode) = @_;
2420   my @cust_svc = $self->_sort_cust_svc(
2421     [ qsearch( 'h_cust_svc',
2422       { 'pkgnum' => $self->pkgnum, },
2423       FS::h_cust_svc->sql_h_search(@_),
2424     ) ]
2425   );
2426   if ( defined($mode) && $mode eq 'I' ) {
2427     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2428     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2429   } else {
2430     return @cust_svc;
2431   }
2432 }
2433
2434 sub _sort_cust_svc {
2435   my( $self, $arrayref ) = @_;
2436
2437   my $sort =
2438     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2439
2440   map  { $_->[0] }
2441   sort $sort
2442   map {
2443         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2444                                              'svcpart' => $_->svcpart     } );
2445         [ $_,
2446           $pkg_svc ? $pkg_svc->primary_svc : '',
2447           $pkg_svc ? $pkg_svc->quantity : 0,
2448         ];
2449       }
2450   @$arrayref;
2451
2452 }
2453
2454 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2455
2456 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2457
2458 Returns the number of services for this package.  Available options are svcpart
2459 and svcdb.  If either is spcififed, returns only the matching services.
2460
2461 =cut
2462
2463 sub num_cust_svc {
2464   my $self = shift;
2465
2466   return $self->{'_num_cust_svc'}
2467     if !scalar(@_)
2468        && exists($self->{'_num_cust_svc'})
2469        && $self->{'_num_cust_svc'} =~ /\d/;
2470
2471   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2472     if $DEBUG > 2;
2473
2474   my %opt = ();
2475   if ( @_ && $_[0] =~ /^\d+/ ) {
2476     $opt{svcpart} = shift;
2477   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2478     %opt = %{ $_[0] };
2479   } elsif ( @_ ) {
2480     %opt = @_;
2481   }
2482
2483   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2484   my $where = ' WHERE pkgnum = ? ';
2485   my @param = ($self->pkgnum);
2486
2487   if ( $opt{'svcpart'} ) {
2488     $where .= ' AND svcpart = ? ';
2489     push @param, $opt{'svcpart'};
2490   }
2491   if ( $opt{'svcdb'} ) {
2492     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2493     $where .= ' AND svcdb = ? ';
2494     push @param, $opt{'svcdb'};
2495   }
2496
2497   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2498   $sth->execute(@param) or die $sth->errstr;
2499   $sth->fetchrow_arrayref->[0];
2500 }
2501
2502 =item available_part_svc
2503
2504 Returns a list of FS::part_svc objects representing services included in this
2505 package but not yet provisioned.  Each FS::part_svc object also has an extra
2506 field, I<num_avail>, which specifies the number of available services.
2507
2508 =cut
2509
2510 sub available_part_svc {
2511   my $self = shift;
2512
2513   my $pkg_quantity = $self->quantity || 1;
2514
2515   grep { $_->num_avail > 0 }
2516     map {
2517           my $part_svc = $_->part_svc;
2518           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2519             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2520
2521           # more evil encapsulation breakage
2522           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2523             my @exports = $part_svc->part_export_did;
2524             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2525           }
2526
2527           $part_svc;
2528         }
2529       $self->part_pkg->pkg_svc;
2530 }
2531
2532 =item part_svc [ OPTION => VALUE ... ]
2533
2534 Returns a list of FS::part_svc objects representing provisioned and available
2535 services included in this package.  Each FS::part_svc object also has the
2536 following extra fields:
2537
2538 =over 4
2539
2540 =item num_cust_svc  (count)
2541
2542 =item num_avail     (quantity - count)
2543
2544 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2545
2546 =back
2547
2548 Accepts one option: summarize_size.  If specified and non-zero, will omit the
2549 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2550 greater.
2551
2552 =cut
2553
2554 #svcnum
2555 #label -> ($cust_svc->label)[1]
2556
2557 sub part_svc {
2558   my $self = shift;
2559   my %opt = @_;
2560
2561   my $pkg_quantity = $self->quantity || 1;
2562
2563   #XXX some sort of sort order besides numeric by svcpart...
2564   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2565     my $pkg_svc = $_;
2566     my $part_svc = $pkg_svc->part_svc;
2567     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2568     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2569     $part_svc->{'Hash'}{'num_avail'}    =
2570       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2571     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2572         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2573       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2574           && $num_cust_svc >= $opt{summarize_size};
2575     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2576     $part_svc;
2577   } $self->part_pkg->pkg_svc;
2578
2579   #extras
2580   push @part_svc, map {
2581     my $part_svc = $_;
2582     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2583     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2584     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
2585     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2586       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2587     $part_svc;
2588   } $self->extra_part_svc;
2589
2590   @part_svc;
2591
2592 }
2593
2594 =item extra_part_svc
2595
2596 Returns a list of FS::part_svc objects corresponding to services in this
2597 package which are still provisioned but not (any longer) available in the
2598 package definition.
2599
2600 =cut
2601
2602 sub extra_part_svc {
2603   my $self = shift;
2604
2605   my $pkgnum  = $self->pkgnum;
2606   #my $pkgpart = $self->pkgpart;
2607
2608 #  qsearch( {
2609 #    'table'     => 'part_svc',
2610 #    'hashref'   => {},
2611 #    'extra_sql' =>
2612 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2613 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
2614 #                       AND pkg_svc.pkgpart = ?
2615 #                       AND quantity > 0
2616 #                 )
2617 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
2618 #                       LEFT JOIN cust_pkg USING ( pkgnum )
2619 #                     WHERE cust_svc.svcpart = part_svc.svcpart
2620 #                       AND pkgnum = ?
2621 #                 )",
2622 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2623 #  } );
2624
2625 #seems to benchmark slightly faster... (or did?)
2626
2627   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2628   my $pkgparts = join(',', @pkgparts);
2629
2630   qsearch( {
2631     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
2632     #MySQL doesn't grok DISINCT ON
2633     'select'      => 'DISTINCT part_svc.*',
2634     'table'       => 'part_svc',
2635     'addl_from'   =>
2636       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
2637                                AND pkg_svc.pkgpart IN ($pkgparts)
2638                                AND quantity > 0
2639                              )
2640        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
2641        LEFT JOIN cust_pkg USING ( pkgnum )
2642       ",
2643     'hashref'     => {},
2644     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2645     'extra_param' => [ [$self->pkgnum=>'int'] ],
2646   } );
2647 }
2648
2649 =item status
2650
2651 Returns a short status string for this package, currently:
2652
2653 =over 4
2654
2655 =item not yet billed
2656
2657 =item one-time charge
2658
2659 =item active
2660
2661 =item suspended
2662
2663 =item cancelled
2664
2665 =back
2666
2667 =cut
2668
2669 sub status {
2670   my $self = shift;
2671
2672   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2673
2674   return 'cancelled' if $self->get('cancel');
2675   return 'suspended' if $self->susp;
2676   return 'not yet billed' unless $self->setup;
2677   return 'one-time charge' if $freq =~ /^(0|$)/;
2678   return 'active';
2679 }
2680
2681 =item ucfirst_status
2682
2683 Returns the status with the first character capitalized.
2684
2685 =cut
2686
2687 sub ucfirst_status {
2688   ucfirst(shift->status);
2689 }
2690
2691 =item statuses
2692
2693 Class method that returns the list of possible status strings for packages
2694 (see L<the status method|/status>).  For example:
2695
2696   @statuses = FS::cust_pkg->statuses();
2697
2698 =cut
2699
2700 tie my %statuscolor, 'Tie::IxHash',
2701   'not yet billed'  => '009999', #teal? cyan?
2702   'one-time charge' => '000000',
2703   'active'          => '00CC00',
2704   'suspended'       => 'FF9900',
2705   'cancelled'       => 'FF0000',
2706 ;
2707
2708 sub statuses {
2709   my $self = shift; #could be class...
2710   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2711   #                                    # mayble split btw one-time vs. recur
2712     keys %statuscolor;
2713 }
2714
2715 =item statuscolor
2716
2717 Returns a hex triplet color string for this package's status.
2718
2719 =cut
2720
2721 sub statuscolor {
2722   my $self = shift;
2723   $statuscolor{$self->status};
2724 }
2725
2726 =item pkg_label
2727
2728 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
2729 "pkg - comment" depending on user preference).
2730
2731 =cut
2732
2733 sub pkg_label {
2734   my $self = shift;
2735   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2736   $label = $self->pkgnum. ": $label"
2737     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2738   $label;
2739 }
2740
2741 =item pkg_label_long
2742
2743 Returns a long label for this package, adding the primary service's label to
2744 pkg_label.
2745
2746 =cut
2747
2748 sub pkg_label_long {
2749   my $self = shift;
2750   my $label = $self->pkg_label;
2751   my $cust_svc = $self->primary_cust_svc;
2752   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2753   $label;
2754 }
2755
2756 =item pkg_locale
2757
2758 Returns a customer-localized label for this package.
2759
2760 =cut
2761
2762 sub pkg_locale {
2763   my $self = shift;
2764   $self->part_pkg->pkg_locale( $self->cust_main->locale );
2765 }
2766
2767 =item primary_cust_svc
2768
2769 Returns a primary service (as FS::cust_svc object) if one can be identified.
2770
2771 =cut
2772
2773 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2774
2775 sub primary_cust_svc {
2776   my $self = shift;
2777
2778   my @cust_svc = $self->cust_svc;
2779
2780   return '' unless @cust_svc; #no serivces - irrelevant then
2781
2782   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2783
2784   # primary service as specified in the package definition
2785   # or exactly one service definition with quantity one
2786   my $svcpart = $self->part_pkg->svcpart;
2787   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2788   return $cust_svc[0] if scalar(@cust_svc) == 1;
2789
2790   #couldn't identify one thing..
2791   return '';
2792 }
2793
2794 =item labels
2795
2796 Returns a list of lists, calling the label method for all services
2797 (see L<FS::cust_svc>) of this billing item.
2798
2799 =cut
2800
2801 sub labels {
2802   my $self = shift;
2803   map { [ $_->label ] } $self->cust_svc;
2804 }
2805
2806 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2807
2808 Like the labels method, but returns historical information on services that
2809 were active as of END_TIMESTAMP and (optionally) not cancelled before
2810 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2811 I<pkg_svc.hidden> flag will be omitted.
2812
2813 Returns a list of lists, calling the label method for all (historical) services
2814 (see L<FS::h_cust_svc>) of this billing item.
2815
2816 =cut
2817
2818 sub h_labels {
2819   my $self = shift;
2820   warn "$me _h_labels called on $self\n"
2821     if $DEBUG;
2822   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2823 }
2824
2825 =item labels_short
2826
2827 Like labels, except returns a simple flat list, and shortens long
2828 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2829 identical services to one line that lists the service label and the number of
2830 individual services rather than individual items.
2831
2832 =cut
2833
2834 sub labels_short {
2835   shift->_labels_short( 'labels', @_ );
2836 }
2837
2838 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2839
2840 Like h_labels, except returns a simple flat list, and shortens long
2841 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2842 identical services to one line that lists the service label and the number of
2843 individual services rather than individual items.
2844
2845 =cut
2846
2847 sub h_labels_short {
2848   shift->_labels_short( 'h_labels', @_ );
2849 }
2850
2851 sub _labels_short {
2852   my( $self, $method ) = ( shift, shift );
2853
2854   warn "$me _labels_short called on $self with $method method\n"
2855     if $DEBUG;
2856
2857   my $conf = new FS::Conf;
2858   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2859
2860   warn "$me _labels_short populating \%labels\n"
2861     if $DEBUG;
2862
2863   my %labels;
2864   #tie %labels, 'Tie::IxHash';
2865   push @{ $labels{$_->[0]} }, $_->[1]
2866     foreach $self->$method(@_);
2867
2868   warn "$me _labels_short populating \@labels\n"
2869     if $DEBUG;
2870
2871   my @labels;
2872   foreach my $label ( keys %labels ) {
2873     my %seen = ();
2874     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2875     my $num = scalar(@values);
2876     warn "$me _labels_short $num items for $label\n"
2877       if $DEBUG;
2878
2879     if ( $num > $max_same_services ) {
2880       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2881         if $DEBUG;
2882       push @labels, "$label ($num)";
2883     } else {
2884       if ( $conf->exists('cust_bill-consolidate_services') ) {
2885         warn "$me _labels_short   consolidating services\n"
2886           if $DEBUG;
2887         # push @labels, "$label: ". join(', ', @values);
2888         while ( @values ) {
2889           my $detail = "$label: ";
2890           $detail .= shift(@values). ', '
2891             while @values
2892                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2893           $detail =~ s/, $//;
2894           push @labels, $detail;
2895         }
2896         warn "$me _labels_short   done consolidating services\n"
2897           if $DEBUG;
2898       } else {
2899         warn "$me _labels_short   adding service data\n"
2900           if $DEBUG;
2901         push @labels, map { "$label: $_" } @values;
2902       }
2903     }
2904   }
2905
2906  @labels;
2907
2908 }
2909
2910 =item cust_main
2911
2912 Returns the parent customer object (see L<FS::cust_main>).
2913
2914 =cut
2915
2916 sub cust_main {
2917   my $self = shift;
2918   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2919 }
2920
2921 =item balance
2922
2923 Returns the balance for this specific package, when using
2924 experimental package balance.
2925
2926 =cut
2927
2928 sub balance {
2929   my $self = shift;
2930   $self->cust_main->balance_pkgnum( $self->pkgnum );
2931 }
2932
2933 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2934
2935 =item cust_location
2936
2937 Returns the location object, if any (see L<FS::cust_location>).
2938
2939 =item cust_location_or_main
2940
2941 If this package is associated with a location, returns the locaiton (see
2942 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2943
2944 =item location_label [ OPTION => VALUE ... ]
2945
2946 Returns the label of the location object (see L<FS::cust_location>).
2947
2948 =cut
2949
2950 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2951
2952 =item tax_locationnum
2953
2954 Returns the foreign key to a L<FS::cust_location> object for calculating
2955 tax on this package, as determined by the C<tax-pkg_address> and
2956 C<tax-ship_address> configuration flags.
2957
2958 =cut
2959
2960 sub tax_locationnum {
2961   my $self = shift;
2962   my $conf = FS::Conf->new;
2963   if ( $conf->exists('tax-pkg_address') ) {
2964     return $self->locationnum;
2965   }
2966   elsif ( $conf->exists('tax-ship_address') ) {
2967     return $self->cust_main->ship_locationnum;
2968   }
2969   else {
2970     return $self->cust_main->bill_locationnum;
2971   }
2972 }
2973
2974 =item tax_location
2975
2976 Returns the L<FS::cust_location> object for tax_locationnum.
2977
2978 =cut
2979
2980 sub tax_location {
2981   my $self = shift;
2982   FS::cust_location->by_key( $self->tax_locationnum )
2983 }
2984
2985 =item seconds_since TIMESTAMP
2986
2987 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2988 package have been online since TIMESTAMP, according to the session monitor.
2989
2990 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2991 L<Time::Local> and L<Date::Parse> for conversion functions.
2992
2993 =cut
2994
2995 sub seconds_since {
2996   my($self, $since) = @_;
2997   my $seconds = 0;
2998
2999   foreach my $cust_svc (
3000     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3001   ) {
3002     $seconds += $cust_svc->seconds_since($since);
3003   }
3004
3005   $seconds;
3006
3007 }
3008
3009 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3010
3011 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3012 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3013 (exclusive).
3014
3015 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3016 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3017 functions.
3018
3019
3020 =cut
3021
3022 sub seconds_since_sqlradacct {
3023   my($self, $start, $end) = @_;
3024
3025   my $seconds = 0;
3026
3027   foreach my $cust_svc (
3028     grep {
3029       my $part_svc = $_->part_svc;
3030       $part_svc->svcdb eq 'svc_acct'
3031         && scalar($part_svc->part_export_usage);
3032     } $self->cust_svc
3033   ) {
3034     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3035   }
3036
3037   $seconds;
3038
3039 }
3040
3041 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3042
3043 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3044 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3045 TIMESTAMP_END
3046 (exclusive).
3047
3048 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3049 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3050 functions.
3051
3052 =cut
3053
3054 sub attribute_since_sqlradacct {
3055   my($self, $start, $end, $attrib) = @_;
3056
3057   my $sum = 0;
3058
3059   foreach my $cust_svc (
3060     grep {
3061       my $part_svc = $_->part_svc;
3062       $part_svc->svcdb eq 'svc_acct'
3063         && scalar($part_svc->part_export_usage);
3064     } $self->cust_svc
3065   ) {
3066     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3067   }
3068
3069   $sum;
3070
3071 }
3072
3073 =item quantity
3074
3075 =cut
3076
3077 sub quantity {
3078   my( $self, $value ) = @_;
3079   if ( defined($value) ) {
3080     $self->setfield('quantity', $value);
3081   }
3082   $self->getfield('quantity') || 1;
3083 }
3084
3085 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3086
3087 Transfers as many services as possible from this package to another package.
3088
3089 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3090 object.  The destination package must already exist.
3091
3092 Services are moved only if the destination allows services with the correct
3093 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3094 this option with caution!  No provision is made for export differences
3095 between the old and new service definitions.  Probably only should be used
3096 when your exports for all service definitions of a given svcdb are identical.
3097 (attempt a transfer without it first, to move all possible svcpart-matching
3098 services)
3099
3100 Any services that can't be moved remain in the original package.
3101
3102 Returns an error, if there is one; otherwise, returns the number of services
3103 that couldn't be moved.
3104
3105 =cut
3106
3107 sub transfer {
3108   my ($self, $dest_pkgnum, %opt) = @_;
3109
3110   my $remaining = 0;
3111   my $dest;
3112   my %target;
3113
3114   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3115     $dest = $dest_pkgnum;
3116     $dest_pkgnum = $dest->pkgnum;
3117   } else {
3118     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3119   }
3120
3121   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3122
3123   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3124     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3125   }
3126
3127   foreach my $cust_svc ($dest->cust_svc) {
3128     $target{$cust_svc->svcpart}--;
3129   }
3130
3131   my %svcpart2svcparts = ();
3132   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3133     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3134     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3135       next if exists $svcpart2svcparts{$svcpart};
3136       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3137       $svcpart2svcparts{$svcpart} = [
3138         map  { $_->[0] }
3139         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3140         map {
3141               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3142                                                    'svcpart' => $_          } );
3143               [ $_,
3144                 $pkg_svc ? $pkg_svc->primary_svc : '',
3145                 $pkg_svc ? $pkg_svc->quantity : 0,
3146               ];
3147             }
3148
3149         grep { $_ != $svcpart }
3150         map  { $_->svcpart }
3151         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3152       ];
3153       warn "alternates for svcpart $svcpart: ".
3154            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3155         if $DEBUG;
3156     }
3157   }
3158
3159   foreach my $cust_svc ($self->cust_svc) {
3160     if($target{$cust_svc->svcpart} > 0
3161        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3162       $target{$cust_svc->svcpart}--;
3163       my $new = new FS::cust_svc { $cust_svc->hash };
3164       $new->pkgnum($dest_pkgnum);
3165       my $error = $new->replace($cust_svc);
3166       return $error if $error;
3167     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3168       if ( $DEBUG ) {
3169         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3170         warn "alternates to consider: ".
3171              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3172       }
3173       my @alternate = grep {
3174                              warn "considering alternate svcpart $_: ".
3175                                   "$target{$_} available in new package\n"
3176                                if $DEBUG;
3177                              $target{$_} > 0;
3178                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3179       if ( @alternate ) {
3180         warn "alternate(s) found\n" if $DEBUG;
3181         my $change_svcpart = $alternate[0];
3182         $target{$change_svcpart}--;
3183         my $new = new FS::cust_svc { $cust_svc->hash };
3184         $new->svcpart($change_svcpart);
3185         $new->pkgnum($dest_pkgnum);
3186         my $error = $new->replace($cust_svc);
3187         return $error if $error;
3188       } else {
3189         $remaining++;
3190       }
3191     } else {
3192       $remaining++
3193     }
3194   }
3195   return $remaining;
3196 }
3197
3198 =item reexport
3199
3200 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3201 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3202
3203 =cut
3204
3205 sub reexport {
3206   my $self = shift;
3207
3208   local $SIG{HUP} = 'IGNORE';
3209   local $SIG{INT} = 'IGNORE';
3210   local $SIG{QUIT} = 'IGNORE';
3211   local $SIG{TERM} = 'IGNORE';
3212   local $SIG{TSTP} = 'IGNORE';
3213   local $SIG{PIPE} = 'IGNORE';
3214
3215   my $oldAutoCommit = $FS::UID::AutoCommit;
3216   local $FS::UID::AutoCommit = 0;
3217   my $dbh = dbh;
3218
3219   foreach my $cust_svc ( $self->cust_svc ) {
3220     #false laziness w/svc_Common::insert
3221     my $svc_x = $cust_svc->svc_x;
3222     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3223       my $error = $part_export->export_insert($svc_x);
3224       if ( $error ) {
3225         $dbh->rollback if $oldAutoCommit;
3226         return $error;
3227       }
3228     }
3229   }
3230
3231   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3232   '';
3233
3234 }
3235
3236 =item insert_reason
3237
3238 Associates this package with a (suspension or cancellation) reason (see
3239 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3240 L<FS::reason>).
3241
3242 Available options are:
3243
3244 =over 4
3245
3246 =item reason
3247
3248 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.
3249
3250 =item reason_otaker
3251
3252 the access_user (see L<FS::access_user>) providing the reason
3253
3254 =item date
3255
3256 a unix timestamp
3257
3258 =item action
3259
3260 the action (cancel, susp, adjourn, expire) associated with the reason
3261
3262 =back
3263
3264 If there is an error, returns the error, otherwise returns false.
3265
3266 =cut
3267
3268 sub insert_reason {
3269   my ($self, %options) = @_;
3270
3271   my $otaker = $options{reason_otaker} ||
3272                $FS::CurrentUser::CurrentUser->username;
3273
3274   my $reasonnum;
3275   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3276
3277     $reasonnum = $1;
3278
3279   } elsif ( ref($options{'reason'}) ) {
3280
3281     return 'Enter a new reason (or select an existing one)'
3282       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3283
3284     my $reason = new FS::reason({
3285       'reason_type' => $options{'reason'}->{'typenum'},
3286       'reason'      => $options{'reason'}->{'reason'},
3287     });
3288     my $error = $reason->insert;
3289     return $error if $error;
3290
3291     $reasonnum = $reason->reasonnum;
3292
3293   } else {
3294     return "Unparsable reason: ". $options{'reason'};
3295   }
3296
3297   my $cust_pkg_reason =
3298     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3299                               'reasonnum' => $reasonnum,
3300                               'otaker'    => $otaker,
3301                               'action'    => substr(uc($options{'action'}),0,1),
3302                               'date'      => $options{'date'}
3303                                                ? $options{'date'}
3304                                                : time,
3305                             });
3306
3307   $cust_pkg_reason->insert;
3308 }
3309
3310 =item insert_discount
3311
3312 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3313 inserting a new discount on the fly (see L<FS::discount>).
3314
3315 Available options are:
3316
3317 =over 4
3318
3319 =item discountnum
3320
3321 =back
3322
3323 If there is an error, returns the error, otherwise returns false.
3324
3325 =cut
3326
3327 sub insert_discount {
3328   #my ($self, %options) = @_;
3329   my $self = shift;
3330
3331   my $cust_pkg_discount = new FS::cust_pkg_discount {
3332     'pkgnum'      => $self->pkgnum,
3333     'discountnum' => $self->discountnum,
3334     'months_used' => 0,
3335     'end_date'    => '', #XXX
3336     #for the create a new discount case
3337     '_type'       => $self->discountnum__type,
3338     'amount'      => $self->discountnum_amount,
3339     'percent'     => $self->discountnum_percent,
3340     'months'      => $self->discountnum_months,
3341     'setup'      => $self->discountnum_setup,
3342     #'disabled'    => $self->discountnum_disabled,
3343   };
3344
3345   $cust_pkg_discount->insert;
3346 }
3347
3348 =item set_usage USAGE_VALUE_HASHREF
3349
3350 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3351 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3352 upbytes, downbytes, and totalbytes are appropriate keys.
3353
3354 All svc_accts which are part of this package have their values reset.
3355
3356 =cut
3357
3358 sub set_usage {
3359   my ($self, $valueref, %opt) = @_;
3360
3361   #only svc_acct can set_usage for now
3362   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3363     my $svc_x = $cust_svc->svc_x;
3364     $svc_x->set_usage($valueref, %opt)
3365       if $svc_x->can("set_usage");
3366   }
3367 }
3368
3369 =item recharge USAGE_VALUE_HASHREF
3370
3371 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3372 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3373 upbytes, downbytes, and totalbytes are appropriate keys.
3374
3375 All svc_accts which are part of this package have their values incremented.
3376
3377 =cut
3378
3379 sub recharge {
3380   my ($self, $valueref) = @_;
3381
3382   #only svc_acct can set_usage for now
3383   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3384     my $svc_x = $cust_svc->svc_x;
3385     $svc_x->recharge($valueref)
3386       if $svc_x->can("recharge");
3387   }
3388 }
3389
3390 =item cust_pkg_discount
3391
3392 =cut
3393
3394 sub cust_pkg_discount {
3395   my $self = shift;
3396   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3397 }
3398
3399 =item cust_pkg_discount_active
3400
3401 =cut
3402
3403 sub cust_pkg_discount_active {
3404   my $self = shift;
3405   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3406 }
3407
3408 =item cust_pkg_usage
3409
3410 Returns a list of all voice usage counters attached to this package.
3411
3412 =cut
3413
3414 sub cust_pkg_usage {
3415   my $self = shift;
3416   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3417 }
3418
3419 =item apply_usage OPTIONS
3420
3421 Takes the following options:
3422 - cdr: a call detail record (L<FS::cdr>)
3423 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3424 - minutes: the maximum number of minutes to be charged
3425
3426 Finds available usage minutes for a call of this class, and subtracts
3427 up to that many minutes from the usage pool.  If the usage pool is empty,
3428 and the C<cdr-minutes_priority> global config option is set, minutes may
3429 be taken from other calls as well.  Either way, an allocation record will
3430 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3431 number of minutes of usage applied to the call.
3432
3433 =cut
3434
3435 sub apply_usage {
3436   my ($self, %opt) = @_;
3437   my $cdr = $opt{cdr};
3438   my $rate_detail = $opt{rate_detail};
3439   my $minutes = $opt{minutes};
3440   my $classnum = $rate_detail->classnum;
3441   my $pkgnum = $self->pkgnum;
3442   my $custnum = $self->custnum;
3443
3444   local $SIG{HUP} = 'IGNORE';
3445   local $SIG{INT} = 'IGNORE';
3446   local $SIG{QUIT} = 'IGNORE';
3447   local $SIG{TERM} = 'IGNORE';
3448   local $SIG{TSTP} = 'IGNORE';
3449   local $SIG{PIPE} = 'IGNORE';
3450
3451   my $oldAutoCommit = $FS::UID::AutoCommit;
3452   local $FS::UID::AutoCommit = 0;
3453   my $dbh = dbh;
3454   my $order = FS::Conf->new->config('cdr-minutes_priority');
3455
3456   my $is_classnum;
3457   if ( $classnum ) {
3458     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3459   } else {
3460     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3461   }
3462   my @usage_recs = qsearch({
3463       'table'     => 'cust_pkg_usage',
3464       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3465                      ' JOIN cust_pkg             USING (pkgnum)'.
3466                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3467       'select'    => 'cust_pkg_usage.*',
3468       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3469                      " ( cust_pkg.custnum = $custnum AND ".
3470                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3471                      $is_classnum . ' AND '.
3472                      " cust_pkg_usage.minutes > 0",
3473       'order_by'  => " ORDER BY priority ASC",
3474   });
3475
3476   my $orig_minutes = $minutes;
3477   my $error;
3478   while (!$error and $minutes > 0 and @usage_recs) {
3479     my $cust_pkg_usage = shift @usage_recs;
3480     $cust_pkg_usage->select_for_update;
3481     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3482         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3483         acctid      => $cdr->acctid,
3484         minutes     => min($cust_pkg_usage->minutes, $minutes),
3485     });
3486     $cust_pkg_usage->set('minutes',
3487       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3488     );
3489     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3490     $minutes -= $cdr_cust_pkg_usage->minutes;
3491   }
3492   if ( $order and $minutes > 0 and !$error ) {
3493     # then try to steal minutes from another call
3494     my %search = (
3495         'table'     => 'cdr_cust_pkg_usage',
3496         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3497                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3498                        ' JOIN cust_pkg              USING (pkgnum)'.
3499                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3500                        ' JOIN cdr                   USING (acctid)',
3501         'select'    => 'cdr_cust_pkg_usage.*',
3502         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3503                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3504                        " ( cust_pkg.custnum = $custnum AND ".
3505                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3506                        " part_pkg_usage_class.classnum = $classnum",
3507         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3508     );
3509     if ( $order eq 'time' ) {
3510       # find CDRs that are using minutes, but have a later startdate
3511       # than this call
3512       my $startdate = $cdr->startdate;
3513       if ($startdate !~ /^\d+$/) {
3514         die "bad cdr startdate '$startdate'";
3515       }
3516       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3517       # minimize needless reshuffling
3518       $search{'order_by'} .= ', cdr.startdate DESC';
3519     } else {
3520       # XXX may not work correctly with rate_time schedules.  Could
3521       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3522       # think...
3523       $search{'addl_from'} .=
3524         ' JOIN rate_detail'.
3525         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3526       if ( $order eq 'rate_high' ) {
3527         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3528                                 $rate_detail->min_charge;
3529         $search{'order_by'} .= ', rate_detail.min_charge ASC';
3530       } elsif ( $order eq 'rate_low' ) {
3531         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3532                                 $rate_detail->min_charge;
3533         $search{'order_by'} .= ', rate_detail.min_charge DESC';
3534       } else {
3535         #  this should really never happen
3536         die "invalid cdr-minutes_priority value '$order'\n";
3537       }
3538     }
3539     my @cdr_usage_recs = qsearch(\%search);
3540     my %reproc_cdrs;
3541     while (!$error and @cdr_usage_recs and $minutes > 0) {
3542       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3543       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3544       my $old_cdr = $cdr_cust_pkg_usage->cdr;
3545       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3546       $cdr_cust_pkg_usage->select_for_update;
3547       $old_cdr->select_for_update;
3548       $cust_pkg_usage->select_for_update;
3549       # in case someone else stole the usage from this CDR
3550       # while waiting for the lock...
3551       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3552       # steal the usage allocation and flag the old CDR for reprocessing
3553       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3554       # if the allocation is more minutes than we need, adjust it...
3555       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3556       if ( $delta > 0 ) {
3557         $cdr_cust_pkg_usage->set('minutes', $minutes);
3558         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3559         $error = $cust_pkg_usage->replace;
3560       }
3561       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3562       $error ||= $cdr_cust_pkg_usage->replace;
3563       # deduct the stolen minutes
3564       $minutes -= $cdr_cust_pkg_usage->minutes;
3565     }
3566     # after all minute-stealing is done, reset the affected CDRs
3567     foreach (values %reproc_cdrs) {
3568       $error ||= $_->set_status('');
3569       # XXX or should we just call $cdr->rate right here?
3570       # it's not like we can create a loop this way, since the min_charge
3571       # or call time has to go monotonically in one direction.
3572       # we COULD get some very deep recursions going, though...
3573     }
3574   } # if $order and $minutes
3575   if ( $error ) {
3576     $dbh->rollback;
3577     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3578   } else {
3579     $dbh->commit if $oldAutoCommit;
3580     return $orig_minutes - $minutes;
3581   }
3582 }
3583
3584 =item supplemental_pkgs
3585
3586 Returns a list of all packages supplemental to this one.
3587
3588 =cut
3589
3590 sub supplemental_pkgs {
3591   my $self = shift;
3592   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3593 }
3594
3595 =item main_pkg
3596
3597 Returns the package that this one is supplemental to, if any.
3598
3599 =cut
3600
3601 sub main_pkg {
3602   my $self = shift;
3603   if ( $self->main_pkgnum ) {
3604     return FS::cust_pkg->by_key($self->main_pkgnum);
3605   }
3606   return;
3607 }
3608
3609 =back
3610
3611 =head1 CLASS METHODS
3612
3613 =over 4
3614
3615 =item recurring_sql
3616
3617 Returns an SQL expression identifying recurring packages.
3618
3619 =cut
3620
3621 sub recurring_sql { "
3622   '0' != ( select freq from part_pkg
3623              where cust_pkg.pkgpart = part_pkg.pkgpart )
3624 "; }
3625
3626 =item onetime_sql
3627
3628 Returns an SQL expression identifying one-time packages.
3629
3630 =cut
3631
3632 sub onetime_sql { "
3633   '0' = ( select freq from part_pkg
3634             where cust_pkg.pkgpart = part_pkg.pkgpart )
3635 "; }
3636
3637 =item ordered_sql
3638
3639 Returns an SQL expression identifying ordered packages (recurring packages not
3640 yet billed).
3641
3642 =cut
3643
3644 sub ordered_sql {
3645    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3646 }
3647
3648 =item active_sql
3649
3650 Returns an SQL expression identifying active packages.
3651
3652 =cut
3653
3654 sub active_sql {
3655   $_[0]->recurring_sql. "
3656   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3657   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3658   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3659 "; }
3660
3661 =item not_yet_billed_sql
3662
3663 Returns an SQL expression identifying packages which have not yet been billed.
3664
3665 =cut
3666
3667 sub not_yet_billed_sql { "
3668       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
3669   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3670   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3671 "; }
3672
3673 =item inactive_sql
3674
3675 Returns an SQL expression identifying inactive packages (one-time packages
3676 that are otherwise unsuspended/uncancelled).
3677
3678 =cut
3679
3680 sub inactive_sql { "
3681   ". $_[0]->onetime_sql(). "
3682   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3683   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3684   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3685 "; }
3686
3687 =item susp_sql
3688 =item suspended_sql
3689
3690 Returns an SQL expression identifying suspended packages.
3691
3692 =cut
3693
3694 sub suspended_sql { susp_sql(@_); }
3695 sub susp_sql {
3696   #$_[0]->recurring_sql(). ' AND '.
3697   "
3698         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
3699     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
3700   ";
3701 }
3702
3703 =item cancel_sql
3704 =item cancelled_sql
3705
3706 Returns an SQL exprression identifying cancelled packages.
3707
3708 =cut
3709
3710 sub cancelled_sql { cancel_sql(@_); }
3711 sub cancel_sql {
3712   #$_[0]->recurring_sql(). ' AND '.
3713   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3714 }
3715
3716 =item status_sql
3717
3718 Returns an SQL expression to give the package status as a string.
3719
3720 =cut
3721
3722 sub status_sql {
3723 "CASE
3724   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3725   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3726   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3727   WHEN ".onetime_sql()." THEN 'one-time charge'
3728   ELSE 'active'
3729 END"
3730 }
3731
3732 =item search HASHREF
3733
3734 (Class method)
3735
3736 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3737 Valid parameters are
3738
3739 =over 4
3740
3741 =item agentnum
3742
3743 =item magic
3744
3745 active, inactive, suspended, cancel (or cancelled)
3746
3747 =item status
3748
3749 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3750
3751 =item custom
3752
3753  boolean selects custom packages
3754
3755 =item classnum
3756
3757 =item pkgpart
3758
3759 pkgpart or arrayref or hashref of pkgparts
3760
3761 =item setup
3762
3763 arrayref of beginning and ending epoch date
3764
3765 =item last_bill
3766
3767 arrayref of beginning and ending epoch date
3768
3769 =item bill
3770
3771 arrayref of beginning and ending epoch date
3772
3773 =item adjourn
3774
3775 arrayref of beginning and ending epoch date
3776
3777 =item susp
3778
3779 arrayref of beginning and ending epoch date
3780
3781 =item expire
3782
3783 arrayref of beginning and ending epoch date
3784
3785 =item cancel
3786
3787 arrayref of beginning and ending epoch date
3788
3789 =item query
3790
3791 pkgnum or APKG_pkgnum
3792
3793 =item cust_fields
3794
3795 a value suited to passing to FS::UI::Web::cust_header
3796
3797 =item CurrentUser
3798
3799 specifies the user for agent virtualization
3800
3801 =item fcc_line
3802
3803 boolean; if true, returns only packages with more than 0 FCC phone lines.
3804
3805 =item state, country
3806
3807 Limit to packages with a service location in the specified state and country.
3808 For FCC 477 reporting, mostly.
3809
3810 =back
3811
3812 =cut
3813
3814 sub search {
3815   my ($class, $params) = @_;
3816   my @where = ();
3817
3818   ##
3819   # parse agent
3820   ##
3821
3822   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3823     push @where,
3824       "cust_main.agentnum = $1";
3825   }
3826
3827   ##
3828   # parse custnum
3829   ##
3830
3831   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3832     push @where,
3833       "cust_pkg.custnum = $1";
3834   }
3835
3836   ##
3837   # custbatch
3838   ##
3839
3840   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3841     push @where,
3842       "cust_pkg.pkgbatch = '$1'";
3843   }
3844
3845   ##
3846   # parse status
3847   ##
3848
3849   if (    $params->{'magic'}  eq 'active'
3850        || $params->{'status'} eq 'active' ) {
3851
3852     push @where, FS::cust_pkg->active_sql();
3853
3854   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3855             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3856
3857     push @where, FS::cust_pkg->not_yet_billed_sql();
3858
3859   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3860             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3861
3862     push @where, FS::cust_pkg->inactive_sql();
3863
3864   } elsif (    $params->{'magic'}  eq 'suspended'
3865             || $params->{'status'} eq 'suspended'  ) {
3866
3867     push @where, FS::cust_pkg->suspended_sql();
3868
3869   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3870             || $params->{'status'} =~ /^cancell?ed$/ ) {
3871
3872     push @where, FS::cust_pkg->cancelled_sql();
3873
3874   }
3875
3876   ###
3877   # parse package class
3878   ###
3879
3880   if ( exists($params->{'classnum'}) ) {
3881
3882     my @classnum = ();
3883     if ( ref($params->{'classnum'}) ) {
3884
3885       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3886         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3887       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3888         @classnum = @{ $params->{'classnum'} };
3889       } else {
3890         die 'unhandled classnum ref '. $params->{'classnum'};
3891       }
3892
3893
3894     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3895       @classnum = ( $1 );
3896     }
3897
3898     if ( @classnum ) {
3899
3900       my @c_where = ();
3901       my @nums = grep $_, @classnum;
3902       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3903       my $null = scalar( grep { $_ eq '' } @classnum );
3904       push @c_where, 'part_pkg.classnum IS NULL' if $null;
3905
3906       if ( scalar(@c_where) == 1 ) {
3907         push @where, @c_where;
3908       } elsif ( @c_where ) {
3909         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3910       }
3911
3912     }
3913
3914
3915   }
3916
3917   ###
3918   # parse package report options
3919   ###
3920
3921   my @report_option = ();
3922   if ( exists($params->{'report_option'}) ) {
3923     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3924       @report_option = @{ $params->{'report_option'} };
3925     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3926       @report_option = split(',', $1);
3927     }
3928
3929   }
3930
3931   if (@report_option) {
3932     # this will result in the empty set for the dangling comma case as it should
3933     push @where,
3934       map{ "0 < ( SELECT count(*) FROM part_pkg_option
3935                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3936                     AND optionname = 'report_option_$_'
3937                     AND optionvalue = '1' )"
3938          } @report_option;
3939   }
3940
3941   foreach my $any ( grep /^report_option_any/, keys %$params ) {
3942
3943     my @report_option_any = ();
3944     if ( ref($params->{$any}) eq 'ARRAY' ) {
3945       @report_option_any = @{ $params->{$any} };
3946     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3947       @report_option_any = split(',', $1);
3948     }
3949
3950     if (@report_option_any) {
3951       # this will result in the empty set for the dangling comma case as it should
3952       push @where, ' ( '. join(' OR ',
3953         map{ "0 < ( SELECT count(*) FROM part_pkg_option
3954                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3955                       AND optionname = 'report_option_$_'
3956                       AND optionvalue = '1' )"
3957            } @report_option_any
3958       ). ' ) ';
3959     }
3960
3961   }
3962
3963   ###
3964   # parse custom
3965   ###
3966
3967   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3968
3969   ###
3970   # parse fcc_line
3971   ###
3972
3973   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3974                                                         if $params->{fcc_line};
3975
3976   ###
3977   # parse censustract
3978   ###
3979
3980   if ( exists($params->{'censustract'}) ) {
3981     $params->{'censustract'} =~ /^([.\d]*)$/;
3982     my $censustract = "cust_location.censustract = '$1'";
3983     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3984     push @where,  "( $censustract )";
3985   }
3986
3987   ###
3988   # parse censustract2
3989   ###
3990   if ( exists($params->{'censustract2'})
3991        && $params->{'censustract2'} =~ /^(\d*)$/
3992      )
3993   {
3994     if ($1) {
3995       push @where, "cust_location.censustract LIKE '$1%'";
3996     } else {
3997       push @where,
3998         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3999     }
4000   }
4001
4002   ###
4003   # parse country/state
4004   ###
4005   for (qw(state country)) { # parsing rules are the same for these
4006   if ( exists($params->{$_})
4007     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4008     {
4009       # XXX post-2.3 only--before that, state/country may be in cust_main
4010       push @where, "cust_location.$_ = '$1'";
4011     }
4012   }
4013
4014   ###
4015   # parse part_pkg
4016   ###
4017
4018   if ( ref($params->{'pkgpart'}) ) {
4019
4020     my @pkgpart = ();
4021     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4022       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4023     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4024       @pkgpart = @{ $params->{'pkgpart'} };
4025     } else {
4026       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4027     }
4028
4029     @pkgpart = grep /^(\d+)$/, @pkgpart;
4030
4031     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4032
4033   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4034     push @where, "pkgpart = $1";
4035   }
4036
4037   ###
4038   # parse dates
4039   ###
4040
4041   my $orderby = '';
4042
4043   #false laziness w/report_cust_pkg.html
4044   my %disable = (
4045     'all'             => {},
4046     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4047     'active'          => { 'susp'=>1, 'cancel'=>1 },
4048     'suspended'       => { 'cancel' => 1 },
4049     'cancelled'       => {},
4050     ''                => {},
4051   );
4052
4053   if( exists($params->{'active'} ) ) {
4054     # This overrides all the other date-related fields
4055     my($beginning, $ending) = @{$params->{'active'}};
4056     push @where,
4057       "cust_pkg.setup IS NOT NULL",
4058       "cust_pkg.setup <= $ending",
4059       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4060       "NOT (".FS::cust_pkg->onetime_sql . ")";
4061   }
4062   else {
4063     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4064
4065       next unless exists($params->{$field});
4066
4067       my($beginning, $ending) = @{$params->{$field}};
4068
4069       next if $beginning == 0 && $ending == 4294967295;
4070
4071       push @where,
4072         "cust_pkg.$field IS NOT NULL",
4073         "cust_pkg.$field >= $beginning",
4074         "cust_pkg.$field <= $ending";
4075
4076       $orderby ||= "ORDER BY cust_pkg.$field";
4077
4078     }
4079   }
4080
4081   $orderby ||= 'ORDER BY bill';
4082
4083   ###
4084   # parse magic, legacy, etc.
4085   ###
4086
4087   if ( $params->{'magic'} &&
4088        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4089   ) {
4090
4091     $orderby = 'ORDER BY pkgnum';
4092
4093     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4094       push @where, "pkgpart = $1";
4095     }
4096
4097   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4098
4099     $orderby = 'ORDER BY pkgnum';
4100
4101   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4102
4103     $orderby = 'ORDER BY pkgnum';
4104
4105     push @where, '0 < (
4106       SELECT count(*) FROM pkg_svc
4107        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4108          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4109                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4110                                      AND cust_svc.svcpart = pkg_svc.svcpart
4111                                 )
4112     )';
4113
4114   }
4115
4116   ##
4117   # setup queries, links, subs, etc. for the search
4118   ##
4119
4120   # here is the agent virtualization
4121   if ($params->{CurrentUser}) {
4122     my $access_user =
4123       qsearchs('access_user', { username => $params->{CurrentUser} });
4124
4125     if ($access_user) {
4126       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4127     } else {
4128       push @where, "1=0";
4129     }
4130   } else {
4131     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4132   }
4133
4134   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4135
4136   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4137                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4138                   'LEFT JOIN cust_location USING ( locationnum ) '.
4139                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4140
4141   my $select;
4142   my $count_query;
4143   if ( $params->{'select_zip5'} ) {
4144     my $zip = 'cust_location.zip';
4145
4146     $select = "DISTINCT substr($zip,1,5) as zip";
4147     $orderby = "ORDER BY substr($zip,1,5)";
4148     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4149   } else {
4150     $select = join(', ',
4151                          'cust_pkg.*',
4152                          ( map "part_pkg.$_", qw( pkg freq ) ),
4153                          'pkg_class.classname',
4154                          'cust_main.custnum AS cust_main_custnum',
4155                          FS::UI::Web::cust_sql_fields(
4156                            $params->{'cust_fields'}
4157                          ),
4158                   );
4159     $count_query = 'SELECT COUNT(*)';
4160   }
4161
4162   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4163
4164   my $sql_query = {
4165     'table'       => 'cust_pkg',
4166     'hashref'     => {},
4167     'select'      => $select,
4168     'extra_sql'   => $extra_sql,
4169     'order_by'    => $orderby,
4170     'addl_from'   => $addl_from,
4171     'count_query' => $count_query,
4172   };
4173
4174 }
4175
4176 =item fcc_477_count
4177
4178 Returns a list of two package counts.  The first is a count of packages
4179 based on the supplied criteria and the second is the count of residential
4180 packages with those same criteria.  Criteria are specified as in the search
4181 method.
4182
4183 =cut
4184
4185 sub fcc_477_count {
4186   my ($class, $params) = @_;
4187
4188   my $sql_query = $class->search( $params );
4189
4190   my $count_sql = delete($sql_query->{'count_query'});
4191   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4192     or die "couldn't parse count_sql";
4193
4194   my $count_sth = dbh->prepare($count_sql)
4195     or die "Error preparing $count_sql: ". dbh->errstr;
4196   $count_sth->execute
4197     or die "Error executing $count_sql: ". $count_sth->errstr;
4198   my $count_arrayref = $count_sth->fetchrow_arrayref;
4199
4200   return ( @$count_arrayref );
4201
4202 }
4203
4204 =item tax_locationnum_sql
4205
4206 Returns an SQL expression for the tax location for a package, based
4207 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4208
4209 =cut
4210
4211 sub tax_locationnum_sql {
4212   my $conf = FS::Conf->new;
4213   if ( $conf->exists('tax-pkg_address') ) {
4214     'cust_pkg.locationnum';
4215   }
4216   elsif ( $conf->exists('tax-ship_address') ) {
4217     'cust_main.ship_locationnum';
4218   }
4219   else {
4220     'cust_main.bill_locationnum';
4221   }
4222 }
4223
4224 =item location_sql
4225
4226 Returns a list: the first item is an SQL fragment identifying matching
4227 packages/customers via location (taking into account shipping and package
4228 address taxation, if enabled), and subsequent items are the parameters to
4229 substitute for the placeholders in that fragment.
4230
4231 =cut
4232
4233 sub location_sql {
4234   my($class, %opt) = @_;
4235   my $ornull = $opt{'ornull'};
4236
4237   my $conf = new FS::Conf;
4238
4239   # '?' placeholders in _location_sql_where
4240   my $x = $ornull ? 3 : 2;
4241   my @bill_param = (
4242     ('district')x3,
4243     ('city')x3,
4244     ('county')x$x,
4245     ('state')x$x,
4246     'country'
4247   );
4248
4249   my $main_where;
4250   my @main_param;
4251   if ( $conf->exists('tax-ship_address') ) {
4252
4253     $main_where = "(
4254          (     ( ship_last IS NULL     OR  ship_last  = '' )
4255            AND ". _location_sql_where('cust_main', '', $ornull ). "
4256          )
4257       OR (       ship_last IS NOT NULL AND ship_last != ''
4258            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4259          )
4260     )";
4261     #    AND payby != 'COMP'
4262
4263     @main_param = ( @bill_param, @bill_param );
4264
4265   } else {
4266
4267     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4268     @main_param = @bill_param;
4269
4270   }
4271
4272   my $where;
4273   my @param;
4274   if ( $conf->exists('tax-pkg_address') ) {
4275
4276     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4277
4278     $where = " (
4279                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4280                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4281                )
4282              ";
4283     @param = ( @main_param, @bill_param );
4284
4285   } else {
4286
4287     $where = $main_where;
4288     @param = @main_param;
4289
4290   }
4291
4292   ( $where, @param );
4293
4294 }
4295
4296 #subroutine, helper for location_sql
4297 sub _location_sql_where {
4298   my $table  = shift;
4299   my $prefix = @_ ? shift : '';
4300   my $ornull = @_ ? shift : '';
4301
4302 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4303
4304   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4305
4306   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4307   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4308   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4309
4310   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4311
4312 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4313   "
4314         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4315     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4316     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4317     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4318     AND   $table.${prefix}country  = ?
4319   ";
4320 }
4321
4322 sub _X_show_zero {
4323   my( $self, $what ) = @_;
4324
4325   my $what_show_zero = $what. '_show_zero';
4326   length($self->$what_show_zero())
4327     ? ($self->$what_show_zero() eq 'Y')
4328     : $self->part_pkg->$what_show_zero();
4329 }
4330
4331 =head1 SUBROUTINES
4332
4333 =over 4
4334
4335 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4336
4337 CUSTNUM is a customer (see L<FS::cust_main>)
4338
4339 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4340 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4341 permitted.
4342
4343 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4344 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4345 new billing items.  An error is returned if this is not possible (see
4346 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4347 parameter.
4348
4349 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4350 newly-created cust_pkg objects.
4351
4352 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4353 and inserted.  Multiple FS::pkg_referral records can be created by
4354 setting I<refnum> to an array reference of refnums or a hash reference with
4355 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4356 record will be created corresponding to cust_main.refnum.
4357
4358 =cut
4359
4360 sub order {
4361   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4362
4363   my $conf = new FS::Conf;
4364
4365   # Transactionize this whole mess
4366   local $SIG{HUP} = 'IGNORE';
4367   local $SIG{INT} = 'IGNORE';
4368   local $SIG{QUIT} = 'IGNORE';
4369   local $SIG{TERM} = 'IGNORE';
4370   local $SIG{TSTP} = 'IGNORE';
4371   local $SIG{PIPE} = 'IGNORE';
4372
4373   my $oldAutoCommit = $FS::UID::AutoCommit;
4374   local $FS::UID::AutoCommit = 0;
4375   my $dbh = dbh;
4376
4377   my $error;
4378 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4379 #  return "Customer not found: $custnum" unless $cust_main;
4380
4381   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4382     if $DEBUG;
4383
4384   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4385                          @$remove_pkgnum;
4386
4387   my $change = scalar(@old_cust_pkg) != 0;
4388
4389   my %hash = ();
4390   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4391
4392     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4393          " to pkgpart ". $pkgparts->[0]. "\n"
4394       if $DEBUG;
4395
4396     my $err_or_cust_pkg =
4397       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4398                                 'refnum'  => $refnum,
4399                               );
4400
4401     unless (ref($err_or_cust_pkg)) {
4402       $dbh->rollback if $oldAutoCommit;
4403       return $err_or_cust_pkg;
4404     }
4405
4406     push @$return_cust_pkg, $err_or_cust_pkg;
4407     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4408     return '';
4409
4410   }
4411
4412   # Create the new packages.
4413   foreach my $pkgpart (@$pkgparts) {
4414
4415     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4416
4417     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4418                                       pkgpart => $pkgpart,
4419                                       refnum  => $refnum,
4420                                       %hash,
4421                                     };
4422     $error = $cust_pkg->insert( 'change' => $change );
4423     push @$return_cust_pkg, $cust_pkg;
4424
4425     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4426       my $supp_pkg = FS::cust_pkg->new({
4427           custnum => $custnum,
4428           pkgpart => $link->dst_pkgpart,
4429           refnum  => $refnum,
4430           main_pkgnum => $cust_pkg->pkgnum,
4431           %hash,
4432       });
4433       $error ||= $supp_pkg->insert( 'change' => $change );
4434       push @$return_cust_pkg, $supp_pkg;
4435     }
4436
4437     if ($error) {
4438       $dbh->rollback if $oldAutoCommit;
4439       return $error;
4440     }
4441
4442   }
4443   # $return_cust_pkg now contains refs to all of the newly
4444   # created packages.
4445
4446   # Transfer services and cancel old packages.
4447   foreach my $old_pkg (@old_cust_pkg) {
4448
4449     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4450       if $DEBUG;
4451
4452     foreach my $new_pkg (@$return_cust_pkg) {
4453       $error = $old_pkg->transfer($new_pkg);
4454       if ($error and $error == 0) {
4455         # $old_pkg->transfer failed.
4456         $dbh->rollback if $oldAutoCommit;
4457         return $error;
4458       }
4459     }
4460
4461     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4462       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4463       foreach my $new_pkg (@$return_cust_pkg) {
4464         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4465         if ($error and $error == 0) {
4466           # $old_pkg->transfer failed.
4467         $dbh->rollback if $oldAutoCommit;
4468         return $error;
4469         }
4470       }
4471     }
4472
4473     if ($error > 0) {
4474       # Transfers were successful, but we went through all of the
4475       # new packages and still had services left on the old package.
4476       # We can't cancel the package under the circumstances, so abort.
4477       $dbh->rollback if $oldAutoCommit;
4478       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4479     }
4480     $error = $old_pkg->cancel( quiet=>1 );
4481     if ($error) {
4482       $dbh->rollback;
4483       return $error;
4484     }
4485   }
4486   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4487   '';
4488 }
4489
4490 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4491
4492 A bulk change method to change packages for multiple customers.
4493
4494 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4495 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4496 permitted.
4497
4498 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4499 replace.  The services (see L<FS::cust_svc>) are moved to the
4500 new billing items.  An error is returned if this is not possible (see
4501 L<FS::pkg_svc>).
4502
4503 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4504 newly-created cust_pkg objects.
4505
4506 =cut
4507
4508 sub bulk_change {
4509   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4510
4511   # Transactionize this whole mess
4512   local $SIG{HUP} = 'IGNORE';
4513   local $SIG{INT} = 'IGNORE';
4514   local $SIG{QUIT} = 'IGNORE';
4515   local $SIG{TERM} = 'IGNORE';
4516   local $SIG{TSTP} = 'IGNORE';
4517   local $SIG{PIPE} = 'IGNORE';
4518
4519   my $oldAutoCommit = $FS::UID::AutoCommit;
4520   local $FS::UID::AutoCommit = 0;
4521   my $dbh = dbh;
4522
4523   my @errors;
4524   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4525                          @$remove_pkgnum;
4526
4527   while(scalar(@old_cust_pkg)) {
4528     my @return = ();
4529     my $custnum = $old_cust_pkg[0]->custnum;
4530     my (@remove) = map { $_->pkgnum }
4531                    grep { $_->custnum == $custnum } @old_cust_pkg;
4532     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4533
4534     my $error = order $custnum, $pkgparts, \@remove, \@return;
4535
4536     push @errors, $error
4537       if $error;
4538     push @$return_cust_pkg, @return;
4539   }
4540
4541   if (scalar(@errors)) {
4542     $dbh->rollback if $oldAutoCommit;
4543     return join(' / ', @errors);
4544   }
4545
4546   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4547   '';
4548 }
4549
4550 # Used by FS::Upgrade to migrate to a new database.
4551 sub _upgrade_data {  # class method
4552   my ($class, %opts) = @_;
4553   $class->_upgrade_otaker(%opts);
4554   my @statements = (
4555     # RT#10139, bug resulting in contract_end being set when it shouldn't
4556   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4557     # RT#10830, bad calculation of prorate date near end of year
4558     # the date range for bill is December 2009, and we move it forward
4559     # one year if it's before the previous bill date (which it should
4560     # never be)
4561   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4562   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4563   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4564     # RT6628, add order_date to cust_pkg
4565     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4566         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4567         history_action = \'insert\') where order_date is null',
4568   );
4569   foreach my $sql (@statements) {
4570     my $sth = dbh->prepare($sql);
4571     $sth->execute or die $sth->errstr;
4572   }
4573 }
4574
4575 =back
4576
4577 =head1 BUGS
4578
4579 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4580
4581 In sub order, the @pkgparts array (passed by reference) is clobbered.
4582
4583 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4584 method to pass dates to the recur_prog expression, it should do so.
4585
4586 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4587 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4588 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4589 configuration values.  Probably need a subroutine which decides what to do
4590 based on whether or not we've fetched the user yet, rather than a hash.  See
4591 FS::UID and the TODO.
4592
4593 Now that things are transactional should the check in the insert method be
4594 moved to check ?
4595
4596 =head1 SEE ALSO
4597
4598 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4599 L<FS::pkg_svc>, schema.html from the base documentation
4600
4601 =cut
4602
4603 1;
4604