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