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