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