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