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 new-style 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 new-style customer billing events (see L<FS::cust_event>) for this invoice.
2778
2779 =cut
2780
2781 #false laziness w/cust_bill.pm
2782 sub num_cust_event {
2783   my $self = shift;
2784   my $sql =
2785     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2786     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2787   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2788   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2789   $sth->fetchrow_arrayref->[0];
2790 }
2791
2792 =item cust_svc [ SVCPART ] (old, deprecated usage)
2793
2794 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2795
2796 =item cust_svc_unsorted [ OPTION => VALUE ... ]
2797
2798 Returns the services for this package, as FS::cust_svc objects (see
2799 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2800 spcififed, returns only the matching services.
2801
2802 As an optimization, use the cust_svc_unsorted version if you are not displaying
2803 the results.
2804
2805 =cut
2806
2807 sub cust_svc {
2808   my $self = shift;
2809   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2810   $self->_sort_cust_svc( $self->cust_svc_unsorted_arrayref(@_) );
2811 }
2812
2813 sub cust_svc_unsorted {
2814   my $self = shift;
2815   @{ $self->cust_svc_unsorted_arrayref(@_) };
2816 }
2817
2818 sub cust_svc_unsorted_arrayref {
2819   my $self = shift;
2820
2821   return () unless $self->num_cust_svc(@_);
2822
2823   my %opt = ();
2824   if ( @_ && $_[0] =~ /^\d+/ ) {
2825     $opt{svcpart} = shift;
2826   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2827     %opt = %{ $_[0] };
2828   } elsif ( @_ ) {
2829     %opt = @_;
2830   }
2831
2832   my %search = (
2833     'table'   => 'cust_svc',
2834     'hashref' => { 'pkgnum' => $self->pkgnum },
2835   );
2836   if ( $opt{svcpart} ) {
2837     $search{hashref}->{svcpart} = $opt{'svcpart'};
2838   }
2839   if ( $opt{'svcdb'} ) {
2840     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2841     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2842   }
2843
2844   [ qsearch(\%search) ];
2845
2846 }
2847
2848 =item overlimit [ SVCPART ]
2849
2850 Returns the services for this package which have exceeded their
2851 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2852 is specified, return only the matching services.
2853
2854 =cut
2855
2856 sub overlimit {
2857   my $self = shift;
2858   return () unless $self->num_cust_svc(@_);
2859   grep { $_->overlimit } $self->cust_svc(@_);
2860 }
2861
2862 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2863
2864 Returns historical services for this package created before END TIMESTAMP and
2865 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2866 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2867 I<pkg_svc.hidden> flag will be omitted.
2868
2869 =cut
2870
2871 sub h_cust_svc {
2872   my $self = shift;
2873   warn "$me _h_cust_svc called on $self\n"
2874     if $DEBUG;
2875
2876   my ($end, $start, $mode) = @_;
2877   my @cust_svc = $self->_sort_cust_svc(
2878     [ qsearch( 'h_cust_svc',
2879       { 'pkgnum' => $self->pkgnum, },
2880       FS::h_cust_svc->sql_h_search(@_),
2881     ) ]
2882   );
2883   if ( defined($mode) && $mode eq 'I' ) {
2884     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2885     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2886   } else {
2887     return @cust_svc;
2888   }
2889 }
2890
2891 sub _sort_cust_svc {
2892   my( $self, $arrayref ) = @_;
2893
2894   my $sort =
2895     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2896
2897   my %pkg_svc = map { $_->svcpart => $_ }
2898                 qsearch( 'pkg_svc', { 'pkgpart' => $self->pkgpart } );
2899
2900   map  { $_->[0] }
2901   sort $sort
2902   map {
2903         my $pkg_svc = $pkg_svc{ $_->svcpart } || '';
2904         [ $_,
2905           $pkg_svc ? $pkg_svc->primary_svc : '',
2906           $pkg_svc ? $pkg_svc->quantity : 0,
2907         ];
2908       }
2909   @$arrayref;
2910
2911 }
2912
2913 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2914
2915 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2916
2917 Returns the number of services for this package.  Available options are svcpart
2918 and svcdb.  If either is spcififed, returns only the matching services.
2919
2920 =cut
2921
2922 sub num_cust_svc {
2923   my $self = shift;
2924
2925   return $self->{'_num_cust_svc'}
2926     if !scalar(@_)
2927        && exists($self->{'_num_cust_svc'})
2928        && $self->{'_num_cust_svc'} =~ /\d/;
2929
2930   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2931     if $DEBUG > 2;
2932
2933   my %opt = ();
2934   if ( @_ && $_[0] =~ /^\d+/ ) {
2935     $opt{svcpart} = shift;
2936   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2937     %opt = %{ $_[0] };
2938   } elsif ( @_ ) {
2939     %opt = @_;
2940   }
2941
2942   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2943   my $where = ' WHERE pkgnum = ? ';
2944   my @param = ($self->pkgnum);
2945
2946   if ( $opt{'svcpart'} ) {
2947     $where .= ' AND svcpart = ? ';
2948     push @param, $opt{'svcpart'};
2949   }
2950   if ( $opt{'svcdb'} ) {
2951     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2952     $where .= ' AND svcdb = ? ';
2953     push @param, $opt{'svcdb'};
2954   }
2955
2956   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2957   $sth->execute(@param) or die $sth->errstr;
2958   $sth->fetchrow_arrayref->[0];
2959 }
2960
2961 =item available_part_svc
2962
2963 Returns a list of FS::part_svc objects representing services included in this
2964 package but not yet provisioned.  Each FS::part_svc object also has an extra
2965 field, I<num_avail>, which specifies the number of available services.
2966
2967 =cut
2968
2969 sub available_part_svc {
2970   my $self = shift;
2971
2972   my $pkg_quantity = $self->quantity || 1;
2973
2974   grep { $_->num_avail > 0 }
2975     map {
2976           my $part_svc = $_->part_svc;
2977           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2978             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2979
2980           # more evil encapsulation breakage
2981           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2982             my @exports = $part_svc->part_export_did;
2983             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2984           }
2985
2986           $part_svc;
2987         }
2988       $self->part_pkg->pkg_svc;
2989 }
2990
2991 =item part_svc [ OPTION => VALUE ... ]
2992
2993 Returns a list of FS::part_svc objects representing provisioned and available
2994 services included in this package.  Each FS::part_svc object also has the
2995 following extra fields:
2996
2997 =over 4
2998
2999 =item num_cust_svc  (count)
3000
3001 =item num_avail     (quantity - count)
3002
3003 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
3004
3005 =back
3006
3007 Accepts one option: summarize_size.  If specified and non-zero, will omit the
3008 extra cust_pkg_svc option for objects where num_cust_svc is this size or
3009 greater.
3010
3011 =cut
3012
3013 #svcnum
3014 #label -> ($cust_svc->label)[1]
3015
3016 sub part_svc {
3017   my $self = shift;
3018   my %opt = @_;
3019
3020   my $pkg_quantity = $self->quantity || 1;
3021
3022   #XXX some sort of sort order besides numeric by svcpart...
3023   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
3024     my $pkg_svc = $_;
3025     my $part_svc = $pkg_svc->part_svc;
3026     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3027     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
3028     $part_svc->{'Hash'}{'num_avail'}    =
3029       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
3030     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3031         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
3032       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
3033           && $num_cust_svc >= $opt{summarize_size};
3034     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
3035     $part_svc;
3036   } $self->part_pkg->pkg_svc;
3037
3038   #extras
3039   push @part_svc, map {
3040     my $part_svc = $_;
3041     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
3042     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
3043     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
3044     $part_svc->{'Hash'}{'cust_pkg_svc'} =
3045       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
3046     $part_svc;
3047   } $self->extra_part_svc;
3048
3049   @part_svc;
3050
3051 }
3052
3053 =item extra_part_svc
3054
3055 Returns a list of FS::part_svc objects corresponding to services in this
3056 package which are still provisioned but not (any longer) available in the
3057 package definition.
3058
3059 =cut
3060
3061 sub extra_part_svc {
3062   my $self = shift;
3063
3064   my $pkgnum  = $self->pkgnum;
3065   #my $pkgpart = $self->pkgpart;
3066
3067 #  qsearch( {
3068 #    'table'     => 'part_svc',
3069 #    'hashref'   => {},
3070 #    'extra_sql' =>
3071 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
3072 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
3073 #                       AND pkg_svc.pkgpart = ?
3074 #                       AND quantity > 0
3075 #                 )
3076 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
3077 #                       LEFT JOIN cust_pkg USING ( pkgnum )
3078 #                     WHERE cust_svc.svcpart = part_svc.svcpart
3079 #                       AND pkgnum = ?
3080 #                 )",
3081 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
3082 #  } );
3083
3084 #seems to benchmark slightly faster... (or did?)
3085
3086   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
3087   my $pkgparts = join(',', @pkgparts);
3088
3089   qsearch( {
3090     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
3091     #MySQL doesn't grok DISINCT ON
3092     'select'      => 'DISTINCT part_svc.*',
3093     'table'       => 'part_svc',
3094     'addl_from'   =>
3095       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
3096                                AND pkg_svc.pkgpart IN ($pkgparts)
3097                                AND quantity > 0
3098                              )
3099        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
3100        LEFT JOIN cust_pkg USING ( pkgnum )
3101       ",
3102     'hashref'     => {},
3103     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
3104     'extra_param' => [ [$self->pkgnum=>'int'] ],
3105   } );
3106 }
3107
3108 =item status
3109
3110 Returns a short status string for this package, currently:
3111
3112 =over 4
3113
3114 =item on hold
3115
3116 =item not yet billed
3117
3118 =item one-time charge
3119
3120 =item active
3121
3122 =item suspended
3123
3124 =item cancelled
3125
3126 =back
3127
3128 =cut
3129
3130 sub status {
3131   my $self = shift;
3132
3133   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
3134
3135   return 'cancelled' if $self->get('cancel');
3136   return 'on hold' if $self->susp && ! $self->setup;
3137   return 'suspended' if $self->susp;
3138   return 'not yet billed' unless $self->setup;
3139   return 'one-time charge' if $freq =~ /^(0|$)/;
3140   return 'active';
3141 }
3142
3143 =item ucfirst_status
3144
3145 Returns the status with the first character capitalized.
3146
3147 =cut
3148
3149 sub ucfirst_status {
3150   ucfirst(shift->status);
3151 }
3152
3153 =item statuses
3154
3155 Class method that returns the list of possible status strings for packages
3156 (see L<the status method|/status>).  For example:
3157
3158   @statuses = FS::cust_pkg->statuses();
3159
3160 =cut
3161
3162 tie my %statuscolor, 'Tie::IxHash',
3163   'on hold'         => '7E0079', #purple!
3164   'not yet billed'  => '009999', #teal? cyan?
3165   'one-time charge' => '000000',
3166   'active'          => '00CC00',
3167   'suspended'       => 'FF9900',
3168   'cancelled'       => 'FF0000',
3169 ;
3170
3171 sub statuses {
3172   my $self = shift; #could be class...
3173   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
3174   #                                    # mayble split btw one-time vs. recur
3175     keys %statuscolor;
3176 }
3177
3178 =item statuscolor
3179
3180 Returns a hex triplet color string for this package's status.
3181
3182 =cut
3183
3184 sub statuscolor {
3185   my $self = shift;
3186   $statuscolor{$self->status};
3187 }
3188
3189 =item pkg_label
3190
3191 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
3192 "pkg - comment" depending on user preference).
3193
3194 =cut
3195
3196 sub pkg_label {
3197   my $self = shift;
3198   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
3199   $label = $self->pkgnum. ": $label"
3200     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
3201   $label;
3202 }
3203
3204 =item pkg_label_long
3205
3206 Returns a long label for this package, adding the primary service's label to
3207 pkg_label.
3208
3209 =cut
3210
3211 sub pkg_label_long {
3212   my $self = shift;
3213   my $label = $self->pkg_label;
3214   my $cust_svc = $self->primary_cust_svc;
3215   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
3216   $label;
3217 }
3218
3219 =item pkg_locale
3220
3221 Returns a customer-localized label for this package.
3222
3223 =cut
3224
3225 sub pkg_locale {
3226   my $self = shift;
3227   $self->part_pkg->pkg_locale( $self->cust_main->locale );
3228 }
3229
3230 =item primary_cust_svc
3231
3232 Returns a primary service (as FS::cust_svc object) if one can be identified.
3233
3234 =cut
3235
3236 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
3237
3238 sub primary_cust_svc {
3239   my $self = shift;
3240
3241   my @cust_svc = $self->cust_svc;
3242
3243   return '' unless @cust_svc; #no serivces - irrelevant then
3244
3245   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
3246
3247   # primary service as specified in the package definition
3248   # or exactly one service definition with quantity one
3249   my $svcpart = $self->part_pkg->svcpart;
3250   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
3251   return $cust_svc[0] if scalar(@cust_svc) == 1;
3252
3253   #couldn't identify one thing..
3254   return '';
3255 }
3256
3257 =item labels
3258
3259 Returns a list of lists, calling the label method for all services
3260 (see L<FS::cust_svc>) of this billing item.
3261
3262 =cut
3263
3264 sub labels {
3265   my $self = shift;
3266   map { [ $_->label ] } $self->cust_svc;
3267 }
3268
3269 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
3270
3271 Like the labels method, but returns historical information on services that
3272 were active as of END_TIMESTAMP and (optionally) not cancelled before
3273 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
3274 I<pkg_svc.hidden> flag will be omitted.
3275
3276 Returns a list of lists, calling the label method for all (historical) services
3277 (see L<FS::h_cust_svc>) of this billing item.
3278
3279 =cut
3280
3281 sub h_labels {
3282   my $self = shift;
3283   warn "$me _h_labels called on $self\n"
3284     if $DEBUG;
3285   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
3286 }
3287
3288 =item labels_short
3289
3290 Like labels, except returns a simple flat list, and shortens long
3291 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3292 identical services to one line that lists the service label and the number of
3293 individual services rather than individual items.
3294
3295 =cut
3296
3297 sub labels_short {
3298   shift->_labels_short( 'labels', @_ );
3299 }
3300
3301 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
3302
3303 Like h_labels, except returns a simple flat list, and shortens long
3304 (currently >5 or the cust_bill-max_same_services configuration value) lists of
3305 identical services to one line that lists the service label and the number of
3306 individual services rather than individual items.
3307
3308 =cut
3309
3310 sub h_labels_short {
3311   shift->_labels_short( 'h_labels', @_ );
3312 }
3313
3314 sub _labels_short {
3315   my( $self, $method ) = ( shift, shift );
3316
3317   warn "$me _labels_short called on $self with $method method\n"
3318     if $DEBUG;
3319
3320   my $conf = new FS::Conf;
3321   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
3322
3323   warn "$me _labels_short populating \%labels\n"
3324     if $DEBUG;
3325
3326   my %labels;
3327   #tie %labels, 'Tie::IxHash';
3328   push @{ $labels{$_->[0]} }, $_->[1]
3329     foreach $self->$method(@_);
3330
3331   warn "$me _labels_short populating \@labels\n"
3332     if $DEBUG;
3333
3334   my @labels;
3335   foreach my $label ( keys %labels ) {
3336     my %seen = ();
3337     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
3338     my $num = scalar(@values);
3339     warn "$me _labels_short $num items for $label\n"
3340       if $DEBUG;
3341
3342     if ( $num > $max_same_services ) {
3343       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
3344         if $DEBUG;
3345       push @labels, "$label ($num)";
3346     } else {
3347       if ( $conf->exists('cust_bill-consolidate_services') ) {
3348         warn "$me _labels_short   consolidating services\n"
3349           if $DEBUG;
3350         # push @labels, "$label: ". join(', ', @values);
3351         while ( @values ) {
3352           my $detail = "$label: ";
3353           $detail .= shift(@values). ', '
3354             while @values
3355                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
3356           $detail =~ s/, $//;
3357           push @labels, $detail;
3358         }
3359         warn "$me _labels_short   done consolidating services\n"
3360           if $DEBUG;
3361       } else {
3362         warn "$me _labels_short   adding service data\n"
3363           if $DEBUG;
3364         push @labels, map { "$label: $_" } @values;
3365       }
3366     }
3367   }
3368
3369  @labels;
3370
3371 }
3372
3373 =item cust_main
3374
3375 Returns the parent customer object (see L<FS::cust_main>).
3376
3377 =cut
3378
3379 sub cust_main {
3380   my $self = shift;
3381   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
3382 }
3383
3384 =item balance
3385
3386 Returns the balance for this specific package, when using
3387 experimental package balance.
3388
3389 =cut
3390
3391 sub balance {
3392   my $self = shift;
3393   $self->cust_main->balance_pkgnum( $self->pkgnum );
3394 }
3395
3396 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
3397
3398 =item cust_location
3399
3400 Returns the location object, if any (see L<FS::cust_location>).
3401
3402 =item cust_location_or_main
3403
3404 If this package is associated with a location, returns the locaiton (see
3405 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
3406
3407 =item location_label [ OPTION => VALUE ... ]
3408
3409 Returns the label of the location object (see L<FS::cust_location>).
3410
3411 =cut
3412
3413 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
3414
3415 =item tax_locationnum
3416
3417 Returns the foreign key to a L<FS::cust_location> object for calculating
3418 tax on this package, as determined by the C<tax-pkg_address> and
3419 C<tax-ship_address> configuration flags.
3420
3421 =cut
3422
3423 sub tax_locationnum {
3424   my $self = shift;
3425   my $conf = FS::Conf->new;
3426   if ( $conf->exists('tax-pkg_address') ) {
3427     return $self->locationnum;
3428   }
3429   elsif ( $conf->exists('tax-ship_address') ) {
3430     return $self->cust_main->ship_locationnum;
3431   }
3432   else {
3433     return $self->cust_main->bill_locationnum;
3434   }
3435 }
3436
3437 =item tax_location
3438
3439 Returns the L<FS::cust_location> object for tax_locationnum.
3440
3441 =cut
3442
3443 sub tax_location {
3444   my $self = shift;
3445   FS::cust_location->by_key( $self->tax_locationnum )
3446 }
3447
3448 =item seconds_since TIMESTAMP
3449
3450 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3451 package have been online since TIMESTAMP, according to the session monitor.
3452
3453 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3454 L<Time::Local> and L<Date::Parse> for conversion functions.
3455
3456 =cut
3457
3458 sub seconds_since {
3459   my($self, $since) = @_;
3460   my $seconds = 0;
3461
3462   foreach my $cust_svc (
3463     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3464   ) {
3465     $seconds += $cust_svc->seconds_since($since);
3466   }
3467
3468   $seconds;
3469
3470 }
3471
3472 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3473
3474 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3475 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3476 (exclusive).
3477
3478 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3479 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3480 functions.
3481
3482
3483 =cut
3484
3485 sub seconds_since_sqlradacct {
3486   my($self, $start, $end) = @_;
3487
3488   my $seconds = 0;
3489
3490   foreach my $cust_svc (
3491     grep {
3492       my $part_svc = $_->part_svc;
3493       $part_svc->svcdb eq 'svc_acct'
3494         && scalar($part_svc->part_export_usage);
3495     } $self->cust_svc
3496   ) {
3497     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3498   }
3499
3500   $seconds;
3501
3502 }
3503
3504 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3505
3506 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3507 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3508 TIMESTAMP_END
3509 (exclusive).
3510
3511 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3512 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3513 functions.
3514
3515 =cut
3516
3517 sub attribute_since_sqlradacct {
3518   my($self, $start, $end, $attrib) = @_;
3519
3520   my $sum = 0;
3521
3522   foreach my $cust_svc (
3523     grep {
3524       my $part_svc = $_->part_svc;
3525       scalar($part_svc->part_export_usage);
3526     } $self->cust_svc
3527   ) {
3528     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3529   }
3530
3531   $sum;
3532
3533 }
3534
3535 =item quantity
3536
3537 =cut
3538
3539 sub quantity {
3540   my( $self, $value ) = @_;
3541   if ( defined($value) ) {
3542     $self->setfield('quantity', $value);
3543   }
3544   $self->getfield('quantity') || 1;
3545 }
3546
3547 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3548
3549 Transfers as many services as possible from this package to another package.
3550
3551 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3552 object.  The destination package must already exist.
3553
3554 Services are moved only if the destination allows services with the correct
3555 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3556 this option with caution!  No provision is made for export differences
3557 between the old and new service definitions.  Probably only should be used
3558 when your exports for all service definitions of a given svcdb are identical.
3559 (attempt a transfer without it first, to move all possible svcpart-matching
3560 services)
3561
3562 Any services that can't be moved remain in the original package.
3563
3564 Returns an error, if there is one; otherwise, returns the number of services
3565 that couldn't be moved.
3566
3567 =cut
3568
3569 sub transfer {
3570   my ($self, $dest_pkgnum, %opt) = @_;
3571
3572   my $remaining = 0;
3573   my $dest;
3574   my %target;
3575
3576   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3577     $dest = $dest_pkgnum;
3578     $dest_pkgnum = $dest->pkgnum;
3579   } else {
3580     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3581   }
3582
3583   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3584
3585   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3586     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3587   }
3588
3589   foreach my $cust_svc ($dest->cust_svc) {
3590     $target{$cust_svc->svcpart}--;
3591   }
3592
3593   my %svcpart2svcparts = ();
3594   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3595     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3596     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3597       next if exists $svcpart2svcparts{$svcpart};
3598       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3599       $svcpart2svcparts{$svcpart} = [
3600         map  { $_->[0] }
3601         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3602         map {
3603               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3604                                                    'svcpart' => $_          } );
3605               [ $_,
3606                 $pkg_svc ? $pkg_svc->primary_svc : '',
3607                 $pkg_svc ? $pkg_svc->quantity : 0,
3608               ];
3609             }
3610
3611         grep { $_ != $svcpart }
3612         map  { $_->svcpart }
3613         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3614       ];
3615       warn "alternates for svcpart $svcpart: ".
3616            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3617         if $DEBUG;
3618     }
3619   }
3620
3621   my $error;
3622   foreach my $cust_svc ($self->cust_svc) {
3623     my $svcnum = $cust_svc->svcnum;
3624     if($target{$cust_svc->svcpart} > 0
3625        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3626       $target{$cust_svc->svcpart}--;
3627       my $new = new FS::cust_svc { $cust_svc->hash };
3628       $new->pkgnum($dest_pkgnum);
3629       $error = $new->replace($cust_svc);
3630     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3631       if ( $DEBUG ) {
3632         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3633         warn "alternates to consider: ".
3634              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3635       }
3636       my @alternate = grep {
3637                              warn "considering alternate svcpart $_: ".
3638                                   "$target{$_} available in new package\n"
3639                                if $DEBUG;
3640                              $target{$_} > 0;
3641                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3642       if ( @alternate ) {
3643         warn "alternate(s) found\n" if $DEBUG;
3644         my $change_svcpart = $alternate[0];
3645         $target{$change_svcpart}--;
3646         my $new = new FS::cust_svc { $cust_svc->hash };
3647         $new->svcpart($change_svcpart);
3648         $new->pkgnum($dest_pkgnum);
3649         $error = $new->replace($cust_svc);
3650       } else {
3651         $remaining++;
3652       }
3653     } else {
3654       $remaining++
3655     }
3656     if ( $error ) {
3657       my @label = $cust_svc->label;
3658       return "service $label[1]: $error";
3659     }
3660   }
3661   return $remaining;
3662 }
3663
3664 =item grab_svcnums SVCNUM, SVCNUM ...
3665
3666 Change the pkgnum for the provided services to this packages.  If there is an
3667 error, returns the error, otherwise returns false.
3668
3669 =cut
3670
3671 sub grab_svcnums {
3672   my $self = shift;
3673   my @svcnum = @_;
3674
3675   local $SIG{HUP} = 'IGNORE';
3676   local $SIG{INT} = 'IGNORE';
3677   local $SIG{QUIT} = 'IGNORE';
3678   local $SIG{TERM} = 'IGNORE';
3679   local $SIG{TSTP} = 'IGNORE';
3680   local $SIG{PIPE} = 'IGNORE';
3681
3682   my $oldAutoCommit = $FS::UID::AutoCommit;
3683   local $FS::UID::AutoCommit = 0;
3684   my $dbh = dbh;
3685
3686   foreach my $svcnum (@svcnum) {
3687     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3688       $dbh->rollback if $oldAutoCommit;
3689       return "unknown svcnum $svcnum";
3690     };
3691     $cust_svc->pkgnum( $self->pkgnum );
3692     my $error = $cust_svc->replace;
3693     if ( $error ) {
3694       $dbh->rollback if $oldAutoCommit;
3695       return $error;
3696     }
3697   }
3698
3699   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3700   '';
3701
3702 }
3703
3704 =item reexport
3705
3706 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3707 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3708
3709 =cut
3710
3711 sub reexport {
3712   my $self = shift;
3713
3714   local $SIG{HUP} = 'IGNORE';
3715   local $SIG{INT} = 'IGNORE';
3716   local $SIG{QUIT} = 'IGNORE';
3717   local $SIG{TERM} = 'IGNORE';
3718   local $SIG{TSTP} = 'IGNORE';
3719   local $SIG{PIPE} = 'IGNORE';
3720
3721   my $oldAutoCommit = $FS::UID::AutoCommit;
3722   local $FS::UID::AutoCommit = 0;
3723   my $dbh = dbh;
3724
3725   foreach my $cust_svc ( $self->cust_svc ) {
3726     #false laziness w/svc_Common::insert
3727     my $svc_x = $cust_svc->svc_x;
3728     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3729       my $error = $part_export->export_insert($svc_x);
3730       if ( $error ) {
3731         $dbh->rollback if $oldAutoCommit;
3732         return $error;
3733       }
3734     }
3735   }
3736
3737   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3738   '';
3739
3740 }
3741
3742 =item export_pkg_change OLD_CUST_PKG
3743
3744 Calls the "pkg_change" export action for all services attached to this package.
3745
3746 =cut
3747
3748 sub export_pkg_change {
3749   my( $self, $old )  = ( shift, shift );
3750
3751   local $SIG{HUP} = 'IGNORE';
3752   local $SIG{INT} = 'IGNORE';
3753   local $SIG{QUIT} = 'IGNORE';
3754   local $SIG{TERM} = 'IGNORE';
3755   local $SIG{TSTP} = 'IGNORE';
3756   local $SIG{PIPE} = 'IGNORE';
3757
3758   my $oldAutoCommit = $FS::UID::AutoCommit;
3759   local $FS::UID::AutoCommit = 0;
3760   my $dbh = dbh;
3761
3762   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3763     my $error = $svc_x->export('pkg_change', $self, $old);
3764     if ( $error ) {
3765       $dbh->rollback if $oldAutoCommit;
3766       return $error;
3767     }
3768   }
3769
3770   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3771   '';
3772
3773 }
3774
3775 =item insert_reason
3776
3777 Associates this package with a (suspension or cancellation) reason (see
3778 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3779 L<FS::reason>).
3780
3781 Available options are:
3782
3783 =over 4
3784
3785 =item reason
3786
3787 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.
3788
3789 =item reason_otaker
3790
3791 the access_user (see L<FS::access_user>) providing the reason
3792
3793 =item date
3794
3795 a unix timestamp
3796
3797 =item action
3798
3799 the action (cancel, susp, adjourn, expire) associated with the reason
3800
3801 =back
3802
3803 If there is an error, returns the error, otherwise returns false.
3804
3805 =cut
3806
3807 sub insert_reason {
3808   my ($self, %options) = @_;
3809
3810   my $otaker = $options{reason_otaker} ||
3811                $FS::CurrentUser::CurrentUser->username;
3812
3813   my $reasonnum;
3814   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3815
3816     $reasonnum = $1;
3817
3818   } elsif ( ref($options{'reason'}) ) {
3819
3820     return 'Enter a new reason (or select an existing one)'
3821       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3822
3823     my $reason = new FS::reason({
3824       'reason_type' => $options{'reason'}->{'typenum'},
3825       'reason'      => $options{'reason'}->{'reason'},
3826     });
3827     my $error = $reason->insert;
3828     return $error if $error;
3829
3830     $reasonnum = $reason->reasonnum;
3831
3832   } else {
3833     return "Unparsable reason: ". $options{'reason'};
3834   }
3835
3836   my $cust_pkg_reason =
3837     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3838                               'reasonnum' => $reasonnum,
3839                               'otaker'    => $otaker,
3840                               'action'    => substr(uc($options{'action'}),0,1),
3841                               'date'      => $options{'date'}
3842                                                ? $options{'date'}
3843                                                : time,
3844                             });
3845
3846   $cust_pkg_reason->insert;
3847 }
3848
3849 =item insert_discount
3850
3851 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3852 inserting a new discount on the fly (see L<FS::discount>).
3853
3854 Available options are:
3855
3856 =over 4
3857
3858 =item discountnum
3859
3860 =back
3861
3862 If there is an error, returns the error, otherwise returns false.
3863
3864 =cut
3865
3866 sub insert_discount {
3867   #my ($self, %options) = @_;
3868   my $self = shift;
3869
3870   my $cust_pkg_discount = new FS::cust_pkg_discount {
3871     'pkgnum'      => $self->pkgnum,
3872     'discountnum' => $self->discountnum,
3873     'months_used' => 0,
3874     'end_date'    => '', #XXX
3875     #for the create a new discount case
3876     '_type'       => $self->discountnum__type,
3877     'amount'      => $self->discountnum_amount,
3878     'percent'     => $self->discountnum_percent,
3879     'months'      => $self->discountnum_months,
3880     'setup'      => $self->discountnum_setup,
3881     #'disabled'    => $self->discountnum_disabled,
3882   };
3883
3884   $cust_pkg_discount->insert;
3885 }
3886
3887 =item set_usage USAGE_VALUE_HASHREF
3888
3889 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3890 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3891 upbytes, downbytes, and totalbytes are appropriate keys.
3892
3893 All svc_accts which are part of this package have their values reset.
3894
3895 =cut
3896
3897 sub set_usage {
3898   my ($self, $valueref, %opt) = @_;
3899
3900   #only svc_acct can set_usage for now
3901   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3902     my $svc_x = $cust_svc->svc_x;
3903     $svc_x->set_usage($valueref, %opt)
3904       if $svc_x->can("set_usage");
3905   }
3906 }
3907
3908 =item recharge USAGE_VALUE_HASHREF
3909
3910 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3911 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3912 upbytes, downbytes, and totalbytes are appropriate keys.
3913
3914 All svc_accts which are part of this package have their values incremented.
3915
3916 =cut
3917
3918 sub recharge {
3919   my ($self, $valueref) = @_;
3920
3921   #only svc_acct can set_usage for now
3922   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3923     my $svc_x = $cust_svc->svc_x;
3924     $svc_x->recharge($valueref)
3925       if $svc_x->can("recharge");
3926   }
3927 }
3928
3929 =item cust_pkg_discount
3930
3931 =cut
3932
3933 sub cust_pkg_discount {
3934   my $self = shift;
3935   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3936 }
3937
3938 =item cust_pkg_discount_active
3939
3940 =cut
3941
3942 sub cust_pkg_discount_active {
3943   my $self = shift;
3944   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3945 }
3946
3947 =item cust_pkg_usage
3948
3949 Returns a list of all voice usage counters attached to this package.
3950
3951 =cut
3952
3953 sub cust_pkg_usage {
3954   my $self = shift;
3955   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3956 }
3957
3958 =item apply_usage OPTIONS
3959
3960 Takes the following options:
3961 - cdr: a call detail record (L<FS::cdr>)
3962 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3963 - minutes: the maximum number of minutes to be charged
3964
3965 Finds available usage minutes for a call of this class, and subtracts
3966 up to that many minutes from the usage pool.  If the usage pool is empty,
3967 and the C<cdr-minutes_priority> global config option is set, minutes may
3968 be taken from other calls as well.  Either way, an allocation record will
3969 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3970 number of minutes of usage applied to the call.
3971
3972 =cut
3973
3974 sub apply_usage {
3975   my ($self, %opt) = @_;
3976   my $cdr = $opt{cdr};
3977   my $rate_detail = $opt{rate_detail};
3978   my $minutes = $opt{minutes};
3979   my $classnum = $rate_detail->classnum;
3980   my $pkgnum = $self->pkgnum;
3981   my $custnum = $self->custnum;
3982
3983   local $SIG{HUP} = 'IGNORE';
3984   local $SIG{INT} = 'IGNORE';
3985   local $SIG{QUIT} = 'IGNORE';
3986   local $SIG{TERM} = 'IGNORE';
3987   local $SIG{TSTP} = 'IGNORE';
3988   local $SIG{PIPE} = 'IGNORE';
3989
3990   my $oldAutoCommit = $FS::UID::AutoCommit;
3991   local $FS::UID::AutoCommit = 0;
3992   my $dbh = dbh;
3993   my $order = FS::Conf->new->config('cdr-minutes_priority');
3994
3995   my $is_classnum;
3996   if ( $classnum ) {
3997     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3998   } else {
3999     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
4000   }
4001   my @usage_recs = qsearch({
4002       'table'     => 'cust_pkg_usage',
4003       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
4004                      ' JOIN cust_pkg             USING (pkgnum)'.
4005                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
4006       'select'    => 'cust_pkg_usage.*',
4007       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
4008                      " ( cust_pkg.custnum = $custnum AND ".
4009                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4010                      $is_classnum . ' AND '.
4011                      " cust_pkg_usage.minutes > 0",
4012       'order_by'  => " ORDER BY priority ASC",
4013   });
4014
4015   my $orig_minutes = $minutes;
4016   my $error;
4017   while (!$error and $minutes > 0 and @usage_recs) {
4018     my $cust_pkg_usage = shift @usage_recs;
4019     $cust_pkg_usage->select_for_update;
4020     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
4021         pkgusagenum => $cust_pkg_usage->pkgusagenum,
4022         acctid      => $cdr->acctid,
4023         minutes     => min($cust_pkg_usage->minutes, $minutes),
4024     });
4025     $cust_pkg_usage->set('minutes',
4026       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
4027     );
4028     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
4029     $minutes -= $cdr_cust_pkg_usage->minutes;
4030   }
4031   if ( $order and $minutes > 0 and !$error ) {
4032     # then try to steal minutes from another call
4033     my %search = (
4034         'table'     => 'cdr_cust_pkg_usage',
4035         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
4036                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
4037                        ' JOIN cust_pkg              USING (pkgnum)'.
4038                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
4039                        ' JOIN cdr                   USING (acctid)',
4040         'select'    => 'cdr_cust_pkg_usage.*',
4041         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
4042                        " ( cust_pkg.pkgnum = $pkgnum OR ".
4043                        " ( cust_pkg.custnum = $custnum AND ".
4044                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
4045                        " part_pkg_usage_class.classnum = $classnum",
4046         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
4047     );
4048     if ( $order eq 'time' ) {
4049       # find CDRs that are using minutes, but have a later startdate
4050       # than this call
4051       my $startdate = $cdr->startdate;
4052       if ($startdate !~ /^\d+$/) {
4053         die "bad cdr startdate '$startdate'";
4054       }
4055       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
4056       # minimize needless reshuffling
4057       $search{'order_by'} .= ', cdr.startdate DESC';
4058     } else {
4059       # XXX may not work correctly with rate_time schedules.  Could
4060       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
4061       # think...
4062       $search{'addl_from'} .=
4063         ' JOIN rate_detail'.
4064         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
4065       if ( $order eq 'rate_high' ) {
4066         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
4067                                 $rate_detail->min_charge;
4068         $search{'order_by'} .= ', rate_detail.min_charge ASC';
4069       } elsif ( $order eq 'rate_low' ) {
4070         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
4071                                 $rate_detail->min_charge;
4072         $search{'order_by'} .= ', rate_detail.min_charge DESC';
4073       } else {
4074         #  this should really never happen
4075         die "invalid cdr-minutes_priority value '$order'\n";
4076       }
4077     }
4078     my @cdr_usage_recs = qsearch(\%search);
4079     my %reproc_cdrs;
4080     while (!$error and @cdr_usage_recs and $minutes > 0) {
4081       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
4082       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
4083       my $old_cdr = $cdr_cust_pkg_usage->cdr;
4084       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
4085       $cdr_cust_pkg_usage->select_for_update;
4086       $old_cdr->select_for_update;
4087       $cust_pkg_usage->select_for_update;
4088       # in case someone else stole the usage from this CDR
4089       # while waiting for the lock...
4090       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
4091       # steal the usage allocation and flag the old CDR for reprocessing
4092       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
4093       # if the allocation is more minutes than we need, adjust it...
4094       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
4095       if ( $delta > 0 ) {
4096         $cdr_cust_pkg_usage->set('minutes', $minutes);
4097         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
4098         $error = $cust_pkg_usage->replace;
4099       }
4100       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
4101       $error ||= $cdr_cust_pkg_usage->replace;
4102       # deduct the stolen minutes
4103       $minutes -= $cdr_cust_pkg_usage->minutes;
4104     }
4105     # after all minute-stealing is done, reset the affected CDRs
4106     foreach (values %reproc_cdrs) {
4107       $error ||= $_->set_status('');
4108       # XXX or should we just call $cdr->rate right here?
4109       # it's not like we can create a loop this way, since the min_charge
4110       # or call time has to go monotonically in one direction.
4111       # we COULD get some very deep recursions going, though...
4112     }
4113   } # if $order and $minutes
4114   if ( $error ) {
4115     $dbh->rollback;
4116     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
4117   } else {
4118     $dbh->commit if $oldAutoCommit;
4119     return $orig_minutes - $minutes;
4120   }
4121 }
4122
4123 =item supplemental_pkgs
4124
4125 Returns a list of all packages supplemental to this one.
4126
4127 =cut
4128
4129 sub supplemental_pkgs {
4130   my $self = shift;
4131   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
4132 }
4133
4134 =item main_pkg
4135
4136 Returns the package that this one is supplemental to, if any.
4137
4138 =cut
4139
4140 sub main_pkg {
4141   my $self = shift;
4142   if ( $self->main_pkgnum ) {
4143     return FS::cust_pkg->by_key($self->main_pkgnum);
4144   }
4145   return;
4146 }
4147
4148 =back
4149
4150 =head1 CLASS METHODS
4151
4152 =over 4
4153
4154 =item recurring_sql
4155
4156 Returns an SQL expression identifying recurring packages.
4157
4158 =cut
4159
4160 sub recurring_sql { "
4161   '0' != ( select freq from part_pkg
4162              where cust_pkg.pkgpart = part_pkg.pkgpart )
4163 "; }
4164
4165 =item onetime_sql
4166
4167 Returns an SQL expression identifying one-time packages.
4168
4169 =cut
4170
4171 sub onetime_sql { "
4172   '0' = ( select freq from part_pkg
4173             where cust_pkg.pkgpart = part_pkg.pkgpart )
4174 "; }
4175
4176 =item ordered_sql
4177
4178 Returns an SQL expression identifying ordered packages (recurring packages not
4179 yet billed).
4180
4181 =cut
4182
4183 sub ordered_sql {
4184    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
4185 }
4186
4187 =item active_sql
4188
4189 Returns an SQL expression identifying active packages.
4190
4191 =cut
4192
4193 sub active_sql {
4194   $_[0]->recurring_sql. "
4195   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4196   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4197   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4198 "; }
4199
4200 =item not_yet_billed_sql
4201
4202 Returns an SQL expression identifying packages which have not yet been billed.
4203
4204 =cut
4205
4206 sub not_yet_billed_sql { "
4207       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
4208   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4209   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4210 "; }
4211
4212 =item inactive_sql
4213
4214 Returns an SQL expression identifying inactive packages (one-time packages
4215 that are otherwise unsuspended/uncancelled).
4216
4217 =cut
4218
4219 sub inactive_sql { "
4220   ". $_[0]->onetime_sql(). "
4221   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
4222   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
4223   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
4224 "; }
4225
4226 =item on_hold_sql
4227
4228 Returns an SQL expression identifying on-hold packages.
4229
4230 =cut
4231
4232 sub on_hold_sql {
4233   #$_[0]->recurring_sql(). ' AND '.
4234   "
4235         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel  = 0 )
4236     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp   != 0
4237     AND ( cust_pkg.setup  IS     NULL  OR cust_pkg.setup   = 0 )
4238   ";
4239 }
4240
4241 =item susp_sql
4242 =item suspended_sql
4243
4244 Returns an SQL expression identifying suspended packages.
4245
4246 =cut
4247
4248 sub suspended_sql { susp_sql(@_); }
4249 sub susp_sql {
4250   #$_[0]->recurring_sql(). ' AND '.
4251   "
4252         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
4253     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
4254     AND   cust_pkg.setup  IS NOT NULL AND cust_pkg.setup != 0
4255   ";
4256 }
4257
4258 =item cancel_sql
4259 =item cancelled_sql
4260
4261 Returns an SQL exprression identifying cancelled packages.
4262
4263 =cut
4264
4265 sub cancelled_sql { cancel_sql(@_); }
4266 sub cancel_sql {
4267   #$_[0]->recurring_sql(). ' AND '.
4268   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
4269 }
4270
4271 =item status_sql
4272
4273 Returns an SQL expression to give the package status as a string.
4274
4275 =cut
4276
4277 sub status_sql {
4278 "CASE
4279   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
4280   WHEN ( cust_pkg.susp IS NOT NULL AND cust_pkg.setup IS NULL ) THEN 'on hold'
4281   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
4282   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
4283   WHEN ".onetime_sql()." THEN 'one-time charge'
4284   ELSE 'active'
4285 END"
4286 }
4287
4288 =item search HASHREF
4289
4290 (Class method)
4291
4292 Returns a qsearch hash expression to search for parameters specified in HASHREF.
4293 Valid parameters are
4294
4295 =over 4
4296
4297 =item agentnum
4298
4299 =item magic
4300
4301 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4302
4303 =item status
4304
4305 on hold, active, inactive (or one-time charge), suspended, cancel (or cancelled)
4306
4307 =item custom
4308
4309  boolean selects custom packages
4310
4311 =item classnum
4312
4313 =item pkgpart
4314
4315 pkgpart or arrayref or hashref of pkgparts
4316
4317 =item setup
4318
4319 arrayref of beginning and ending epoch date
4320
4321 =item last_bill
4322
4323 arrayref of beginning and ending epoch date
4324
4325 =item bill
4326
4327 arrayref of beginning and ending epoch date
4328
4329 =item adjourn
4330
4331 arrayref of beginning and ending epoch date
4332
4333 =item susp
4334
4335 arrayref of beginning and ending epoch date
4336
4337 =item expire
4338
4339 arrayref of beginning and ending epoch date
4340
4341 =item cancel
4342
4343 arrayref of beginning and ending epoch date
4344
4345 =item query
4346
4347 pkgnum or APKG_pkgnum
4348
4349 =item cust_fields
4350
4351 a value suited to passing to FS::UI::Web::cust_header
4352
4353 =item CurrentUser
4354
4355 specifies the user for agent virtualization
4356
4357 =item fcc_line
4358
4359 boolean; if true, returns only packages with more than 0 FCC phone lines.
4360
4361 =item state, country
4362
4363 Limit to packages with a service location in the specified state and country.
4364 For FCC 477 reporting, mostly.
4365
4366 =item location_cust
4367
4368 Limit to packages whose service locations are the same as the customer's
4369 default service location.
4370
4371 =item location_nocust
4372
4373 Limit to packages whose service locations are not the customer's default
4374 service location.
4375
4376 =item location_census
4377
4378 Limit to packages whose service locations have census tracts.
4379
4380 =item location_nocensus
4381
4382 Limit to packages whose service locations do not have a census tract.
4383
4384 =item location_geocode
4385
4386 Limit to packages whose locations have geocodes.
4387
4388 =item location_geocode
4389
4390 Limit to packages whose locations do not have geocodes.
4391
4392 =back
4393
4394 =cut
4395
4396 sub search {
4397   my ($class, $params) = @_;
4398   my @where = ();
4399
4400   ##
4401   # parse agent
4402   ##
4403
4404   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
4405     push @where,
4406       "cust_main.agentnum = $1";
4407   }
4408
4409   ##
4410   # parse cust_status
4411   ##
4412
4413   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
4414     push @where, FS::cust_main->cust_status_sql . " = '$1' ";
4415   }
4416
4417   ##
4418   # parse customer sales person
4419   ##
4420
4421   if ( $params->{'cust_main_salesnum'} =~ /^(\d+)$/ ) {
4422     push @where, ($1 > 0) ? "cust_main.salesnum = $1"
4423                           : 'cust_main.salesnum IS NULL';
4424   }
4425
4426
4427   ##
4428   # parse sales person
4429   ##
4430
4431   if ( $params->{'salesnum'} =~ /^(\d+)$/ ) {
4432     push @where, ($1 > 0) ? "cust_pkg.salesnum = $1"
4433                           : 'cust_pkg.salesnum IS NULL';
4434   }
4435
4436   ##
4437   # parse custnum
4438   ##
4439
4440   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
4441     push @where,
4442       "cust_pkg.custnum = $1";
4443   }
4444
4445   ##
4446   # custbatch
4447   ##
4448
4449   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
4450     push @where,
4451       "cust_pkg.pkgbatch = '$1'";
4452   }
4453
4454   ##
4455   # parse status
4456   ##
4457
4458   if (    $params->{'magic'}  eq 'active'
4459        || $params->{'status'} eq 'active' ) {
4460
4461     push @where, FS::cust_pkg->active_sql();
4462
4463   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
4464             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
4465
4466     push @where, FS::cust_pkg->not_yet_billed_sql();
4467
4468   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
4469             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
4470
4471     push @where, FS::cust_pkg->inactive_sql();
4472
4473   } elsif (    $params->{'magic'}  =~ /^on[ _]hold$/
4474             || $params->{'status'} =~ /^on[ _]hold$/ ) {
4475
4476     push @where, FS::cust_pkg->on_hold_sql();
4477
4478
4479   } elsif (    $params->{'magic'}  eq 'suspended'
4480             || $params->{'status'} eq 'suspended'  ) {
4481
4482     push @where, FS::cust_pkg->suspended_sql();
4483
4484   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
4485             || $params->{'status'} =~ /^cancell?ed$/ ) {
4486
4487     push @where, FS::cust_pkg->cancelled_sql();
4488
4489   }
4490
4491   ###
4492   # parse package class
4493   ###
4494
4495   if ( exists($params->{'classnum'}) ) {
4496
4497     my @classnum = ();
4498     if ( ref($params->{'classnum'}) ) {
4499
4500       if ( ref($params->{'classnum'}) eq 'HASH' ) {
4501         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
4502       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
4503         @classnum = @{ $params->{'classnum'} };
4504       } else {
4505         die 'unhandled classnum ref '. $params->{'classnum'};
4506       }
4507
4508
4509     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4510       @classnum = ( $1 );
4511     }
4512
4513     if ( @classnum ) {
4514
4515       my @c_where = ();
4516       my @nums = grep $_, @classnum;
4517       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4518       my $null = scalar( grep { $_ eq '' } @classnum );
4519       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4520
4521       if ( scalar(@c_where) == 1 ) {
4522         push @where, @c_where;
4523       } elsif ( @c_where ) {
4524         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4525       }
4526
4527     }
4528
4529
4530   }
4531
4532   ###
4533   # parse package report options
4534   ###
4535
4536   my @report_option = ();
4537   if ( exists($params->{'report_option'}) ) {
4538     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4539       @report_option = @{ $params->{'report_option'} };
4540     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4541       @report_option = split(',', $1);
4542     }
4543
4544   }
4545
4546   if (@report_option) {
4547     # this will result in the empty set for the dangling comma case as it should
4548     push @where,
4549       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4550                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4551                     AND optionname = 'report_option_$_'
4552                     AND optionvalue = '1' )"
4553          } @report_option;
4554   }
4555
4556   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4557
4558     my @report_option_any = ();
4559     if ( ref($params->{$any}) eq 'ARRAY' ) {
4560       @report_option_any = @{ $params->{$any} };
4561     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4562       @report_option_any = split(',', $1);
4563     }
4564
4565     if (@report_option_any) {
4566       # this will result in the empty set for the dangling comma case as it should
4567       push @where, ' ( '. join(' OR ',
4568         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4569                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4570                       AND optionname = 'report_option_$_'
4571                       AND optionvalue = '1' )"
4572            } @report_option_any
4573       ). ' ) ';
4574     }
4575
4576   }
4577
4578   ###
4579   # parse custom
4580   ###
4581
4582   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4583
4584   ###
4585   # parse fcc_line
4586   ###
4587
4588   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4589                                                         if $params->{fcc_line};
4590
4591   ###
4592   # parse censustract
4593   ###
4594
4595   if ( exists($params->{'censustract'}) ) {
4596     $params->{'censustract'} =~ /^([.\d]*)$/;
4597     my $censustract = "cust_location.censustract = '$1'";
4598     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4599     push @where,  "( $censustract )";
4600   }
4601
4602   ###
4603   # parse censustract2
4604   ###
4605   if ( exists($params->{'censustract2'})
4606        && $params->{'censustract2'} =~ /^(\d*)$/
4607      )
4608   {
4609     if ($1) {
4610       push @where, "cust_location.censustract LIKE '$1%'";
4611     } else {
4612       push @where,
4613         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4614     }
4615   }
4616
4617   ###
4618   # parse country/state
4619   ###
4620   for (qw(state country)) { # parsing rules are the same for these
4621   if ( exists($params->{$_})
4622     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4623     {
4624       # XXX post-2.3 only--before that, state/country may be in cust_main
4625       push @where, "cust_location.$_ = '$1'";
4626     }
4627   }
4628
4629   ###
4630   # location_* flags
4631   ###
4632   if ( $params->{location_cust} xor $params->{location_nocust} ) {
4633     my $op = $params->{location_cust} ? '=' : '!=';
4634     push @where, "cust_location.locationnum $op cust_main.ship_locationnum";
4635   }
4636   if ( $params->{location_census} xor $params->{location_nocensus} ) {
4637     my $op = $params->{location_census} ? "IS NOT NULL" : "IS NULL";
4638     push @where, "cust_location.censustract $op";
4639   }
4640   if ( $params->{location_geocode} xor $params->{location_nogeocode} ) {
4641     my $op = $params->{location_geocode} ? "IS NOT NULL" : "IS NULL";
4642     push @where, "cust_location.geocode $op";
4643   }
4644
4645   ###
4646   # parse part_pkg
4647   ###
4648
4649   if ( ref($params->{'pkgpart'}) ) {
4650
4651     my @pkgpart = ();
4652     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4653       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4654     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4655       @pkgpart = @{ $params->{'pkgpart'} };
4656     } else {
4657       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4658     }
4659
4660     @pkgpart = grep /^(\d+)$/, @pkgpart;
4661
4662     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4663
4664   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4665     push @where, "pkgpart = $1";
4666   }
4667
4668   ###
4669   # parse dates
4670   ###
4671
4672   my $orderby = '';
4673
4674   #false laziness w/report_cust_pkg.html
4675   my %disable = (
4676     'all'             => {},
4677     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4678     'active'          => { 'susp'=>1, 'cancel'=>1 },
4679     'suspended'       => { 'cancel' => 1 },
4680     'cancelled'       => {},
4681     ''                => {},
4682   );
4683
4684   if( exists($params->{'active'} ) ) {
4685     # This overrides all the other date-related fields, and includes packages
4686     # that were active at some time during the interval.  It excludes:
4687     # - packages that were set up after the end of the interval
4688     # - packages that were canceled before the start of the interval
4689     # - packages that were suspended before the start of the interval
4690     #   and are still suspended now
4691     my($beginning, $ending) = @{$params->{'active'}};
4692     push @where,
4693       "cust_pkg.setup IS NOT NULL",
4694       "cust_pkg.setup <= $ending",
4695       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4696       "(cust_pkg.susp   IS NULL OR cust_pkg.susp   >= $beginning )",
4697       "NOT (".FS::cust_pkg->onetime_sql . ")";
4698   }
4699   else {
4700     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4701
4702       next unless exists($params->{$field});
4703
4704       my($beginning, $ending) = @{$params->{$field}};
4705
4706       next if $beginning == 0 && $ending == 4294967295;
4707
4708       push @where,
4709         "cust_pkg.$field IS NOT NULL",
4710         "cust_pkg.$field >= $beginning",
4711         "cust_pkg.$field <= $ending";
4712
4713       $orderby ||= "ORDER BY cust_pkg.$field";
4714
4715     }
4716   }
4717
4718   $orderby ||= 'ORDER BY bill';
4719
4720   ###
4721   # parse magic, legacy, etc.
4722   ###
4723
4724   if ( $params->{'magic'} &&
4725        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4726   ) {
4727
4728     $orderby = 'ORDER BY pkgnum';
4729
4730     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4731       push @where, "pkgpart = $1";
4732     }
4733
4734   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4735
4736     $orderby = 'ORDER BY pkgnum';
4737
4738   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4739
4740     $orderby = 'ORDER BY pkgnum';
4741
4742     push @where, '0 < (
4743       SELECT count(*) FROM pkg_svc
4744        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4745          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4746                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4747                                      AND cust_svc.svcpart = pkg_svc.svcpart
4748                                 )
4749     )';
4750
4751   }
4752
4753   ##
4754   # setup queries, links, subs, etc. for the search
4755   ##
4756
4757   # here is the agent virtualization
4758   if ($params->{CurrentUser}) {
4759     my $access_user =
4760       qsearchs('access_user', { username => $params->{CurrentUser} });
4761
4762     if ($access_user) {
4763       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4764     } else {
4765       push @where, "1=0";
4766     }
4767   } else {
4768     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4769   }
4770
4771   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4772
4773   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4774                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4775                   'LEFT JOIN cust_location USING ( locationnum ) '.
4776                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4777
4778   my $select;
4779   my $count_query;
4780   if ( $params->{'select_zip5'} ) {
4781     my $zip = 'cust_location.zip';
4782
4783     $select = "DISTINCT substr($zip,1,5) as zip";
4784     $orderby = "ORDER BY substr($zip,1,5)";
4785     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4786   } else {
4787     $select = join(', ',
4788                          'cust_pkg.*',
4789                          ( map "part_pkg.$_", qw( pkg freq ) ),
4790                          'pkg_class.classname',
4791                          'cust_main.custnum AS cust_main_custnum',
4792                          FS::UI::Web::cust_sql_fields(
4793                            $params->{'cust_fields'}
4794                          ),
4795                   );
4796     $count_query = 'SELECT COUNT(*)';
4797   }
4798
4799   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4800
4801   my $sql_query = {
4802     'table'       => 'cust_pkg',
4803     'hashref'     => {},
4804     'select'      => $select,
4805     'extra_sql'   => $extra_sql,
4806     'order_by'    => $orderby,
4807     'addl_from'   => $addl_from,
4808     'count_query' => $count_query,
4809   };
4810
4811 }
4812
4813 =item fcc_477_count
4814
4815 Returns a list of two package counts.  The first is a count of packages
4816 based on the supplied criteria and the second is the count of residential
4817 packages with those same criteria.  Criteria are specified as in the search
4818 method.
4819
4820 =cut
4821
4822 sub fcc_477_count {
4823   my ($class, $params) = @_;
4824
4825   my $sql_query = $class->search( $params );
4826
4827   my $count_sql = delete($sql_query->{'count_query'});
4828   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4829     or die "couldn't parse count_sql";
4830
4831   my $count_sth = dbh->prepare($count_sql)
4832     or die "Error preparing $count_sql: ". dbh->errstr;
4833   $count_sth->execute
4834     or die "Error executing $count_sql: ". $count_sth->errstr;
4835   my $count_arrayref = $count_sth->fetchrow_arrayref;
4836
4837   return ( @$count_arrayref );
4838
4839 }
4840
4841 =item tax_locationnum_sql
4842
4843 Returns an SQL expression for the tax location for a package, based
4844 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4845
4846 =cut
4847
4848 sub tax_locationnum_sql {
4849   my $conf = FS::Conf->new;
4850   if ( $conf->exists('tax-pkg_address') ) {
4851     'cust_pkg.locationnum';
4852   }
4853   elsif ( $conf->exists('tax-ship_address') ) {
4854     'cust_main.ship_locationnum';
4855   }
4856   else {
4857     'cust_main.bill_locationnum';
4858   }
4859 }
4860
4861 =item location_sql
4862
4863 Returns a list: the first item is an SQL fragment identifying matching
4864 packages/customers via location (taking into account shipping and package
4865 address taxation, if enabled), and subsequent items are the parameters to
4866 substitute for the placeholders in that fragment.
4867
4868 =cut
4869
4870 sub location_sql {
4871   my($class, %opt) = @_;
4872   my $ornull = $opt{'ornull'};
4873
4874   my $conf = new FS::Conf;
4875
4876   # '?' placeholders in _location_sql_where
4877   my $x = $ornull ? 3 : 2;
4878   my @bill_param = (
4879     ('district')x3,
4880     ('city')x3,
4881     ('county')x$x,
4882     ('state')x$x,
4883     'country'
4884   );
4885
4886   my $main_where;
4887   my @main_param;
4888   if ( $conf->exists('tax-ship_address') ) {
4889
4890     $main_where = "(
4891          (     ( ship_last IS NULL     OR  ship_last  = '' )
4892            AND ". _location_sql_where('cust_main', '', $ornull ). "
4893          )
4894       OR (       ship_last IS NOT NULL AND ship_last != ''
4895            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4896          )
4897     )";
4898     #    AND payby != 'COMP'
4899
4900     @main_param = ( @bill_param, @bill_param );
4901
4902   } else {
4903
4904     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4905     @main_param = @bill_param;
4906
4907   }
4908
4909   my $where;
4910   my @param;
4911   if ( $conf->exists('tax-pkg_address') ) {
4912
4913     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4914
4915     $where = " (
4916                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4917                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4918                )
4919              ";
4920     @param = ( @main_param, @bill_param );
4921
4922   } else {
4923
4924     $where = $main_where;
4925     @param = @main_param;
4926
4927   }
4928
4929   ( $where, @param );
4930
4931 }
4932
4933 #subroutine, helper for location_sql
4934 sub _location_sql_where {
4935   my $table  = shift;
4936   my $prefix = @_ ? shift : '';
4937   my $ornull = @_ ? shift : '';
4938
4939 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4940
4941   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4942
4943   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4944   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4945   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4946
4947   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4948
4949 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4950   "
4951         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4952     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4953     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4954     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4955     AND   $table.${prefix}country  = ?
4956   ";
4957 }
4958
4959 sub _X_show_zero {
4960   my( $self, $what ) = @_;
4961
4962   my $what_show_zero = $what. '_show_zero';
4963   length($self->$what_show_zero())
4964     ? ($self->$what_show_zero() eq 'Y')
4965     : $self->part_pkg->$what_show_zero();
4966 }
4967
4968 =head1 SUBROUTINES
4969
4970 =over 4
4971
4972 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4973
4974 CUSTNUM is a customer (see L<FS::cust_main>)
4975
4976 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4977 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4978 permitted.
4979
4980 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4981 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4982 new billing items.  An error is returned if this is not possible (see
4983 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4984 parameter.
4985
4986 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4987 newly-created cust_pkg objects.
4988
4989 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4990 and inserted.  Multiple FS::pkg_referral records can be created by
4991 setting I<refnum> to an array reference of refnums or a hash reference with
4992 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4993 record will be created corresponding to cust_main.refnum.
4994
4995 =cut
4996
4997 sub order {
4998   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4999
5000   my $conf = new FS::Conf;
5001
5002   # Transactionize this whole mess
5003   local $SIG{HUP} = 'IGNORE';
5004   local $SIG{INT} = 'IGNORE';
5005   local $SIG{QUIT} = 'IGNORE';
5006   local $SIG{TERM} = 'IGNORE';
5007   local $SIG{TSTP} = 'IGNORE';
5008   local $SIG{PIPE} = 'IGNORE';
5009
5010   my $oldAutoCommit = $FS::UID::AutoCommit;
5011   local $FS::UID::AutoCommit = 0;
5012   my $dbh = dbh;
5013
5014   my $error;
5015 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
5016 #  return "Customer not found: $custnum" unless $cust_main;
5017
5018   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
5019     if $DEBUG;
5020
5021   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5022                          @$remove_pkgnum;
5023
5024   my $change = scalar(@old_cust_pkg) != 0;
5025
5026   my %hash = ();
5027   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
5028
5029     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
5030          " to pkgpart ". $pkgparts->[0]. "\n"
5031       if $DEBUG;
5032
5033     my $err_or_cust_pkg =
5034       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
5035                                 'refnum'  => $refnum,
5036                               );
5037
5038     unless (ref($err_or_cust_pkg)) {
5039       $dbh->rollback if $oldAutoCommit;
5040       return $err_or_cust_pkg;
5041     }
5042
5043     push @$return_cust_pkg, $err_or_cust_pkg;
5044     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5045     return '';
5046
5047   }
5048
5049   # Create the new packages.
5050   foreach my $pkgpart (@$pkgparts) {
5051
5052     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
5053
5054     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
5055                                       pkgpart => $pkgpart,
5056                                       refnum  => $refnum,
5057                                       %hash,
5058                                     };
5059     $error = $cust_pkg->insert( 'change' => $change );
5060     push @$return_cust_pkg, $cust_pkg;
5061
5062     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
5063       my $supp_pkg = FS::cust_pkg->new({
5064           custnum => $custnum,
5065           pkgpart => $link->dst_pkgpart,
5066           refnum  => $refnum,
5067           main_pkgnum => $cust_pkg->pkgnum,
5068           %hash,
5069       });
5070       $error ||= $supp_pkg->insert( 'change' => $change );
5071       push @$return_cust_pkg, $supp_pkg;
5072     }
5073
5074     if ($error) {
5075       $dbh->rollback if $oldAutoCommit;
5076       return $error;
5077     }
5078
5079   }
5080   # $return_cust_pkg now contains refs to all of the newly
5081   # created packages.
5082
5083   # Transfer services and cancel old packages.
5084   foreach my $old_pkg (@old_cust_pkg) {
5085
5086     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
5087       if $DEBUG;
5088
5089     foreach my $new_pkg (@$return_cust_pkg) {
5090       $error = $old_pkg->transfer($new_pkg);
5091       if ($error and $error == 0) {
5092         # $old_pkg->transfer failed.
5093         $dbh->rollback if $oldAutoCommit;
5094         return $error;
5095       }
5096     }
5097
5098     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
5099       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
5100       foreach my $new_pkg (@$return_cust_pkg) {
5101         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
5102         if ($error and $error == 0) {
5103           # $old_pkg->transfer failed.
5104         $dbh->rollback if $oldAutoCommit;
5105         return $error;
5106         }
5107       }
5108     }
5109
5110     if ($error > 0) {
5111       # Transfers were successful, but we went through all of the
5112       # new packages and still had services left on the old package.
5113       # We can't cancel the package under the circumstances, so abort.
5114       $dbh->rollback if $oldAutoCommit;
5115       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
5116     }
5117     $error = $old_pkg->cancel( quiet=>1 );
5118     if ($error) {
5119       $dbh->rollback;
5120       return $error;
5121     }
5122   }
5123   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5124   '';
5125 }
5126
5127 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
5128
5129 A bulk change method to change packages for multiple customers.
5130
5131 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
5132 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
5133 permitted.
5134
5135 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
5136 replace.  The services (see L<FS::cust_svc>) are moved to the
5137 new billing items.  An error is returned if this is not possible (see
5138 L<FS::pkg_svc>).
5139
5140 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
5141 newly-created cust_pkg objects.
5142
5143 =cut
5144
5145 sub bulk_change {
5146   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
5147
5148   # Transactionize this whole mess
5149   local $SIG{HUP} = 'IGNORE';
5150   local $SIG{INT} = 'IGNORE';
5151   local $SIG{QUIT} = 'IGNORE';
5152   local $SIG{TERM} = 'IGNORE';
5153   local $SIG{TSTP} = 'IGNORE';
5154   local $SIG{PIPE} = 'IGNORE';
5155
5156   my $oldAutoCommit = $FS::UID::AutoCommit;
5157   local $FS::UID::AutoCommit = 0;
5158   my $dbh = dbh;
5159
5160   my @errors;
5161   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
5162                          @$remove_pkgnum;
5163
5164   while(scalar(@old_cust_pkg)) {
5165     my @return = ();
5166     my $custnum = $old_cust_pkg[0]->custnum;
5167     my (@remove) = map { $_->pkgnum }
5168                    grep { $_->custnum == $custnum } @old_cust_pkg;
5169     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
5170
5171     my $error = order $custnum, $pkgparts, \@remove, \@return;
5172
5173     push @errors, $error
5174       if $error;
5175     push @$return_cust_pkg, @return;
5176   }
5177
5178   if (scalar(@errors)) {
5179     $dbh->rollback if $oldAutoCommit;
5180     return join(' / ', @errors);
5181   }
5182
5183   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
5184   '';
5185 }
5186
5187 # Used by FS::Upgrade to migrate to a new database.
5188 sub _upgrade_data {  # class method
5189   my ($class, %opts) = @_;
5190   $class->_upgrade_otaker(%opts);
5191   my @statements = (
5192     # RT#10139, bug resulting in contract_end being set when it shouldn't
5193   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
5194     # RT#10830, bad calculation of prorate date near end of year
5195     # the date range for bill is December 2009, and we move it forward
5196     # one year if it's before the previous bill date (which it should
5197     # never be)
5198   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
5199   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
5200   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
5201     # RT6628, add order_date to cust_pkg
5202     'update cust_pkg set order_date = (select history_date from h_cust_pkg
5203         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
5204         history_action = \'insert\') where order_date is null',
5205   );
5206   foreach my $sql (@statements) {
5207     my $sth = dbh->prepare($sql);
5208     $sth->execute or die $sth->errstr;
5209   }
5210 }
5211
5212 =back
5213
5214 =head1 BUGS
5215
5216 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
5217
5218 In sub order, the @pkgparts array (passed by reference) is clobbered.
5219
5220 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
5221 method to pass dates to the recur_prog expression, it should do so.
5222
5223 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
5224 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
5225 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
5226 configuration values.  Probably need a subroutine which decides what to do
5227 based on whether or not we've fetched the user yet, rather than a hash.  See
5228 FS::UID and the TODO.
5229
5230 Now that things are transactional should the check in the insert method be
5231 moved to check ?
5232
5233 =head1 SEE ALSO
5234
5235 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
5236 L<FS::pkg_svc>, schema.html from the base documentation
5237
5238 =cut
5239
5240 1;
5241