FS/FS/cust_pkg.pm

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