FS/FS/cust_pkg.pm

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