FS/FS/cust_pkg.pm

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