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