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   # Order any supplemental packages.
1929   my $part_pkg = $cust_pkg->part_pkg;
1930   my @old_supp_pkgs = $self->supplemental_pkgs;
1931   my @new_supp_pkgs;
1932   foreach my $link ($part_pkg->supp_part_pkg_link) {
1933     my $old;
1934     foreach (@old_supp_pkgs) {
1935       if ($_->pkgpart == $link->dst_pkgpart) {
1936         $old = $_;
1937         $_->pkgpart(0); # so that it can't match more than once
1938       }
1939       last if $old;
1940     }
1941     # false laziness with FS::cust_main::Packages::order_pkg
1942     my $new = FS::cust_pkg->new({
1943         pkgpart       => $link->dst_pkgpart,
1944         pkglinknum    => $link->pkglinknum,
1945         custnum       => $custnum,
1946         main_pkgnum   => $cust_pkg->pkgnum,
1947         locationnum   => $cust_pkg->locationnum,
1948         start_date    => $cust_pkg->start_date,
1949         order_date    => $cust_pkg->order_date,
1950         expire        => $cust_pkg->expire,
1951         adjourn       => $cust_pkg->adjourn,
1952         contract_end  => $cust_pkg->contract_end,
1953         refnum        => $cust_pkg->refnum,
1954         discountnum   => $cust_pkg->discountnum,
1955         waive_setup   => $cust_pkg->waive_setup,
1956     });
1957     if ( $old and $opt->{'keep_dates'} ) {
1958       foreach (qw(setup bill last_bill)) {
1959         $new->set($_, $old->get($_));
1960       }
1961     }
1962     $error = $new->insert( allow_pkgpart => $same_pkgpart );
1963     # transfer services
1964     if ( $old ) {
1965       $error ||= $old->transfer($new);
1966     }
1967     if ( $error and $error > 0 ) {
1968       # no reason why this should ever fail, but still...
1969       $error = "Unable to transfer all services from supplemental package ".
1970         $old->pkgnum;
1971     }
1972     if ( $error ) {
1973       $dbh->rollback if $oldAutoCommit;
1974       return $error;
1975     }
1976     push @new_supp_pkgs, $new;
1977   }
1978
1979   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
1980   #remaining time.
1981   #Don't allow billing the package (preceding period packages and/or
1982   #outstanding usage) if we are keeping dates (i.e. location changing),
1983   #because the new package will be billed for the same date range.
1984   #Supplemental packages are also canceled here.
1985   $error = $self->cancel(
1986     quiet          => 1,
1987     unused_credit  => $unused_credit,
1988     nobill         => $keep_dates,
1989     change_custnum => ( $self->custnum != $custnum ? $custnum : '' ),
1990   );
1991   if ($error) {
1992     $dbh->rollback if $oldAutoCommit;
1993     return $error;
1994   }
1995
1996   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1997     #$self->cust_main
1998     my $error = $cust_pkg->cust_main->bill(
1999       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
2000     );
2001     if ( $error ) {
2002       $dbh->rollback if $oldAutoCommit;
2003       return $error;
2004     }
2005   }
2006
2007   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2008
2009   $cust_pkg;
2010
2011 }
2012
2013 =item set_quantity QUANTITY
2014
2015 Change the package's quantity field.  This is the one package property
2016 that can safely be changed without canceling and reordering the package
2017 (because it doesn't affect tax eligibility).  Returns an error or an
2018 empty string.
2019
2020 =cut
2021
2022 sub set_quantity {
2023   my $self = shift;
2024   $self = $self->replace_old; # just to make sure
2025   my $qty = shift;
2026   ($qty =~ /^\d+$/ and $qty > 0) or return "bad package quantity $qty";
2027   $self->set('quantity' => $qty);
2028   $self->replace;
2029 }
2030
2031 use Storable 'thaw';
2032 use MIME::Base64;
2033 sub process_bulk_cust_pkg {
2034   my $job = shift;
2035   my $param = thaw(decode_base64(shift));
2036   warn Dumper($param) if $DEBUG;
2037
2038   my $old_part_pkg = qsearchs('part_pkg',
2039                               { pkgpart => $param->{'old_pkgpart'} });
2040   my $new_part_pkg = qsearchs('part_pkg',
2041                               { pkgpart => $param->{'new_pkgpart'} });
2042   die "Must select a new package type\n" unless $new_part_pkg;
2043   #my $keep_dates = $param->{'keep_dates'} || 0;
2044   my $keep_dates = 1; # there is no good reason to turn this off
2045
2046   local $SIG{HUP} = 'IGNORE';
2047   local $SIG{INT} = 'IGNORE';
2048   local $SIG{QUIT} = 'IGNORE';
2049   local $SIG{TERM} = 'IGNORE';
2050   local $SIG{TSTP} = 'IGNORE';
2051   local $SIG{PIPE} = 'IGNORE';
2052
2053   my $oldAutoCommit = $FS::UID::AutoCommit;
2054   local $FS::UID::AutoCommit = 0;
2055   my $dbh = dbh;
2056
2057   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
2058
2059   my $i = 0;
2060   foreach my $old_cust_pkg ( @cust_pkgs ) {
2061     $i++;
2062     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
2063     if ( $old_cust_pkg->getfield('cancel') ) {
2064       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
2065         $old_cust_pkg->pkgnum."\n"
2066         if $DEBUG;
2067       next;
2068     }
2069     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
2070       if $DEBUG;
2071     my $error = $old_cust_pkg->change(
2072       'pkgpart'     => $param->{'new_pkgpart'},
2073       'keep_dates'  => $keep_dates
2074     );
2075     if ( !ref($error) ) { # change returns the cust_pkg on success
2076       $dbh->rollback;
2077       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
2078     }
2079   }
2080   $dbh->commit if $oldAutoCommit;
2081   return;
2082 }
2083
2084 =item last_bill
2085
2086 Returns the last bill date, or if there is no last bill date, the setup date.
2087 Useful for billing metered services.
2088
2089 =cut
2090
2091 sub last_bill {
2092   my $self = shift;
2093   return $self->setfield('last_bill', $_[0]) if @_;
2094   return $self->getfield('last_bill') if $self->getfield('last_bill');
2095   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
2096                                                   'edate'  => $self->bill,  } );
2097   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
2098 }
2099
2100 =item last_cust_pkg_reason ACTION
2101
2102 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
2103 Returns false if there is no reason or the package is not currenly ACTION'd
2104 ACTION is one of adjourn, susp, cancel, or expire.
2105
2106 =cut
2107
2108 sub last_cust_pkg_reason {
2109   my ( $self, $action ) = ( shift, shift );
2110   my $date = $self->get($action);
2111   qsearchs( {
2112               'table' => 'cust_pkg_reason',
2113               'hashref' => { 'pkgnum' => $self->pkgnum,
2114                              'action' => substr(uc($action), 0, 1),
2115                              'date'   => $date,
2116                            },
2117               'order_by' => 'ORDER BY num DESC LIMIT 1',
2118            } );
2119 }
2120
2121 =item last_reason ACTION
2122
2123 Returns the most recent ACTION FS::reason associated with the package.
2124 Returns false if there is no reason or the package is not currenly ACTION'd
2125 ACTION is one of adjourn, susp, cancel, or expire.
2126
2127 =cut
2128
2129 sub last_reason {
2130   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2131   $cust_pkg_reason->reason
2132     if $cust_pkg_reason;
2133 }
2134
2135 =item part_pkg
2136
2137 Returns the definition for this billing item, as an FS::part_pkg object (see
2138 L<FS::part_pkg>).
2139
2140 =cut
2141
2142 sub part_pkg {
2143   my $self = shift;
2144   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2145   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2146   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2147 }
2148
2149 =item old_cust_pkg
2150
2151 Returns the cancelled package this package was changed from, if any.
2152
2153 =cut
2154
2155 sub old_cust_pkg {
2156   my $self = shift;
2157   return '' unless $self->change_pkgnum;
2158   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2159 }
2160
2161 =item change_cust_main
2162
2163 Returns the customter this package was detached to, if any.
2164
2165 =cut
2166
2167 sub change_cust_main {
2168   my $self = shift;
2169   return '' unless $self->change_custnum;
2170   qsearchs('cust_main', { 'custnum' => $self->change_custnum } );
2171 }
2172
2173 =item calc_setup
2174
2175 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2176 item.
2177
2178 =cut
2179
2180 sub calc_setup {
2181   my $self = shift;
2182   $self->part_pkg->calc_setup($self, @_);
2183 }
2184
2185 =item calc_recur
2186
2187 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2188 item.
2189
2190 =cut
2191
2192 sub calc_recur {
2193   my $self = shift;
2194   $self->part_pkg->calc_recur($self, @_);
2195 }
2196
2197 =item base_setup
2198
2199 Calls the I<base_setup> of the FS::part_pkg object associated with this billing
2200 item.
2201
2202 =cut
2203
2204 sub base_setup {
2205   my $self = shift;
2206   $self->part_pkg->base_setup($self, @_);
2207 }
2208
2209 =item base_recur
2210
2211 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2212 item.
2213
2214 =cut
2215
2216 sub base_recur {
2217   my $self = shift;
2218   $self->part_pkg->base_recur($self, @_);
2219 }
2220
2221 =item calc_remain
2222
2223 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2224 billing item.
2225
2226 =cut
2227
2228 sub calc_remain {
2229   my $self = shift;
2230   $self->part_pkg->calc_remain($self, @_);
2231 }
2232
2233 =item calc_cancel
2234
2235 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2236 billing item.
2237
2238 =cut
2239
2240 sub calc_cancel {
2241   my $self = shift;
2242   $self->part_pkg->calc_cancel($self, @_);
2243 }
2244
2245 =item cust_bill_pkg
2246
2247 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2248
2249 =cut
2250
2251 sub cust_bill_pkg {
2252   my $self = shift;
2253   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2254 }
2255
2256 =item cust_pkg_detail [ DETAILTYPE ]
2257
2258 Returns any customer package details for this package (see
2259 L<FS::cust_pkg_detail>).
2260
2261 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2262
2263 =cut
2264
2265 sub cust_pkg_detail {
2266   my $self = shift;
2267   my %hash = ( 'pkgnum' => $self->pkgnum );
2268   $hash{detailtype} = shift if @_;
2269   qsearch({
2270     'table'    => 'cust_pkg_detail',
2271     'hashref'  => \%hash,
2272     'order_by' => 'ORDER BY weight, pkgdetailnum',
2273   });
2274 }
2275
2276 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2277
2278 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2279
2280 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2281
2282 If there is an error, returns the error, otherwise returns false.
2283
2284 =cut
2285
2286 sub set_cust_pkg_detail {
2287   my( $self, $detailtype, @details ) = @_;
2288
2289   local $SIG{HUP} = 'IGNORE';
2290   local $SIG{INT} = 'IGNORE';
2291   local $SIG{QUIT} = 'IGNORE';
2292   local $SIG{TERM} = 'IGNORE';
2293   local $SIG{TSTP} = 'IGNORE';
2294   local $SIG{PIPE} = 'IGNORE';
2295
2296   my $oldAutoCommit = $FS::UID::AutoCommit;
2297   local $FS::UID::AutoCommit = 0;
2298   my $dbh = dbh;
2299
2300   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2301     my $error = $current->delete;
2302     if ( $error ) {
2303       $dbh->rollback if $oldAutoCommit;
2304       return "error removing old detail: $error";
2305     }
2306   }
2307
2308   foreach my $detail ( @details ) {
2309     my $cust_pkg_detail = new FS::cust_pkg_detail {
2310       'pkgnum'     => $self->pkgnum,
2311       'detailtype' => $detailtype,
2312       'detail'     => $detail,
2313     };
2314     my $error = $cust_pkg_detail->insert;
2315     if ( $error ) {
2316       $dbh->rollback if $oldAutoCommit;
2317       return "error adding new detail: $error";
2318     }
2319
2320   }
2321
2322   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2323   '';
2324
2325 }
2326
2327 =item cust_event
2328
2329 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2330
2331 =cut
2332
2333 #false laziness w/cust_bill.pm
2334 sub cust_event {
2335   my $self = shift;
2336   qsearch({
2337     'table'     => 'cust_event',
2338     'addl_from' => 'JOIN part_event USING ( eventpart )',
2339     'hashref'   => { 'tablenum' => $self->pkgnum },
2340     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2341   });
2342 }
2343
2344 =item num_cust_event
2345
2346 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2347
2348 =cut
2349
2350 #false laziness w/cust_bill.pm
2351 sub num_cust_event {
2352   my $self = shift;
2353   my $sql =
2354     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2355     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2356   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2357   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2358   $sth->fetchrow_arrayref->[0];
2359 }
2360
2361 =item part_pkg_currency_option OPTIONNAME
2362
2363 Returns a two item list consisting of the currency of this customer, if any,
2364 and a value for the provided option.  If the customer has a currency, the value
2365 is the option value the given name and the currency (see
2366 L<FS::part_pkg_currency>).  Otherwise, if the customer has no currency, is the
2367 regular option value for the given name (see L<FS::part_pkg_option>).
2368
2369 =cut
2370
2371 sub part_pkg_currency_option {
2372   my( $self, $optionname ) = @_;
2373   my $part_pkg = $self->part_pkg;
2374   if ( my $currency = $self->cust_main->currency ) {
2375     ($currency, $part_pkg->part_pkg_currency_option($currency, $optionname) );
2376   } else {
2377     ('', $part_pkg->option($optionname) );
2378   }
2379 }
2380
2381 =item cust_svc [ SVCPART ] (old, deprecated usage)
2382
2383 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2384
2385 Returns the services for this package, as FS::cust_svc objects (see
2386 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2387 spcififed, returns only the matching services.
2388
2389 =cut
2390
2391 sub cust_svc {
2392   my $self = shift;
2393
2394   return () unless $self->num_cust_svc(@_);
2395
2396   my %opt = ();
2397   if ( @_ && $_[0] =~ /^\d+/ ) {
2398     $opt{svcpart} = shift;
2399   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2400     %opt = %{ $_[0] };
2401   } elsif ( @_ ) {
2402     %opt = @_;
2403   }
2404
2405   my %search = (
2406     'table'   => 'cust_svc',
2407     'hashref' => { 'pkgnum' => $self->pkgnum },
2408   );
2409   if ( $opt{svcpart} ) {
2410     $search{hashref}->{svcpart} = $opt{'svcpart'};
2411   }
2412   if ( $opt{'svcdb'} ) {
2413     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2414     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2415   }
2416
2417   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2418
2419   #if ( $self->{'_svcnum'} ) {
2420   #  values %{ $self->{'_svcnum'}->cache };
2421   #} else {
2422     $self->_sort_cust_svc( [ qsearch(\%search) ] );
2423   #}
2424
2425 }
2426
2427 =item overlimit [ SVCPART ]
2428
2429 Returns the services for this package which have exceeded their
2430 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2431 is specified, return only the matching services.
2432
2433 =cut
2434
2435 sub overlimit {
2436   my $self = shift;
2437   return () unless $self->num_cust_svc(@_);
2438   grep { $_->overlimit } $self->cust_svc(@_);
2439 }
2440
2441 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2442
2443 Returns historical services for this package created before END TIMESTAMP and
2444 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2445 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2446 I<pkg_svc.hidden> flag will be omitted.
2447
2448 =cut
2449
2450 sub h_cust_svc {
2451   my $self = shift;
2452   warn "$me _h_cust_svc called on $self\n"
2453     if $DEBUG;
2454
2455   my ($end, $start, $mode) = @_;
2456   my @cust_svc = $self->_sort_cust_svc(
2457     [ qsearch( 'h_cust_svc',
2458       { 'pkgnum' => $self->pkgnum, },
2459       FS::h_cust_svc->sql_h_search(@_),
2460     ) ]
2461   );
2462   if ( defined($mode) && $mode eq 'I' ) {
2463     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2464     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2465   } else {
2466     return @cust_svc;
2467   }
2468 }
2469
2470 sub _sort_cust_svc {
2471   my( $self, $arrayref ) = @_;
2472
2473   my $sort =
2474     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2475
2476   map  { $_->[0] }
2477   sort $sort
2478   map {
2479         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2480                                              'svcpart' => $_->svcpart     } );
2481         [ $_,
2482           $pkg_svc ? $pkg_svc->primary_svc : '',
2483           $pkg_svc ? $pkg_svc->quantity : 0,
2484         ];
2485       }
2486   @$arrayref;
2487
2488 }
2489
2490 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2491
2492 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2493
2494 Returns the number of services for this package.  Available options are svcpart
2495 and svcdb.  If either is spcififed, returns only the matching services.
2496
2497 =cut
2498
2499 sub num_cust_svc {
2500   my $self = shift;
2501
2502   return $self->{'_num_cust_svc'}
2503     if !scalar(@_)
2504        && exists($self->{'_num_cust_svc'})
2505        && $self->{'_num_cust_svc'} =~ /\d/;
2506
2507   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2508     if $DEBUG > 2;
2509
2510   my %opt = ();
2511   if ( @_ && $_[0] =~ /^\d+/ ) {
2512     $opt{svcpart} = shift;
2513   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2514     %opt = %{ $_[0] };
2515   } elsif ( @_ ) {
2516     %opt = @_;
2517   }
2518
2519   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2520   my $where = ' WHERE pkgnum = ? ';
2521   my @param = ($self->pkgnum);
2522
2523   if ( $opt{'svcpart'} ) {
2524     $where .= ' AND svcpart = ? ';
2525     push @param, $opt{'svcpart'};
2526   }
2527   if ( $opt{'svcdb'} ) {
2528     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2529     $where .= ' AND svcdb = ? ';
2530     push @param, $opt{'svcdb'};
2531   }
2532
2533   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2534   $sth->execute(@param) or die $sth->errstr;
2535   $sth->fetchrow_arrayref->[0];
2536 }
2537
2538 =item available_part_svc
2539
2540 Returns a list of FS::part_svc objects representing services included in this
2541 package but not yet provisioned.  Each FS::part_svc object also has an extra
2542 field, I<num_avail>, which specifies the number of available services.
2543
2544 =cut
2545
2546 sub available_part_svc {
2547   my $self = shift;
2548
2549   my $pkg_quantity = $self->quantity || 1;
2550
2551   grep { $_->num_avail > 0 }
2552     map {
2553           my $part_svc = $_->part_svc;
2554           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2555             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2556
2557           # more evil encapsulation breakage
2558           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2559             my @exports = $part_svc->part_export_did;
2560             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2561           }
2562
2563           $part_svc;
2564         }
2565       $self->part_pkg->pkg_svc;
2566 }
2567
2568 =item part_svc [ OPTION => VALUE ... ]
2569
2570 Returns a list of FS::part_svc objects representing provisioned and available
2571 services included in this package.  Each FS::part_svc object also has the
2572 following extra fields:
2573
2574 =over 4
2575
2576 =item num_cust_svc  (count)
2577
2578 =item num_avail     (quantity - count)
2579
2580 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2581
2582 =back
2583
2584 Accepts one option: summarize_size.  If specified and non-zero, will omit the
2585 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2586 greater.
2587
2588 =cut
2589
2590 #svcnum
2591 #label -> ($cust_svc->label)[1]
2592
2593 sub part_svc {
2594   my $self = shift;
2595   my %opt = @_;
2596
2597   my $pkg_quantity = $self->quantity || 1;
2598
2599   #XXX some sort of sort order besides numeric by svcpart...
2600   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2601     my $pkg_svc = $_;
2602     my $part_svc = $pkg_svc->part_svc;
2603     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2604     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2605     $part_svc->{'Hash'}{'num_avail'}    =
2606       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2607     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2608         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2609       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2610           && $num_cust_svc >= $opt{summarize_size};
2611     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2612     $part_svc;
2613   } $self->part_pkg->pkg_svc;
2614
2615   #extras
2616   push @part_svc, map {
2617     my $part_svc = $_;
2618     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2619     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2620     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
2621     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2622       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2623     $part_svc;
2624   } $self->extra_part_svc;
2625
2626   @part_svc;
2627
2628 }
2629
2630 =item extra_part_svc
2631
2632 Returns a list of FS::part_svc objects corresponding to services in this
2633 package which are still provisioned but not (any longer) available in the
2634 package definition.
2635
2636 =cut
2637
2638 sub extra_part_svc {
2639   my $self = shift;
2640
2641   my $pkgnum  = $self->pkgnum;
2642   #my $pkgpart = $self->pkgpart;
2643
2644 #  qsearch( {
2645 #    'table'     => 'part_svc',
2646 #    'hashref'   => {},
2647 #    'extra_sql' =>
2648 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2649 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
2650 #                       AND pkg_svc.pkgpart = ?
2651 #                       AND quantity > 0
2652 #                 )
2653 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
2654 #                       LEFT JOIN cust_pkg USING ( pkgnum )
2655 #                     WHERE cust_svc.svcpart = part_svc.svcpart
2656 #                       AND pkgnum = ?
2657 #                 )",
2658 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2659 #  } );
2660
2661 #seems to benchmark slightly faster... (or did?)
2662
2663   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2664   my $pkgparts = join(',', @pkgparts);
2665
2666   qsearch( {
2667     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
2668     #MySQL doesn't grok DISINCT ON
2669     'select'      => 'DISTINCT part_svc.*',
2670     'table'       => 'part_svc',
2671     'addl_from'   =>
2672       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
2673                                AND pkg_svc.pkgpart IN ($pkgparts)
2674                                AND quantity > 0
2675                              )
2676        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
2677        LEFT JOIN cust_pkg USING ( pkgnum )
2678       ",
2679     'hashref'     => {},
2680     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2681     'extra_param' => [ [$self->pkgnum=>'int'] ],
2682   } );
2683 }
2684
2685 =item status
2686
2687 Returns a short status string for this package, currently:
2688
2689 =over 4
2690
2691 =item not yet billed
2692
2693 =item one-time charge
2694
2695 =item active
2696
2697 =item suspended
2698
2699 =item cancelled
2700
2701 =back
2702
2703 =cut
2704
2705 sub status {
2706   my $self = shift;
2707
2708   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2709
2710   return 'cancelled' if $self->get('cancel');
2711   return 'suspended' if $self->susp;
2712   return 'not yet billed' unless $self->setup;
2713   return 'one-time charge' if $freq =~ /^(0|$)/;
2714   return 'active';
2715 }
2716
2717 =item ucfirst_status
2718
2719 Returns the status with the first character capitalized.
2720
2721 =cut
2722
2723 sub ucfirst_status {
2724   ucfirst(shift->status);
2725 }
2726
2727 =item statuses
2728
2729 Class method that returns the list of possible status strings for packages
2730 (see L<the status method|/status>).  For example:
2731
2732   @statuses = FS::cust_pkg->statuses();
2733
2734 =cut
2735
2736 tie my %statuscolor, 'Tie::IxHash',
2737   'not yet billed'  => '009999', #teal? cyan?
2738   'one-time charge' => '000000',
2739   'active'          => '00CC00',
2740   'suspended'       => 'FF9900',
2741   'cancelled'       => 'FF0000',
2742 ;
2743
2744 sub statuses {
2745   my $self = shift; #could be class...
2746   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2747   #                                    # mayble split btw one-time vs. recur
2748     keys %statuscolor;
2749 }
2750
2751 =item statuscolor
2752
2753 Returns a hex triplet color string for this package's status.
2754
2755 =cut
2756
2757 sub statuscolor {
2758   my $self = shift;
2759   $statuscolor{$self->status};
2760 }
2761
2762 =item pkg_label
2763
2764 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
2765 "pkg - comment" depending on user preference).
2766
2767 =cut
2768
2769 sub pkg_label {
2770   my $self = shift;
2771   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2772   $label = $self->pkgnum. ": $label"
2773     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2774   $label;
2775 }
2776
2777 =item pkg_label_long
2778
2779 Returns a long label for this package, adding the primary service's label to
2780 pkg_label.
2781
2782 =cut
2783
2784 sub pkg_label_long {
2785   my $self = shift;
2786   my $label = $self->pkg_label;
2787   my $cust_svc = $self->primary_cust_svc;
2788   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2789   $label;
2790 }
2791
2792 =item pkg_locale
2793
2794 Returns a customer-localized label for this package.
2795
2796 =cut
2797
2798 sub pkg_locale {
2799   my $self = shift;
2800   $self->part_pkg->pkg_locale( $self->cust_main->locale );
2801 }
2802
2803 =item primary_cust_svc
2804
2805 Returns a primary service (as FS::cust_svc object) if one can be identified.
2806
2807 =cut
2808
2809 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2810
2811 sub primary_cust_svc {
2812   my $self = shift;
2813
2814   my @cust_svc = $self->cust_svc;
2815
2816   return '' unless @cust_svc; #no serivces - irrelevant then
2817
2818   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2819
2820   # primary service as specified in the package definition
2821   # or exactly one service definition with quantity one
2822   my $svcpart = $self->part_pkg->svcpart;
2823   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2824   return $cust_svc[0] if scalar(@cust_svc) == 1;
2825
2826   #couldn't identify one thing..
2827   return '';
2828 }
2829
2830 =item labels
2831
2832 Returns a list of lists, calling the label method for all services
2833 (see L<FS::cust_svc>) of this billing item.
2834
2835 =cut
2836
2837 sub labels {
2838   my $self = shift;
2839   map { [ $_->label ] } $self->cust_svc;
2840 }
2841
2842 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2843
2844 Like the labels method, but returns historical information on services that
2845 were active as of END_TIMESTAMP and (optionally) not cancelled before
2846 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2847 I<pkg_svc.hidden> flag will be omitted.
2848
2849 Returns a list of lists, calling the label method for all (historical) services
2850 (see L<FS::h_cust_svc>) of this billing item.
2851
2852 =cut
2853
2854 sub h_labels {
2855   my $self = shift;
2856   warn "$me _h_labels called on $self\n"
2857     if $DEBUG;
2858   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2859 }
2860
2861 =item labels_short
2862
2863 Like labels, except returns a simple flat list, and shortens long
2864 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2865 identical services to one line that lists the service label and the number of
2866 individual services rather than individual items.
2867
2868 =cut
2869
2870 sub labels_short {
2871   shift->_labels_short( 'labels', @_ );
2872 }
2873
2874 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2875
2876 Like h_labels, except returns a simple flat list, and shortens long
2877 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2878 identical services to one line that lists the service label and the number of
2879 individual services rather than individual items.
2880
2881 =cut
2882
2883 sub h_labels_short {
2884   shift->_labels_short( 'h_labels', @_ );
2885 }
2886
2887 sub _labels_short {
2888   my( $self, $method ) = ( shift, shift );
2889
2890   warn "$me _labels_short called on $self with $method method\n"
2891     if $DEBUG;
2892
2893   my $conf = new FS::Conf;
2894   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2895
2896   warn "$me _labels_short populating \%labels\n"
2897     if $DEBUG;
2898
2899   my %labels;
2900   #tie %labels, 'Tie::IxHash';
2901   push @{ $labels{$_->[0]} }, $_->[1]
2902     foreach $self->$method(@_);
2903
2904   warn "$me _labels_short populating \@labels\n"
2905     if $DEBUG;
2906
2907   my @labels;
2908   foreach my $label ( keys %labels ) {
2909     my %seen = ();
2910     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2911     my $num = scalar(@values);
2912     warn "$me _labels_short $num items for $label\n"
2913       if $DEBUG;
2914
2915     if ( $num > $max_same_services ) {
2916       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2917         if $DEBUG;
2918       push @labels, "$label ($num)";
2919     } else {
2920       if ( $conf->exists('cust_bill-consolidate_services') ) {
2921         warn "$me _labels_short   consolidating services\n"
2922           if $DEBUG;
2923         # push @labels, "$label: ". join(', ', @values);
2924         while ( @values ) {
2925           my $detail = "$label: ";
2926           $detail .= shift(@values). ', '
2927             while @values
2928                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2929           $detail =~ s/, $//;
2930           push @labels, $detail;
2931         }
2932         warn "$me _labels_short   done consolidating services\n"
2933           if $DEBUG;
2934       } else {
2935         warn "$me _labels_short   adding service data\n"
2936           if $DEBUG;
2937         push @labels, map { "$label: $_" } @values;
2938       }
2939     }
2940   }
2941
2942  @labels;
2943
2944 }
2945
2946 =item cust_main
2947
2948 Returns the parent customer object (see L<FS::cust_main>).
2949
2950 =cut
2951
2952 sub cust_main {
2953   my $self = shift;
2954   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2955 }
2956
2957 =item balance
2958
2959 Returns the balance for this specific package, when using
2960 experimental package balance.
2961
2962 =cut
2963
2964 sub balance {
2965   my $self = shift;
2966   $self->cust_main->balance_pkgnum( $self->pkgnum );
2967 }
2968
2969 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2970
2971 =item cust_location
2972
2973 Returns the location object, if any (see L<FS::cust_location>).
2974
2975 =item cust_location_or_main
2976
2977 If this package is associated with a location, returns the locaiton (see
2978 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2979
2980 =item location_label [ OPTION => VALUE ... ]
2981
2982 Returns the label of the location object (see L<FS::cust_location>).
2983
2984 =cut
2985
2986 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2987
2988 =item tax_locationnum
2989
2990 Returns the foreign key to a L<FS::cust_location> object for calculating
2991 tax on this package, as determined by the C<tax-pkg_address> and
2992 C<tax-ship_address> configuration flags.
2993
2994 =cut
2995
2996 sub tax_locationnum {
2997   my $self = shift;
2998   my $conf = FS::Conf->new;
2999   if ( $conf->exists('tax-pkg_address') ) {
3000     return $self->locationnum;
3001   }
3002   elsif ( $conf->exists('tax-ship_address') ) {
3003     return $self->cust_main->ship_locationnum;
3004   }
3005   else {
3006     return $self->cust_main->bill_locationnum;
3007   }
3008 }
3009
3010 =item tax_location
3011
3012 Returns the L<FS::cust_location> object for tax_locationnum.
3013
3014 =cut
3015
3016 sub tax_location {
3017   my $self = shift;
3018   FS::cust_location->by_key( $self->tax_locationnum )
3019 }
3020
3021 =item seconds_since TIMESTAMP
3022
3023 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
3024 package have been online since TIMESTAMP, according to the session monitor.
3025
3026 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
3027 L<Time::Local> and L<Date::Parse> for conversion functions.
3028
3029 =cut
3030
3031 sub seconds_since {
3032   my($self, $since) = @_;
3033   my $seconds = 0;
3034
3035   foreach my $cust_svc (
3036     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
3037   ) {
3038     $seconds += $cust_svc->seconds_since($since);
3039   }
3040
3041   $seconds;
3042
3043 }
3044
3045 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
3046
3047 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
3048 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
3049 (exclusive).
3050
3051 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3052 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3053 functions.
3054
3055
3056 =cut
3057
3058 sub seconds_since_sqlradacct {
3059   my($self, $start, $end) = @_;
3060
3061   my $seconds = 0;
3062
3063   foreach my $cust_svc (
3064     grep {
3065       my $part_svc = $_->part_svc;
3066       $part_svc->svcdb eq 'svc_acct'
3067         && scalar($part_svc->part_export_usage);
3068     } $self->cust_svc
3069   ) {
3070     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
3071   }
3072
3073   $seconds;
3074
3075 }
3076
3077 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
3078
3079 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
3080 in this package for sessions ending between TIMESTAMP_START (inclusive) and
3081 TIMESTAMP_END
3082 (exclusive).
3083
3084 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
3085 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
3086 functions.
3087
3088 =cut
3089
3090 sub attribute_since_sqlradacct {
3091   my($self, $start, $end, $attrib) = @_;
3092
3093   my $sum = 0;
3094
3095   foreach my $cust_svc (
3096     grep {
3097       my $part_svc = $_->part_svc;
3098       $part_svc->svcdb eq 'svc_acct'
3099         && scalar($part_svc->part_export_usage);
3100     } $self->cust_svc
3101   ) {
3102     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
3103   }
3104
3105   $sum;
3106
3107 }
3108
3109 =item quantity
3110
3111 =cut
3112
3113 sub quantity {
3114   my( $self, $value ) = @_;
3115   if ( defined($value) ) {
3116     $self->setfield('quantity', $value);
3117   }
3118   $self->getfield('quantity') || 1;
3119 }
3120
3121 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
3122
3123 Transfers as many services as possible from this package to another package.
3124
3125 The destination package can be specified by pkgnum by passing an FS::cust_pkg
3126 object.  The destination package must already exist.
3127
3128 Services are moved only if the destination allows services with the correct
3129 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
3130 this option with caution!  No provision is made for export differences
3131 between the old and new service definitions.  Probably only should be used
3132 when your exports for all service definitions of a given svcdb are identical.
3133 (attempt a transfer without it first, to move all possible svcpart-matching
3134 services)
3135
3136 Any services that can't be moved remain in the original package.
3137
3138 Returns an error, if there is one; otherwise, returns the number of services
3139 that couldn't be moved.
3140
3141 =cut
3142
3143 sub transfer {
3144   my ($self, $dest_pkgnum, %opt) = @_;
3145
3146   my $remaining = 0;
3147   my $dest;
3148   my %target;
3149
3150   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
3151     $dest = $dest_pkgnum;
3152     $dest_pkgnum = $dest->pkgnum;
3153   } else {
3154     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
3155   }
3156
3157   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
3158
3159   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
3160     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
3161   }
3162
3163   foreach my $cust_svc ($dest->cust_svc) {
3164     $target{$cust_svc->svcpart}--;
3165   }
3166
3167   my %svcpart2svcparts = ();
3168   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3169     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
3170     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
3171       next if exists $svcpart2svcparts{$svcpart};
3172       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3173       $svcpart2svcparts{$svcpart} = [
3174         map  { $_->[0] }
3175         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3176         map {
3177               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3178                                                    'svcpart' => $_          } );
3179               [ $_,
3180                 $pkg_svc ? $pkg_svc->primary_svc : '',
3181                 $pkg_svc ? $pkg_svc->quantity : 0,
3182               ];
3183             }
3184
3185         grep { $_ != $svcpart }
3186         map  { $_->svcpart }
3187         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3188       ];
3189       warn "alternates for svcpart $svcpart: ".
3190            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3191         if $DEBUG;
3192     }
3193   }
3194
3195   foreach my $cust_svc ($self->cust_svc) {
3196     if($target{$cust_svc->svcpart} > 0
3197        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3198       $target{$cust_svc->svcpart}--;
3199       my $new = new FS::cust_svc { $cust_svc->hash };
3200       $new->pkgnum($dest_pkgnum);
3201       my $error = $new->replace($cust_svc);
3202       return $error if $error;
3203     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3204       if ( $DEBUG ) {
3205         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3206         warn "alternates to consider: ".
3207              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3208       }
3209       my @alternate = grep {
3210                              warn "considering alternate svcpart $_: ".
3211                                   "$target{$_} available in new package\n"
3212                                if $DEBUG;
3213                              $target{$_} > 0;
3214                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3215       if ( @alternate ) {
3216         warn "alternate(s) found\n" if $DEBUG;
3217         my $change_svcpart = $alternate[0];
3218         $target{$change_svcpart}--;
3219         my $new = new FS::cust_svc { $cust_svc->hash };
3220         $new->svcpart($change_svcpart);
3221         $new->pkgnum($dest_pkgnum);
3222         my $error = $new->replace($cust_svc);
3223         return $error if $error;
3224       } else {
3225         $remaining++;
3226       }
3227     } else {
3228       $remaining++
3229     }
3230   }
3231   return $remaining;
3232 }
3233
3234 =item grab_svcnums SVCNUM, SVCNUM ...
3235
3236 Change the pkgnum for the provided services to this packages.  If there is an
3237 error, returns the error, otherwise returns false.
3238
3239 =cut
3240
3241 sub grab_svcnums {
3242   my $self = shift;
3243   my @svcnum = @_;
3244
3245   local $SIG{HUP} = 'IGNORE';
3246   local $SIG{INT} = 'IGNORE';
3247   local $SIG{QUIT} = 'IGNORE';
3248   local $SIG{TERM} = 'IGNORE';
3249   local $SIG{TSTP} = 'IGNORE';
3250   local $SIG{PIPE} = 'IGNORE';
3251
3252   my $oldAutoCommit = $FS::UID::AutoCommit;
3253   local $FS::UID::AutoCommit = 0;
3254   my $dbh = dbh;
3255
3256   foreach my $svcnum (@svcnum) {
3257     my $cust_svc = qsearchs('cust_svc', { svcnum=>$svcnum } ) or do {
3258       $dbh->rollback if $oldAutoCommit;
3259       return "unknown svcnum $svcnum";
3260     };
3261     $cust_svc->pkgnum( $self->pkgnum );
3262     my $error = $cust_svc->replace;
3263     if ( $error ) {
3264       $dbh->rollback if $oldAutoCommit;
3265       return $error;
3266     }
3267   }
3268
3269   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3270   '';
3271
3272 }
3273
3274 =item reexport
3275
3276 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3277 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3278
3279 =cut
3280
3281 #looks like this is still used by the order_pkg and change_pkg methods in
3282 # ClientAPI/MyAccount, need to look into those before removing
3283 sub reexport {
3284   my $self = shift;
3285
3286   local $SIG{HUP} = 'IGNORE';
3287   local $SIG{INT} = 'IGNORE';
3288   local $SIG{QUIT} = 'IGNORE';
3289   local $SIG{TERM} = 'IGNORE';
3290   local $SIG{TSTP} = 'IGNORE';
3291   local $SIG{PIPE} = 'IGNORE';
3292
3293   my $oldAutoCommit = $FS::UID::AutoCommit;
3294   local $FS::UID::AutoCommit = 0;
3295   my $dbh = dbh;
3296
3297   foreach my $cust_svc ( $self->cust_svc ) {
3298     #false laziness w/svc_Common::insert
3299     my $svc_x = $cust_svc->svc_x;
3300     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3301       my $error = $part_export->export_insert($svc_x);
3302       if ( $error ) {
3303         $dbh->rollback if $oldAutoCommit;
3304         return $error;
3305       }
3306     }
3307   }
3308
3309   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3310   '';
3311
3312 }
3313
3314 =item export_pkg_change OLD_CUST_PKG
3315
3316 Calls the "pkg_change" export action for all services attached to this package.
3317
3318 =cut
3319
3320 sub export_pkg_change {
3321   my( $self, $old )  = ( shift, shift );
3322
3323   local $SIG{HUP} = 'IGNORE';
3324   local $SIG{INT} = 'IGNORE';
3325   local $SIG{QUIT} = 'IGNORE';
3326   local $SIG{TERM} = 'IGNORE';
3327   local $SIG{TSTP} = 'IGNORE';
3328   local $SIG{PIPE} = 'IGNORE';
3329
3330   my $oldAutoCommit = $FS::UID::AutoCommit;
3331   local $FS::UID::AutoCommit = 0;
3332   my $dbh = dbh;
3333
3334   foreach my $svc_x ( map $_->svc_x, $self->cust_svc ) {
3335     my $error = $svc_x->export('pkg_change', $self, $old);
3336     if ( $error ) {
3337       $dbh->rollback if $oldAutoCommit;
3338       return $error;
3339     }
3340   }
3341
3342   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3343   '';
3344
3345 }
3346
3347 =item insert_reason
3348
3349 Associates this package with a (suspension or cancellation) reason (see
3350 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3351 L<FS::reason>).
3352
3353 Available options are:
3354
3355 =over 4
3356
3357 =item reason
3358
3359 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.
3360
3361 =item reason_otaker
3362
3363 the access_user (see L<FS::access_user>) providing the reason
3364
3365 =item date
3366
3367 a unix timestamp
3368
3369 =item action
3370
3371 the action (cancel, susp, adjourn, expire) associated with the reason
3372
3373 =back
3374
3375 If there is an error, returns the error, otherwise returns false.
3376
3377 =cut
3378
3379 sub insert_reason {
3380   my ($self, %options) = @_;
3381
3382   my $otaker = $options{reason_otaker} ||
3383                $FS::CurrentUser::CurrentUser->username;
3384
3385   my $reasonnum;
3386   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3387
3388     $reasonnum = $1;
3389
3390   } elsif ( ref($options{'reason'}) ) {
3391
3392     return 'Enter a new reason (or select an existing one)'
3393       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3394
3395     my $reason = new FS::reason({
3396       'reason_type' => $options{'reason'}->{'typenum'},
3397       'reason'      => $options{'reason'}->{'reason'},
3398     });
3399     my $error = $reason->insert;
3400     return $error if $error;
3401
3402     $reasonnum = $reason->reasonnum;
3403
3404   } else {
3405     return "Unparsable reason: ". $options{'reason'};
3406   }
3407
3408   my $cust_pkg_reason =
3409     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3410                               'reasonnum' => $reasonnum,
3411                               'otaker'    => $otaker,
3412                               'action'    => substr(uc($options{'action'}),0,1),
3413                               'date'      => $options{'date'}
3414                                                ? $options{'date'}
3415                                                : time,
3416                             });
3417
3418   $cust_pkg_reason->insert;
3419 }
3420
3421 =item insert_discount
3422
3423 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3424 inserting a new discount on the fly (see L<FS::discount>).
3425
3426 Available options are:
3427
3428 =over 4
3429
3430 =item discountnum
3431
3432 =back
3433
3434 If there is an error, returns the error, otherwise returns false.
3435
3436 =cut
3437
3438 sub insert_discount {
3439   #my ($self, %options) = @_;
3440   my $self = shift;
3441
3442   my $cust_pkg_discount = new FS::cust_pkg_discount {
3443     'pkgnum'      => $self->pkgnum,
3444     'discountnum' => $self->discountnum,
3445     'months_used' => 0,
3446     'end_date'    => '', #XXX
3447     #for the create a new discount case
3448     '_type'       => $self->discountnum__type,
3449     'amount'      => $self->discountnum_amount,
3450     'percent'     => $self->discountnum_percent,
3451     'months'      => $self->discountnum_months,
3452     'setup'      => $self->discountnum_setup,
3453     #'disabled'    => $self->discountnum_disabled,
3454   };
3455
3456   $cust_pkg_discount->insert;
3457 }
3458
3459 =item set_usage USAGE_VALUE_HASHREF
3460
3461 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3462 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3463 upbytes, downbytes, and totalbytes are appropriate keys.
3464
3465 All svc_accts which are part of this package have their values reset.
3466
3467 =cut
3468
3469 sub set_usage {
3470   my ($self, $valueref, %opt) = @_;
3471
3472   #only svc_acct can set_usage for now
3473   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3474     my $svc_x = $cust_svc->svc_x;
3475     $svc_x->set_usage($valueref, %opt)
3476       if $svc_x->can("set_usage");
3477   }
3478 }
3479
3480 =item recharge USAGE_VALUE_HASHREF
3481
3482 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3483 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3484 upbytes, downbytes, and totalbytes are appropriate keys.
3485
3486 All svc_accts which are part of this package have their values incremented.
3487
3488 =cut
3489
3490 sub recharge {
3491   my ($self, $valueref) = @_;
3492
3493   #only svc_acct can set_usage for now
3494   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3495     my $svc_x = $cust_svc->svc_x;
3496     $svc_x->recharge($valueref)
3497       if $svc_x->can("recharge");
3498   }
3499 }
3500
3501 =item cust_pkg_discount
3502
3503 =cut
3504
3505 sub cust_pkg_discount {
3506   my $self = shift;
3507   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3508 }
3509
3510 =item cust_pkg_discount_active
3511
3512 =cut
3513
3514 sub cust_pkg_discount_active {
3515   my $self = shift;
3516   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3517 }
3518
3519 =item cust_pkg_usage
3520
3521 Returns a list of all voice usage counters attached to this package.
3522
3523 =cut
3524
3525 sub cust_pkg_usage {
3526   my $self = shift;
3527   qsearch('cust_pkg_usage', { pkgnum => $self->pkgnum });
3528 }
3529
3530 =item apply_usage OPTIONS
3531
3532 Takes the following options:
3533 - cdr: a call detail record (L<FS::cdr>)
3534 - rate_detail: the rate determined for this call (L<FS::rate_detail>)
3535 - minutes: the maximum number of minutes to be charged
3536
3537 Finds available usage minutes for a call of this class, and subtracts
3538 up to that many minutes from the usage pool.  If the usage pool is empty,
3539 and the C<cdr-minutes_priority> global config option is set, minutes may
3540 be taken from other calls as well.  Either way, an allocation record will
3541 be created (L<FS::cdr_cust_pkg_usage>) and this method will return the
3542 number of minutes of usage applied to the call.
3543
3544 =cut
3545
3546 sub apply_usage {
3547   my ($self, %opt) = @_;
3548   my $cdr = $opt{cdr};
3549   my $rate_detail = $opt{rate_detail};
3550   my $minutes = $opt{minutes};
3551   my $classnum = $rate_detail->classnum;
3552   my $pkgnum = $self->pkgnum;
3553   my $custnum = $self->custnum;
3554
3555   local $SIG{HUP} = 'IGNORE';
3556   local $SIG{INT} = 'IGNORE';
3557   local $SIG{QUIT} = 'IGNORE';
3558   local $SIG{TERM} = 'IGNORE';
3559   local $SIG{TSTP} = 'IGNORE';
3560   local $SIG{PIPE} = 'IGNORE';
3561
3562   my $oldAutoCommit = $FS::UID::AutoCommit;
3563   local $FS::UID::AutoCommit = 0;
3564   my $dbh = dbh;
3565   my $order = FS::Conf->new->config('cdr-minutes_priority');
3566
3567   my $is_classnum;
3568   if ( $classnum ) {
3569     $is_classnum = ' part_pkg_usage_class.classnum = '.$classnum;
3570   } else {
3571     $is_classnum = ' part_pkg_usage_class.classnum IS NULL';
3572   }
3573   my @usage_recs = qsearch({
3574       'table'     => 'cust_pkg_usage',
3575       'addl_from' => ' JOIN part_pkg_usage       USING (pkgusagepart)'.
3576                      ' JOIN cust_pkg             USING (pkgnum)'.
3577                      ' JOIN part_pkg_usage_class USING (pkgusagepart)',
3578       'select'    => 'cust_pkg_usage.*',
3579       'extra_sql' => " WHERE ( cust_pkg.pkgnum = $pkgnum OR ".
3580                      " ( cust_pkg.custnum = $custnum AND ".
3581                      " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3582                      $is_classnum . ' AND '.
3583                      " cust_pkg_usage.minutes > 0",
3584       'order_by'  => " ORDER BY priority ASC",
3585   });
3586
3587   my $orig_minutes = $minutes;
3588   my $error;
3589   while (!$error and $minutes > 0 and @usage_recs) {
3590     my $cust_pkg_usage = shift @usage_recs;
3591     $cust_pkg_usage->select_for_update;
3592     my $cdr_cust_pkg_usage = FS::cdr_cust_pkg_usage->new({
3593         pkgusagenum => $cust_pkg_usage->pkgusagenum,
3594         acctid      => $cdr->acctid,
3595         minutes     => min($cust_pkg_usage->minutes, $minutes),
3596     });
3597     $cust_pkg_usage->set('minutes',
3598       sprintf('%.0f', $cust_pkg_usage->minutes - $cdr_cust_pkg_usage->minutes)
3599     );
3600     $error = $cust_pkg_usage->replace || $cdr_cust_pkg_usage->insert;
3601     $minutes -= $cdr_cust_pkg_usage->minutes;
3602   }
3603   if ( $order and $minutes > 0 and !$error ) {
3604     # then try to steal minutes from another call
3605     my %search = (
3606         'table'     => 'cdr_cust_pkg_usage',
3607         'addl_from' => ' JOIN cust_pkg_usage        USING (pkgusagenum)'.
3608                        ' JOIN part_pkg_usage        USING (pkgusagepart)'.
3609                        ' JOIN cust_pkg              USING (pkgnum)'.
3610                        ' JOIN part_pkg_usage_class  USING (pkgusagepart)'.
3611                        ' JOIN cdr                   USING (acctid)',
3612         'select'    => 'cdr_cust_pkg_usage.*',
3613         'extra_sql' => " WHERE cdr.freesidestatus = 'rated' AND ".
3614                        " ( cust_pkg.pkgnum = $pkgnum OR ".
3615                        " ( cust_pkg.custnum = $custnum AND ".
3616                        " part_pkg_usage.shared IS NOT NULL ) ) AND ".
3617                        " part_pkg_usage_class.classnum = $classnum",
3618         'order_by'  => ' ORDER BY part_pkg_usage.priority ASC',
3619     );
3620     if ( $order eq 'time' ) {
3621       # find CDRs that are using minutes, but have a later startdate
3622       # than this call
3623       my $startdate = $cdr->startdate;
3624       if ($startdate !~ /^\d+$/) {
3625         die "bad cdr startdate '$startdate'";
3626       }
3627       $search{'extra_sql'} .= " AND cdr.startdate > $startdate";
3628       # minimize needless reshuffling
3629       $search{'order_by'} .= ', cdr.startdate DESC';
3630     } else {
3631       # XXX may not work correctly with rate_time schedules.  Could
3632       # fix this by storing ratedetailnum in cdr_cust_pkg_usage, I
3633       # think...
3634       $search{'addl_from'} .=
3635         ' JOIN rate_detail'.
3636         ' ON (cdr.rated_ratedetailnum = rate_detail.ratedetailnum)';
3637       if ( $order eq 'rate_high' ) {
3638         $search{'extra_sql'} .= ' AND rate_detail.min_charge < '.
3639                                 $rate_detail->min_charge;
3640         $search{'order_by'} .= ', rate_detail.min_charge ASC';
3641       } elsif ( $order eq 'rate_low' ) {
3642         $search{'extra_sql'} .= ' AND rate_detail.min_charge > '.
3643                                 $rate_detail->min_charge;
3644         $search{'order_by'} .= ', rate_detail.min_charge DESC';
3645       } else {
3646         #  this should really never happen
3647         die "invalid cdr-minutes_priority value '$order'\n";
3648       }
3649     }
3650     my @cdr_usage_recs = qsearch(\%search);
3651     my %reproc_cdrs;
3652     while (!$error and @cdr_usage_recs and $minutes > 0) {
3653       my $cdr_cust_pkg_usage = shift @cdr_usage_recs;
3654       my $cust_pkg_usage = $cdr_cust_pkg_usage->cust_pkg_usage;
3655       my $old_cdr = $cdr_cust_pkg_usage->cdr;
3656       $reproc_cdrs{$old_cdr->acctid} = $old_cdr;
3657       $cdr_cust_pkg_usage->select_for_update;
3658       $old_cdr->select_for_update;
3659       $cust_pkg_usage->select_for_update;
3660       # in case someone else stole the usage from this CDR
3661       # while waiting for the lock...
3662       next if $old_cdr->acctid != $cdr_cust_pkg_usage->acctid;
3663       # steal the usage allocation and flag the old CDR for reprocessing
3664       $cdr_cust_pkg_usage->set('acctid', $cdr->acctid);
3665       # if the allocation is more minutes than we need, adjust it...
3666       my $delta = $cdr_cust_pkg_usage->minutes - $minutes;
3667       if ( $delta > 0 ) {
3668         $cdr_cust_pkg_usage->set('minutes', $minutes);
3669         $cust_pkg_usage->set('minutes', $cust_pkg_usage->minutes + $delta);
3670         $error = $cust_pkg_usage->replace;
3671       }
3672       #warn 'CDR '.$cdr->acctid . ' stealing allocation '.$cdr_cust_pkg_usage->cdrusagenum.' from CDR '.$old_cdr->acctid."\n";
3673       $error ||= $cdr_cust_pkg_usage->replace;
3674       # deduct the stolen minutes
3675       $minutes -= $cdr_cust_pkg_usage->minutes;
3676     }
3677     # after all minute-stealing is done, reset the affected CDRs
3678     foreach (values %reproc_cdrs) {
3679       $error ||= $_->set_status('');
3680       # XXX or should we just call $cdr->rate right here?
3681       # it's not like we can create a loop this way, since the min_charge
3682       # or call time has to go monotonically in one direction.
3683       # we COULD get some very deep recursions going, though...
3684     }
3685   } # if $order and $minutes
3686   if ( $error ) {
3687     $dbh->rollback;
3688     die "error applying included minutes\npkgnum ".$self->pkgnum.", class $classnum, acctid ".$cdr->acctid."\n$error\n"
3689   } else {
3690     $dbh->commit if $oldAutoCommit;
3691     return $orig_minutes - $minutes;
3692   }
3693 }
3694
3695 =item supplemental_pkgs
3696
3697 Returns a list of all packages supplemental to this one.
3698
3699 =cut
3700
3701 sub supplemental_pkgs {
3702   my $self = shift;
3703   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3704 }
3705
3706 =item main_pkg
3707
3708 Returns the package that this one is supplemental to, if any.
3709
3710 =cut
3711
3712 sub main_pkg {
3713   my $self = shift;
3714   if ( $self->main_pkgnum ) {
3715     return FS::cust_pkg->by_key($self->main_pkgnum);
3716   }
3717   return;
3718 }
3719
3720 =back
3721
3722 =head1 CLASS METHODS
3723
3724 =over 4
3725
3726 =item recurring_sql
3727
3728 Returns an SQL expression identifying recurring packages.
3729
3730 =cut
3731
3732 sub recurring_sql { "
3733   '0' != ( select freq from part_pkg
3734              where cust_pkg.pkgpart = part_pkg.pkgpart )
3735 "; }
3736
3737 =item onetime_sql
3738
3739 Returns an SQL expression identifying one-time packages.
3740
3741 =cut
3742
3743 sub onetime_sql { "
3744   '0' = ( select freq from part_pkg
3745             where cust_pkg.pkgpart = part_pkg.pkgpart )
3746 "; }
3747
3748 =item ordered_sql
3749
3750 Returns an SQL expression identifying ordered packages (recurring packages not
3751 yet billed).
3752
3753 =cut
3754
3755 sub ordered_sql {
3756    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3757 }
3758
3759 =item active_sql
3760
3761 Returns an SQL expression identifying active packages.
3762
3763 =cut
3764
3765 sub active_sql {
3766   $_[0]->recurring_sql. "
3767   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3768   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3769   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3770 "; }
3771
3772 =item not_yet_billed_sql
3773
3774 Returns an SQL expression identifying packages which have not yet been billed.
3775
3776 =cut
3777
3778 sub not_yet_billed_sql { "
3779       ( cust_pkg.setup  IS NULL OR 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 inactive_sql
3785
3786 Returns an SQL expression identifying inactive packages (one-time packages
3787 that are otherwise unsuspended/uncancelled).
3788
3789 =cut
3790
3791 sub inactive_sql { "
3792   ". $_[0]->onetime_sql(). "
3793   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3794   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3795   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3796 "; }
3797
3798 =item susp_sql
3799 =item suspended_sql
3800
3801 Returns an SQL expression identifying suspended packages.
3802
3803 =cut
3804
3805 sub suspended_sql { susp_sql(@_); }
3806 sub susp_sql {
3807   #$_[0]->recurring_sql(). ' AND '.
3808   "
3809         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
3810     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
3811   ";
3812 }
3813
3814 =item cancel_sql
3815 =item cancelled_sql
3816
3817 Returns an SQL exprression identifying cancelled packages.
3818
3819 =cut
3820
3821 sub cancelled_sql { cancel_sql(@_); }
3822 sub cancel_sql {
3823   #$_[0]->recurring_sql(). ' AND '.
3824   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3825 }
3826
3827 =item status_sql
3828
3829 Returns an SQL expression to give the package status as a string.
3830
3831 =cut
3832
3833 sub status_sql {
3834 "CASE
3835   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3836   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3837   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3838   WHEN ".onetime_sql()." THEN 'one-time charge'
3839   ELSE 'active'
3840 END"
3841 }
3842
3843 =item search HASHREF
3844
3845 (Class method)
3846
3847 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3848 Valid parameters are
3849
3850 =over 4
3851
3852 =item agentnum
3853
3854 =item magic
3855
3856 active, inactive, suspended, cancel (or cancelled)
3857
3858 =item status
3859
3860 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3861
3862 =item custom
3863
3864  boolean selects custom packages
3865
3866 =item classnum
3867
3868 =item pkgpart
3869
3870 pkgpart or arrayref or hashref of pkgparts
3871
3872 =item setup
3873
3874 arrayref of beginning and ending epoch date
3875
3876 =item last_bill
3877
3878 arrayref of beginning and ending epoch date
3879
3880 =item bill
3881
3882 arrayref of beginning and ending epoch date
3883
3884 =item adjourn
3885
3886 arrayref of beginning and ending epoch date
3887
3888 =item susp
3889
3890 arrayref of beginning and ending epoch date
3891
3892 =item expire
3893
3894 arrayref of beginning and ending epoch date
3895
3896 =item cancel
3897
3898 arrayref of beginning and ending epoch date
3899
3900 =item query
3901
3902 pkgnum or APKG_pkgnum
3903
3904 =item cust_fields
3905
3906 a value suited to passing to FS::UI::Web::cust_header
3907
3908 =item CurrentUser
3909
3910 specifies the user for agent virtualization
3911
3912 =item fcc_line
3913
3914 boolean; if true, returns only packages with more than 0 FCC phone lines.
3915
3916 =item state, country
3917
3918 Limit to packages with a service location in the specified state and country.
3919 For FCC 477 reporting, mostly.
3920
3921 =back
3922
3923 =cut
3924
3925 sub search {
3926   my ($class, $params) = @_;
3927   my @where = ();
3928
3929   ##
3930   # parse agent
3931   ##
3932
3933   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3934     push @where,
3935       "cust_main.agentnum = $1";
3936   }
3937
3938   ##
3939   # parse custnum
3940   ##
3941
3942   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3943     push @where,
3944       "cust_pkg.custnum = $1";
3945   }
3946
3947   ##
3948   # custbatch
3949   ##
3950
3951   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3952     push @where,
3953       "cust_pkg.pkgbatch = '$1'";
3954   }
3955
3956   ##
3957   # parse status
3958   ##
3959
3960   if (    $params->{'magic'}  eq 'active'
3961        || $params->{'status'} eq 'active' ) {
3962
3963     push @where, FS::cust_pkg->active_sql();
3964
3965   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3966             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3967
3968     push @where, FS::cust_pkg->not_yet_billed_sql();
3969
3970   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3971             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3972
3973     push @where, FS::cust_pkg->inactive_sql();
3974
3975   } elsif (    $params->{'magic'}  eq 'suspended'
3976             || $params->{'status'} eq 'suspended'  ) {
3977
3978     push @where, FS::cust_pkg->suspended_sql();
3979
3980   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3981             || $params->{'status'} =~ /^cancell?ed$/ ) {
3982
3983     push @where, FS::cust_pkg->cancelled_sql();
3984
3985   }
3986
3987   ###
3988   # parse package class
3989   ###
3990
3991   if ( exists($params->{'classnum'}) ) {
3992
3993     my @classnum = ();
3994     if ( ref($params->{'classnum'}) ) {
3995
3996       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3997         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3998       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3999         @classnum = @{ $params->{'classnum'} };
4000       } else {
4001         die 'unhandled classnum ref '. $params->{'classnum'};
4002       }
4003
4004
4005     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
4006       @classnum = ( $1 );
4007     }
4008
4009     if ( @classnum ) {
4010
4011       my @c_where = ();
4012       my @nums = grep $_, @classnum;
4013       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
4014       my $null = scalar( grep { $_ eq '' } @classnum );
4015       push @c_where, 'part_pkg.classnum IS NULL' if $null;
4016
4017       if ( scalar(@c_where) == 1 ) {
4018         push @where, @c_where;
4019       } elsif ( @c_where ) {
4020         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
4021       }
4022
4023     }
4024
4025
4026   }
4027
4028   ###
4029   # parse package report options
4030   ###
4031
4032   my @report_option = ();
4033   if ( exists($params->{'report_option'}) ) {
4034     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
4035       @report_option = @{ $params->{'report_option'} };
4036     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
4037       @report_option = split(',', $1);
4038     }
4039
4040   }
4041
4042   if (@report_option) {
4043     # this will result in the empty set for the dangling comma case as it should
4044     push @where,
4045       map{ "0 < ( SELECT count(*) FROM part_pkg_option
4046                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4047                     AND optionname = 'report_option_$_'
4048                     AND optionvalue = '1' )"
4049          } @report_option;
4050   }
4051
4052   foreach my $any ( grep /^report_option_any/, keys %$params ) {
4053
4054     my @report_option_any = ();
4055     if ( ref($params->{$any}) eq 'ARRAY' ) {
4056       @report_option_any = @{ $params->{$any} };
4057     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
4058       @report_option_any = split(',', $1);
4059     }
4060
4061     if (@report_option_any) {
4062       # this will result in the empty set for the dangling comma case as it should
4063       push @where, ' ( '. join(' OR ',
4064         map{ "0 < ( SELECT count(*) FROM part_pkg_option
4065                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
4066                       AND optionname = 'report_option_$_'
4067                       AND optionvalue = '1' )"
4068            } @report_option_any
4069       ). ' ) ';
4070     }
4071
4072   }
4073
4074   ###
4075   # parse custom
4076   ###
4077
4078   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
4079
4080   ###
4081   # parse fcc_line
4082   ###
4083
4084   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
4085                                                         if $params->{fcc_line};
4086
4087   ###
4088   # parse censustract
4089   ###
4090
4091   if ( exists($params->{'censustract'}) ) {
4092     $params->{'censustract'} =~ /^([.\d]*)$/;
4093     my $censustract = "cust_location.censustract = '$1'";
4094     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
4095     push @where,  "( $censustract )";
4096   }
4097
4098   ###
4099   # parse censustract2
4100   ###
4101   if ( exists($params->{'censustract2'})
4102        && $params->{'censustract2'} =~ /^(\d*)$/
4103      )
4104   {
4105     if ($1) {
4106       push @where, "cust_location.censustract LIKE '$1%'";
4107     } else {
4108       push @where,
4109         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
4110     }
4111   }
4112
4113   ###
4114   # parse country/state
4115   ###
4116   for (qw(state country)) { # parsing rules are the same for these
4117   if ( exists($params->{$_})
4118     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
4119     {
4120       # XXX post-2.3 only--before that, state/country may be in cust_main
4121       push @where, "cust_location.$_ = '$1'";
4122     }
4123   }
4124
4125   ###
4126   # parse part_pkg
4127   ###
4128
4129   if ( ref($params->{'pkgpart'}) ) {
4130
4131     my @pkgpart = ();
4132     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
4133       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
4134     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
4135       @pkgpart = @{ $params->{'pkgpart'} };
4136     } else {
4137       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
4138     }
4139
4140     @pkgpart = grep /^(\d+)$/, @pkgpart;
4141
4142     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
4143
4144   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4145     push @where, "pkgpart = $1";
4146   }
4147
4148   ###
4149   # parse dates
4150   ###
4151
4152   my $orderby = '';
4153
4154   #false laziness w/report_cust_pkg.html
4155   my %disable = (
4156     'all'             => {},
4157     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
4158     'active'          => { 'susp'=>1, 'cancel'=>1 },
4159     'suspended'       => { 'cancel' => 1 },
4160     'cancelled'       => {},
4161     ''                => {},
4162   );
4163
4164   if( exists($params->{'active'} ) ) {
4165     # This overrides all the other date-related fields
4166     my($beginning, $ending) = @{$params->{'active'}};
4167     push @where,
4168       "cust_pkg.setup IS NOT NULL",
4169       "cust_pkg.setup <= $ending",
4170       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
4171       "NOT (".FS::cust_pkg->onetime_sql . ")";
4172   }
4173   else {
4174     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
4175
4176       next unless exists($params->{$field});
4177
4178       my($beginning, $ending) = @{$params->{$field}};
4179
4180       next if $beginning == 0 && $ending == 4294967295;
4181
4182       push @where,
4183         "cust_pkg.$field IS NOT NULL",
4184         "cust_pkg.$field >= $beginning",
4185         "cust_pkg.$field <= $ending";
4186
4187       $orderby ||= "ORDER BY cust_pkg.$field";
4188
4189     }
4190   }
4191
4192   $orderby ||= 'ORDER BY bill';
4193
4194   ###
4195   # parse magic, legacy, etc.
4196   ###
4197
4198   if ( $params->{'magic'} &&
4199        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
4200   ) {
4201
4202     $orderby = 'ORDER BY pkgnum';
4203
4204     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
4205       push @where, "pkgpart = $1";
4206     }
4207
4208   } elsif ( $params->{'query'} eq 'pkgnum' ) {
4209
4210     $orderby = 'ORDER BY pkgnum';
4211
4212   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
4213
4214     $orderby = 'ORDER BY pkgnum';
4215
4216     push @where, '0 < (
4217       SELECT count(*) FROM pkg_svc
4218        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
4219          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
4220                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
4221                                      AND cust_svc.svcpart = pkg_svc.svcpart
4222                                 )
4223     )';
4224
4225   }
4226
4227   ##
4228   # setup queries, links, subs, etc. for the search
4229   ##
4230
4231   # here is the agent virtualization
4232   if ($params->{CurrentUser}) {
4233     my $access_user =
4234       qsearchs('access_user', { username => $params->{CurrentUser} });
4235
4236     if ($access_user) {
4237       push @where, $access_user->agentnums_sql('table'=>'cust_main');
4238     } else {
4239       push @where, "1=0";
4240     }
4241   } else {
4242     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
4243   }
4244
4245   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
4246
4247   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
4248                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
4249                   'LEFT JOIN cust_location USING ( locationnum ) '.
4250                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
4251
4252   my $select;
4253   my $count_query;
4254   if ( $params->{'select_zip5'} ) {
4255     my $zip = 'cust_location.zip';
4256
4257     $select = "DISTINCT substr($zip,1,5) as zip";
4258     $orderby = "ORDER BY substr($zip,1,5)";
4259     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
4260   } else {
4261     $select = join(', ',
4262                          'cust_pkg.*',
4263                          ( map "part_pkg.$_", qw( pkg freq ) ),
4264                          'pkg_class.classname',
4265                          'cust_main.custnum AS cust_main_custnum',
4266                          FS::UI::Web::cust_sql_fields(
4267                            $params->{'cust_fields'}
4268                          ),
4269                   );
4270     $count_query = 'SELECT COUNT(*)';
4271   }
4272
4273   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
4274
4275   my $sql_query = {
4276     'table'       => 'cust_pkg',
4277     'hashref'     => {},
4278     'select'      => $select,
4279     'extra_sql'   => $extra_sql,
4280     'order_by'    => $orderby,
4281     'addl_from'   => $addl_from,
4282     'count_query' => $count_query,
4283   };
4284
4285 }
4286
4287 =item fcc_477_count
4288
4289 Returns a list of two package counts.  The first is a count of packages
4290 based on the supplied criteria and the second is the count of residential
4291 packages with those same criteria.  Criteria are specified as in the search
4292 method.
4293
4294 =cut
4295
4296 sub fcc_477_count {
4297   my ($class, $params) = @_;
4298
4299   my $sql_query = $class->search( $params );
4300
4301   my $count_sql = delete($sql_query->{'count_query'});
4302   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
4303     or die "couldn't parse count_sql";
4304
4305   my $count_sth = dbh->prepare($count_sql)
4306     or die "Error preparing $count_sql: ". dbh->errstr;
4307   $count_sth->execute
4308     or die "Error executing $count_sql: ". $count_sth->errstr;
4309   my $count_arrayref = $count_sth->fetchrow_arrayref;
4310
4311   return ( @$count_arrayref );
4312
4313 }
4314
4315 =item tax_locationnum_sql
4316
4317 Returns an SQL expression for the tax location for a package, based
4318 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
4319
4320 =cut
4321
4322 sub tax_locationnum_sql {
4323   my $conf = FS::Conf->new;
4324   if ( $conf->exists('tax-pkg_address') ) {
4325     'cust_pkg.locationnum';
4326   }
4327   elsif ( $conf->exists('tax-ship_address') ) {
4328     'cust_main.ship_locationnum';
4329   }
4330   else {
4331     'cust_main.bill_locationnum';
4332   }
4333 }
4334
4335 =item location_sql
4336
4337 Returns a list: the first item is an SQL fragment identifying matching
4338 packages/customers via location (taking into account shipping and package
4339 address taxation, if enabled), and subsequent items are the parameters to
4340 substitute for the placeholders in that fragment.
4341
4342 =cut
4343
4344 sub location_sql {
4345   my($class, %opt) = @_;
4346   my $ornull = $opt{'ornull'};
4347
4348   my $conf = new FS::Conf;
4349
4350   # '?' placeholders in _location_sql_where
4351   my $x = $ornull ? 3 : 2;
4352   my @bill_param = (
4353     ('district')x3,
4354     ('city')x3,
4355     ('county')x$x,
4356     ('state')x$x,
4357     'country'
4358   );
4359
4360   my $main_where;
4361   my @main_param;
4362   if ( $conf->exists('tax-ship_address') ) {
4363
4364     $main_where = "(
4365          (     ( ship_last IS NULL     OR  ship_last  = '' )
4366            AND ". _location_sql_where('cust_main', '', $ornull ). "
4367          )
4368       OR (       ship_last IS NOT NULL AND ship_last != ''
4369            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
4370          )
4371     )";
4372     #    AND payby != 'COMP'
4373
4374     @main_param = ( @bill_param, @bill_param );
4375
4376   } else {
4377
4378     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
4379     @main_param = @bill_param;
4380
4381   }
4382
4383   my $where;
4384   my @param;
4385   if ( $conf->exists('tax-pkg_address') ) {
4386
4387     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
4388
4389     $where = " (
4390                     ( cust_pkg.locationnum IS     NULL AND $main_where )
4391                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
4392                )
4393              ";
4394     @param = ( @main_param, @bill_param );
4395
4396   } else {
4397
4398     $where = $main_where;
4399     @param = @main_param;
4400
4401   }
4402
4403   ( $where, @param );
4404
4405 }
4406
4407 #subroutine, helper for location_sql
4408 sub _location_sql_where {
4409   my $table  = shift;
4410   my $prefix = @_ ? shift : '';
4411   my $ornull = @_ ? shift : '';
4412
4413 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
4414
4415   $ornull = $ornull ? ' OR ? IS NULL ' : '';
4416
4417   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
4418   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
4419   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
4420
4421   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
4422
4423 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4424   "
4425         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4426     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4427     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4428     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4429     AND   $table.${prefix}country  = ?
4430   ";
4431 }
4432
4433 sub _X_show_zero {
4434   my( $self, $what ) = @_;
4435
4436   my $what_show_zero = $what. '_show_zero';
4437   length($self->$what_show_zero())
4438     ? ($self->$what_show_zero() eq 'Y')
4439     : $self->part_pkg->$what_show_zero();
4440 }
4441
4442 =head1 SUBROUTINES
4443
4444 =over 4
4445
4446 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4447
4448 CUSTNUM is a customer (see L<FS::cust_main>)
4449
4450 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4451 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4452 permitted.
4453
4454 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4455 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4456 new billing items.  An error is returned if this is not possible (see
4457 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4458 parameter.
4459
4460 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4461 newly-created cust_pkg objects.
4462
4463 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4464 and inserted.  Multiple FS::pkg_referral records can be created by
4465 setting I<refnum> to an array reference of refnums or a hash reference with
4466 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4467 record will be created corresponding to cust_main.refnum.
4468
4469 =cut
4470
4471 sub order {
4472   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4473
4474   my $conf = new FS::Conf;
4475
4476   # Transactionize this whole mess
4477   local $SIG{HUP} = 'IGNORE';
4478   local $SIG{INT} = 'IGNORE';
4479   local $SIG{QUIT} = 'IGNORE';
4480   local $SIG{TERM} = 'IGNORE';
4481   local $SIG{TSTP} = 'IGNORE';
4482   local $SIG{PIPE} = 'IGNORE';
4483
4484   my $oldAutoCommit = $FS::UID::AutoCommit;
4485   local $FS::UID::AutoCommit = 0;
4486   my $dbh = dbh;
4487
4488   my $error;
4489 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4490 #  return "Customer not found: $custnum" unless $cust_main;
4491
4492   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4493     if $DEBUG;
4494
4495   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4496                          @$remove_pkgnum;
4497
4498   my $change = scalar(@old_cust_pkg) != 0;
4499
4500   my %hash = ();
4501   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4502
4503     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4504          " to pkgpart ". $pkgparts->[0]. "\n"
4505       if $DEBUG;
4506
4507     my $err_or_cust_pkg =
4508       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4509                                 'refnum'  => $refnum,
4510                               );
4511
4512     unless (ref($err_or_cust_pkg)) {
4513       $dbh->rollback if $oldAutoCommit;
4514       return $err_or_cust_pkg;
4515     }
4516
4517     push @$return_cust_pkg, $err_or_cust_pkg;
4518     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4519     return '';
4520
4521   }
4522
4523   # Create the new packages.
4524   foreach my $pkgpart (@$pkgparts) {
4525
4526     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4527
4528     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4529                                       pkgpart => $pkgpart,
4530                                       refnum  => $refnum,
4531                                       %hash,
4532                                     };
4533     $error = $cust_pkg->insert( 'change' => $change );
4534     push @$return_cust_pkg, $cust_pkg;
4535
4536     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4537       my $supp_pkg = FS::cust_pkg->new({
4538           custnum => $custnum,
4539           pkgpart => $link->dst_pkgpart,
4540           refnum  => $refnum,
4541           main_pkgnum => $cust_pkg->pkgnum,
4542           %hash,
4543       });
4544       $error ||= $supp_pkg->insert( 'change' => $change );
4545       push @$return_cust_pkg, $supp_pkg;
4546     }
4547
4548     if ($error) {
4549       $dbh->rollback if $oldAutoCommit;
4550       return $error;
4551     }
4552
4553   }
4554   # $return_cust_pkg now contains refs to all of the newly
4555   # created packages.
4556
4557   # Transfer services and cancel old packages.
4558   foreach my $old_pkg (@old_cust_pkg) {
4559
4560     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4561       if $DEBUG;
4562
4563     foreach my $new_pkg (@$return_cust_pkg) {
4564       $error = $old_pkg->transfer($new_pkg);
4565       if ($error and $error == 0) {
4566         # $old_pkg->transfer failed.
4567         $dbh->rollback if $oldAutoCommit;
4568         return $error;
4569       }
4570     }
4571
4572     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4573       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4574       foreach my $new_pkg (@$return_cust_pkg) {
4575         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4576         if ($error and $error == 0) {
4577           # $old_pkg->transfer failed.
4578         $dbh->rollback if $oldAutoCommit;
4579         return $error;
4580         }
4581       }
4582     }
4583
4584     if ($error > 0) {
4585       # Transfers were successful, but we went through all of the
4586       # new packages and still had services left on the old package.
4587       # We can't cancel the package under the circumstances, so abort.
4588       $dbh->rollback if $oldAutoCommit;
4589       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4590     }
4591     $error = $old_pkg->cancel( quiet=>1 );
4592     if ($error) {
4593       $dbh->rollback;
4594       return $error;
4595     }
4596   }
4597   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4598   '';
4599 }
4600
4601 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4602
4603 A bulk change method to change packages for multiple customers.
4604
4605 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4606 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4607 permitted.
4608
4609 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4610 replace.  The services (see L<FS::cust_svc>) are moved to the
4611 new billing items.  An error is returned if this is not possible (see
4612 L<FS::pkg_svc>).
4613
4614 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4615 newly-created cust_pkg objects.
4616
4617 =cut
4618
4619 sub bulk_change {
4620   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4621
4622   # Transactionize this whole mess
4623   local $SIG{HUP} = 'IGNORE';
4624   local $SIG{INT} = 'IGNORE';
4625   local $SIG{QUIT} = 'IGNORE';
4626   local $SIG{TERM} = 'IGNORE';
4627   local $SIG{TSTP} = 'IGNORE';
4628   local $SIG{PIPE} = 'IGNORE';
4629
4630   my $oldAutoCommit = $FS::UID::AutoCommit;
4631   local $FS::UID::AutoCommit = 0;
4632   my $dbh = dbh;
4633
4634   my @errors;
4635   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4636                          @$remove_pkgnum;
4637
4638   while(scalar(@old_cust_pkg)) {
4639     my @return = ();
4640     my $custnum = $old_cust_pkg[0]->custnum;
4641     my (@remove) = map { $_->pkgnum }
4642                    grep { $_->custnum == $custnum } @old_cust_pkg;
4643     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4644
4645     my $error = order $custnum, $pkgparts, \@remove, \@return;
4646
4647     push @errors, $error
4648       if $error;
4649     push @$return_cust_pkg, @return;
4650   }
4651
4652   if (scalar(@errors)) {
4653     $dbh->rollback if $oldAutoCommit;
4654     return join(' / ', @errors);
4655   }
4656
4657   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4658   '';
4659 }
4660
4661 # Used by FS::Upgrade to migrate to a new database.
4662 sub _upgrade_data {  # class method
4663   my ($class, %opts) = @_;
4664   $class->_upgrade_otaker(%opts);
4665   my @statements = (
4666     # RT#10139, bug resulting in contract_end being set when it shouldn't
4667   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4668     # RT#10830, bad calculation of prorate date near end of year
4669     # the date range for bill is December 2009, and we move it forward
4670     # one year if it's before the previous bill date (which it should
4671     # never be)
4672   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4673   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4674   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4675     # RT6628, add order_date to cust_pkg
4676     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4677         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4678         history_action = \'insert\') where order_date is null',
4679   );
4680   foreach my $sql (@statements) {
4681     my $sth = dbh->prepare($sql);
4682     $sth->execute or die $sth->errstr;
4683   }
4684 }
4685
4686 =back
4687
4688 =head1 BUGS
4689
4690 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4691
4692 In sub order, the @pkgparts array (passed by reference) is clobbered.
4693
4694 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4695 method to pass dates to the recur_prog expression, it should do so.
4696
4697 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4698 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4699 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4700 configuration values.  Probably need a subroutine which decides what to do
4701 based on whether or not we've fetched the user yet, rather than a hash.  See
4702 FS::UID and the TODO.
4703
4704 Now that things are transactional should the check in the insert method be
4705 moved to check ?
4706
4707 =head1 SEE ALSO
4708
4709 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4710 L<FS::pkg_svc>, schema.html from the base documentation
4711
4712 =cut
4713
4714 1;
4715