FS/FS/cust_pkg.pm

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