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