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