FS/FS/cust_pkg.pm

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