FS/FS/cust_pkg.pm

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