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