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