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