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