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