FS/FS/cust_pkg.pm

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