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