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