FS/FS/cust_pkg.pm

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