FS/FS/cust_pkg.pm

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