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