FS/FS/cust_pkg.pm

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