FS/FS/cust_pkg.pm

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