FS/FS/cust_pkg.pm

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