FS/FS/cust_pkg.pm

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