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 primary_cust_svc
2676
2677 Returns a primary service (as FS::cust_svc object) if one can be identified.
2678
2679 =cut
2680
2681 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2682
2683 sub primary_cust_svc {
2684   my $self = shift;
2685
2686   my @cust_svc = $self->cust_svc;
2687
2688   return '' unless @cust_svc; #no serivces - irrelevant then
2689
2690   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2691
2692   # primary service as specified in the package definition
2693   # or exactly one service definition with quantity one
2694   my $svcpart = $self->part_pkg->svcpart;
2695   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2696   return $cust_svc[0] if scalar(@cust_svc) == 1;
2697
2698   #couldn't identify one thing..
2699   return '';
2700 }
2701
2702 =item labels
2703
2704 Returns a list of lists, calling the label method for all services
2705 (see L<FS::cust_svc>) of this billing item.
2706
2707 =cut
2708
2709 sub labels {
2710   my $self = shift;
2711   map { [ $_->label ] } $self->cust_svc;
2712 }
2713
2714 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2715
2716 Like the labels method, but returns historical information on services that
2717 were active as of END_TIMESTAMP and (optionally) not cancelled before
2718 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2719 I<pkg_svc.hidden> flag will be omitted.
2720
2721 Returns a list of lists, calling the label method for all (historical) services
2722 (see L<FS::h_cust_svc>) of this billing item.
2723
2724 =cut
2725
2726 sub h_labels {
2727   my $self = shift;
2728   warn "$me _h_labels called on $self\n"
2729     if $DEBUG;
2730   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2731 }
2732
2733 =item labels_short
2734
2735 Like labels, except returns a simple flat list, and shortens long
2736 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2737 identical services to one line that lists the service label and the number of
2738 individual services rather than individual items.
2739
2740 =cut
2741
2742 sub labels_short {
2743   shift->_labels_short( 'labels', @_ );
2744 }
2745
2746 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2747
2748 Like h_labels, except returns a simple flat list, and shortens long
2749 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2750 identical services to one line that lists the service label and the number of
2751 individual services rather than individual items.
2752
2753 =cut
2754
2755 sub h_labels_short {
2756   shift->_labels_short( 'h_labels', @_ );
2757 }
2758
2759 sub _labels_short {
2760   my( $self, $method ) = ( shift, shift );
2761
2762   warn "$me _labels_short called on $self with $method method\n"
2763     if $DEBUG;
2764
2765   my $conf = new FS::Conf;
2766   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2767
2768   warn "$me _labels_short populating \%labels\n"
2769     if $DEBUG;
2770
2771   my %labels;
2772   #tie %labels, 'Tie::IxHash';
2773   push @{ $labels{$_->[0]} }, $_->[1]
2774     foreach $self->$method(@_);
2775
2776   warn "$me _labels_short populating \@labels\n"
2777     if $DEBUG;
2778
2779   my @labels;
2780   foreach my $label ( keys %labels ) {
2781     my %seen = ();
2782     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2783     my $num = scalar(@values);
2784     warn "$me _labels_short $num items for $label\n"
2785       if $DEBUG;
2786
2787     if ( $num > $max_same_services ) {
2788       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2789         if $DEBUG;
2790       push @labels, "$label ($num)";
2791     } else {
2792       if ( $conf->exists('cust_bill-consolidate_services') ) {
2793         warn "$me _labels_short   consolidating services\n"
2794           if $DEBUG;
2795         # push @labels, "$label: ". join(', ', @values);
2796         while ( @values ) {
2797           my $detail = "$label: ";
2798           $detail .= shift(@values). ', '
2799             while @values
2800                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2801           $detail =~ s/, $//;
2802           push @labels, $detail;
2803         }
2804         warn "$me _labels_short   done consolidating services\n"
2805           if $DEBUG;
2806       } else {
2807         warn "$me _labels_short   adding service data\n"
2808           if $DEBUG;
2809         push @labels, map { "$label: $_" } @values;
2810       }
2811     }
2812   }
2813
2814  @labels;
2815
2816 }
2817
2818 =item cust_main
2819
2820 Returns the parent customer object (see L<FS::cust_main>).
2821
2822 =cut
2823
2824 sub cust_main {
2825   my $self = shift;
2826   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2827 }
2828
2829 =item balance
2830
2831 Returns the balance for this specific package, when using
2832 experimental package balance.
2833
2834 =cut
2835
2836 sub balance {
2837   my $self = shift;
2838   $self->cust_main->balance_pkgnum( $self->pkgnum );
2839 }
2840
2841 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2842
2843 =item cust_location
2844
2845 Returns the location object, if any (see L<FS::cust_location>).
2846
2847 =item cust_location_or_main
2848
2849 If this package is associated with a location, returns the locaiton (see
2850 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2851
2852 =item location_label [ OPTION => VALUE ... ]
2853
2854 Returns the label of the location object (see L<FS::cust_location>).
2855
2856 =cut
2857
2858 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2859
2860 =item tax_locationnum
2861
2862 Returns the foreign key to a L<FS::cust_location> object for calculating
2863 tax on this package, as determined by the C<tax-pkg_address> and
2864 C<tax-ship_address> configuration flags.
2865
2866 =cut
2867
2868 sub tax_locationnum {
2869   my $self = shift;
2870   my $conf = FS::Conf->new;
2871   if ( $conf->exists('tax-pkg_address') ) {
2872     return $self->locationnum;
2873   }
2874   elsif ( $conf->exists('tax-ship_address') ) {
2875     return $self->cust_main->ship_locationnum;
2876   }
2877   else {
2878     return $self->cust_main->bill_locationnum;
2879   }
2880 }
2881
2882 =item tax_location
2883
2884 Returns the L<FS::cust_location> object for tax_locationnum.
2885
2886 =cut
2887
2888 sub tax_location {
2889   my $self = shift;
2890   FS::cust_location->by_key( $self->tax_locationnum )
2891 }
2892
2893 =item seconds_since TIMESTAMP
2894
2895 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2896 package have been online since TIMESTAMP, according to the session monitor.
2897
2898 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2899 L<Time::Local> and L<Date::Parse> for conversion functions.
2900
2901 =cut
2902
2903 sub seconds_since {
2904   my($self, $since) = @_;
2905   my $seconds = 0;
2906
2907   foreach my $cust_svc (
2908     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2909   ) {
2910     $seconds += $cust_svc->seconds_since($since);
2911   }
2912
2913   $seconds;
2914
2915 }
2916
2917 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2918
2919 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2920 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2921 (exclusive).
2922
2923 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2924 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2925 functions.
2926
2927
2928 =cut
2929
2930 sub seconds_since_sqlradacct {
2931   my($self, $start, $end) = @_;
2932
2933   my $seconds = 0;
2934
2935   foreach my $cust_svc (
2936     grep {
2937       my $part_svc = $_->part_svc;
2938       $part_svc->svcdb eq 'svc_acct'
2939         && scalar($part_svc->part_export_usage);
2940     } $self->cust_svc
2941   ) {
2942     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2943   }
2944
2945   $seconds;
2946
2947 }
2948
2949 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2950
2951 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2952 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2953 TIMESTAMP_END
2954 (exclusive).
2955
2956 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2957 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2958 functions.
2959
2960 =cut
2961
2962 sub attribute_since_sqlradacct {
2963   my($self, $start, $end, $attrib) = @_;
2964
2965   my $sum = 0;
2966
2967   foreach my $cust_svc (
2968     grep {
2969       my $part_svc = $_->part_svc;
2970       $part_svc->svcdb eq 'svc_acct'
2971         && scalar($part_svc->part_export_usage);
2972     } $self->cust_svc
2973   ) {
2974     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2975   }
2976
2977   $sum;
2978
2979 }
2980
2981 =item quantity
2982
2983 =cut
2984
2985 sub quantity {
2986   my( $self, $value ) = @_;
2987   if ( defined($value) ) {
2988     $self->setfield('quantity', $value);
2989   }
2990   $self->getfield('quantity') || 1;
2991 }
2992
2993 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2994
2995 Transfers as many services as possible from this package to another package.
2996
2997 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2998 object.  The destination package must already exist.
2999
3000 Services are moved only if the destination allows services with the correct
3001 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3002 this option with caution!  No provision is made for export differences
3003 between the old and new service definitions.  Probably only should be used
3004 when your exports for all service definitions of a given svcdb are identical.
3005 (attempt a transfer without it first, to move all possible svcpart-matching
3006 services)
3007
3008 Any services that can't be moved remain in the original package.
3009
3010 Returns an error, if there is one; otherwise, returns the number of services
3011 that couldn't be moved.
3012
3013 =cut
3014
3015 sub transfer {
3016   my ($self, $dest_pkgnum, %opt) = @_;
3017
3018   my $remaining = 0;
3019   my $dest;
3020   my %target;
3021
3022   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3023     $dest = $dest_pkgnum;
3024     $dest_pkgnum = $dest->pkgnum;
3025   } else {
3026     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3027   }
3028
3029   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3030
3031   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3032     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3033   }
3034
3035   foreach my $cust_svc ($dest->cust_svc) {
3036     $target{$cust_svc->svcpart}--;
3037   }
3038
3039   my %svcpart2svcparts = ();
3040   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3041     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3042     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3043       next if exists $svcpart2svcparts{$svcpart};
3044       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3045       $svcpart2svcparts{$svcpart} = [
3046         map  { $_->[0] }
3047         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3048         map {
3049               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3050                                                    'svcpart' => $_          } );
3051               [ $_,
3052                 $pkg_svc ? $pkg_svc->primary_svc : '',
3053                 $pkg_svc ? $pkg_svc->quantity : 0,
3054               ];
3055             }
3056
3057         grep { $_ != $svcpart }
3058         map  { $_->svcpart }
3059         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3060       ];
3061       warn "alternates for svcpart $svcpart: ".
3062            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3063         if $DEBUG;
3064     }
3065   }
3066
3067   foreach my $cust_svc ($self->cust_svc) {
3068     if($target{$cust_svc->svcpart} > 0
3069        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3070       $target{$cust_svc->svcpart}--;
3071       my $new = new FS::cust_svc { $cust_svc->hash };
3072       $new->pkgnum($dest_pkgnum);
3073       my $error = $new->replace($cust_svc);
3074       return $error if $error;
3075     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3076       if ( $DEBUG ) {
3077         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3078         warn "alternates to consider: ".
3079              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3080       }
3081       my @alternate = grep {
3082                              warn "considering alternate svcpart $_: ".
3083                                   "$target{$_} available in new package\n"
3084                                if $DEBUG;
3085                              $target{$_} > 0;
3086                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3087       if ( @alternate ) {
3088         warn "alternate(s) found\n" if $DEBUG;
3089         my $change_svcpart = $alternate[0];
3090         $target{$change_svcpart}--;
3091         my $new = new FS::cust_svc { $cust_svc->hash };
3092         $new->svcpart($change_svcpart);
3093         $new->pkgnum($dest_pkgnum);
3094         my $error = $new->replace($cust_svc);
3095         return $error if $error;
3096       } else {
3097         $remaining++;
3098       }
3099     } else {
3100       $remaining++
3101     }
3102   }
3103   return $remaining;
3104 }
3105
3106 =item reexport
3107
3108 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3109 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3110
3111 =cut
3112
3113 sub reexport {
3114   my $self = shift;
3115
3116   local $SIG{HUP} = 'IGNORE';
3117   local $SIG{INT} = 'IGNORE';
3118   local $SIG{QUIT} = 'IGNORE';
3119   local $SIG{TERM} = 'IGNORE';
3120   local $SIG{TSTP} = 'IGNORE';
3121   local $SIG{PIPE} = 'IGNORE';
3122
3123   my $oldAutoCommit = $FS::UID::AutoCommit;
3124   local $FS::UID::AutoCommit = 0;
3125   my $dbh = dbh;
3126
3127   foreach my $cust_svc ( $self->cust_svc ) {
3128     #false laziness w/svc_Common::insert
3129     my $svc_x = $cust_svc->svc_x;
3130     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3131       my $error = $part_export->export_insert($svc_x);
3132       if ( $error ) {
3133         $dbh->rollback if $oldAutoCommit;
3134         return $error;
3135       }
3136     }
3137   }
3138
3139   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3140   '';
3141
3142 }
3143
3144 =item insert_reason
3145
3146 Associates this package with a (suspension or cancellation) reason (see
3147 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3148 L<FS::reason>).
3149
3150 Available options are:
3151
3152 =over 4
3153
3154 =item reason
3155
3156 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.
3157
3158 =item reason_otaker
3159
3160 the access_user (see L<FS::access_user>) providing the reason
3161
3162 =item date
3163
3164 a unix timestamp
3165
3166 =item action
3167
3168 the action (cancel, susp, adjourn, expire) associated with the reason
3169
3170 =back
3171
3172 If there is an error, returns the error, otherwise returns false.
3173
3174 =cut
3175
3176 sub insert_reason {
3177   my ($self, %options) = @_;
3178
3179   my $otaker = $options{reason_otaker} ||
3180                $FS::CurrentUser::CurrentUser->username;
3181
3182   my $reasonnum;
3183   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3184
3185     $reasonnum = $1;
3186
3187   } elsif ( ref($options{'reason'}) ) {
3188
3189     return 'Enter a new reason (or select an existing one)'
3190       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3191
3192     my $reason = new FS::reason({
3193       'reason_type' => $options{'reason'}->{'typenum'},
3194       'reason'      => $options{'reason'}->{'reason'},
3195     });
3196     my $error = $reason->insert;
3197     return $error if $error;
3198
3199     $reasonnum = $reason->reasonnum;
3200
3201   } else {
3202     return "Unparsable reason: ". $options{'reason'};
3203   }
3204
3205   my $cust_pkg_reason =
3206     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3207                               'reasonnum' => $reasonnum,
3208                               'otaker'    => $otaker,
3209                               'action'    => substr(uc($options{'action'}),0,1),
3210                               'date'      => $options{'date'}
3211                                                ? $options{'date'}
3212                                                : time,
3213                             });
3214
3215   $cust_pkg_reason->insert;
3216 }
3217
3218 =item insert_discount
3219
3220 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3221 inserting a new discount on the fly (see L<FS::discount>).
3222
3223 Available options are:
3224
3225 =over 4
3226
3227 =item discountnum
3228
3229 =back
3230
3231 If there is an error, returns the error, otherwise returns false.
3232
3233 =cut
3234
3235 sub insert_discount {
3236   #my ($self, %options) = @_;
3237   my $self = shift;
3238
3239   my $cust_pkg_discount = new FS::cust_pkg_discount {
3240     'pkgnum'      => $self->pkgnum,
3241     'discountnum' => $self->discountnum,
3242     'months_used' => 0,
3243     'end_date'    => '', #XXX
3244     #for the create a new discount case
3245     '_type'       => $self->discountnum__type,
3246     'amount'      => $self->discountnum_amount,
3247     'percent'     => $self->discountnum_percent,
3248     'months'      => $self->discountnum_months,
3249     'setup'      => $self->discountnum_setup,
3250     #'disabled'    => $self->discountnum_disabled,
3251   };
3252
3253   $cust_pkg_discount->insert;
3254 }
3255
3256 =item set_usage USAGE_VALUE_HASHREF
3257
3258 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3259 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3260 upbytes, downbytes, and totalbytes are appropriate keys.
3261
3262 All svc_accts which are part of this package have their values reset.
3263
3264 =cut
3265
3266 sub set_usage {
3267   my ($self, $valueref, %opt) = @_;
3268
3269   #only svc_acct can set_usage for now
3270   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3271     my $svc_x = $cust_svc->svc_x;
3272     $svc_x->set_usage($valueref, %opt)
3273       if $svc_x->can("set_usage");
3274   }
3275 }
3276
3277 =item recharge USAGE_VALUE_HASHREF
3278
3279 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3280 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3281 upbytes, downbytes, and totalbytes are appropriate keys.
3282
3283 All svc_accts which are part of this package have their values incremented.
3284
3285 =cut
3286
3287 sub recharge {
3288   my ($self, $valueref) = @_;
3289
3290   #only svc_acct can set_usage for now
3291   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3292     my $svc_x = $cust_svc->svc_x;
3293     $svc_x->recharge($valueref)
3294       if $svc_x->can("recharge");
3295   }
3296 }
3297
3298 =item cust_pkg_discount
3299
3300 =cut
3301
3302 sub cust_pkg_discount {
3303   my $self = shift;
3304   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3305 }
3306
3307 =item cust_pkg_discount_active
3308
3309 =cut
3310
3311 sub cust_pkg_discount_active {
3312   my $self = shift;
3313   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3314 }
3315
3316 =item cust_pkg_usage
3317
3318 Returns a list of all voice usage counters attached to this package.
3319
3320 =cut
3321
3322 sub cust_pkg_usage {
3323   my $self = shift;
3324   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3325 }
3326
3327 =item apply_usage OPTIONS
3328
3329 Takes the following options:
3330 - cdr: a call detail record (L<FS::cdr>)
3331 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3332 - minutes: the maximum number of minutes to be charged
3333
3334 Finds available usage minutes for a call of this class, and subtracts
3335 up to that many minutes from the usage pool.  If the usage pool is empty,
3336 and the C<cdr-minutes_priority> global config option is set, minutes may
3337 be taken from other calls as well.  Either way, an allocation record will
3338 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3339 number of minutes of usage applied to the call.
3340
3341 =cut
3342
3343 sub apply_usage {
3344   my ($self, %opt) = @_;
3345   my $cdr = $opt{cdr};
3346   my $rate_detail = $opt{rate_detail};
3347   my $minutes = $opt{minutes};
3348   my $classnum = $rate_detail->classnum;
3349   my $pkgnum = $self->pkgnum;
3350   my $custnum = $self->custnum;
3351
3352   local $SIG{HUP} = 'IGNORE';
3353   local $SIG{INT} = 'IGNORE';
3354   local $SIG{QUIT} = 'IGNORE';
3355   local $SIG{TERM} = 'IGNORE';
3356   local $SIG{TSTP} = 'IGNORE';
3357   local $SIG{PIPE} = 'IGNORE';
3358
3359   my $oldAutoCommit = $FS::UID::AutoCommit;
3360   local $FS::UID::AutoCommit = 0;
3361   my $dbh = dbh;
3362   my $order = FS::Conf->new->config('cdr-minutes_priority');
3363
3364   my $is_classnum;
3365   if ( $classnum ) {
3366     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3367   } else {
3368     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3369   }
3370   my @usage_recs = qsearch({
3371       'table'     => 'cust_pkg_usage',
3372       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3373                      ' JOIN cust_pkg             USING (pkgnum)'.
3374                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3375       'select'    => 'cust_pkg_usage.*',
3376       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3377                      " ( cust_pkg.custnum = $custnum AND ".
3378                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3379                      $is_classnum . ' AND '.
3380                      " cust_pkg_usage.minutes > 0",
3381       'order_by'  => " ORDER BY priority ASC",
3382   });
3383
3384   my $orig_minutes = $minutes;
3385   my $error;
3386   while (!$error and $minutes > 0 and @usage_recs) {
3387     my $cust_pkg_usage = shift @usage_recs;
3388     $cust_pkg_usage->select_for_update;
3389     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3390         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3391         acctid      => $cdr->acctid,
3392         minutes     => min($cust_pkg_usage->minutes, $minutes),
3393     });
3394     $cust_pkg_usage->set('minutes',
3395       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3396     );
3397     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3398     $minutes -= $cdr_cust_pkg_usage->minutes;
3399   }
3400   if ( $order and $minutes > 0 and !$error ) {
3401     # then try to steal minutes from another call
3402     my %search = (
3403         'table'     => 'cdr_cust_pkg_usage',
3404         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3405                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3406                        ' JOIN cust_pkg              USING (pkgnum)'.
3407                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3408                        ' JOIN cdr                   USING (acctid)',
3409         'select'    => 'cdr_cust_pkg_usage.*',
3410         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3411                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3412                        " ( cust_pkg.custnum = $custnum AND ".
3413                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3414                        " part_pkg_usage_class.classnum = $classnum",
3415         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3416     );
3417     if ( $order eq 'time' ) {
3418       # find CDRs that are using minutes, but have a later startdate
3419       # than this call
3420       my $startdate = $cdr->startdate;
3421       if ($startdate !~ /^\d+$/) {
3422         die "bad cdr startdate '$startdate'";
3423       }
3424       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3425       # minimize needless reshuffling
3426       $search{'order_by'} .= ', cdr.startdate DESC';
3427     } else {
3428       # XXX may not work correctly with rate_time schedules.  Could
3429       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3430       # think...
3431       $search{'addl_from'} .=
3432         ' JOIN rate_detail'.
3433         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3434       if ( $order eq 'rate_high' ) {
3435         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3436                                 $rate_detail->min_charge;
3437         $search{'order_by'} .= ', rate_detail.min_charge ASC';
3438       } elsif ( $order eq 'rate_low' ) {
3439         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3440                                 $rate_detail->min_charge;
3441         $search{'order_by'} .= ', rate_detail.min_charge DESC';
3442       } else {
3443         #  this should really never happen
3444         die "invalid cdr-minutes_priority value '$order'\n";
3445       }
3446     }
3447     my @cdr_usage_recs = qsearch(\%search);
3448     my %reproc_cdrs;
3449     while (!$error and @cdr_usage_recs and $minutes > 0) {
3450       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3451       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3452       my $old_cdr = $cdr_cust_pkg_usage->cdr;
3453       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3454       $cdr_cust_pkg_usage->select_for_update;
3455       $old_cdr->select_for_update;
3456       $cust_pkg_usage->select_for_update;
3457       # in case someone else stole the usage from this CDR
3458       # while waiting for the lock...
3459       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3460       # steal the usage allocation and flag the old CDR for reprocessing
3461       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3462       # if the allocation is more minutes than we need, adjust it...
3463       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3464       if ( $delta > 0 ) {
3465         $cdr_cust_pkg_usage->set('minutes', $minutes);
3466         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3467         $error = $cust_pkg_usage->replace;
3468       }
3469       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3470       $error ||= $cdr_cust_pkg_usage->replace;
3471       # deduct the stolen minutes
3472       $minutes -= $cdr_cust_pkg_usage->minutes;
3473     }
3474     # after all minute-stealing is done, reset the affected CDRs
3475     foreach (values %reproc_cdrs) {
3476       $error ||= $_->set_status('');
3477       # XXX or should we just call $cdr->rate right here?
3478       # it's not like we can create a loop this way, since the min_charge
3479       # or call time has to go monotonically in one direction.
3480       # we COULD get some very deep recursions going, though...
3481     }
3482   } # if $order and $minutes
3483   if ( $error ) {
3484     $dbh->rollback;
3485     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3486   } else {
3487     $dbh->commit if $oldAutoCommit;
3488     return $orig_minutes - $minutes;
3489   }
3490 }
3491
3492 =item supplemental_pkgs
3493
3494 Returns a list of all packages supplemental to this one.
3495
3496 =cut
3497
3498 sub supplemental_pkgs {
3499   my $self = shift;
3500   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3501 }
3502
3503 =item main_pkg
3504
3505 Returns the package that this one is supplemental to, if any.
3506
3507 =cut
3508
3509 sub main_pkg {
3510   my $self = shift;
3511   if ( $self->main_pkgnum ) {
3512     return FS::cust_pkg->by_key($self->main_pkgnum);
3513   }
3514   return;
3515 }
3516
3517 =back
3518
3519 =head1 CLASS METHODS
3520
3521 =over 4
3522
3523 =item recurring_sql
3524
3525 Returns an SQL expression identifying recurring packages.
3526
3527 =cut
3528
3529 sub recurring_sql { "
3530   '0' != ( select freq from part_pkg
3531              where cust_pkg.pkgpart = part_pkg.pkgpart )
3532 "; }
3533
3534 =item onetime_sql
3535
3536 Returns an SQL expression identifying one-time packages.
3537
3538 =cut
3539
3540 sub onetime_sql { "
3541   '0' = ( select freq from part_pkg
3542             where cust_pkg.pkgpart = part_pkg.pkgpart )
3543 "; }
3544
3545 =item ordered_sql
3546
3547 Returns an SQL expression identifying ordered packages (recurring packages not
3548 yet billed).
3549
3550 =cut
3551
3552 sub ordered_sql {
3553    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3554 }
3555
3556 =item active_sql
3557
3558 Returns an SQL expression identifying active packages.
3559
3560 =cut
3561
3562 sub active_sql {
3563   $_[0]->recurring_sql. "
3564   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3565   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3566   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3567 "; }
3568
3569 =item not_yet_billed_sql
3570
3571 Returns an SQL expression identifying packages which have not yet been billed.
3572
3573 =cut
3574
3575 sub not_yet_billed_sql { "
3576       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
3577   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3578   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3579 "; }
3580
3581 =item inactive_sql
3582
3583 Returns an SQL expression identifying inactive packages (one-time packages
3584 that are otherwise unsuspended/uncancelled).
3585
3586 =cut
3587
3588 sub inactive_sql { "
3589   ". $_[0]->onetime_sql(). "
3590   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3591   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3592   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3593 "; }
3594
3595 =item susp_sql
3596 =item suspended_sql
3597
3598 Returns an SQL expression identifying suspended packages.
3599
3600 =cut
3601
3602 sub suspended_sql { susp_sql(@_); }
3603 sub susp_sql {
3604   #$_[0]->recurring_sql(). ' AND '.
3605   "
3606         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
3607     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
3608   ";
3609 }
3610
3611 =item cancel_sql
3612 =item cancelled_sql
3613
3614 Returns an SQL exprression identifying cancelled packages.
3615
3616 =cut
3617
3618 sub cancelled_sql { cancel_sql(@_); }
3619 sub cancel_sql {
3620   #$_[0]->recurring_sql(). ' AND '.
3621   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3622 }
3623
3624 =item status_sql
3625
3626 Returns an SQL expression to give the package status as a string.
3627
3628 =cut
3629
3630 sub status_sql {
3631 "CASE
3632   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3633   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3634   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3635   WHEN ".onetime_sql()." THEN 'one-time charge'
3636   ELSE 'active'
3637 END"
3638 }
3639
3640 =item search HASHREF
3641
3642 (Class method)
3643
3644 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3645 Valid parameters are
3646
3647 =over 4
3648
3649 =item agentnum
3650
3651 =item magic
3652
3653 active, inactive, suspended, cancel (or cancelled)
3654
3655 =item status
3656
3657 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3658
3659 =item custom
3660
3661  boolean selects custom packages
3662
3663 =item classnum
3664
3665 =item pkgpart
3666
3667 pkgpart or arrayref or hashref of pkgparts
3668
3669 =item setup
3670
3671 arrayref of beginning and ending epoch date
3672
3673 =item last_bill
3674
3675 arrayref of beginning and ending epoch date
3676
3677 =item bill
3678
3679 arrayref of beginning and ending epoch date
3680
3681 =item adjourn
3682
3683 arrayref of beginning and ending epoch date
3684
3685 =item susp
3686
3687 arrayref of beginning and ending epoch date
3688
3689 =item expire
3690
3691 arrayref of beginning and ending epoch date
3692
3693 =item cancel
3694
3695 arrayref of beginning and ending epoch date
3696
3697 =item query
3698
3699 pkgnum or APKG_pkgnum
3700
3701 =item cust_fields
3702
3703 a value suited to passing to FS::UI::Web::cust_header
3704
3705 =item CurrentUser
3706
3707 specifies the user for agent virtualization
3708
3709 =item fcc_line
3710
3711 boolean; if true, returns only packages with more than 0 FCC phone lines.
3712
3713 =item state, country
3714
3715 Limit to packages with a service location in the specified state and country.
3716 For FCC 477 reporting, mostly.
3717
3718 =back
3719
3720 =cut
3721
3722 sub search {
3723   my ($class, $params) = @_;
3724   my @where = ();
3725
3726   ##
3727   # parse agent
3728   ##
3729
3730   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3731     push @where,
3732       "cust_main.agentnum = $1";
3733   }
3734
3735   ##
3736   # parse custnum
3737   ##
3738
3739   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3740     push @where,
3741       "cust_pkg.custnum = $1";
3742   }
3743
3744   ##
3745   # custbatch
3746   ##
3747
3748   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3749     push @where,
3750       "cust_pkg.pkgbatch = '$1'";
3751   }
3752
3753   ##
3754   # parse status
3755   ##
3756
3757   if (    $params->{'magic'}  eq 'active'
3758        || $params->{'status'} eq 'active' ) {
3759
3760     push @where, FS::cust_pkg->active_sql();
3761
3762   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3763             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3764
3765     push @where, FS::cust_pkg->not_yet_billed_sql();
3766
3767   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3768             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3769
3770     push @where, FS::cust_pkg->inactive_sql();
3771
3772   } elsif (    $params->{'magic'}  eq 'suspended'
3773             || $params->{'status'} eq 'suspended'  ) {
3774
3775     push @where, FS::cust_pkg->suspended_sql();
3776
3777   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3778             || $params->{'status'} =~ /^cancell?ed$/ ) {
3779
3780     push @where, FS::cust_pkg->cancelled_sql();
3781
3782   }
3783
3784   ###
3785   # parse package class
3786   ###
3787
3788   if ( exists($params->{'classnum'}) ) {
3789
3790     my @classnum = ();
3791     if ( ref($params->{'classnum'}) ) {
3792
3793       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3794         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3795       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3796         @classnum = @{ $params->{'classnum'} };
3797       } else {
3798         die 'unhandled classnum ref '. $params->{'classnum'};
3799       }
3800
3801
3802     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3803       @classnum = ( $1 );
3804     }
3805
3806     if ( @classnum ) {
3807
3808       my @c_where = ();
3809       my @nums = grep $_, @classnum;
3810       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3811       my $null = scalar( grep { $_ eq '' } @classnum );
3812       push @c_where, 'part_pkg.classnum IS NULL' if $null;
3813
3814       if ( scalar(@c_where) == 1 ) {
3815         push @where, @c_where;
3816       } elsif ( @c_where ) {
3817         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3818       }
3819
3820     }
3821
3822
3823   }
3824
3825   ###
3826   # parse package report options
3827   ###
3828
3829   my @report_option = ();
3830   if ( exists($params->{'report_option'}) ) {
3831     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3832       @report_option = @{ $params->{'report_option'} };
3833     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3834       @report_option = split(',', $1);
3835     }
3836
3837   }
3838
3839   if (@report_option) {
3840     # this will result in the empty set for the dangling comma case as it should
3841     push @where,
3842       map{ "0 < ( SELECT count(*) FROM part_pkg_option
3843                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3844                     AND optionname = 'report_option_$_'
3845                     AND optionvalue = '1' )"
3846          } @report_option;
3847   }
3848
3849   foreach my $any ( grep /^report_option_any/, keys %$params ) {
3850
3851     my @report_option_any = ();
3852     if ( ref($params->{$any}) eq 'ARRAY' ) {
3853       @report_option_any = @{ $params->{$any} };
3854     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3855       @report_option_any = split(',', $1);
3856     }
3857
3858     if (@report_option_any) {
3859       # this will result in the empty set for the dangling comma case as it should
3860       push @where, ' ( '. join(' OR ',
3861         map{ "0 < ( SELECT count(*) FROM part_pkg_option
3862                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3863                       AND optionname = 'report_option_$_'
3864                       AND optionvalue = '1' )"
3865            } @report_option_any
3866       ). ' ) ';
3867     }
3868
3869   }
3870
3871   ###
3872   # parse custom
3873   ###
3874
3875   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3876
3877   ###
3878   # parse fcc_line
3879   ###
3880
3881   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3882                                                         if $params->{fcc_line};
3883
3884   ###
3885   # parse censustract
3886   ###
3887
3888   if ( exists($params->{'censustract'}) ) {
3889     $params->{'censustract'} =~ /^([.\d]*)$/;
3890     my $censustract = "cust_location.censustract = '$1'";
3891     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3892     push @where,  "( $censustract )";
3893   }
3894
3895   ###
3896   # parse censustract2
3897   ###
3898   if ( exists($params->{'censustract2'})
3899        && $params->{'censustract2'} =~ /^(\d*)$/
3900      )
3901   {
3902     if ($1) {
3903       push @where, "cust_location.censustract LIKE '$1%'";
3904     } else {
3905       push @where,
3906         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3907     }
3908   }
3909
3910   ###
3911   # parse country/state
3912   ###
3913   for (qw(state country)) { # parsing rules are the same for these
3914   if ( exists($params->{$_})
3915     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3916     {
3917       # XXX post-2.3 only--before that, state/country may be in cust_main
3918       push @where, "cust_location.$_ = '$1'";
3919     }
3920   }
3921
3922   ###
3923   # parse part_pkg
3924   ###
3925
3926   if ( ref($params->{'pkgpart'}) ) {
3927
3928     my @pkgpart = ();
3929     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3930       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3931     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3932       @pkgpart = @{ $params->{'pkgpart'} };
3933     } else {
3934       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3935     }
3936
3937     @pkgpart = grep /^(\d+)$/, @pkgpart;
3938
3939     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3940
3941   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3942     push @where, "pkgpart = $1";
3943   }
3944
3945   ###
3946   # parse dates
3947   ###
3948
3949   my $orderby = '';
3950
3951   #false laziness w/report_cust_pkg.html
3952   my %disable = (
3953     'all'             => {},
3954     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3955     'active'          => { 'susp'=>1, 'cancel'=>1 },
3956     'suspended'       => { 'cancel' => 1 },
3957     'cancelled'       => {},
3958     ''                => {},
3959   );
3960
3961   if( exists($params->{'active'} ) ) {
3962     # This overrides all the other date-related fields
3963     my($beginning, $ending) = @{$params->{'active'}};
3964     push @where,
3965       "cust_pkg.setup IS NOT NULL",
3966       "cust_pkg.setup <= $ending",
3967       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3968       "NOT (".FS::cust_pkg->onetime_sql . ")";
3969   }
3970   else {
3971     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
3972
3973       next unless exists($params->{$field});
3974
3975       my($beginning, $ending) = @{$params->{$field}};
3976
3977       next if $beginning == 0 && $ending == 4294967295;
3978
3979       push @where,
3980         "cust_pkg.$field IS NOT NULL",
3981         "cust_pkg.$field >= $beginning",
3982         "cust_pkg.$field <= $ending";
3983
3984       $orderby ||= "ORDER BY cust_pkg.$field";
3985
3986     }
3987   }
3988
3989   $orderby ||= 'ORDER BY bill';
3990
3991   ###
3992   # parse magic, legacy, etc.
3993   ###
3994
3995   if ( $params->{'magic'} &&
3996        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3997   ) {
3998
3999     $orderby = 'ORDER BY pkgnum';
4000
4001     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4002       push @where, "pkgpart = $1";
4003     }
4004
4005   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4006
4007     $orderby = 'ORDER BY pkgnum';
4008
4009   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4010
4011     $orderby = 'ORDER BY pkgnum';
4012
4013     push @where, '0 < (
4014       SELECT count(*) FROM pkg_svc
4015        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4016          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4017                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4018                                      AND cust_svc.svcpart = pkg_svc.svcpart
4019                                 )
4020     )';
4021
4022   }
4023
4024   ##
4025   # setup queries, links, subs, etc. for the search
4026   ##
4027
4028   # here is the agent virtualization
4029   if ($params->{CurrentUser}) {
4030     my $access_user =
4031       qsearchs('access_user', { username => $params->{CurrentUser} });
4032
4033     if ($access_user) {
4034       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4035     } else {
4036       push @where, "1=0";
4037     }
4038   } else {
4039     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4040   }
4041
4042   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4043
4044   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4045                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4046                   'LEFT JOIN cust_location USING ( locationnum ) '.
4047                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4048
4049   my $select;
4050   my $count_query;
4051   if ( $params->{'select_zip5'} ) {
4052     my $zip = 'cust_location.zip';
4053
4054     $select = "DISTINCT substr($zip,1,5) as zip";
4055     $orderby = "ORDER BY substr($zip,1,5)";
4056     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4057   } else {
4058     $select = join(', ',
4059                          'cust_pkg.*',
4060                          ( map "part_pkg.$_", qw( pkg freq ) ),
4061                          'pkg_class.classname',
4062                          'cust_main.custnum AS cust_main_custnum',
4063                          FS::UI::Web::cust_sql_fields(
4064                            $params->{'cust_fields'}
4065                          ),
4066                   );
4067     $count_query = 'SELECT COUNT(*)';
4068   }
4069
4070   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4071
4072   my $sql_query = {
4073     'table'       => 'cust_pkg',
4074     'hashref'     => {},
4075     'select'      => $select,
4076     'extra_sql'   => $extra_sql,
4077     'order_by'    => $orderby,
4078     'addl_from'   => $addl_from,
4079     'count_query' => $count_query,
4080   };
4081
4082 }
4083
4084 =item fcc_477_count
4085
4086 Returns a list of two package counts.  The first is a count of packages
4087 based on the supplied criteria and the second is the count of residential
4088 packages with those same criteria.  Criteria are specified as in the search
4089 method.
4090
4091 =cut
4092
4093 sub fcc_477_count {
4094   my ($class, $params) = @_;
4095
4096   my $sql_query = $class->search( $params );
4097
4098   my $count_sql = delete($sql_query->{'count_query'});
4099   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4100     or die "couldn't parse count_sql";
4101
4102   my $count_sth = dbh->prepare($count_sql)
4103     or die "Error preparing $count_sql: ". dbh->errstr;
4104   $count_sth->execute
4105     or die "Error executing $count_sql: ". $count_sth->errstr;
4106   my $count_arrayref = $count_sth->fetchrow_arrayref;
4107
4108   return ( @$count_arrayref );
4109
4110 }
4111
4112 =item tax_locationnum_sql
4113
4114 Returns an SQL expression for the tax location for a package, based
4115 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4116
4117 =cut
4118
4119 sub tax_locationnum_sql {
4120   my $conf = FS::Conf->new;
4121   if ( $conf->exists('tax-pkg_address') ) {
4122     'cust_pkg.locationnum';
4123   }
4124   elsif ( $conf->exists('tax-ship_address') ) {
4125     'cust_main.ship_locationnum';
4126   }
4127   else {
4128     'cust_main.bill_locationnum';
4129   }
4130 }
4131
4132 =item location_sql
4133
4134 Returns a list: the first item is an SQL fragment identifying matching
4135 packages/customers via location (taking into account shipping and package
4136 address taxation, if enabled), and subsequent items are the parameters to
4137 substitute for the placeholders in that fragment.
4138
4139 =cut
4140
4141 sub location_sql {
4142   my($class, %opt) = @_;
4143   my $ornull = $opt{'ornull'};
4144
4145   my $conf = new FS::Conf;
4146
4147   # '?' placeholders in _location_sql_where
4148   my $x = $ornull ? 3 : 2;
4149   my @bill_param = (
4150     ('district')x3,
4151     ('city')x3,
4152     ('county')x$x,
4153     ('state')x$x,
4154     'country'
4155   );
4156
4157   my $main_where;
4158   my @main_param;
4159   if ( $conf->exists('tax-ship_address') ) {
4160
4161     $main_where = "(
4162          (     ( ship_last IS NULL     OR  ship_last  = '' )
4163            AND ". _location_sql_where('cust_main', '', $ornull ). "
4164          )
4165       OR (       ship_last IS NOT NULL AND ship_last != ''
4166            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4167          )
4168     )";
4169     #    AND payby != 'COMP'
4170
4171     @main_param = ( @bill_param, @bill_param );
4172
4173   } else {
4174
4175     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4176     @main_param = @bill_param;
4177
4178   }
4179
4180   my $where;
4181   my @param;
4182   if ( $conf->exists('tax-pkg_address') ) {
4183
4184     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4185
4186     $where = " (
4187                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4188                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4189                )
4190              ";
4191     @param = ( @main_param, @bill_param );
4192
4193   } else {
4194
4195     $where = $main_where;
4196     @param = @main_param;
4197
4198   }
4199
4200   ( $where, @param );
4201
4202 }
4203
4204 #subroutine, helper for location_sql
4205 sub _location_sql_where {
4206   my $table  = shift;
4207   my $prefix = @_ ? shift : '';
4208   my $ornull = @_ ? shift : '';
4209
4210 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4211
4212   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4213
4214   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4215   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4216   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4217
4218   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4219
4220 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4221   "
4222         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4223     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4224     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4225     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4226     AND   $table.${prefix}country  = ?
4227   ";
4228 }
4229
4230 sub _X_show_zero {
4231   my( $self, $what ) = @_;
4232
4233   my $what_show_zero = $what. '_show_zero';
4234   length($self->$what_show_zero())
4235     ? ($self->$what_show_zero() eq 'Y')
4236     : $self->part_pkg->$what_show_zero();
4237 }
4238
4239 =head1 SUBROUTINES
4240
4241 =over 4
4242
4243 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4244
4245 CUSTNUM is a customer (see L<FS::cust_main>)
4246
4247 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4248 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4249 permitted.
4250
4251 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4252 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4253 new billing items.  An error is returned if this is not possible (see
4254 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4255 parameter.
4256
4257 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4258 newly-created cust_pkg objects.
4259
4260 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4261 and inserted.  Multiple FS::pkg_referral records can be created by
4262 setting I<refnum> to an array reference of refnums or a hash reference with
4263 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4264 record will be created corresponding to cust_main.refnum.
4265
4266 =cut
4267
4268 sub order {
4269   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4270
4271   my $conf = new FS::Conf;
4272
4273   # Transactionize this whole mess
4274   local $SIG{HUP} = 'IGNORE';
4275   local $SIG{INT} = 'IGNORE';
4276   local $SIG{QUIT} = 'IGNORE';
4277   local $SIG{TERM} = 'IGNORE';
4278   local $SIG{TSTP} = 'IGNORE';
4279   local $SIG{PIPE} = 'IGNORE';
4280
4281   my $oldAutoCommit = $FS::UID::AutoCommit;
4282   local $FS::UID::AutoCommit = 0;
4283   my $dbh = dbh;
4284
4285   my $error;
4286 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4287 #  return "Customer not found: $custnum" unless $cust_main;
4288
4289   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4290     if $DEBUG;
4291
4292   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4293                          @$remove_pkgnum;
4294
4295   my $change = scalar(@old_cust_pkg) != 0;
4296
4297   my %hash = ();
4298   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4299
4300     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4301          " to pkgpart ". $pkgparts->[0]. "\n"
4302       if $DEBUG;
4303
4304     my $err_or_cust_pkg =
4305       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4306                                 'refnum'  => $refnum,
4307                               );
4308
4309     unless (ref($err_or_cust_pkg)) {
4310       $dbh->rollback if $oldAutoCommit;
4311       return $err_or_cust_pkg;
4312     }
4313
4314     push @$return_cust_pkg, $err_or_cust_pkg;
4315     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4316     return '';
4317
4318   }
4319
4320   # Create the new packages.
4321   foreach my $pkgpart (@$pkgparts) {
4322
4323     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4324
4325     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4326                                       pkgpart => $pkgpart,
4327                                       refnum  => $refnum,
4328                                       %hash,
4329                                     };
4330     $error = $cust_pkg->insert( 'change' => $change );
4331     push @$return_cust_pkg, $cust_pkg;
4332
4333     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4334       my $supp_pkg = FS::cust_pkg->new({
4335           custnum => $custnum,
4336           pkgpart => $link->dst_pkgpart,
4337           refnum  => $refnum,
4338           main_pkgnum => $cust_pkg->pkgnum,
4339           %hash,
4340       });
4341       $error ||= $supp_pkg->insert( 'change' => $change );
4342       push @$return_cust_pkg, $supp_pkg;
4343     }
4344
4345     if ($error) {
4346       $dbh->rollback if $oldAutoCommit;
4347       return $error;
4348     }
4349
4350   }
4351   # $return_cust_pkg now contains refs to all of the newly
4352   # created packages.
4353
4354   # Transfer services and cancel old packages.
4355   foreach my $old_pkg (@old_cust_pkg) {
4356
4357     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4358       if $DEBUG;
4359
4360     foreach my $new_pkg (@$return_cust_pkg) {
4361       $error = $old_pkg->transfer($new_pkg);
4362       if ($error and $error == 0) {
4363         # $old_pkg->transfer failed.
4364         $dbh->rollback if $oldAutoCommit;
4365         return $error;
4366       }
4367     }
4368
4369     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4370       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4371       foreach my $new_pkg (@$return_cust_pkg) {
4372         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4373         if ($error and $error == 0) {
4374           # $old_pkg->transfer failed.
4375         $dbh->rollback if $oldAutoCommit;
4376         return $error;
4377         }
4378       }
4379     }
4380
4381     if ($error > 0) {
4382       # Transfers were successful, but we went through all of the
4383       # new packages and still had services left on the old package.
4384       # We can't cancel the package under the circumstances, so abort.
4385       $dbh->rollback if $oldAutoCommit;
4386       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4387     }
4388     $error = $old_pkg->cancel( quiet=>1 );
4389     if ($error) {
4390       $dbh->rollback;
4391       return $error;
4392     }
4393   }
4394   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4395   '';
4396 }
4397
4398 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4399
4400 A bulk change method to change packages for multiple customers.
4401
4402 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4403 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4404 permitted.
4405
4406 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4407 replace.  The services (see L<FS::cust_svc>) are moved to the
4408 new billing items.  An error is returned if this is not possible (see
4409 L<FS::pkg_svc>).
4410
4411 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4412 newly-created cust_pkg objects.
4413
4414 =cut
4415
4416 sub bulk_change {
4417   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4418
4419   # Transactionize this whole mess
4420   local $SIG{HUP} = 'IGNORE';
4421   local $SIG{INT} = 'IGNORE';
4422   local $SIG{QUIT} = 'IGNORE';
4423   local $SIG{TERM} = 'IGNORE';
4424   local $SIG{TSTP} = 'IGNORE';
4425   local $SIG{PIPE} = 'IGNORE';
4426
4427   my $oldAutoCommit = $FS::UID::AutoCommit;
4428   local $FS::UID::AutoCommit = 0;
4429   my $dbh = dbh;
4430
4431   my @errors;
4432   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4433                          @$remove_pkgnum;
4434
4435   while(scalar(@old_cust_pkg)) {
4436     my @return = ();
4437     my $custnum = $old_cust_pkg[0]->custnum;
4438     my (@remove) = map { $_->pkgnum }
4439                    grep { $_->custnum == $custnum } @old_cust_pkg;
4440     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4441
4442     my $error = order $custnum, $pkgparts, \@remove, \@return;
4443
4444     push @errors, $error
4445       if $error;
4446     push @$return_cust_pkg, @return;
4447   }
4448
4449   if (scalar(@errors)) {
4450     $dbh->rollback if $oldAutoCommit;
4451     return join(' / ', @errors);
4452   }
4453
4454   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4455   '';
4456 }
4457
4458 # Used by FS::Upgrade to migrate to a new database.
4459 sub _upgrade_data {  # class method
4460   my ($class, %opts) = @_;
4461   $class->_upgrade_otaker(%opts);
4462   my @statements = (
4463     # RT#10139, bug resulting in contract_end being set when it shouldn't
4464   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4465     # RT#10830, bad calculation of prorate date near end of year
4466     # the date range for bill is December 2009, and we move it forward
4467     # one year if it's before the previous bill date (which it should
4468     # never be)
4469   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4470   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4471   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4472     # RT6628, add order_date to cust_pkg
4473     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4474         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4475         history_action = \'insert\') where order_date is null',
4476   );
4477   foreach my $sql (@statements) {
4478     my $sth = dbh->prepare($sql);
4479     $sth->execute or die $sth->errstr;
4480   }
4481 }
4482
4483 =back
4484
4485 =head1 BUGS
4486
4487 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4488
4489 In sub order, the @pkgparts array (passed by reference) is clobbered.
4490
4491 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4492 method to pass dates to the recur_prog expression, it should do so.
4493
4494 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4495 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4496 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4497 configuration values.  Probably need a subroutine which decides what to do
4498 based on whether or not we've fetched the user yet, rather than a hash.  See
4499 FS::UID and the TODO.
4500
4501 Now that things are transactional should the check in the insert method be
4502 moved to check ?
4503
4504 =head1 SEE ALSO
4505
4506 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4507 L<FS::pkg_svc>, schema.html from the base documentation
4508
4509 =cut
4510
4511 1;
4512