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