FS/FS/cust_pkg.pm

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