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->invoice_from_full( $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
2460   if ( exists($opt{'taxclass'})
2461           and $part_pkg->taxclass ne $opt{'taxclass'}) {
2462
2463       $part_pkg->set('taxclass', $opt{'taxclass'});
2464   }
2465
2466   my $error;
2467   if ( $part_pkg->modified or $pkg_opt_modified ) {
2468     # can we safely modify the package def?
2469     # Yes, if it's not available for purchase, and this is the only instance
2470     # of it.
2471     if ( $part_pkg->disabled
2472          and FS::cust_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 1
2473          and FS::quotation_pkg->count('pkgpart = '.$part_pkg->pkgpart) == 0
2474        ) {
2475       $error = $part_pkg->replace( options => \%pkg_opt );
2476     } else {
2477       # clone it
2478       $part_pkg = $part_pkg->clone;
2479       $part_pkg->set('disabled' => 'Y');
2480       $error = $part_pkg->insert( options => \%pkg_opt );
2481       # and associate this as yet-unbilled package to the new package def
2482       $self->set('pkgpart' => $part_pkg->pkgpart);
2483     }
2484     if ( $error ) {
2485       $dbh->rollback if $oldAutoCommit;
2486       return $error;
2487     }
2488   }
2489
2490   if ($self->modified) { # for quantity or start_date change, or if we had
2491                          # to clone the existing package def
2492     my $error = $self->replace;
2493     return $error if $error;
2494   }
2495   if (defined $old_classnum) {
2496     # fix invoice grouping records
2497     my $old_catname = $old_classnum
2498                       ? FS::pkg_class->by_key($old_classnum)->categoryname
2499                       : '';
2500     my $new_catname = $opt{'classnum'}
2501                       ? $part_pkg->pkg_class->categoryname
2502                       : '';
2503     if ( $old_catname ne $new_catname ) {
2504       foreach my $cust_bill_pkg ($self->cust_bill_pkg) {
2505         # (there should only be one...)
2506         my @display = qsearch( 'cust_bill_pkg_display', {
2507             'billpkgnum'  => $cust_bill_pkg->billpkgnum,
2508             'section'     => $old_catname,
2509         });
2510         foreach (@display) {
2511           $_->set('section', $new_catname);
2512           $error = $_->replace;
2513           if ( $error ) {
2514             $dbh->rollback if $oldAutoCommit;
2515             return $error;
2516           }
2517         }
2518       } # foreach $cust_bill_pkg
2519     }
2520
2521     if ( $opt{'adjust_commission'} ) {
2522       # fix commission credits...tricky.
2523       foreach my $cust_event ($self->cust_event) {
2524         my $part_event = $cust_event->part_event;
2525         foreach my $table (qw(sales agent)) {
2526           my $class =
2527             "FS::part_event::Action::Mixin::credit_${table}_pkg_class";
2528           my $credit = qsearchs('cust_credit', {
2529               'eventnum' => $cust_event->eventnum,
2530           });
2531           if ( $part_event->isa($class) ) {
2532             # Yes, this results in current commission rates being applied
2533             # retroactively to a one-time charge.  For accounting purposes
2534             # there ought to be some kind of time limit on doing this.
2535             my $amount = $part_event->_calc_credit($self);
2536             if ( $credit and $credit->amount ne $amount ) {
2537               # Void the old credit.
2538               $error = $credit->void('Package class changed');
2539               if ( $error ) {
2540                 $dbh->rollback if $oldAutoCommit;
2541                 return "$error (adjusting commission credit)";
2542               }
2543             }
2544             # redo the event action to recreate the credit.
2545             local $@ = '';
2546             eval { $part_event->do_action( $self, $cust_event ) };
2547             if ( $@ ) {
2548               $dbh->rollback if $oldAutoCommit;
2549               return $@;
2550             }
2551           } # if $part_event->isa($class)
2552         } # foreach $table
2553       } # foreach $cust_event
2554     } # if $opt{'adjust_commission'}
2555   } # if defined $old_classnum
2556
2557   $dbh->commit if $oldAutoCommit;
2558   '';
2559 }
2560
2561
2562
2563 use Data::Dumper;
2564 sub process_bulk_cust_pkg {
2565   my $job = shift;
2566   my $param = shift;
2567   warn Dumper($param) if $DEBUG;
2568
2569   my $old_part_pkg = qsearchs('part_pkg',
2570                               { pkgpart => $param->{'old_pkgpart'} });
2571   my $new_part_pkg = qsearchs('part_pkg',
2572                               { pkgpart => $param->{'new_pkgpart'} });
2573   die "Must select a new package type\n" unless $new_part_pkg;
2574   #my $keep_dates = $param->{'keep_dates'} || 0;
2575   my $keep_dates = 1; # there is no good reason to turn this off
2576
2577   my $oldAutoCommit = $FS::UID::AutoCommit;
2578   local $FS::UID::AutoCommit = 0;
2579   my $dbh = dbh;
2580
2581   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2582
2583   my $i = 0;
2584   foreach my $old_cust_pkg ( @cust_pkgs ) {
2585     $i++;
2586     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2587     if ( $old_cust_pkg->getfield('cancel') ) {
2588       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2589         $old_cust_pkg->pkgnum."\n"
2590         if $DEBUG;
2591       next;
2592     }
2593     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2594       if $DEBUG;
2595     my $error = $old_cust_pkg->change(
2596       'pkgpart'     => $param->{'new_pkgpart'},
2597       'keep_dates'  => $keep_dates
2598     );
2599     if ( !ref($error) ) { # change returns the cust_pkg on success
2600       $dbh->rollback;
2601       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2602     }
2603   }
2604   $dbh->commit if $oldAutoCommit;
2605   return;
2606 }
2607
2608 =item last_bill
2609
2610 Returns the last bill date, or if there is no last bill date, the setup date.
2611 Useful for billing metered services.
2612
2613 =cut
2614
2615 sub last_bill {
2616   my $self = shift;
2617   return $self->setfield('last_bill', $_[0]) if @_;
2618   return $self->getfield('last_bill') if $self->getfield('last_bill');
2619   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2620                                                   'edate'  => $self->bill,  } );
2621   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2622 }
2623
2624 =item last_cust_pkg_reason ACTION
2625
2626 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2627 Returns false if there is no reason or the package is not currenly ACTION'd
2628 ACTION is one of adjourn, susp, cancel, or expire.
2629
2630 =cut
2631
2632 sub last_cust_pkg_reason {
2633   my ( $self, $action ) = ( shift, shift );
2634   my $date = $self->get($action);
2635   qsearchs( {
2636               'table' => 'cust_pkg_reason',
2637               'hashref' => { 'pkgnum' => $self->pkgnum,
2638                              'action' => substr(uc($action), 0, 1),
2639                              'date'   => $date,
2640                            },
2641               'order_by' => 'ORDER BY num DESC LIMIT 1',
2642            } );
2643 }
2644
2645 =item last_reason ACTION
2646
2647 Returns the most recent ACTION FS::reason associated with the package.
2648 Returns false if there is no reason or the package is not currenly ACTION'd
2649 ACTION is one of adjourn, susp, cancel, or expire.
2650
2651 =cut
2652
2653 sub last_reason {
2654   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2655   $cust_pkg_reason->reason
2656     if $cust_pkg_reason;
2657 }
2658
2659 =item part_pkg
2660
2661 Returns the definition for this billing item, as an FS::part_pkg object (see
2662 L<FS::part_pkg>).
2663
2664 =cut
2665
2666 sub part_pkg {
2667   my $self = shift;
2668   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2669   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2670   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2671 }
2672
2673 =item old_cust_pkg
2674
2675 Returns the cancelled package this package was changed from, if any.
2676
2677 =cut
2678
2679 sub old_cust_pkg {
2680   my $self = shift;
2681   return '' unless $self->change_pkgnum;
2682   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2683 }
2684
2685 =item change_cust_main
2686
2687 Returns the customter this package was detached to, if any.
2688
2689 =cut
2690
2691 sub change_cust_main {
2692   my $self = shift;
2693   return '' unless $self->change_custnum;
2694   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2695 }
2696
2697 =item calc_setup
2698
2699 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2700 item.
2701
2702 =cut
2703
2704 sub calc_setup {
2705   my $self = shift;
2706   $self->part_pkg->calc_setup($self, @_);
2707 }
2708
2709 =item calc_recur
2710
2711 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2712 item.
2713
2714 =cut
2715
2716 sub calc_recur {
2717   my $self = shift;
2718   $self->part_pkg->calc_recur($self, @_);
2719 }
2720
2721 =item base_setup
2722
2723 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2724 item.
2725
2726 =cut
2727
2728 sub base_setup {
2729   my $self = shift;
2730   $self->part_pkg->base_setup($self, @_);
2731 }
2732
2733 =item base_recur
2734
2735 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2736 item.
2737
2738 =cut
2739
2740 sub base_recur {
2741   my $self = shift;
2742   $self->part_pkg->base_recur($self, @_);
2743 }
2744
2745 =item calc_remain
2746
2747 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2748 billing item.
2749
2750 =cut
2751
2752 sub calc_remain {
2753   my $self = shift;
2754   $self->part_pkg->calc_remain($self, @_);
2755 }
2756
2757 =item calc_cancel
2758
2759 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2760 billing item.
2761
2762 =cut
2763
2764 sub calc_cancel {
2765   my $self = shift;
2766   $self->part_pkg->calc_cancel($self, @_);
2767 }
2768
2769 =item cust_bill_pkg
2770
2771 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2772
2773 =cut
2774
2775 sub cust_bill_pkg {
2776   my $self = shift;
2777   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2778 }
2779
2780 =item cust_pkg_detail [ DETAILTYPE ]
2781
2782 Returns any customer package details for this package (see
2783 L<FS::cust_pkg_detail>).
2784
2785 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2786
2787 =cut
2788
2789 sub cust_pkg_detail {
2790   my $self = shift;
2791   my %hash = ( 'pkgnum' => $self->pkgnum );
2792   $hash{detailtype} = shift if @_;
2793   qsearch({
2794     'table'    => 'cust_pkg_detail',
2795     'hashref'  => \%hash,
2796     'order_by' => 'ORDER BY weight, pkgdetailnum',
2797   });
2798 }
2799
2800 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2801
2802 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2803
2804 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2805
2806 If there is an error, returns the error, otherwise returns false.
2807
2808 =cut
2809
2810 sub set_cust_pkg_detail {
2811   my( $self, $detailtype, @details ) = @_;
2812
2813   my $oldAutoCommit = $FS::UID::AutoCommit;
2814   local $FS::UID::AutoCommit = 0;
2815   my $dbh = dbh;
2816
2817   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2818     my $error = $current->delete;
2819     if ( $error ) {
2820       $dbh->rollback if $oldAutoCommit;
2821       return "error removing old detail: $error";
2822     }
2823   }
2824
2825   foreach my $detail ( @details ) {
2826     my $cust_pkg_detail = new FS::cust_pkg_detail {
2827       'pkgnum'     => $self->pkgnum,
2828       'detailtype' => $detailtype,
2829       'detail'     => $detail,
2830     };
2831     my $error = $cust_pkg_detail->insert;
2832     if ( $error ) {
2833       $dbh->rollback if $oldAutoCommit;
2834       return "error adding new detail: $error";
2835     }
2836
2837   }
2838
2839   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2840   '';
2841
2842 }
2843
2844 =item cust_event
2845
2846 Returns the customer billing events (see L<FS::cust_event>) for this invoice.
2847
2848 =cut
2849
2850 #false laziness w/cust_bill.pm
2851 sub cust_event {
2852   my $self = shift;
2853   qsearch({
2854     'table'     => 'cust_event',
2855     'addl_from' => 'JOIN part_event USING ( eventpart )',
2856     'hashref'   => { 'tablenum' => $self->pkgnum },
2857     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2858   });
2859 }
2860
2861 =item num_cust_event
2862
2863 Returns the number of customer billing events (see L<FS::cust_event>) for this package.
2864
2865 =cut
2866
2867 #false laziness w/cust_bill.pm
2868 sub num_cust_event {
2869   my $self = shift;
2870   my $sql = "SELECT COUNT(*) ". $self->_from_cust_event_where;
2871   $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref->[0];
2872 }
2873
2874 =item exists_cust_event
2875
2876 Returns true if there are customer billing events (see L<FS::cust_event>) for this package.  More efficient than using num_cust_event.
2877
2878 =cut
2879
2880 sub exists_cust_event {
2881   my $self = shift;
2882   my $sql = "SELECT 1 ". $self->_from_cust_event_where. " LIMIT 1";
2883   my $row = $self->_prep_ex($sql, $self->pkgnum)->fetchrow_arrayref;
2884   $row ? $row->[0] : '';
2885 }
2886
2887 sub _from_cust_event_where {
2888   #my $self = shift;
2889   " FROM cust_event JOIN part_event USING ( eventpart ) ".
2890   "  WHERE tablenum = ? AND eventtable = 'cust_pkg' ";
2891 }
2892
2893 sub _prep_ex {
2894   my( $self, $sql, @args ) = @_;
2895   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2896   $sth->execute(@args)         or die $sth->errstr. " executing $sql";
2897   $sth;
2898 }
2899
2900 =item part_pkg_currency_option OPTIONNAME
2901
2902 Returns a two item list consisting of the currency of this customer, if any,
2903 and a value for the provided option.  If the customer has a currency, the value
2904 is the option value the given name and the currency (see
2905 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
2906 regular option value for the given name (see L<FS::part_pkg_option>).
2907
2908 =cut
2909
2910 sub part_pkg_currency_option {
2911   my( $self, $optionname ) = @_;
2912   my $part_pkg = $self->part_pkg;
2913   if ( my $currency = $self->cust_main->currency ) {
2914     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2915   } else {
2916     ('', $part_pkg->option($optionname) );
2917   }
2918 }
2919
2920 =item cust_svc [ SVCPART ] (old, deprecated usage)
2921
2922 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2923
2924 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2925
2926 Returns the services for this package, as FS::cust_svc objects (see
2927 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2928 spcififed, returns only the matching services.
2929
2930 As an optimization, use the cust_svc_unsorted version if you are not displaying
2931 the results.
2932
2933 =cut
2934
2935 sub cust_svc {
2936   my $self = shift;
2937   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2938   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2939 }
2940
2941 sub cust_svc_unsorted {
2942   my $self = shift;
2943   @{ $self->cust_svc_unsorted_arrayref(@_) };
2944 }
2945
2946 sub cust_svc_unsorted_arrayref {
2947   my $self = shift;
2948
2949   return [] unless $self->num_cust_svc(@_);
2950
2951   my %opt = ();
2952   if ( @_ && $_[0] =~ /^\d+/ ) {
2953     $opt{svcpart} = shift;
2954   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2955     %opt = %{ $_[0] };
2956   } elsif ( @_ ) {
2957     %opt = @_;
2958   }
2959
2960   my %search = (
2961     'table'   => 'cust_svc',
2962     'hashref' => { 'pkgnum' => $self->pkgnum },
2963   );
2964   if ( $opt{svcpart} ) {
2965     $search{hashref}->{svcpart} = $opt{'svcpart'};
2966   }
2967   if ( $opt{'svcdb'} ) {
2968     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2969     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2970   }
2971
2972   [ qsearch(\%search) ];
2973
2974 }
2975
2976 =item overlimit [ SVCPART ]
2977
2978 Returns the services for this package which have exceeded their
2979 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2980 is specified, return only the matching services.
2981
2982 =cut
2983
2984 sub overlimit {
2985   my $self = shift;
2986   return () unless $self->num_cust_svc(@_);
2987   grep { $_->overlimit } $self->cust_svc(@_);
2988 }
2989
2990 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2991
2992 Returns historical services for this package created before END TIMESTAMP and
2993 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2994 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2995 I<pkg_svc.hidden> flag will be omitted.
2996
2997 =cut
2998
2999 sub h_cust_svc {
3000   my $self = shift;
3001   warn "$me _h_cust_svc called on $self\n"
3002     if $DEBUG;
3003
3004   my ($end, $start, $mode) = @_;
3005
3006   local($FS::Record::qsearch_qualify_columns) = 0;
3007
3008   my @cust_svc = $self->_sort_cust_svc(
3009     [ qsearch( 'h_cust_svc',
3010       { 'pkgnum' => $self->pkgnum, },
3011       FS::h_cust_svc->sql_h_search(@_),
3012     ) ]
3013   );
3014
3015   if ( defined($mode) && $mode eq 'I' ) {
3016     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
3017     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
3018   } else {
3019     return @cust_svc;
3020   }
3021 }
3022
3023 sub _sort_cust_svc {
3024   my( $self, $arrayref ) = @_;
3025
3026   my $sort =
3027     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
3028
3029   my %pkg_svc = map { $_->svcpart => $_ }
3030                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
3031
3032   map  { $_->[0] }
3033   sort $sort
3034   map {
3035         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
3036         [ $_,
3037           $pkg_svc ? $pkg_svc->primary_svc : '',
3038           $pkg_svc ? $pkg_svc->quantity : 0,
3039         ];
3040       }
3041   @$arrayref;
3042
3043 }
3044
3045 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
3046
3047 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
3048
3049 Returns the number of services for this package.  Available options are svcpart
3050 and svcdb.  If either is spcififed, returns only the matching services.
3051
3052 =cut
3053
3054 sub num_cust_svc {
3055   my $self = shift;
3056
3057   return $self->{'_num_cust_svc'}
3058     if !scalar(@_)
3059        && exists($self->{'_num_cust_svc'})
3060        && $self->{'_num_cust_svc'} =~ /\d/;
3061
3062   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
3063     if $DEBUG > 2;
3064
3065   my %opt = ();
3066   if ( @_ && $_[0] =~ /^\d+/ ) {
3067     $opt{svcpart} = shift;
3068   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
3069     %opt = %{ $_[0] };
3070   } elsif ( @_ ) {
3071     %opt = @_;
3072   }
3073
3074   my $select = 'SELECT COUNT(*) FROM cust_svc ';
3075   my $where = ' WHERE pkgnum = ? ';
3076   my @param = ($self->pkgnum);
3077
3078   if ( $opt{'svcpart'} ) {
3079     $where .= ' AND svcpart = ? ';
3080     push @param, $opt{'svcpart'};
3081   }
3082   if ( $opt{'svcdb'} ) {
3083     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
3084     $where .= ' AND svcdb = ? ';
3085     push @param, $opt{'svcdb'};
3086   }
3087
3088   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
3089   $sth->execute(@param) or die $sth->errstr;
3090   $sth->fetchrow_arrayref->[0];
3091 }
3092
3093 =item available_part_svc
3094
3095 Returns a list of FS::part_svc objects representing services included in this
3096 package but not yet provisioned.  Each FS::part_svc object also has an extra
3097 field, I<num_avail>, which specifies the number of available services.
3098
3099 =cut
3100
3101 sub available_part_svc {
3102   my $self = shift;
3103
3104   my $pkg_quantity = $self->quantity || 1;
3105
3106   grep { $_->num_avail > 0 }
3107     map {
3108           my $part_svc = $_->part_svc;
3109           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
3110             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
3111
3112           # more evil encapsulation breakage
3113           if($part_svc->{'Hash'}{'num_avail'} > 0) {
3114             my @exports = $part_svc->part_export_did;
3115             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
3116           }
3117
3118           $part_svc;
3119         }
3120       $self->part_pkg->pkg_svc;
3121 }
3122
3123 =item part_svc [ OPTION => VALUE ... ]
3124
3125 Returns a list of FS::part_svc objects representing provisioned and available
3126 services included in this package.  Each FS::part_svc object also has the
3127 following extra fields:
3128
3129 =over 4
3130
3131 =item num_cust_svc
3132
3133 (count)
3134
3135 =item num_avail
3136
3137 (quantity - count)
3138
3139 =item cust_pkg_svc
3140
3141 (services) - array reference containing the provisioned services, as cust_svc objects
3142
3143 =back
3144
3145 Accepts two options:
3146
3147 =over 4
3148
3149 =item summarize_size
3150
3151 If true, will omit the extra cust_pkg_svc option for objects where num_cust_svc
3152 is this size or greater.
3153
3154 =item hide_discontinued
3155
3156 If true, will omit looking for services that are no longer avaialble in the
3157 package definition.
3158
3159 =back
3160
3161 =cut
3162
3163 #svcnum
3164 #label -> ($cust_svc->label)[1]
3165
3166 sub part_svc {
3167   my $self = shift;
3168   my %opt = @_;
3169
3170   my $pkg_quantity = $self->quantity || 1;
3171
3172   #XXX some sort of sort order besides numeric by svcpart...
3173   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3174     my $pkg_svc = $_;
3175     my $part_svc = $pkg_svc->part_svc;
3176     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3177     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3178     $part_svc->{'Hash'}{'num_avail'}    =
3179       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3180     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3181         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3182       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3183           && $num_cust_svc >= $opt{summarize_size};
3184     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3185     $part_svc;
3186   } $self->part_pkg->pkg_svc;
3187
3188   unless ( $opt{hide_discontinued} ) {
3189     #extras
3190     push @part_svc, map {
3191       my $part_svc = $_;
3192       my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3193       $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3194       $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3195       $part_svc->{'Hash'}{'cust_pkg_svc'} =
3196         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3197       $part_svc;
3198     } $self->extra_part_svc;
3199   }
3200
3201   @part_svc;
3202
3203 }
3204
3205 =item extra_part_svc
3206
3207 Returns a list of FS::part_svc objects corresponding to services in this
3208 package which are still provisioned but not (any longer) available in the
3209 package definition.
3210
3211 =cut
3212
3213 sub extra_part_svc {
3214   my $self = shift;
3215
3216   my $pkgnum  = $self->pkgnum;
3217   #my $pkgpart = $self->pkgpart;
3218
3219 #  qsearch( {
3220 #    'table'     => 'part_svc',
3221 #    'hashref'   => {},
3222 #    'extra_sql' =>
3223 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3224 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3225 #                       AND pkg_svc.pkgpart = ?
3226 #                       AND quantity > 0
3227 #                 )
3228 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3229 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3230 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3231 #                       AND pkgnum = ?
3232 #                 )",
3233 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3234 #  } );
3235
3236 #seems to benchmark slightly faster... (or did?)
3237
3238   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3239   my $pkgparts = join(',', @pkgparts);
3240
3241   qsearch( {
3242     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3243     #MySQL doesn't grok DISINCT ON
3244     'select'      => 'DISTINCT part_svc.*',
3245     'table'       => 'part_svc',
3246     'addl_from'   =>
3247       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3248                                AND pkg_svc.pkgpart IN ($pkgparts)
3249                                AND quantity > 0
3250                              )
3251        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3252        LEFT JOIN cust_pkg USING ( pkgnum )
3253       ",
3254     'hashref'     => {},
3255     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3256     'extra_param' => [ [$self->pkgnum=>'int'] ],
3257   } );
3258 }
3259
3260 =item status
3261
3262 Returns a short status string for this package, currently:
3263
3264 =over 4
3265
3266 =item on hold
3267
3268 =item not yet billed
3269
3270 =item one-time charge
3271
3272 =item active
3273
3274 =item suspended
3275
3276 =item cancelled
3277
3278 =back
3279
3280 =cut
3281
3282 sub status {
3283   my $self = shift;
3284
3285   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3286
3287   return 'cancelled' if $self->get('cancel');
3288   return 'on hold' if $self->susp && ! $self->setup;
3289   return 'suspended' if $self->susp;
3290   return 'not yet billed' unless $self->setup;
3291   return 'one-time charge' if $freq =~ /^(0|$)/;
3292   return 'active';
3293 }
3294
3295 =item ucfirst_status
3296
3297 Returns the status with the first character capitalized.
3298
3299 =cut
3300
3301 sub ucfirst_status {
3302   ucfirst(shift->status);
3303 }
3304
3305 =item statuses
3306
3307 Class method that returns the list of possible status strings for packages
3308 (see L<the status method|/status>).  For example:
3309
3310   @statuses = FS::cust_pkg->statuses();
3311
3312 =cut
3313
3314 tie my %statuscolor, 'Tie::IxHash',
3315   'on hold'         => '7E0079', #purple!
3316   'not yet billed'  => '009999', #teal? cyan?
3317   'one-time charge' => '0000CC', #blue  #'000000',
3318   'active'          => '00CC00',
3319   'suspended'       => 'FF9900',
3320   'cancelled'       => 'FF0000',
3321 ;
3322
3323 sub statuses {
3324   my $self = shift; #could be class...
3325   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3326   #                                    # mayble split btw one-time vs. recur
3327     keys %statuscolor;
3328 }
3329
3330 sub statuscolors {
3331   #my $self = shift;
3332   \%statuscolor;
3333 }
3334
3335 =item statuscolor
3336
3337 Returns a hex triplet color string for this package's status.
3338
3339 =cut
3340
3341 sub statuscolor {
3342   my $self = shift;
3343   $statuscolor{$self->status};
3344 }
3345
3346 =item pkg_label
3347
3348 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3349 "pkg - comment" depending on user preference).
3350
3351 =cut
3352
3353 sub pkg_label {
3354   my $self = shift;
3355   my $label = $self->part_pkg->pkg_comment( cust_pkg=>$self, nopkgpart=>1 );
3356   $label = $self->pkgnum. ": $label"
3357     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3358   $label;
3359 }
3360
3361 =item pkg_label_long
3362
3363 Returns a long label for this package, adding the primary service's label to
3364 pkg_label.
3365
3366 =cut
3367
3368 sub pkg_label_long {
3369   my $self = shift;
3370   my $label = $self->pkg_label;
3371   my $cust_svc = $self->primary_cust_svc;
3372   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3373   $label;
3374 }
3375
3376 =item pkg_locale
3377
3378 Returns a customer-localized label for this package.
3379
3380 =cut
3381
3382 sub pkg_locale {
3383   my $self = shift;
3384   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3385 }
3386
3387 =item primary_cust_svc
3388
3389 Returns a primary service (as FS::cust_svc object) if one can be identified.
3390
3391 =cut
3392
3393 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3394
3395 sub primary_cust_svc {
3396   my $self = shift;
3397
3398   my @cust_svc = $self->cust_svc;
3399
3400   return '' unless @cust_svc; #no serivces - irrelevant then
3401
3402   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3403
3404   # primary service as specified in the package definition
3405   # or exactly one service definition with quantity one
3406   my $svcpart = $self->part_pkg->svcpart;
3407   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3408   return $cust_svc[0] if scalar(@cust_svc) == 1;
3409
3410   #couldn't identify one thing..
3411   return '';
3412 }
3413
3414 =item labels
3415
3416 Returns a list of lists, calling the label method for all services
3417 (see L<FS::cust_svc>) of this billing item.
3418
3419 =cut
3420
3421 sub labels {
3422   my $self = shift;
3423   map { [ $_->label ] } $self->cust_svc;
3424 }
3425
3426 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3427
3428 Like the labels method, but returns historical information on services that
3429 were active as of END_TIMESTAMP and (optionally) not cancelled before
3430 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3431 I<pkg_svc.hidden> flag will be omitted.
3432
3433 Returns a list of lists, calling the label method for all (historical) services
3434 (see L<FS::h_cust_svc>) of this billing item.
3435
3436 =cut
3437
3438 sub h_labels {
3439   my $self = shift;
3440   warn "$me _h_labels called on $self\n"
3441     if $DEBUG;
3442   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3443 }
3444
3445 =item labels_short
3446
3447 Like labels, except returns a simple flat list, and shortens long
3448 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3449 identical services to one line that lists the service label and the number of
3450 individual services rather than individual items.
3451
3452 =cut
3453
3454 sub labels_short {
3455   shift->_labels_short( 'labels', @_ );
3456 }
3457
3458 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3459
3460 Like h_labels, except returns a simple flat list, and shortens long
3461 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3462 identical services to one line that lists the service label and the number of
3463 individual services rather than individual items.
3464
3465 =cut
3466
3467 sub h_labels_short {
3468   shift->_labels_short( 'h_labels', @_ );
3469 }
3470
3471 sub _labels_short {
3472   my( $self, $method ) = ( shift, shift );
3473
3474   warn "$me _labels_short called on $self with $method method\n"
3475     if $DEBUG;
3476
3477   my $conf = new FS::Conf;
3478   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3479
3480   warn "$me _labels_short populating \%labels\n"
3481     if $DEBUG;
3482
3483   my %labels;
3484   #tie %labels, 'Tie::IxHash';
3485   push @{ $labels{$_->[0]} }, $_->[1]
3486     foreach $self->$method(@_);
3487
3488   warn "$me _labels_short populating \@labels\n"
3489     if $DEBUG;
3490
3491   my @labels;
3492   foreach my $label ( keys %labels ) {
3493     my %seen = ();
3494     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3495     my $num = scalar(@values);
3496     warn "$me _labels_short $num items for $label\n"
3497       if $DEBUG;
3498
3499     if ( $num > $max_same_services ) {
3500       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3501         if $DEBUG;
3502       push @labels, "$label ($num)";
3503     } else {
3504       if ( $conf->exists('cust_bill-consolidate_services') ) {
3505         warn "$me _labels_short   consolidating services\n"
3506           if $DEBUG;
3507         # push @labels, "$label: ". join(', ', @values);
3508         while ( @values ) {
3509           my $detail = "$label: ";
3510           $detail .= shift(@values). ', '
3511             while @values
3512                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3513           $detail =~ s/, $//;
3514           push @labels, $detail;
3515         }
3516         warn "$me _labels_short   done consolidating services\n"
3517           if $DEBUG;
3518       } else {
3519         warn "$me _labels_short   adding service data\n"
3520           if $DEBUG;
3521         push @labels, map { "$label: $_" } @values;
3522       }
3523     }
3524   }
3525
3526  @labels;
3527
3528 }
3529
3530 =item cust_main
3531
3532 Returns the parent customer object (see L<FS::cust_main>).
3533
3534 =item balance
3535
3536 Returns the balance for this specific package, when using
3537 experimental package balance.
3538
3539 =cut
3540
3541 sub balance {
3542   my $self = shift;
3543   $self->cust_main->balance_pkgnum( $self->pkgnum );
3544 }
3545
3546 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3547
3548 =item cust_location
3549
3550 Returns the location object, if any (see L<FS::cust_location>).
3551
3552 =item cust_location_or_main
3553
3554 If this package is associated with a location, returns the locaiton (see
3555 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3556
3557 =item location_label [ OPTION => VALUE ... ]
3558
3559 Returns the label of the location object (see L<FS::cust_location>).
3560
3561 =cut
3562
3563 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3564
3565 =item tax_locationnum
3566
3567 Returns the foreign key to a L<FS::cust_location> object for calculating
3568 tax on this package, as determined by the C<tax-pkg_address> and
3569 C<tax-ship_address> configuration flags.
3570
3571 =cut
3572
3573 sub tax_locationnum {
3574   my $self = shift;
3575   my $conf = FS::Conf->new;
3576   if ( $conf->exists('tax-pkg_address') ) {
3577     return $self->locationnum;
3578   }
3579   elsif ( $conf->exists('tax-ship_address') ) {
3580     return $self->cust_main->ship_locationnum;
3581   }
3582   else {
3583     return $self->cust_main->bill_locationnum;
3584   }
3585 }
3586
3587 =item tax_location
3588
3589 Returns the L<FS::cust_location> object for tax_locationnum.
3590
3591 =cut
3592
3593 sub tax_location {
3594   my $self = shift;
3595   my $conf = FS::Conf->new;
3596   if ( $conf->exists('tax-pkg_address') and $self->locationnum ) {
3597     return FS::cust_location->by_key($self->locationnum);
3598   }
3599   elsif ( $conf->exists('tax-ship_address') ) {
3600     return $self->cust_main->ship_location;
3601   }
3602   else {
3603     return $self->cust_main->bill_location;
3604   }
3605 }
3606
3607 =item seconds_since TIMESTAMP
3608
3609 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3610 package have been online since TIMESTAMP, according to the session monitor.
3611
3612 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3613 L<Time::Local> and L<Date::Parse> for conversion functions.
3614
3615 =cut
3616
3617 sub seconds_since {
3618   my($self, $since) = @_;
3619   my $seconds = 0;
3620
3621   foreach my $cust_svc (
3622     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3623   ) {
3624     $seconds += $cust_svc->seconds_since($since);
3625   }
3626
3627   $seconds;
3628
3629 }
3630
3631 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3632
3633 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3634 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3635 (exclusive).
3636
3637 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3638 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3639 functions.
3640
3641
3642 =cut
3643
3644 sub seconds_since_sqlradacct {
3645   my($self, $start, $end) = @_;
3646
3647   my $seconds = 0;
3648
3649   foreach my $cust_svc (
3650     grep {
3651       my $part_svc = $_->part_svc;
3652       $part_svc->svcdb eq 'svc_acct'
3653         && scalar($part_svc->part_export_usage);
3654     } $self->cust_svc
3655   ) {
3656     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3657   }
3658
3659   $seconds;
3660
3661 }
3662
3663 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3664
3665 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3666 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3667 TIMESTAMP_END
3668 (exclusive).
3669
3670 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3671 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3672 functions.
3673
3674 =cut
3675
3676 sub attribute_since_sqlradacct {
3677   my($self, $start, $end, $attrib) = @_;
3678
3679   my $sum = 0;
3680
3681   foreach my $cust_svc (
3682     grep {
3683       my $part_svc = $_->part_svc;
3684       scalar($part_svc->part_export_usage);
3685     } $self->cust_svc
3686   ) {
3687     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3688   }
3689
3690   $sum;
3691
3692 }
3693
3694 =item quantity
3695
3696 =cut
3697
3698 sub quantity {
3699   my( $self, $value ) = @_;
3700   if ( defined($value) ) {
3701     $self->setfield('quantity', $value);
3702   }
3703   $self->getfield('quantity') || 1;
3704 }
3705
3706 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3707
3708 Transfers as many services as possible from this package to another package.
3709
3710 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3711 object.  The destination package must already exist.
3712
3713 Services are moved only if the destination allows services with the correct
3714 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3715 this option with caution!  No provision is made for export differences
3716 between the old and new service definitions.  Probably only should be used
3717 when your exports for all service definitions of a given svcdb are identical.
3718 (attempt a transfer without it first, to move all possible svcpart-matching
3719 services)
3720
3721 Any services that can't be moved remain in the original package.
3722
3723 Returns an error, if there is one; otherwise, returns the number of services
3724 that couldn't be moved.
3725
3726 =cut
3727
3728 sub transfer {
3729   my ($self, $dest_pkgnum, %opt) = @_;
3730
3731   my $remaining = 0;
3732   my $dest;
3733   my %target;
3734
3735   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3736     $dest = $dest_pkgnum;
3737     $dest_pkgnum = $dest->pkgnum;
3738   } else {
3739     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3740   }
3741
3742   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3743
3744   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3745     $target{$pkg_svc->svcpart} = $pkg_svc->quantity * ( $dest->quantity || 1 );
3746   }
3747
3748   foreach my $cust_svc ($dest->cust_svc) {
3749     $target{$cust_svc->svcpart}--;
3750   }
3751
3752   my %svcpart2svcparts = ();
3753   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3754     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3755     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3756       next if exists $svcpart2svcparts{$svcpart};
3757       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3758       $svcpart2svcparts{$svcpart} = [
3759         map  { $_->[0] }
3760         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3761         map {
3762               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3763                                                    'svcpart' => $_          } );
3764               [ $_,
3765                 $pkg_svc ? $pkg_svc->primary_svc : '',
3766                 $pkg_svc ? $pkg_svc->quantity : 0,
3767               ];
3768             }
3769
3770         grep { $_ != $svcpart }
3771         map  { $_->svcpart }
3772         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3773       ];
3774       warn "alternates for svcpart $svcpart: ".
3775            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3776         if $DEBUG;
3777     }
3778   }
3779
3780   my $error;
3781   foreach my $cust_svc ($self->cust_svc) {
3782     my $svcnum = $cust_svc->svcnum;
3783     if($target{$cust_svc->svcpart} > 0
3784        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3785       $target{$cust_svc->svcpart}--;
3786       my $new = new FS::cust_svc { $cust_svc->hash };
3787       $new->pkgnum($dest_pkgnum);
3788       $error = $new->replace($cust_svc);
3789     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3790       if ( $DEBUG ) {
3791         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3792         warn "alternates to consider: ".
3793              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3794       }
3795       my @alternate = grep {
3796                              warn "considering alternate svcpart $_: ".
3797                                   "$target{$_} available in new package\n"
3798                                if $DEBUG;
3799                              $target{$_} > 0;
3800                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3801       if ( @alternate ) {
3802         warn "alternate(s) found\n" if $DEBUG;
3803         my $change_svcpart = $alternate[0];
3804         $target{$change_svcpart}--;
3805         my $new = new FS::cust_svc { $cust_svc->hash };
3806         $new->svcpart($change_svcpart);
3807         $new->pkgnum($dest_pkgnum);
3808         $error = $new->replace($cust_svc);
3809       } else {
3810         $remaining++;
3811       }
3812     } else {
3813       $remaining++
3814     }
3815     if ( $error ) {
3816       my @label = $cust_svc->label;
3817       return "$label[0] $label[1]: $error";
3818     }
3819   }
3820   return $remaining;
3821 }
3822
3823 =item grab_svcnums SVCNUM, SVCNUM ...
3824
3825 Change the pkgnum for the provided services to this packages.  If there is an
3826 error, returns the error, otherwise returns false.
3827
3828 =cut
3829
3830 sub grab_svcnums {
3831   my $self = shift;
3832   my @svcnum = @_;
3833
3834   my $oldAutoCommit = $FS::UID::AutoCommit;
3835   local $FS::UID::AutoCommit = 0;
3836   my $dbh = dbh;
3837
3838   foreach my $svcnum (@svcnum) {
3839     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3840       $dbh->rollback if $oldAutoCommit;
3841       return "unknown svcnum $svcnum";
3842     };
3843     $cust_svc->pkgnum( $self->pkgnum );
3844     my $error = $cust_svc->replace;
3845     if ( $error ) {
3846       $dbh->rollback if $oldAutoCommit;
3847       return $error;
3848     }
3849   }
3850
3851   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3852   '';
3853
3854 }
3855
3856 =item reexport
3857
3858 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3859 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3860
3861 =cut
3862
3863 #looks like this is still used by the order_pkg and change_pkg methods in
3864 # ClientAPI/MyAccount, need to look into those before removing
3865 sub reexport {
3866   my $self = shift;
3867
3868   my $oldAutoCommit = $FS::UID::AutoCommit;
3869   local $FS::UID::AutoCommit = 0;
3870   my $dbh = dbh;
3871
3872   foreach my $cust_svc ( $self->cust_svc ) {
3873     #false laziness w/svc_Common::insert
3874     my $svc_x = $cust_svc->svc_x;
3875     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3876       my $error = $part_export->export_insert($svc_x);
3877       if ( $error ) {
3878         $dbh->rollback if $oldAutoCommit;
3879         return $error;
3880       }
3881     }
3882   }
3883
3884   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3885   '';
3886
3887 }
3888
3889 =item export_pkg_change OLD_CUST_PKG
3890
3891 Calls the "pkg_change" export action for all services attached to this package.
3892
3893 =cut
3894
3895 sub export_pkg_change {
3896   my( $self, $old )  = ( shift, shift );
3897
3898   my $oldAutoCommit = $FS::UID::AutoCommit;
3899   local $FS::UID::AutoCommit = 0;
3900   my $dbh = dbh;
3901
3902   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3903     my $error = $svc_x->export('pkg_change', $self, $old);
3904     if ( $error ) {
3905       $dbh->rollback if $oldAutoCommit;
3906       return $error;
3907     }
3908   }
3909
3910   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3911   '';
3912
3913 }
3914
3915 =item insert_reason
3916
3917 Associates this package with a (suspension or cancellation) reason (see
3918 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3919 L<FS::reason>).
3920
3921 Available options are:
3922
3923 =over 4
3924
3925 =item reason
3926
3927 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.
3928
3929 =item reason_otaker
3930
3931 the access_user (see L<FS::access_user>) providing the reason
3932
3933 =item date
3934
3935 a unix timestamp
3936
3937 =item action
3938
3939 the action (cancel, susp, adjourn, expire) associated with the reason
3940
3941 =back
3942
3943 If there is an error, returns the error, otherwise returns false.
3944
3945 =cut
3946
3947 sub insert_reason {
3948   my ($self, %options) = @_;
3949
3950   my $otaker = $options{reason_otaker} ||
3951                $FS::CurrentUser::CurrentUser->username;
3952
3953   my $reasonnum;
3954   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3955
3956     $reasonnum = $1;
3957
3958   } elsif ( ref($options{'reason'}) ) {
3959
3960     return 'Enter a new reason (or select an existing one)'
3961       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3962
3963     my $reason = new FS::reason({
3964       'reason_type' => $options{'reason'}->{'typenum'},
3965       'reason'      => $options{'reason'}->{'reason'},
3966     });
3967     my $error = $reason->insert;
3968     return $error if $error;
3969
3970     $reasonnum = $reason->reasonnum;
3971
3972   } else {
3973     return "Unparseable reason: ". $options{'reason'};
3974   }
3975
3976   my $cust_pkg_reason =
3977     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3978                               'reasonnum' => $reasonnum,
3979                               'otaker'    => $otaker,
3980                               'action'    => substr(uc($options{'action'}),0,1),
3981                               'date'      => $options{'date'}
3982                                                ? $options{'date'}
3983                                                : time,
3984                             });
3985
3986   $cust_pkg_reason->insert;
3987 }
3988
3989 =item insert_discount
3990
3991 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3992 inserting a new discount on the fly (see L<FS::discount>).
3993
3994 Available options are:
3995
3996 =over 4
3997
3998 =item discountnum
3999
4000 =back
4001
4002 If there is an error, returns the error, otherwise returns false.
4003
4004 =cut
4005
4006 sub insert_discount {
4007   #my ($self, %options) = @_;
4008   my $self = shift;
4009
4010   my $cust_pkg_discount = new FS::cust_pkg_discount {
4011     'pkgnum'      => $self->pkgnum,
4012     'discountnum' => $self->discountnum,
4013     'months_used' => 0,
4014     'end_date'    => '', #XXX
4015     #for the create a new discount case
4016     '_type'       => $self->discountnum__type,
4017     'amount'      => $self->discountnum_amount,
4018     'percent'     => $self->discountnum_percent,
4019     'months'      => $self->discountnum_months,
4020     'setup'      => $self->discountnum_setup,
4021     #'disabled'    => $self->discountnum_disabled,
4022   };
4023
4024   $cust_pkg_discount->insert;
4025 }
4026
4027 =item set_usage USAGE_VALUE_HASHREF
4028
4029 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4030 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4031 upbytes, downbytes, and totalbytes are appropriate keys.
4032
4033 All svc_accts which are part of this package have their values reset.
4034
4035 =cut
4036
4037 sub set_usage {
4038   my ($self, $valueref, %opt) = @_;
4039
4040   #only svc_acct can set_usage for now
4041   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4042     my $svc_x = $cust_svc->svc_x;
4043     $svc_x->set_usage($valueref, %opt)
4044       if $svc_x->can("set_usage");
4045   }
4046 }
4047
4048 =item recharge USAGE_VALUE_HASHREF
4049
4050 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
4051 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
4052 upbytes, downbytes, and totalbytes are appropriate keys.
4053
4054 All svc_accts which are part of this package have their values incremented.
4055
4056 =cut
4057
4058 sub recharge {
4059   my ($self, $valueref) = @_;
4060
4061   #only svc_acct can set_usage for now
4062   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
4063     my $svc_x = $cust_svc->svc_x;
4064     $svc_x->recharge($valueref)
4065       if $svc_x->can("recharge");
4066   }
4067 }
4068
4069 =item apply_usageprice
4070
4071 =cut
4072
4073 sub apply_usageprice {
4074   my $self = shift;
4075
4076   my $oldAutoCommit = $FS::UID::AutoCommit;
4077   local $FS::UID::AutoCommit = 0;
4078   my $dbh = dbh;
4079
4080   my $error = '';
4081
4082   foreach my $cust_pkg_usageprice ( $self->cust_pkg_usageprice ) {
4083     $error ||= $cust_pkg_usageprice->apply;
4084   }
4085
4086   if ( $error ) {
4087     $dbh->rollback if $oldAutoCommit;
4088     die "error applying part_pkg_usageprice add-ons, pkgnum ". $self->pkgnum.
4089         ": $error\n";
4090   } else {
4091     $dbh->commit if $oldAutoCommit;
4092   }
4093
4094
4095 }
4096
4097 =item cust_pkg_discount
4098
4099 =item cust_pkg_discount_active
4100
4101 =cut
4102
4103 sub cust_pkg_discount_active {
4104   my $self = shift;
4105   grep { $_->status eq 'active' } $self->cust_pkg_discount;
4106 }
4107
4108 =item cust_pkg_usage
4109
4110 Returns a list of all voice usage counters attached to this package.
4111
4112 =item apply_usage OPTIONS
4113
4114 Takes the following options:
4115 - cdr: a call detail record (L<FS::cdr>)
4116 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
4117 - minutes: the maximum number of minutes to be charged
4118
4119 Finds available usage minutes for a call of this class, and subtracts
4120 up to that many minutes from the usage pool.  If the usage pool is empty,
4121 and the C<cdr-minutes_priority> global config option is set, minutes may
4122 be taken from other calls as well.  Either way, an allocation record will
4123 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
4124 number of minutes of usage applied to the call.
4125
4126 =cut
4127
4128 sub apply_usage {
4129   my ($self, %opt) = @_;
4130   my $cdr = $opt{cdr};
4131   my $rate_detail = $opt{rate_detail};
4132   my $minutes = $opt{minutes};
4133   my $classnum = $rate_detail->classnum;
4134   my $pkgnum = $self->pkgnum;
4135   my $custnum = $self->custnum;
4136
4137   my $oldAutoCommit = $FS::UID::AutoCommit;
4138   local $FS::UID::AutoCommit = 0;
4139   my $dbh = dbh;
4140
4141   my $order = FS::Conf->new->config('cdr-minutes_priority');
4142
4143   my $is_classnum;
4144   if ( $classnum ) {
4145     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
4146   } else {
4147     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4148   }
4149   my @usage_recs = qsearch({
4150       'table'     => 'cust_pkg_usage',
4151       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4152                      ' JOIN cust_pkg             USING (pkgnum)'.
4153                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4154       'select'    => 'cust_pkg_usage.*',
4155       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4156                      " ( cust_pkg.custnum = $custnum AND ".
4157                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4158                      $is_classnum . ' AND '.
4159                      " cust_pkg_usage.minutes > 0",
4160       'order_by'  => " ORDER BY priority ASC",
4161   });
4162
4163   my $orig_minutes = $minutes;
4164   my $error;
4165   while (!$error and $minutes > 0 and @usage_recs) {
4166     my $cust_pkg_usage = shift @usage_recs;
4167     $cust_pkg_usage->select_for_update;
4168     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4169         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4170         acctid      => $cdr->acctid,
4171         minutes     => min($cust_pkg_usage->minutes, $minutes),
4172     });
4173     $cust_pkg_usage->set('minutes',
4174       $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes
4175     );
4176     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4177     $minutes -= $cdr_cust_pkg_usage->minutes;
4178   }
4179   if ( $order and $minutes > 0 and !$error ) {
4180     # then try to steal minutes from another call
4181     my %search = (
4182         'table'     => 'cdr_cust_pkg_usage',
4183         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4184                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4185                        ' JOIN cust_pkg              USING (pkgnum)'.
4186                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4187                        ' JOIN cdr                   USING (acctid)',
4188         'select'    => 'cdr_cust_pkg_usage.*',
4189         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4190                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4191                        " ( cust_pkg.custnum = $custnum AND ".
4192                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4193                        " part_pkg_usage_class.classnum = $classnum",
4194         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4195     );
4196     if ( $order eq 'time' ) {
4197       # find CDRs that are using minutes, but have a later startdate
4198       # than this call
4199       my $startdate = $cdr->startdate;
4200       if ($startdate !~ /^\d+$/) {
4201         die "bad cdr startdate '$startdate'";
4202       }
4203       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4204       # minimize needless reshuffling
4205       $search{'order_by'} .= ', cdr.startdate DESC';
4206     } else {
4207       # XXX may not work correctly with rate_time schedules.  Could
4208       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4209       # think...
4210       $search{'addl_from'} .=
4211         ' JOIN rate_detail'.
4212         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4213       if ( $order eq 'rate_high' ) {
4214         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4215                                 $rate_detail->min_charge;
4216         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4217       } elsif ( $order eq 'rate_low' ) {
4218         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4219                                 $rate_detail->min_charge;
4220         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4221       } else {
4222         #  this should really never happen
4223         die "invalid cdr-minutes_priority value '$order'\n";
4224       }
4225     }
4226     my @cdr_usage_recs = qsearch(\%search);
4227     my %reproc_cdrs;
4228     while (!$error and @cdr_usage_recs and $minutes > 0) {
4229       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4230       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4231       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4232       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4233       $cdr_cust_pkg_usage->select_for_update;
4234       $old_cdr->select_for_update;
4235       $cust_pkg_usage->select_for_update;
4236       # in case someone else stole the usage from this CDR
4237       # while waiting for the lock...
4238       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4239       # steal the usage allocation and flag the old CDR for reprocessing
4240       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4241       # if the allocation is more minutes than we need, adjust it...
4242       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4243       if ( $delta > 0 ) {
4244         $cdr_cust_pkg_usage->set('minutes', $minutes);
4245         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4246         $error = $cust_pkg_usage->replace;
4247       }
4248       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4249       $error ||= $cdr_cust_pkg_usage->replace;
4250       # deduct the stolen minutes
4251       $minutes -= $cdr_cust_pkg_usage->minutes;
4252     }
4253     # after all minute-stealing is done, reset the affected CDRs
4254     foreach (values %reproc_cdrs) {
4255       $error ||= $_->set_status('');
4256       # XXX or should we just call $cdr->rate right here?
4257       # it's not like we can create a loop this way, since the min_charge
4258       # or call time has to go monotonically in one direction.
4259       # we COULD get some very deep recursions going, though...
4260     }
4261   } # if $order and $minutes
4262   if ( $error ) {
4263     $dbh->rollback;
4264     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4265   } else {
4266     $dbh->commit if $oldAutoCommit;
4267     return $orig_minutes - $minutes;
4268   }
4269 }
4270
4271 =item supplemental_pkgs
4272
4273 Returns a list of all packages supplemental to this one.
4274
4275 =cut
4276
4277 sub supplemental_pkgs {
4278   my $self = shift;
4279   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4280 }
4281
4282 =item main_pkg
4283
4284 Returns the package that this one is supplemental to, if any.
4285
4286 =cut
4287
4288 sub main_pkg {
4289   my $self = shift;
4290   if ( $self->main_pkgnum ) {
4291     return FS::cust_pkg->by_key($self->main_pkgnum);
4292   }
4293   return;
4294 }
4295
4296 =back
4297
4298 =head1 CLASS METHODS
4299
4300 =over 4
4301
4302 =item recurring_sql
4303
4304 Returns an SQL expression identifying recurring packages.
4305
4306 =cut
4307
4308 sub recurring_sql { "
4309   '0' != ( select freq from part_pkg
4310              where cust_pkg.pkgpart = part_pkg.pkgpart )
4311 "; }
4312
4313 =item onetime_sql
4314
4315 Returns an SQL expression identifying one-time packages.
4316
4317 =cut
4318
4319 sub onetime_sql { "
4320   '0' = ( select freq from part_pkg
4321             where cust_pkg.pkgpart = part_pkg.pkgpart )
4322 "; }
4323
4324 =item ordered_sql
4325
4326 Returns an SQL expression identifying ordered packages (recurring packages not
4327 yet billed).
4328
4329 =cut
4330
4331 sub ordered_sql {
4332    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4333 }
4334
4335 =item active_sql
4336
4337 Returns an SQL expression identifying active packages.
4338
4339 =cut
4340
4341 sub active_sql {
4342   $_[0]->recurring_sql. "
4343   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4344   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4345   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4346 "; }
4347
4348 =item not_yet_billed_sql
4349
4350 Returns an SQL expression identifying packages which have not yet been billed.
4351
4352 =cut
4353
4354 sub not_yet_billed_sql { "
4355       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4356   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4357   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4358 "; }
4359
4360 =item inactive_sql
4361
4362 Returns an SQL expression identifying inactive packages (one-time packages
4363 that are otherwise unsuspended/uncancelled).
4364
4365 =cut
4366
4367 sub inactive_sql { "
4368   ". $_[0]->onetime_sql(). "
4369   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4370   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4371   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4372 "; }
4373
4374 =item on_hold_sql
4375
4376 Returns an SQL expression identifying on-hold packages.
4377
4378 =cut
4379
4380 sub on_hold_sql {
4381   #$_[0]->recurring_sql(). ' AND '.
4382   "
4383         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4384     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4385     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4386   ";
4387 }
4388
4389 =item susp_sql
4390 =item suspended_sql
4391
4392 Returns an SQL expression identifying suspended packages.
4393
4394 =cut
4395
4396 sub suspended_sql { susp_sql(@_); }
4397 sub susp_sql {
4398   #$_[0]->recurring_sql(). ' AND '.
4399   "
4400         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4401     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4402     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4403   ";
4404 }
4405
4406 =item cancel_sql
4407 =item cancelled_sql
4408
4409 Returns an SQL exprression identifying cancelled packages.
4410
4411 =cut
4412
4413 sub cancelled_sql { cancel_sql(@_); }
4414 sub cancel_sql {
4415   #$_[0]->recurring_sql(). ' AND '.
4416   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4417 }
4418
4419 =item status_sql
4420
4421 Returns an SQL expression to give the package status as a string.
4422
4423 =cut
4424
4425 sub status_sql {
4426 "CASE
4427   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4428   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4429   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4430   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4431   WHEN ".onetime_sql()." THEN 'one-time charge'
4432   ELSE 'active'
4433 END"
4434 }
4435
4436 =item fcc_477_count
4437
4438 Returns a list of two package counts.  The first is a count of packages
4439 based on the supplied criteria and the second is the count of residential
4440 packages with those same criteria.  Criteria are specified as in the search
4441 method.
4442
4443 =cut
4444
4445 sub fcc_477_count {
4446   my ($class, $params) = @_;
4447
4448   my $sql_query = $class->search( $params );
4449
4450   my $count_sql = delete($sql_query->{'count_query'});
4451   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4452     or die "couldn't parse count_sql";
4453
4454   my $count_sth = dbh->prepare($count_sql)
4455     or die "Error preparing $count_sql: ". dbh->errstr;
4456   $count_sth->execute
4457     or die "Error executing $count_sql: ". $count_sth->errstr;
4458   my $count_arrayref = $count_sth->fetchrow_arrayref;
4459
4460   return ( @$count_arrayref );
4461
4462 }
4463
4464 =item tax_locationnum_sql
4465
4466 Returns an SQL expression for the tax location for a package, based
4467 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4468
4469 =cut
4470
4471 sub tax_locationnum_sql {
4472   my $conf = FS::Conf->new;
4473   if ( $conf->exists('tax-pkg_address') ) {
4474     'cust_pkg.locationnum';
4475   }
4476   elsif ( $conf->exists('tax-ship_address') ) {
4477     'cust_main.ship_locationnum';
4478   }
4479   else {
4480     'cust_main.bill_locationnum';
4481   }
4482 }
4483
4484 =item location_sql
4485
4486 Returns a list: the first item is an SQL fragment identifying matching
4487 packages/customers via location (taking into account shipping and package
4488 address taxation, if enabled), and subsequent items are the parameters to
4489 substitute for the placeholders in that fragment.
4490
4491 =cut
4492
4493 sub location_sql {
4494   my($class, %opt) = @_;
4495   my $ornull = $opt{'ornull'};
4496
4497   my $conf = new FS::Conf;
4498
4499   # '?' placeholders in _location_sql_where
4500   my $x = $ornull ? 3 : 2;
4501   my @bill_param = (
4502     ('district')x3,
4503     ('city')x3,
4504     ('county')x$x,
4505     ('state')x$x,
4506     'country'
4507   );
4508
4509   my $main_where;
4510   my @main_param;
4511   if ( $conf->exists('tax-ship_address') ) {
4512
4513     $main_where = "(
4514          (     ( ship_last IS NULL     OR  ship_last  = '' )
4515            AND ". _location_sql_where('cust_main', '', $ornull ). "
4516          )
4517       OR (       ship_last IS NOT NULL AND ship_last != ''
4518            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4519          )
4520     )";
4521     #    AND payby != 'COMP'
4522
4523     @main_param = ( @bill_param, @bill_param );
4524
4525   } else {
4526
4527     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4528     @main_param = @bill_param;
4529
4530   }
4531
4532   my $where;
4533   my @param;
4534   if ( $conf->exists('tax-pkg_address') ) {
4535
4536     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4537
4538     $where = " (
4539                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4540                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4541                )
4542              ";
4543     @param = ( @main_param, @bill_param );
4544
4545   } else {
4546
4547     $where = $main_where;
4548     @param = @main_param;
4549
4550   }
4551
4552   ( $where, @param );
4553
4554 }
4555
4556 #subroutine, helper for location_sql
4557 sub _location_sql_where {
4558   my $table  = shift;
4559   my $prefix = @_ ? shift : '';
4560   my $ornull = @_ ? shift : '';
4561
4562 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4563
4564   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4565
4566   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4567   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4568   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4569
4570   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4571
4572 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4573   "
4574         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4575     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4576     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4577     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4578     AND   $table.${prefix}country  = ?
4579   ";
4580 }
4581
4582 sub _X_show_zero {
4583   my( $self, $what ) = @_;
4584
4585   my $what_show_zero = $what. '_show_zero';
4586   length($self->$what_show_zero())
4587     ? ($self->$what_show_zero() eq 'Y')
4588     : $self->part_pkg->$what_show_zero();
4589 }
4590
4591 =head1 SUBROUTINES
4592
4593 =over 4
4594
4595 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4596
4597 CUSTNUM is a customer (see L<FS::cust_main>)
4598
4599 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4600 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4601 permitted.
4602
4603 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4604 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4605 new billing items.  An error is returned if this is not possible (see
4606 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4607 parameter.
4608
4609 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4610 newly-created cust_pkg objects.
4611
4612 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4613 and inserted.  Multiple FS::pkg_referral records can be created by
4614 setting I<refnum> to an array reference of refnums or a hash reference with
4615 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4616 record will be created corresponding to cust_main.refnum.
4617
4618 =cut
4619
4620 sub order {
4621   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4622
4623   my $conf = new FS::Conf;
4624
4625   # Transactionize this whole mess
4626   my $oldAutoCommit = $FS::UID::AutoCommit;
4627   local $FS::UID::AutoCommit = 0;
4628   my $dbh = dbh;
4629
4630   my $error;
4631 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4632 #  return "Customer not found: $custnum" unless $cust_main;
4633
4634   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4635     if $DEBUG;
4636
4637   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4638                          @$remove_pkgnum;
4639
4640   my $change = scalar(@old_cust_pkg) != 0;
4641
4642   my %hash = ();
4643   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4644
4645     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4646          " to pkgpart ". $pkgparts->[0]. "\n"
4647       if $DEBUG;
4648
4649     my $err_or_cust_pkg =
4650       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4651                                 'refnum'  => $refnum,
4652                               );
4653
4654     unless (ref($err_or_cust_pkg)) {
4655       $dbh->rollback if $oldAutoCommit;
4656       return $err_or_cust_pkg;
4657     }
4658
4659     push @$return_cust_pkg, $err_or_cust_pkg;
4660     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4661     return '';
4662
4663   }
4664
4665   # Create the new packages.
4666   foreach my $pkgpart (@$pkgparts) {
4667
4668     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4669
4670     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4671                                       pkgpart => $pkgpart,
4672                                       refnum  => $refnum,
4673                                       %hash,
4674                                     };
4675     $error = $cust_pkg->insert( 'change' => $change );
4676     push @$return_cust_pkg, $cust_pkg;
4677
4678     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4679       my $supp_pkg = FS::cust_pkg->new({
4680           custnum => $custnum,
4681           pkgpart => $link->dst_pkgpart,
4682           refnum  => $refnum,
4683           main_pkgnum => $cust_pkg->pkgnum,
4684           %hash,
4685       });
4686       $error ||= $supp_pkg->insert( 'change' => $change );
4687       push @$return_cust_pkg, $supp_pkg;
4688     }
4689
4690     if ($error) {
4691       $dbh->rollback if $oldAutoCommit;
4692       return $error;
4693     }
4694
4695   }
4696   # $return_cust_pkg now contains refs to all of the newly
4697   # created packages.
4698
4699   # Transfer services and cancel old packages.
4700   foreach my $old_pkg (@old_cust_pkg) {
4701
4702     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4703       if $DEBUG;
4704
4705     foreach my $new_pkg (@$return_cust_pkg) {
4706       $error = $old_pkg->transfer($new_pkg);
4707       if ($error and $error == 0) {
4708         # $old_pkg->transfer failed.
4709         $dbh->rollback if $oldAutoCommit;
4710         return $error;
4711       }
4712     }
4713
4714     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4715       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4716       foreach my $new_pkg (@$return_cust_pkg) {
4717         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4718         if ($error and $error == 0) {
4719           # $old_pkg->transfer failed.
4720         $dbh->rollback if $oldAutoCommit;
4721         return $error;
4722         }
4723       }
4724     }
4725
4726     if ($error > 0) {
4727       # Transfers were successful, but we went through all of the
4728       # new packages and still had services left on the old package.
4729       # We can't cancel the package under the circumstances, so abort.
4730       $dbh->rollback if $oldAutoCommit;
4731       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4732     }
4733     $error = $old_pkg->cancel( quiet=>1 );
4734     if ($error) {
4735       $dbh->rollback;
4736       return $error;
4737     }
4738   }
4739   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4740   '';
4741 }
4742
4743 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4744
4745 A bulk change method to change packages for multiple customers.
4746
4747 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4748 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4749 permitted.
4750
4751 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4752 replace.  The services (see L<FS::cust_svc>) are moved to the
4753 new billing items.  An error is returned if this is not possible (see
4754 L<FS::pkg_svc>).
4755
4756 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4757 newly-created cust_pkg objects.
4758
4759 =cut
4760
4761 sub bulk_change {
4762   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4763
4764   # Transactionize this whole mess
4765   my $oldAutoCommit = $FS::UID::AutoCommit;
4766   local $FS::UID::AutoCommit = 0;
4767   my $dbh = dbh;
4768
4769   my @errors;
4770   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4771                          @$remove_pkgnum;
4772
4773   while(scalar(@old_cust_pkg)) {
4774     my @return = ();
4775     my $custnum = $old_cust_pkg[0]->custnum;
4776     my (@remove) = map { $_->pkgnum }
4777                    grep { $_->custnum == $custnum } @old_cust_pkg;
4778     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4779
4780     my $error = order $custnum, $pkgparts, \@remove, \@return;
4781
4782     push @errors, $error
4783       if $error;
4784     push @$return_cust_pkg, @return;
4785   }
4786
4787   if (scalar(@errors)) {
4788     $dbh->rollback if $oldAutoCommit;
4789     return join(' / ', @errors);
4790   }
4791
4792   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4793   '';
4794 }
4795
4796 # Used by FS::Upgrade to migrate to a new database.
4797 sub _upgrade_data {  # class method
4798   my ($class, %opts) = @_;
4799   $class->_upgrade_otaker(%opts);
4800   my @statements = (
4801     # RT#10139, bug resulting in contract_end being set when it shouldn't
4802   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4803     # RT#10830, bad calculation of prorate date near end of year
4804     # the date range for bill is December 2009, and we move it forward
4805     # one year if it's before the previous bill date (which it should
4806     # never be)
4807   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4808   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4809   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4810     # RT6628, add order_date to cust_pkg
4811     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4812         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4813         history_action = \'insert\') where order_date is null',
4814   );
4815   foreach my $sql (@statements) {
4816     my $sth = dbh->prepare($sql);
4817     $sth->execute or die $sth->errstr;
4818   }
4819
4820   # RT31194: supplemental package links that are deleted don't clean up
4821   # linked records
4822   my @pkglinknums = qsearch({
4823       'select'    => 'DISTINCT cust_pkg.pkglinknum',
4824       'table'     => 'cust_pkg',
4825       'addl_from' => ' LEFT JOIN part_pkg_link USING (pkglinknum) ',
4826       'extra_sql' => ' WHERE cust_pkg.pkglinknum IS NOT NULL
4827                         AND part_pkg_link.pkglinknum IS NULL',
4828   });
4829   foreach (@pkglinknums) {
4830     my $pkglinknum = $_->pkglinknum;
4831     warn "cleaning part_pkg_link #$pkglinknum\n";
4832     my $part_pkg_link = FS::part_pkg_link->new({pkglinknum => $pkglinknum});
4833     my $error = $part_pkg_link->remove_linked;
4834     die $error if $error;
4835   }
4836 }
4837
4838 =back
4839
4840 =head1 BUGS
4841
4842 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4843
4844 In sub order, the @pkgparts array (passed by reference) is clobbered.
4845
4846 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4847 method to pass dates to the recur_prog expression, it should do so.
4848
4849 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4850 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4851 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4852 configuration values.  Probably need a subroutine which decides what to do
4853 based on whether or not we've fetched the user yet, rather than a hash.  See
4854 FS::UID and the TODO.
4855
4856 Now that things are transactional should the check in the insert method be
4857 moved to check ?
4858
4859 =head1 SEE ALSO
4860
4861 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4862 L<FS::pkg_svc>, schema.html from the base documentation
4863
4864 =cut
4865
4866 1;
4867