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