FS/FS/cust_pkg.pm

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