FS/FS/cust_pkg.pm

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