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