FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common );
   6 use vars qw($disable_agentcheck $DEBUG $me);
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( getotaker dbh );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs );
  16 use FS::CurrentUser;
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::cust_location;
  21 use FS::pkg_svc;
  22 use FS::cust_bill_pkg;
  23 use FS::cust_pkg_detail;
  24 use FS::cust_event;
  25 use FS::h_cust_svc;
  26 use FS::reg_code;
  27 use FS::part_svc;
  28 use FS::cust_pkg_reason;
  29 use FS::reason;
  30 use FS::cust_pkg_discount;
  31 use FS::discount;
  32 use FS::UI::Web;
  33
  34 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  35 # setup }
  36 # because they load configuration by setting FS::UID::callback (see TODO)
  37 use FS::svc_acct;
  38 use FS::svc_domain;
  39 use FS::svc_www;
  40 use FS::svc_forward;
  41
  42 # for sending cancel emails in sub cancel
  43 use FS::Conf;
  44
  45 $DEBUG = 0;
  46 $me = '[FS::cust_pkg]';
  47
  48 $disable_agentcheck = 0;
  49
  50 sub _cache {
  51   my $self = shift;
  52   my ( $hashref, $cache ) = @_;
  53   #if ( $hashref->{'pkgpart'} ) {
  54   if ( $hashref->{'pkg'} ) {
  55     # #@{ $self->{'_pkgnum'} } = ();
  56     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  57     # $self->{'_pkgpart'} = $subcache;
  58     # #push @{ $self->{'_pkgnum'} },
  59     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  60     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  61   }
  62   if ( exists $hashref->{'svcnum'} ) {
  63     #@{ $self->{'_pkgnum'} } = ();
  64     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  65     $self->{'_svcnum'} = $subcache;
  66     #push @{ $self->{'_pkgnum'} },
  67     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  68   }
  69 }
  70
  71 =head1 NAME
  72
  73 FS::cust_pkg - Object methods for cust_pkg objects
  74
  75 =head1 SYNOPSIS
  76
  77   use FS::cust_pkg;
  78
  79   $record = new FS::cust_pkg \%hash;
  80   $record = new FS::cust_pkg { 'column' => 'value' };
  81
  82   $error = $record->insert;
  83
  84   $error = $new_record->replace($old_record);
  85
  86   $error = $record->delete;
  87
  88   $error = $record->check;
  89
  90   $error = $record->cancel;
  91
  92   $error = $record->suspend;
  93
  94   $error = $record->unsuspend;
  95
  96   $part_pkg = $record->part_pkg;
  97
  98   @labels = $record->labels;
  99
 100   $seconds = $record->seconds_since($timestamp);
 101
 102   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 103   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 104
 105 =head1 DESCRIPTION
 106
 107 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 108 inherits from FS::Record.  The following fields are currently supported:
 109
 110 =over 4
 111
 112 =item pkgnum
 113
 114 Primary key (assigned automatically for new billing items)
 115
 116 =item custnum
 117
 118 Customer (see L<FS::cust_main>)
 119
 120 =item pkgpart
 121
 122 Billing item definition (see L<FS::part_pkg>)
 123
 124 =item locationnum
 125
 126 Optional link to package location (see L<FS::location>)
 127
 128 =item order_date
 129
 130 date package was ordered (also remains same on changes)
 131
 132 =item start_date
 133
 134 date
 135
 136 =item setup
 137
 138 date
 139
 140 =item bill
 141
 142 date (next bill date)
 143
 144 =item last_bill
 145
 146 last bill date
 147
 148 =item adjourn
 149
 150 date
 151
 152 =item susp
 153
 154 date
 155
 156 =item expire
 157
 158 date
 159
 160 =item contract_end
 161
 162 date
 163
 164 =item cancel
 165
 166 date
 167
 168 =item usernum
 169
 170 order taker (see L<FS::access_user>)
 171
 172 =item manual_flag
 173
 174 If this field is set to 1, disables the automatic
 175 unsuspension of this package when using the B<unsuspendauto> config option.
 176
 177 =item quantity
 178
 179 If not set, defaults to 1
 180
 181 =item change_date
 182
 183 Date of change from previous package
 184
 185 =item change_pkgnum
 186
 187 Previous pkgnum
 188
 189 =item change_pkgpart
 190
 191 Previous pkgpart
 192
 193 =item change_locationnum
 194
 195 Previous locationnum
 196
 197 =back
 198
 199 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 200 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 201 L<Time::Local> and L<Date::Parse> for conversion functions.
 202
 203 =head1 METHODS
 204
 205 =over 4
 206
 207 =item new HASHREF
 208
 209 Create a new billing item.  To add the item to the database, see L<"insert">.
 210
 211 =cut
 212
 213 sub table { 'cust_pkg'; }
 214 sub cust_linked { $_[0]->cust_main_custnum; }
 215 sub cust_unlinked_msg {
 216   my $self = shift;
 217   "WARNING: can't find cust_main.custnum ". $self->custnum.
 218   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 219 }
 220
 221 =item insert [ OPTION => VALUE ... ]
 222
 223 Adds this billing item to the database ("Orders" the item).  If there is an
 224 error, returns the error, otherwise returns false.
 225
 226 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 227 will be used to look up the package definition and agent restrictions will be
 228 ignored.
 229
 230 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 231 be created and inserted.  Multiple FS::pkg_referral records can be created by
 232 setting I<refnum> to an array reference of refnums or a hash reference with
 233 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 234 record will be created corresponding to cust_main.refnum.
 235
 236 The following options are available:
 237
 238 =over 4
 239
 240 =item change
 241
 242 If set true, supresses any referral credit to a referring customer.
 243
 244 =item options
 245
 246 cust_pkg_option records will be created
 247
 248 =item ticket_subject
 249
 250 a ticket will be added to this customer with this subject
 251
 252 =item ticket_queue
 253
 254 an optional queue name for ticket additions
 255
 256 =back
 257
 258 =cut
 259
 260 sub insert {
 261   my( $self, %options ) = @_;
 262
 263   if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
 264     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 265     $mon += 1 unless $mday == 1;
 266     until ( $mon < 12 ) { $mon -= 12; $year++; }
 267     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 268   }
 269
 270   foreach my $action ( qw(expire adjourn contract_end) ) {
 271     my $months = $self->part_pkg->option("${action}_months",1);
 272     if($months and !$self->$action) {
 273       my $start = $self->start_date || $self->setup || time;
 274       $self->$action( $self->part_pkg->add_freq($start, $months) );
 275     }
 276   }
 277
 278   $self->order_date(time);
 279
 280   local $SIG{HUP} = 'IGNORE';
 281   local $SIG{INT} = 'IGNORE';
 282   local $SIG{QUIT} = 'IGNORE';
 283   local $SIG{TERM} = 'IGNORE';
 284   local $SIG{TSTP} = 'IGNORE';
 285   local $SIG{PIPE} = 'IGNORE';
 286
 287   my $oldAutoCommit = $FS::UID::AutoCommit;
 288   local $FS::UID::AutoCommit = 0;
 289   my $dbh = dbh;
 290
 291   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 292   if ( $error ) {
 293     $dbh->rollback if $oldAutoCommit;
 294     return $error;
 295   }
 296
 297   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 298   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 299   $self->process_m2m( 'link_table'   => 'pkg_referral',
 300                       'target_table' => 'part_referral',
 301                       'params'       => $self->refnum,
 302                     );
 303
 304   if ( $self->discountnum ) {
 305     my $error = $self->insert_discount();
 306     if ( $error ) {
 307       $dbh->rollback if $oldAutoCommit;
 308       return $error;
 309     }
 310   }
 311
 312   #if ( $self->reg_code ) {
 313   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 314   #  $error = $reg_code->delete;
 315   #  if ( $error ) {
 316   #    $dbh->rollback if $oldAutoCommit;
 317   #    return $error;
 318   #  }
 319   #}
 320
 321   my $conf = new FS::Conf;
 322
 323   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 324
 325     #eval '
 326     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 327     #  use RT;
 328     #';
 329     #die $@ if $@;
 330     #
 331     #RT::LoadConfig();
 332     #RT::Init();
 333     use FS::TicketSystem;
 334     FS::TicketSystem->init();
 335
 336     my $q = new RT::Queue($RT::SystemUser);
 337     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 338     my $t = new RT::Ticket($RT::SystemUser);
 339     my $mime = new MIME::Entity;
 340     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 341     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 342                 Subject => $options{ticket_subject},
 343                 MIMEObj => $mime,
 344               );
 345     $t->AddLink( Type   => 'MemberOf',
 346                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 347                );
 348   }
 349
 350   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 351     my $queue = new FS::queue {
 352       'job'     => 'FS::cust_main::queueable_print',
 353     };
 354     $error = $queue->insert(
 355       'custnum'  => $self->custnum,
 356       'template' => 'welcome_letter',
 357     );
 358
 359     if ($error) {
 360       warn "can't send welcome letter: $error";
 361     }
 362
 363   }
 364
 365   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 366   '';
 367
 368 }
 369
 370 =item delete
 371
 372 This method now works but you probably shouldn't use it.
 373
 374 You don't want to delete billing items, because there would then be no record
 375 the customer ever purchased the item.  Instead, see the cancel method.
 376
 377 =cut
 378
 379 #sub delete {
 380 #  return "Can't delete cust_pkg records!";
 381 #}
 382
 383 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 384
 385 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 386 returns the error, otherwise returns false.
 387
 388 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 389
 390 Changing pkgpart may have disasterous effects.  See the order subroutine.
 391
 392 setup and bill are normally updated by calling the bill method of a customer
 393 object (see L<FS::cust_main>).
 394
 395 suspend is normally updated by the suspend and unsuspend methods.
 396
 397 cancel is normally updated by the cancel method (and also the order subroutine
 398 in some cases).
 399
 400 Available options are:
 401
 402 =over 4
 403
 404 =item reason
 405
 406 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.
 407
 408 =item reason_otaker
 409
 410 the access_user (see L<FS::access_user>) providing the reason
 411
 412 =item options
 413
 414 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 415
 416 =back
 417
 418 =cut
 419
 420 sub replace {
 421   my $new = shift;
 422
 423   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 424               ? shift
 425               : $new->replace_old;
 426
 427   my $options =
 428     ( ref($_[0]) eq 'HASH' )
 429       ? shift
 430       : { @_ };
 431
 432   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 433   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 434
 435   #allow this *sigh*
 436   #return "Can't change setup once it exists!"
 437   #  if $old->getfield('setup') &&
 438   #     $old->getfield('setup') != $new->getfield('setup');
 439
 440   #some logic for bill, susp, cancel?
 441
 442   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 443
 444   local $SIG{HUP} = 'IGNORE';
 445   local $SIG{INT} = 'IGNORE';
 446   local $SIG{QUIT} = 'IGNORE';
 447   local $SIG{TERM} = 'IGNORE';
 448   local $SIG{TSTP} = 'IGNORE';
 449   local $SIG{PIPE} = 'IGNORE';
 450
 451   my $oldAutoCommit = $FS::UID::AutoCommit;
 452   local $FS::UID::AutoCommit = 0;
 453   my $dbh = dbh;
 454
 455   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 456     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 457       my $error = $new->insert_reason(
 458         'reason'        => $options->{'reason'},
 459         'date'          => $new->$method,
 460         'action'        => $method,
 461         'reason_otaker' => $options->{'reason_otaker'},
 462       );
 463       if ( $error ) {
 464         dbh->rollback if $oldAutoCommit;
 465         return "Error inserting cust_pkg_reason: $error";
 466       }
 467     }
 468   }
 469
 470   #save off and freeze RADIUS attributes for any associated svc_acct records
 471   my @svc_acct = ();
 472   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 473
 474                 #also check for specific exports?
 475                 # to avoid spurious modify export events
 476     @svc_acct = map  { $_->svc_x }
 477                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 478                      $old->cust_svc;
 479
 480     $_->snapshot foreach @svc_acct;
 481
 482   }
 483
 484   my $error = $new->SUPER::replace($old,
 485                                    $options->{options} ? $options->{options} : ()
 486                                   );
 487   if ( $error ) {
 488     $dbh->rollback if $oldAutoCommit;
 489     return $error;
 490   }
 491
 492   #for prepaid packages,
 493   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 494   foreach my $old_svc_acct ( @svc_acct ) {
 495     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 496     my $s_error = $new_svc_acct->replace($old_svc_acct);
 497     if ( $s_error ) {
 498       $dbh->rollback if $oldAutoCommit;
 499       return $s_error;
 500     }
 501   }
 502
 503   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 504   '';
 505
 506 }
 507
 508 =item check
 509
 510 Checks all fields to make sure this is a valid billing item.  If there is an
 511 error, returns the error, otherwise returns false.  Called by the insert and
 512 replace methods.
 513
 514 =cut
 515
 516 sub check {
 517   my $self = shift;
 518
 519   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 520
 521   my $error =
 522     $self->ut_numbern('pkgnum')
 523     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 524     || $self->ut_numbern('pkgpart')
 525     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 526     || $self->ut_numbern('start_date')
 527     || $self->ut_numbern('setup')
 528     || $self->ut_numbern('bill')
 529     || $self->ut_numbern('susp')
 530     || $self->ut_numbern('cancel')
 531     || $self->ut_numbern('adjourn')
 532     || $self->ut_numbern('expire')
 533     || $self->ut_enum('no_auto', [ '', 'Y' ])
 534   ;
 535   return $error if $error;
 536
 537   if ( $self->reg_code ) {
 538
 539     unless ( grep { $self->pkgpart == $_->pkgpart }
 540              map  { $_->reg_code_pkg }
 541              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 542                                      'agentnum' => $self->cust_main->agentnum })
 543            ) {
 544       return "Unknown registration code";
 545     }
 546
 547   } elsif ( $self->promo_code ) {
 548
 549     my $promo_part_pkg =
 550       qsearchs('part_pkg', {
 551         'pkgpart'    => $self->pkgpart,
 552         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 553       } );
 554     return 'Unknown promotional code' unless $promo_part_pkg;
 555
 556   } else {
 557
 558     unless ( $disable_agentcheck ) {
 559       my $agent =
 560         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 561       return "agent ". $agent->agentnum. ':'. $agent->agent.
 562              " can't purchase pkgpart ". $self->pkgpart
 563         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 564             || $agent->agentnum == $self->part_pkg->agentnum;
 565     }
 566
 567     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 568     return $error if $error;
 569
 570   }
 571
 572   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 573
 574   if ( $self->dbdef_table->column('manual_flag') ) {
 575     $self->manual_flag('') if $self->manual_flag eq ' ';
 576     $self->manual_flag =~ /^([01]?)$/
 577       or return "Illegal manual_flag ". $self->manual_flag;
 578     $self->manual_flag($1);
 579   }
 580
 581   $self->SUPER::check;
 582 }
 583
 584 =item cancel [ OPTION => VALUE ... ]
 585
 586 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 587 in this package, then cancels the package itself (sets the cancel field to
 588 now).
 589
 590 Available options are:
 591
 592 =over 4
 593
 594 =item quiet - can be set true to supress email cancellation notices.
 595
 596 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 597
 598 =item reason - 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.
 599
 600 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 601
 602 =item nobill - can be set true to skip billing if it might otherwise be done.
 603
 604 =item unused_credit - can be set to 1 to credit the remaining time, or 0 to
 605 not credit it.  This must be set (by change()) when changing the package
 606 to a different pkgpart or location, and probably shouldn't be in any other
 607 case.  If it's not set, the 'unused_credit_cancel' part_pkg option will
 608 be used.
 609
 610 =back
 611
 612 If there is an error, returns the error, otherwise returns false.
 613
 614 =cut
 615
 616 sub cancel {
 617   my( $self, %options ) = @_;
 618   my $error;
 619
 620   my $conf = new FS::Conf;
 621
 622   warn "cust_pkg::cancel called with options".
 623        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 624     if $DEBUG;
 625
 626   local $SIG{HUP} = 'IGNORE';
 627   local $SIG{INT} = 'IGNORE';
 628   local $SIG{QUIT} = 'IGNORE';
 629   local $SIG{TERM} = 'IGNORE';
 630   local $SIG{TSTP} = 'IGNORE';
 631   local $SIG{PIPE} = 'IGNORE';
 632
 633   my $oldAutoCommit = $FS::UID::AutoCommit;
 634   local $FS::UID::AutoCommit = 0;
 635   my $dbh = dbh;
 636
 637   my $old = $self->select_for_update;
 638
 639   if ( $old->get('cancel') || $self->get('cancel') ) {
 640     dbh->rollback if $oldAutoCommit;
 641     return "";  # no error
 642   }
 643
 644   my $date = $options{date} if $options{date}; # expire/cancel later
 645   $date = '' if ($date && $date <= time);      # complain instead?
 646
 647   #race condition: usage could be ongoing until unprovisioned
 648   #resolved by performing a change package instead (which unprovisions) and
 649   #later cancelling
 650   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 651       my $copy = $self->new({$self->hash});
 652       my $error =
 653         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 654       warn "Error billing during cancel, custnum ".
 655         #$self->cust_main->custnum. ": $error"
 656         ": $error"
 657         if $error;
 658   }
 659
 660   my $cancel_time = $options{'time'} || time;
 661
 662   if ( $options{'reason'} ) {
 663     $error = $self->insert_reason( 'reason' => $options{'reason'},
 664                                    'action' => $date ? 'expire' : 'cancel',
 665                                    'date'   => $date ? $date : $cancel_time,
 666                                    'reason_otaker' => $options{'reason_otaker'},
 667                                  );
 668     if ( $error ) {
 669       dbh->rollback if $oldAutoCommit;
 670       return "Error inserting cust_pkg_reason: $error";
 671     }
 672   }
 673
 674   my %svc;
 675   if ( $date ) {
 676 # copied from below
 677     foreach my $cust_svc (
 678       #schwartz
 679       map  { $_->[0] }
 680       sort { $a->[1] <=> $b->[1] }
 681       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 682       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 683     ) {
 684       my $error = $cust_svc->cancel( ('date' => $date) );
 685
 686       if ( $error ) {
 687         $dbh->rollback if $oldAutoCommit;
 688         return "Error expiring cust_svc: $error";
 689       }
 690     }
 691   } else { #!date
 692     foreach my $cust_svc (
 693       #schwartz
 694       map  { $_->[0] }
 695       sort { $a->[1] <=> $b->[1] }
 696       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 697       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 698     ) {
 699       my $error = $cust_svc->cancel;
 700
 701       if ( $error ) {
 702         $dbh->rollback if $oldAutoCommit;
 703         return "Error cancelling cust_svc: $error";
 704       }
 705     }
 706   } #if $date
 707
 708   # Add a credit for remaining service
 709   my $last_bill = $self->getfield('last_bill') || 0;
 710   my $next_bill = $self->getfield('bill') || 0;
 711   my $do_credit;
 712   if ( exists($options{'unused_credit'}) ) {
 713     $do_credit = $options{'unused_credit'};
 714   }
 715   else {
 716     $do_credit = $self->part_pkg->option('unused_credit_cancel', 1);
 717   }
 718   if ( $do_credit
 719         and $last_bill > 0 # the package has been billed
 720         and $next_bill > 0 # the package has a next bill date
 721         and $next_bill >= $cancel_time # which is in the future
 722   ) {
 723     my $remaining_value = $self->calc_remain('time' => $cancel_time);
 724     if ( $remaining_value > 0 ) {
 725       # && !$options{'no_credit'} ) {
 726       # Undocumented, unused option.
 727       # part_pkg configuration should decide this anyway.
 728       my $error = $self->cust_main->credit(
 729         $remaining_value,
 730         'Credit for unused time on '. $self->part_pkg->pkg,
 731         'reason_type' => $conf->config('cancel_credit_type'),
 732       );
 733       if ($error) {
 734         $dbh->rollback if $oldAutoCommit;
 735         return "Error crediting customer \$$remaining_value for unused time on".
 736                $self->part_pkg->pkg. ": $error";
 737       }
 738     } #if $remaining_value
 739   } #if $do_credit
 740
 741   my %hash = $self->hash;
 742   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 743   my $new = new FS::cust_pkg ( \%hash );
 744   $error = $new->replace( $self, options => { $self->options } );
 745   if ( $error ) {
 746     $dbh->rollback if $oldAutoCommit;
 747     return $error;
 748   }
 749
 750   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 751   return '' if $date; #no errors
 752
 753   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 754   if ( !$options{'quiet'} &&
 755         $conf->exists('emailcancel', $self->cust_main->agentnum) &&
 756         @invoicing_list ) {
 757     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 758     my $error = '';
 759     if ( $msgnum ) {
 760       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 761       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 762                                     'object'    => $self );
 763     }
 764     else {
 765       $error = send_email(
 766         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 767         'to'      => \@invoicing_list,
 768         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 769         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 770       );
 771     }
 772     #should this do something on errors?
 773   }
 774
 775   ''; #no errors
 776
 777 }
 778
 779 =item cancel_if_expired [ NOW_TIMESTAMP ]
 780
 781 Cancels this package if its expire date has been reached.
 782
 783 =cut
 784
 785 sub cancel_if_expired {
 786   my $self = shift;
 787   my $time = shift || time;
 788   return '' unless $self->expire && $self->expire <= $time;
 789   my $error = $self->cancel;
 790   if ( $error ) {
 791     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 792            $self->custnum. ": $error";
 793   }
 794   '';
 795 }
 796
 797 =item unexpire
 798
 799 Cancels any pending expiration (sets the expire field to null).
 800
 801 If there is an error, returns the error, otherwise returns false.
 802
 803 =cut
 804
 805 sub unexpire {
 806   my( $self, %options ) = @_;
 807   my $error;
 808
 809   local $SIG{HUP} = 'IGNORE';
 810   local $SIG{INT} = 'IGNORE';
 811   local $SIG{QUIT} = 'IGNORE';
 812   local $SIG{TERM} = 'IGNORE';
 813   local $SIG{TSTP} = 'IGNORE';
 814   local $SIG{PIPE} = 'IGNORE';
 815
 816   my $oldAutoCommit = $FS::UID::AutoCommit;
 817   local $FS::UID::AutoCommit = 0;
 818   my $dbh = dbh;
 819
 820   my $old = $self->select_for_update;
 821
 822   my $pkgnum = $old->pkgnum;
 823   if ( $old->get('cancel') || $self->get('cancel') ) {
 824     dbh->rollback if $oldAutoCommit;
 825     return "Can't unexpire cancelled package $pkgnum";
 826     # or at least it's pointless
 827   }
 828
 829   unless ( $old->get('expire') && $self->get('expire') ) {
 830     dbh->rollback if $oldAutoCommit;
 831     return "";  # no error
 832   }
 833
 834   my %hash = $self->hash;
 835   $hash{'expire'} = '';
 836   my $new = new FS::cust_pkg ( \%hash );
 837   $error = $new->replace( $self, options => { $self->options } );
 838   if ( $error ) {
 839     $dbh->rollback if $oldAutoCommit;
 840     return $error;
 841   }
 842
 843   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 844
 845   ''; #no errors
 846
 847 }
 848
 849 =item suspend [ OPTION => VALUE ... ]
 850
 851 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 852 package, then suspends the package itself (sets the susp field to now).
 853
 854 Available options are:
 855
 856 =over 4
 857
 858 =item reason - 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.
 859
 860 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 861
 862 =back
 863
 864 If there is an error, returns the error, otherwise returns false.
 865
 866 =cut
 867
 868 sub suspend {
 869   my( $self, %options ) = @_;
 870   my $error;
 871
 872   local $SIG{HUP} = 'IGNORE';
 873   local $SIG{INT} = 'IGNORE';
 874   local $SIG{QUIT} = 'IGNORE';
 875   local $SIG{TERM} = 'IGNORE';
 876   local $SIG{TSTP} = 'IGNORE';
 877   local $SIG{PIPE} = 'IGNORE';
 878
 879   my $oldAutoCommit = $FS::UID::AutoCommit;
 880   local $FS::UID::AutoCommit = 0;
 881   my $dbh = dbh;
 882
 883   my $old = $self->select_for_update;
 884
 885   my $pkgnum = $old->pkgnum;
 886   if ( $old->get('cancel') || $self->get('cancel') ) {
 887     dbh->rollback if $oldAutoCommit;
 888     return "Can't suspend cancelled package $pkgnum";
 889   }
 890
 891   if ( $old->get('susp') || $self->get('susp') ) {
 892     dbh->rollback if $oldAutoCommit;
 893     return "";  # no error                     # complain on adjourn?
 894   }
 895
 896   my $date = $options{date} if $options{date}; # adjourn/suspend later
 897   $date = '' if ($date && $date <= time);      # complain instead?
 898
 899   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 900     dbh->rollback if $oldAutoCommit;
 901     return "Package $pkgnum expires before it would be suspended.";
 902   }
 903
 904   my $suspend_time = $options{'time'} || time;
 905
 906   if ( $options{'reason'} ) {
 907     $error = $self->insert_reason( 'reason' => $options{'reason'},
 908                                    'action' => $date ? 'adjourn' : 'suspend',
 909                                    'date'   => $date ? $date : $suspend_time,
 910                                    'reason_otaker' => $options{'reason_otaker'},
 911                                  );
 912     if ( $error ) {
 913       dbh->rollback if $oldAutoCommit;
 914       return "Error inserting cust_pkg_reason: $error";
 915     }
 916   }
 917
 918   unless ( $date ) {
 919
 920     my @labels = ();
 921
 922     foreach my $cust_svc (
 923       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 924     ) {
 925       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 926
 927       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 928         $dbh->rollback if $oldAutoCommit;
 929         return "Illegal svcdb value in part_svc!";
 930       };
 931       my $svcdb = $1;
 932       require "FS/$svcdb.pm";
 933
 934       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 935       if ($svc) {
 936         $error = $svc->suspend;
 937         if ( $error ) {
 938           $dbh->rollback if $oldAutoCommit;
 939           return $error;
 940         }
 941         my( $label, $value ) = $cust_svc->label;
 942         push @labels, "$label: $value";
 943       }
 944     }
 945
 946     my $conf = new FS::Conf;
 947     if ( $conf->config('suspend_email_admin') ) {
 948
 949       my $error = send_email(
 950         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 951                                    #invoice_from ??? well as good as any
 952         'to'      => $conf->config('suspend_email_admin'),
 953         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 954         'body'    => [
 955           "This is an automatic message from your Freeside installation\n",
 956           "informing you that the following customer package has been suspended:\n",
 957           "\n",
 958           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 959           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 960           ( map { "Service : $_\n" } @labels ),
 961         ],
 962       );
 963
 964       if ( $error ) {
 965         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 966              "$error\n";
 967       }
 968
 969     }
 970
 971   }
 972
 973   my %hash = $self->hash;
 974   if ( $date ) {
 975     $hash{'adjourn'} = $date;
 976   } else {
 977     $hash{'susp'} = $suspend_time;
 978   }
 979   my $new = new FS::cust_pkg ( \%hash );
 980   $error = $new->replace( $self, options => { $self->options } );
 981   if ( $error ) {
 982     $dbh->rollback if $oldAutoCommit;
 983     return $error;
 984   }
 985
 986   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 987
 988   ''; #no errors
 989 }
 990
 991 =item unsuspend [ OPTION => VALUE ... ]
 992
 993 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 994 package, then unsuspends the package itself (clears the susp field and the
 995 adjourn field if it is in the past).
 996
 997 Available options are:
 998
 999 =over 4
1000
1001 =item adjust_next_bill
1002
1003 Can be set true to adjust the next bill date forward by
1004 the amount of time the account was inactive.  This was set true by default
1005 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
1006 explicitly requested.  Price plans for which this makes sense (anniversary-date
1007 based than prorate or subscription) could have an option to enable this
1008 behaviour?
1009
1010 =back
1011
1012 If there is an error, returns the error, otherwise returns false.
1013
1014 =cut
1015
1016 sub unsuspend {
1017   my( $self, %opt ) = @_;
1018   my $error;
1019
1020   local $SIG{HUP} = 'IGNORE';
1021   local $SIG{INT} = 'IGNORE';
1022   local $SIG{QUIT} = 'IGNORE';
1023   local $SIG{TERM} = 'IGNORE';
1024   local $SIG{TSTP} = 'IGNORE';
1025   local $SIG{PIPE} = 'IGNORE';
1026
1027   my $oldAutoCommit = $FS::UID::AutoCommit;
1028   local $FS::UID::AutoCommit = 0;
1029   my $dbh = dbh;
1030
1031   my $old = $self->select_for_update;
1032
1033   my $pkgnum = $old->pkgnum;
1034   if ( $old->get('cancel') || $self->get('cancel') ) {
1035     dbh->rollback if $oldAutoCommit;
1036     return "Can't unsuspend cancelled package $pkgnum";
1037   }
1038
1039   unless ( $old->get('susp') && $self->get('susp') ) {
1040     dbh->rollback if $oldAutoCommit;
1041     return "";  # no error                     # complain instead?
1042   }
1043
1044   foreach my $cust_svc (
1045     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1046   ) {
1047     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1048
1049     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1050       $dbh->rollback if $oldAutoCommit;
1051       return "Illegal svcdb value in part_svc!";
1052     };
1053     my $svcdb = $1;
1054     require "FS/$svcdb.pm";
1055
1056     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1057     if ($svc) {
1058       $error = $svc->unsuspend;
1059       if ( $error ) {
1060         $dbh->rollback if $oldAutoCommit;
1061         return $error;
1062       }
1063     }
1064
1065   }
1066
1067   my %hash = $self->hash;
1068   my $inactive = time - $hash{'susp'};
1069
1070   my $conf = new FS::Conf;
1071
1072   if ( $inactive > 0 &&
1073        ( $hash{'bill'} || $hash{'setup'} ) &&
1074        ( $opt{'adjust_next_bill'} ||
1075          $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1076          $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1077      ) {
1078
1079     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1080
1081   }
1082
1083   $hash{'susp'} = '';
1084   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1085   my $new = new FS::cust_pkg ( \%hash );
1086   $error = $new->replace( $self, options => { $self->options } );
1087   if ( $error ) {
1088     $dbh->rollback if $oldAutoCommit;
1089     return $error;
1090   }
1091
1092   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1093
1094   ''; #no errors
1095 }
1096
1097 =item unadjourn
1098
1099 Cancels any pending suspension (sets the adjourn field to null).
1100
1101 If there is an error, returns the error, otherwise returns false.
1102
1103 =cut
1104
1105 sub unadjourn {
1106   my( $self, %options ) = @_;
1107   my $error;
1108
1109   local $SIG{HUP} = 'IGNORE';
1110   local $SIG{INT} = 'IGNORE';
1111   local $SIG{QUIT} = 'IGNORE';
1112   local $SIG{TERM} = 'IGNORE';
1113   local $SIG{TSTP} = 'IGNORE';
1114   local $SIG{PIPE} = 'IGNORE';
1115
1116   my $oldAutoCommit = $FS::UID::AutoCommit;
1117   local $FS::UID::AutoCommit = 0;
1118   my $dbh = dbh;
1119
1120   my $old = $self->select_for_update;
1121
1122   my $pkgnum = $old->pkgnum;
1123   if ( $old->get('cancel') || $self->get('cancel') ) {
1124     dbh->rollback if $oldAutoCommit;
1125     return "Can't unadjourn cancelled package $pkgnum";
1126     # or at least it's pointless
1127   }
1128
1129   if ( $old->get('susp') || $self->get('susp') ) {
1130     dbh->rollback if $oldAutoCommit;
1131     return "Can't unadjourn suspended package $pkgnum";
1132     # perhaps this is arbitrary
1133   }
1134
1135   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1136     dbh->rollback if $oldAutoCommit;
1137     return "";  # no error
1138   }
1139
1140   my %hash = $self->hash;
1141   $hash{'adjourn'} = '';
1142   my $new = new FS::cust_pkg ( \%hash );
1143   $error = $new->replace( $self, options => { $self->options } );
1144   if ( $error ) {
1145     $dbh->rollback if $oldAutoCommit;
1146     return $error;
1147   }
1148
1149   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1150
1151   ''; #no errors
1152
1153 }
1154
1155
1156 =item change HASHREF | OPTION => VALUE ...
1157
1158 Changes this package: cancels it and creates a new one, with a different
1159 pkgpart or locationnum or both.  All services are transferred to the new
1160 package (no change will be made if this is not possible).
1161
1162 Options may be passed as a list of key/value pairs or as a hash reference.
1163 Options are:
1164
1165 =over 4
1166
1167 =item locationnum
1168
1169 New locationnum, to change the location for this package.
1170
1171 =item cust_location
1172
1173 New FS::cust_location object, to create a new location and assign it
1174 to this package.
1175
1176 =item pkgpart
1177
1178 New pkgpart (see L<FS::part_pkg>).
1179
1180 =item refnum
1181
1182 New refnum (see L<FS::part_referral>).
1183
1184 =item keep_dates
1185
1186 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1187 susp, adjourn, cancel, expire, and contract_end) to the new package.
1188
1189 =back
1190
1191 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1192 (otherwise, what's the point?)
1193
1194 Returns either the new FS::cust_pkg object or a scalar error.
1195
1196 For example:
1197
1198   my $err_or_new_cust_pkg = $old_cust_pkg->change
1199
1200 =cut
1201
1202 #some false laziness w/order
1203 sub change {
1204   my $self = shift;
1205   my $opt = ref($_[0]) ? shift : { @_ };
1206
1207 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1208 #
1209
1210   my $conf = new FS::Conf;
1211
1212   # Transactionize this whole mess
1213   local $SIG{HUP} = 'IGNORE';
1214   local $SIG{INT} = 'IGNORE';
1215   local $SIG{QUIT} = 'IGNORE';
1216   local $SIG{TERM} = 'IGNORE';
1217   local $SIG{TSTP} = 'IGNORE';
1218   local $SIG{PIPE} = 'IGNORE';
1219
1220   my $oldAutoCommit = $FS::UID::AutoCommit;
1221   local $FS::UID::AutoCommit = 0;
1222   my $dbh = dbh;
1223
1224   my $error;
1225
1226   my %hash = ();
1227
1228   my $time = time;
1229
1230   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1231
1232   #$hash{$_} = $self->$_() foreach qw( setup );
1233
1234   $hash{'setup'} = $time if $self->setup;
1235
1236   $hash{'change_date'} = $time;
1237   $hash{"change_$_"}  = $self->$_()
1238     foreach qw( pkgnum pkgpart locationnum );
1239
1240   if ( $opt->{'cust_location'} &&
1241        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1242     $error = $opt->{'cust_location'}->insert;
1243     if ( $error ) {
1244       $dbh->rollback if $oldAutoCommit;
1245       return "inserting cust_location (transaction rolled back): $error";
1246     }
1247     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1248   }
1249
1250   my $unused_credit = 0;
1251   if ( $opt->{'keep_dates'} ) {
1252     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1253                           start_date contract_end ) ) {
1254       $hash{$date} = $self->getfield($date);
1255     }
1256   }
1257   # Special case.  If the pkgpart is changing, and the customer is
1258   # going to be credited for remaining time, don't keep setup, bill,
1259   # or last_bill dates, and DO pass the flag to cancel() to credit
1260   # the customer.
1261   if ( $opt->{'pkgpart'}
1262       and $opt->{'pkgpart'} != $self->pkgpart
1263       and $self->part_pkg->option('unused_credit_change', 1) ) {
1264     $unused_credit = 1;
1265     $hash{$_} = '' foreach qw(setup bill last_bill);
1266   }
1267
1268   # Create the new package.
1269   my $cust_pkg = new FS::cust_pkg {
1270     custnum      => $self->custnum,
1271     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1272     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1273     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1274     %hash,
1275   };
1276
1277   $error = $cust_pkg->insert( 'change' => 1 );
1278   if ($error) {
1279     $dbh->rollback if $oldAutoCommit;
1280     return $error;
1281   }
1282
1283   # Transfer services and cancel old package.
1284
1285   $error = $self->transfer($cust_pkg);
1286   if ($error and $error == 0) {
1287     # $old_pkg->transfer failed.
1288     $dbh->rollback if $oldAutoCommit;
1289     return $error;
1290   }
1291
1292   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1293     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1294     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1295     if ($error and $error == 0) {
1296       # $old_pkg->transfer failed.
1297       $dbh->rollback if $oldAutoCommit;
1298       return $error;
1299     }
1300   }
1301
1302   if ($error > 0) {
1303     # Transfers were successful, but we still had services left on the old
1304     # package.  We can't change the package under this circumstances, so abort.
1305     $dbh->rollback if $oldAutoCommit;
1306     return "Unable to transfer all services from package ". $self->pkgnum;
1307   }
1308
1309   #reset usage if changing pkgpart
1310   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1311   if ($self->pkgpart != $cust_pkg->pkgpart) {
1312     my $part_pkg = $cust_pkg->part_pkg;
1313     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1314                                                  ? ()
1315                                                  : ( 'null' => 1 )
1316                                    )
1317       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1318
1319     if ($error) {
1320       $dbh->rollback if $oldAutoCommit;
1321       return "Error setting usage values: $error";
1322     }
1323   }
1324
1325   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
1326   #remaining time.
1327   $error = $self->cancel( quiet=>1, unused_credit => $unused_credit );
1328   if ($error) {
1329     $dbh->rollback if $oldAutoCommit;
1330     return $error;
1331   }
1332
1333   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1334     #$self->cust_main
1335     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1336     if ( $error ) {
1337       $dbh->rollback if $oldAutoCommit;
1338       return $error;
1339     }
1340   }
1341
1342   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1343
1344   $cust_pkg;
1345
1346 }
1347
1348 use Data::Dumper;
1349 use Storable 'thaw';
1350 use MIME::Base64;
1351 sub process_bulk_cust_pkg {
1352   my $job = shift;
1353   my $param = thaw(decode_base64(shift));
1354   warn Dumper($param) if $DEBUG;
1355
1356   my $old_part_pkg = qsearchs('part_pkg',
1357                               { pkgpart => $param->{'old_pkgpart'} });
1358   my $new_part_pkg = qsearchs('part_pkg',
1359                               { pkgpart => $param->{'new_pkgpart'} });
1360   die "Must select a new package type\n" unless $new_part_pkg;
1361   #my $keep_dates = $param->{'keep_dates'} || 0;
1362   my $keep_dates = 1; # there is no good reason to turn this off
1363
1364   local $SIG{HUP} = 'IGNORE';
1365   local $SIG{INT} = 'IGNORE';
1366   local $SIG{QUIT} = 'IGNORE';
1367   local $SIG{TERM} = 'IGNORE';
1368   local $SIG{TSTP} = 'IGNORE';
1369   local $SIG{PIPE} = 'IGNORE';
1370
1371   my $oldAutoCommit = $FS::UID::AutoCommit;
1372   local $FS::UID::AutoCommit = 0;
1373   my $dbh = dbh;
1374
1375   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1376
1377   my $i = 0;
1378   foreach my $old_cust_pkg ( @cust_pkgs ) {
1379     $i++;
1380     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1381     if ( $old_cust_pkg->getfield('cancel') ) {
1382       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1383         $old_cust_pkg->pkgnum."\n"
1384         if $DEBUG;
1385       next;
1386     }
1387     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1388       if $DEBUG;
1389     my $error = $old_cust_pkg->change(
1390       'pkgpart'     => $param->{'new_pkgpart'},
1391       'keep_dates'  => $keep_dates
1392     );
1393     if ( !ref($error) ) { # change returns the cust_pkg on success
1394       $dbh->rollback;
1395       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1396     }
1397   }
1398   $dbh->commit if $oldAutoCommit;
1399   return;
1400 }
1401
1402 =item last_bill
1403
1404 Returns the last bill date, or if there is no last bill date, the setup date.
1405 Useful for billing metered services.
1406
1407 =cut
1408
1409 sub last_bill {
1410   my $self = shift;
1411   return $self->setfield('last_bill', $_[0]) if @_;
1412   return $self->getfield('last_bill') if $self->getfield('last_bill');
1413   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1414                                                   'edate'  => $self->bill,  } );
1415   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1416 }
1417
1418 =item last_cust_pkg_reason ACTION
1419
1420 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1421 Returns false if there is no reason or the package is not currenly ACTION'd
1422 ACTION is one of adjourn, susp, cancel, or expire.
1423
1424 =cut
1425
1426 sub last_cust_pkg_reason {
1427   my ( $self, $action ) = ( shift, shift );
1428   my $date = $self->get($action);
1429   qsearchs( {
1430               'table' => 'cust_pkg_reason',
1431               'hashref' => { 'pkgnum' => $self->pkgnum,
1432                              'action' => substr(uc($action), 0, 1),
1433                              'date'   => $date,
1434                            },
1435               'order_by' => 'ORDER BY num DESC LIMIT 1',
1436            } );
1437 }
1438
1439 =item last_reason ACTION
1440
1441 Returns the most recent ACTION FS::reason associated with the package.
1442 Returns false if there is no reason or the package is not currenly ACTION'd
1443 ACTION is one of adjourn, susp, cancel, or expire.
1444
1445 =cut
1446
1447 sub last_reason {
1448   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1449   $cust_pkg_reason->reason
1450     if $cust_pkg_reason;
1451 }
1452
1453 =item part_pkg
1454
1455 Returns the definition for this billing item, as an FS::part_pkg object (see
1456 L<FS::part_pkg>).
1457
1458 =cut
1459
1460 sub part_pkg {
1461   my $self = shift;
1462   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1463   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1464   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1465 }
1466
1467 =item old_cust_pkg
1468
1469 Returns the cancelled package this package was changed from, if any.
1470
1471 =cut
1472
1473 sub old_cust_pkg {
1474   my $self = shift;
1475   return '' unless $self->change_pkgnum;
1476   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1477 }
1478
1479 =item calc_setup
1480
1481 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1482 item.
1483
1484 =cut
1485
1486 sub calc_setup {
1487   my $self = shift;
1488   $self->part_pkg->calc_setup($self, @_);
1489 }
1490
1491 =item calc_recur
1492
1493 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1494 item.
1495
1496 =cut
1497
1498 sub calc_recur {
1499   my $self = shift;
1500   $self->part_pkg->calc_recur($self, @_);
1501 }
1502
1503 =item base_recur
1504
1505 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1506 item.
1507
1508 =cut
1509
1510 sub base_recur {
1511   my $self = shift;
1512   $self->part_pkg->base_recur($self, @_);
1513 }
1514
1515 =item calc_remain
1516
1517 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1518 billing item.
1519
1520 =cut
1521
1522 sub calc_remain {
1523   my $self = shift;
1524   $self->part_pkg->calc_remain($self, @_);
1525 }
1526
1527 =item calc_cancel
1528
1529 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1530 billing item.
1531
1532 =cut
1533
1534 sub calc_cancel {
1535   my $self = shift;
1536   $self->part_pkg->calc_cancel($self, @_);
1537 }
1538
1539 =item cust_bill_pkg
1540
1541 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1542
1543 =cut
1544
1545 sub cust_bill_pkg {
1546   my $self = shift;
1547   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1548 }
1549
1550 =item cust_pkg_detail [ DETAILTYPE ]
1551
1552 Returns any customer package details for this package (see
1553 L<FS::cust_pkg_detail>).
1554
1555 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1556
1557 =cut
1558
1559 sub cust_pkg_detail {
1560   my $self = shift;
1561   my %hash = ( 'pkgnum' => $self->pkgnum );
1562   $hash{detailtype} = shift if @_;
1563   qsearch({
1564     'table'    => 'cust_pkg_detail',
1565     'hashref'  => \%hash,
1566     'order_by' => 'ORDER BY weight, pkgdetailnum',
1567   });
1568 }
1569
1570 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1571
1572 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1573
1574 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1575
1576 If there is an error, returns the error, otherwise returns false.
1577
1578 =cut
1579
1580 sub set_cust_pkg_detail {
1581   my( $self, $detailtype, @details ) = @_;
1582
1583   local $SIG{HUP} = 'IGNORE';
1584   local $SIG{INT} = 'IGNORE';
1585   local $SIG{QUIT} = 'IGNORE';
1586   local $SIG{TERM} = 'IGNORE';
1587   local $SIG{TSTP} = 'IGNORE';
1588   local $SIG{PIPE} = 'IGNORE';
1589
1590   my $oldAutoCommit = $FS::UID::AutoCommit;
1591   local $FS::UID::AutoCommit = 0;
1592   my $dbh = dbh;
1593
1594   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1595     my $error = $current->delete;
1596     if ( $error ) {
1597       $dbh->rollback if $oldAutoCommit;
1598       return "error removing old detail: $error";
1599     }
1600   }
1601
1602   foreach my $detail ( @details ) {
1603     my $cust_pkg_detail = new FS::cust_pkg_detail {
1604       'pkgnum'     => $self->pkgnum,
1605       'detailtype' => $detailtype,
1606       'detail'     => $detail,
1607     };
1608     my $error = $cust_pkg_detail->insert;
1609     if ( $error ) {
1610       $dbh->rollback if $oldAutoCommit;
1611       return "error adding new detail: $error";
1612     }
1613
1614   }
1615
1616   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1617   '';
1618
1619 }
1620
1621 =item cust_event
1622
1623 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1624
1625 =cut
1626
1627 #false laziness w/cust_bill.pm
1628 sub cust_event {
1629   my $self = shift;
1630   qsearch({
1631     'table'     => 'cust_event',
1632     'addl_from' => 'JOIN part_event USING ( eventpart )',
1633     'hashref'   => { 'tablenum' => $self->pkgnum },
1634     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1635   });
1636 }
1637
1638 =item num_cust_event
1639
1640 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1641
1642 =cut
1643
1644 #false laziness w/cust_bill.pm
1645 sub num_cust_event {
1646   my $self = shift;
1647   my $sql =
1648     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1649     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1650   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1651   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1652   $sth->fetchrow_arrayref->[0];
1653 }
1654
1655 =item cust_svc [ SVCPART ]
1656
1657 Returns the services for this package, as FS::cust_svc objects (see
1658 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1659 services.
1660
1661 =cut
1662
1663 sub cust_svc {
1664   my $self = shift;
1665
1666   return () unless $self->num_cust_svc(@_);
1667
1668   if ( @_ ) {
1669     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1670                                   'svcpart' => shift,          } );
1671   }
1672
1673   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1674
1675   #if ( $self->{'_svcnum'} ) {
1676   #  values %{ $self->{'_svcnum'}->cache };
1677   #} else {
1678     $self->_sort_cust_svc(
1679       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1680     );
1681   #}
1682
1683 }
1684
1685 =item overlimit [ SVCPART ]
1686
1687 Returns the services for this package which have exceeded their
1688 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1689 is specified, return only the matching services.
1690
1691 =cut
1692
1693 sub overlimit {
1694   my $self = shift;
1695   return () unless $self->num_cust_svc(@_);
1696   grep { $_->overlimit } $self->cust_svc(@_);
1697 }
1698
1699 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1700
1701 Returns historical services for this package created before END TIMESTAMP and
1702 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1703 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
1704 I<pkg_svc.hidden> flag will be omitted.
1705
1706 =cut
1707
1708 sub h_cust_svc {
1709   my $self = shift;
1710   my ($end, $start, $mode) = @_;
1711   my @cust_svc = $self->_sort_cust_svc(
1712     [ qsearch( 'h_cust_svc',
1713       { 'pkgnum' => $self->pkgnum, },
1714       FS::h_cust_svc->sql_h_search(@_),
1715     ) ]
1716   );
1717   if ( $mode eq 'I' ) {
1718     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1719     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1720   }
1721   else {
1722     return @cust_svc;
1723   }
1724 }
1725
1726 sub _sort_cust_svc {
1727   my( $self, $arrayref ) = @_;
1728
1729   my $sort =
1730     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1731
1732   map  { $_->[0] }
1733   sort $sort
1734   map {
1735         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1736                                              'svcpart' => $_->svcpart     } );
1737         [ $_,
1738           $pkg_svc ? $pkg_svc->primary_svc : '',
1739           $pkg_svc ? $pkg_svc->quantity : 0,
1740         ];
1741       }
1742   @$arrayref;
1743
1744 }
1745
1746 =item num_cust_svc [ SVCPART ]
1747
1748 Returns the number of provisioned services for this package.  If a svcpart is
1749 specified, counts only the matching services.
1750
1751 =cut
1752
1753 sub num_cust_svc {
1754   my $self = shift;
1755
1756   return $self->{'_num_cust_svc'}
1757     if !scalar(@_)
1758        && exists($self->{'_num_cust_svc'})
1759        && $self->{'_num_cust_svc'} =~ /\d/;
1760
1761   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1762     if $DEBUG > 2;
1763
1764   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1765   $sql .= ' AND svcpart = ?' if @_;
1766
1767   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1768   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1769   $sth->fetchrow_arrayref->[0];
1770 }
1771
1772 =item available_part_svc
1773
1774 Returns a list of FS::part_svc objects representing services included in this
1775 package but not yet provisioned.  Each FS::part_svc object also has an extra
1776 field, I<num_avail>, which specifies the number of available services.
1777
1778 =cut
1779
1780 sub available_part_svc {
1781   my $self = shift;
1782   grep { $_->num_avail > 0 }
1783     map {
1784           my $part_svc = $_->part_svc;
1785           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1786             $_->quantity - $self->num_cust_svc($_->svcpart);
1787
1788           # more evil encapsulation breakage
1789           if($part_svc->{'Hash'}{'num_avail'} > 0) {
1790             my @exports = $part_svc->part_export_did;
1791             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
1792           }
1793
1794           $part_svc;
1795         }
1796       $self->part_pkg->pkg_svc;
1797 }
1798
1799 =item part_svc
1800
1801 Returns a list of FS::part_svc objects representing provisioned and available
1802 services included in this package.  Each FS::part_svc object also has the
1803 following extra fields:
1804
1805 =over 4
1806
1807 =item num_cust_svc  (count)
1808
1809 =item num_avail     (quantity - count)
1810
1811 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1812
1813 svcnum
1814 label -> ($cust_svc->label)[1]
1815
1816 =back
1817
1818 =cut
1819
1820 sub part_svc {
1821   my $self = shift;
1822
1823   #XXX some sort of sort order besides numeric by svcpart...
1824   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1825     my $pkg_svc = $_;
1826     my $part_svc = $pkg_svc->part_svc;
1827     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1828     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1829     $part_svc->{'Hash'}{'num_avail'}    =
1830       max( 0, $pkg_svc->quantity - $num_cust_svc );
1831     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1832       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1833     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
1834     $part_svc;
1835   } $self->part_pkg->pkg_svc;
1836
1837   #extras
1838   push @part_svc, map {
1839     my $part_svc = $_;
1840     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1841     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1842     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1843     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1844       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1845     $part_svc;
1846   } $self->extra_part_svc;
1847
1848   @part_svc;
1849
1850 }
1851
1852 =item extra_part_svc
1853
1854 Returns a list of FS::part_svc objects corresponding to services in this
1855 package which are still provisioned but not (any longer) available in the
1856 package definition.
1857
1858 =cut
1859
1860 sub extra_part_svc {
1861   my $self = shift;
1862
1863   my $pkgnum  = $self->pkgnum;
1864   my $pkgpart = $self->pkgpart;
1865
1866 #  qsearch( {
1867 #    'table'     => 'part_svc',
1868 #    'hashref'   => {},
1869 #    'extra_sql' =>
1870 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1871 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1872 #                       AND pkg_svc.pkgpart = ?
1873 #                       AND quantity > 0
1874 #                 )
1875 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1876 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1877 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1878 #                       AND pkgnum = ?
1879 #                 )",
1880 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1881 #  } );
1882
1883 #seems to benchmark slightly faster...
1884   qsearch( {
1885     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1886     #MySQL doesn't grok DISINCT ON
1887     'select'      => 'DISTINCT part_svc.*',
1888     'table'       => 'part_svc',
1889     'addl_from'   =>
1890       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1891                                AND pkg_svc.pkgpart   = ?
1892                                AND quantity > 0
1893                              )
1894        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1895        LEFT JOIN cust_pkg USING ( pkgnum )
1896       ',
1897     'hashref'     => {},
1898     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1899     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1900   } );
1901 }
1902
1903 =item status
1904
1905 Returns a short status string for this package, currently:
1906
1907 =over 4
1908
1909 =item not yet billed
1910
1911 =item one-time charge
1912
1913 =item active
1914
1915 =item suspended
1916
1917 =item cancelled
1918
1919 =back
1920
1921 =cut
1922
1923 sub status {
1924   my $self = shift;
1925
1926   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1927
1928   return 'cancelled' if $self->get('cancel');
1929   return 'suspended' if $self->susp;
1930   return 'not yet billed' unless $self->setup;
1931   return 'one-time charge' if $freq =~ /^(0|$)/;
1932   return 'active';
1933 }
1934
1935 =item ucfirst_status
1936
1937 Returns the status with the first character capitalized.
1938
1939 =cut
1940
1941 sub ucfirst_status {
1942   ucfirst(shift->status);
1943 }
1944
1945 =item statuses
1946
1947 Class method that returns the list of possible status strings for packages
1948 (see L<the status method|/status>).  For example:
1949
1950   @statuses = FS::cust_pkg->statuses();
1951
1952 =cut
1953
1954 tie my %statuscolor, 'Tie::IxHash',
1955   'not yet billed'  => '009999', #teal? cyan?
1956   'one-time charge' => '000000',
1957   'active'          => '00CC00',
1958   'suspended'       => 'FF9900',
1959   'cancelled'       => 'FF0000',
1960 ;
1961
1962 sub statuses {
1963   my $self = shift; #could be class...
1964   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1965   #                                    # mayble split btw one-time vs. recur
1966     keys %statuscolor;
1967 }
1968
1969 =item statuscolor
1970
1971 Returns a hex triplet color string for this package's status.
1972
1973 =cut
1974
1975 sub statuscolor {
1976   my $self = shift;
1977   $statuscolor{$self->status};
1978 }
1979
1980 =item pkg_label
1981
1982 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1983 "pkg-comment" depending on user preference).
1984
1985 =cut
1986
1987 sub pkg_label {
1988   my $self = shift;
1989   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1990   $label = $self->pkgnum. ": $label"
1991     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1992   $label;
1993 }
1994
1995 =item pkg_label_long
1996
1997 Returns a long label for this package, adding the primary service's label to
1998 pkg_label.
1999
2000 =cut
2001
2002 sub pkg_label_long {
2003   my $self = shift;
2004   my $label = $self->pkg_label;
2005   my $cust_svc = $self->primary_cust_svc;
2006   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2007   $label;
2008 }
2009
2010 =item primary_cust_svc
2011
2012 Returns a primary service (as FS::cust_svc object) if one can be identified.
2013
2014 =cut
2015
2016 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2017
2018 sub primary_cust_svc {
2019   my $self = shift;
2020
2021   my @cust_svc = $self->cust_svc;
2022
2023   return '' unless @cust_svc; #no serivces - irrelevant then
2024
2025   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2026
2027   # primary service as specified in the package definition
2028   # or exactly one service definition with quantity one
2029   my $svcpart = $self->part_pkg->svcpart;
2030   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2031   return $cust_svc[0] if scalar(@cust_svc) == 1;
2032
2033   #couldn't identify one thing..
2034   return '';
2035 }
2036
2037 =item labels
2038
2039 Returns a list of lists, calling the label method for all services
2040 (see L<FS::cust_svc>) of this billing item.
2041
2042 =cut
2043
2044 sub labels {
2045   my $self = shift;
2046   map { [ $_->label ] } $self->cust_svc;
2047 }
2048
2049 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2050
2051 Like the labels method, but returns historical information on services that
2052 were active as of END_TIMESTAMP and (optionally) not cancelled before
2053 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2054 I<pkg_svc.hidden> flag will be omitted.
2055
2056 Returns a list of lists, calling the label method for all (historical) services
2057 (see L<FS::h_cust_svc>) of this billing item.
2058
2059 =cut
2060
2061 sub h_labels {
2062   my $self = shift;
2063   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2064 }
2065
2066 =item labels_short
2067
2068 Like labels, except returns a simple flat list, and shortens long
2069 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2070 identical services to one line that lists the service label and the number of
2071 individual services rather than individual items.
2072
2073 =cut
2074
2075 sub labels_short {
2076   shift->_labels_short( 'labels', @_ );
2077 }
2078
2079 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2080
2081 Like h_labels, except returns a simple flat list, and shortens long
2082 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2083 identical services to one line that lists the service label and the number of
2084 individual services rather than individual items.
2085
2086 =cut
2087
2088 sub h_labels_short {
2089   shift->_labels_short( 'h_labels', @_ );
2090 }
2091
2092 sub _labels_short {
2093   my( $self, $method ) = ( shift, shift );
2094
2095   my $conf = new FS::Conf;
2096   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2097
2098   my %labels;
2099   #tie %labels, 'Tie::IxHash';
2100   push @{ $labels{$_->[0]} }, $_->[1]
2101     foreach $self->$method(@_);
2102   my @labels;
2103   foreach my $label ( keys %labels ) {
2104     my %seen = ();
2105     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2106     my $num = scalar(@values);
2107     if ( $num > $max_same_services ) {
2108       push @labels, "$label ($num)";
2109     } else {
2110       if ( $conf->exists('cust_bill-consolidate_services') ) {
2111         # push @labels, "$label: ". join(', ', @values);
2112         while ( @values ) {
2113           my $detail = "$label: ";
2114           $detail .= shift(@values). ', '
2115             while @values && length($detail.$values[0]) < 78;
2116           $detail =~ s/, $//;
2117           push @labels, $detail;
2118         }
2119       } else {
2120         push @labels, map { "$label: $_" } @values;
2121       }
2122     }
2123   }
2124
2125  @labels;
2126
2127 }
2128
2129 =item cust_main
2130
2131 Returns the parent customer object (see L<FS::cust_main>).
2132
2133 =cut
2134
2135 sub cust_main {
2136   my $self = shift;
2137   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2138 }
2139
2140 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2141
2142 =item cust_location
2143
2144 Returns the location object, if any (see L<FS::cust_location>).
2145
2146 =item cust_location_or_main
2147
2148 If this package is associated with a location, returns the locaiton (see
2149 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2150
2151 =item location_label [ OPTION => VALUE ... ]
2152
2153 Returns the label of the location object (see L<FS::cust_location>).
2154
2155 =cut
2156
2157 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2158
2159 =item seconds_since TIMESTAMP
2160
2161 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2162 package have been online since TIMESTAMP, according to the session monitor.
2163
2164 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2165 L<Time::Local> and L<Date::Parse> for conversion functions.
2166
2167 =cut
2168
2169 sub seconds_since {
2170   my($self, $since) = @_;
2171   my $seconds = 0;
2172
2173   foreach my $cust_svc (
2174     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2175   ) {
2176     $seconds += $cust_svc->seconds_since($since);
2177   }
2178
2179   $seconds;
2180
2181 }
2182
2183 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2184
2185 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2186 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2187 (exclusive).
2188
2189 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2190 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2191 functions.
2192
2193
2194 =cut
2195
2196 sub seconds_since_sqlradacct {
2197   my($self, $start, $end) = @_;
2198
2199   my $seconds = 0;
2200
2201   foreach my $cust_svc (
2202     grep {
2203       my $part_svc = $_->part_svc;
2204       $part_svc->svcdb eq 'svc_acct'
2205         && scalar($part_svc->part_export('sqlradius'));
2206     } $self->cust_svc
2207   ) {
2208     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2209   }
2210
2211   $seconds;
2212
2213 }
2214
2215 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2216
2217 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2218 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2219 TIMESTAMP_END
2220 (exclusive).
2221
2222 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2223 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2224 functions.
2225
2226 =cut
2227
2228 sub attribute_since_sqlradacct {
2229   my($self, $start, $end, $attrib) = @_;
2230
2231   my $sum = 0;
2232
2233   foreach my $cust_svc (
2234     grep {
2235       my $part_svc = $_->part_svc;
2236       $part_svc->svcdb eq 'svc_acct'
2237         && scalar($part_svc->part_export('sqlradius'));
2238     } $self->cust_svc
2239   ) {
2240     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2241   }
2242
2243   $sum;
2244
2245 }
2246
2247 =item quantity
2248
2249 =cut
2250
2251 sub quantity {
2252   my( $self, $value ) = @_;
2253   if ( defined($value) ) {
2254     $self->setfield('quantity', $value);
2255   }
2256   $self->getfield('quantity') || 1;
2257 }
2258
2259 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2260
2261 Transfers as many services as possible from this package to another package.
2262
2263 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2264 object.  The destination package must already exist.
2265
2266 Services are moved only if the destination allows services with the correct
2267 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2268 this option with caution!  No provision is made for export differences
2269 between the old and new service definitions.  Probably only should be used
2270 when your exports for all service definitions of a given svcdb are identical.
2271 (attempt a transfer without it first, to move all possible svcpart-matching
2272 services)
2273
2274 Any services that can't be moved remain in the original package.
2275
2276 Returns an error, if there is one; otherwise, returns the number of services
2277 that couldn't be moved.
2278
2279 =cut
2280
2281 sub transfer {
2282   my ($self, $dest_pkgnum, %opt) = @_;
2283
2284   my $remaining = 0;
2285   my $dest;
2286   my %target;
2287
2288   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2289     $dest = $dest_pkgnum;
2290     $dest_pkgnum = $dest->pkgnum;
2291   } else {
2292     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2293   }
2294
2295   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2296
2297   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2298     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2299   }
2300
2301   foreach my $cust_svc ($dest->cust_svc) {
2302     $target{$cust_svc->svcpart}--;
2303   }
2304
2305   my %svcpart2svcparts = ();
2306   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2307     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2308     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2309       next if exists $svcpart2svcparts{$svcpart};
2310       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2311       $svcpart2svcparts{$svcpart} = [
2312         map  { $_->[0] }
2313         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2314         map {
2315               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2316                                                    'svcpart' => $_          } );
2317               [ $_,
2318                 $pkg_svc ? $pkg_svc->primary_svc : '',
2319                 $pkg_svc ? $pkg_svc->quantity : 0,
2320               ];
2321             }
2322
2323         grep { $_ != $svcpart }
2324         map  { $_->svcpart }
2325         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2326       ];
2327       warn "alternates for svcpart $svcpart: ".
2328            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2329         if $DEBUG;
2330     }
2331   }
2332
2333   foreach my $cust_svc ($self->cust_svc) {
2334     if($target{$cust_svc->svcpart} > 0) {
2335       $target{$cust_svc->svcpart}--;
2336       my $new = new FS::cust_svc { $cust_svc->hash };
2337       $new->pkgnum($dest_pkgnum);
2338       my $error = $new->replace($cust_svc);
2339       return $error if $error;
2340     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2341       if ( $DEBUG ) {
2342         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2343         warn "alternates to consider: ".
2344              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2345       }
2346       my @alternate = grep {
2347                              warn "considering alternate svcpart $_: ".
2348                                   "$target{$_} available in new package\n"
2349                                if $DEBUG;
2350                              $target{$_} > 0;
2351                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2352       if ( @alternate ) {
2353         warn "alternate(s) found\n" if $DEBUG;
2354         my $change_svcpart = $alternate[0];
2355         $target{$change_svcpart}--;
2356         my $new = new FS::cust_svc { $cust_svc->hash };
2357         $new->svcpart($change_svcpart);
2358         $new->pkgnum($dest_pkgnum);
2359         my $error = $new->replace($cust_svc);
2360         return $error if $error;
2361       } else {
2362         $remaining++;
2363       }
2364     } else {
2365       $remaining++
2366     }
2367   }
2368   return $remaining;
2369 }
2370
2371 =item reexport
2372
2373 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2374 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2375
2376 =cut
2377
2378 sub reexport {
2379   my $self = shift;
2380
2381   local $SIG{HUP} = 'IGNORE';
2382   local $SIG{INT} = 'IGNORE';
2383   local $SIG{QUIT} = 'IGNORE';
2384   local $SIG{TERM} = 'IGNORE';
2385   local $SIG{TSTP} = 'IGNORE';
2386   local $SIG{PIPE} = 'IGNORE';
2387
2388   my $oldAutoCommit = $FS::UID::AutoCommit;
2389   local $FS::UID::AutoCommit = 0;
2390   my $dbh = dbh;
2391
2392   foreach my $cust_svc ( $self->cust_svc ) {
2393     #false laziness w/svc_Common::insert
2394     my $svc_x = $cust_svc->svc_x;
2395     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2396       my $error = $part_export->export_insert($svc_x);
2397       if ( $error ) {
2398         $dbh->rollback if $oldAutoCommit;
2399         return $error;
2400       }
2401     }
2402   }
2403
2404   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2405   '';
2406
2407 }
2408
2409 =item insert_reason
2410
2411 Associates this package with a (suspension or cancellation) reason (see
2412 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2413 L<FS::reason>).
2414
2415 Available options are:
2416
2417 =over 4
2418
2419 =item reason
2420
2421 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.
2422
2423 =item reason_otaker
2424
2425 the access_user (see L<FS::access_user>) providing the reason
2426
2427 =item date
2428
2429 a unix timestamp
2430
2431 =item action
2432
2433 the action (cancel, susp, adjourn, expire) associated with the reason
2434
2435 =back
2436
2437 If there is an error, returns the error, otherwise returns false.
2438
2439 =cut
2440
2441 sub insert_reason {
2442   my ($self, %options) = @_;
2443
2444   my $otaker = $options{reason_otaker} ||
2445                $FS::CurrentUser::CurrentUser->username;
2446
2447   my $reasonnum;
2448   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2449
2450     $reasonnum = $1;
2451
2452   } elsif ( ref($options{'reason'}) ) {
2453
2454     return 'Enter a new reason (or select an existing one)'
2455       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2456
2457     my $reason = new FS::reason({
2458       'reason_type' => $options{'reason'}->{'typenum'},
2459       'reason'      => $options{'reason'}->{'reason'},
2460     });
2461     my $error = $reason->insert;
2462     return $error if $error;
2463
2464     $reasonnum = $reason->reasonnum;
2465
2466   } else {
2467     return "Unparsable reason: ". $options{'reason'};
2468   }
2469
2470   my $cust_pkg_reason =
2471     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2472                               'reasonnum' => $reasonnum,
2473                               'otaker'    => $otaker,
2474                               'action'    => substr(uc($options{'action'}),0,1),
2475                               'date'      => $options{'date'}
2476                                                ? $options{'date'}
2477                                                : time,
2478                             });
2479
2480   $cust_pkg_reason->insert;
2481 }
2482
2483 =item insert_discount
2484
2485 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2486 inserting a new discount on the fly (see L<FS::discount>).
2487
2488 Available options are:
2489
2490 =over 4
2491
2492 =item discountnum
2493
2494 =back
2495
2496 If there is an error, returns the error, otherwise returns false.
2497
2498 =cut
2499
2500 sub insert_discount {
2501   #my ($self, %options) = @_;
2502   my $self = shift;
2503
2504   my $cust_pkg_discount = new FS::cust_pkg_discount {
2505     'pkgnum'      => $self->pkgnum,
2506     'discountnum' => $self->discountnum,
2507     'months_used' => 0,
2508     'end_date'    => '', #XXX
2509     'otaker'      => $self->otaker,
2510     #for the create a new discount case
2511     '_type'       => $self->discountnum__type,
2512     'amount'      => $self->discountnum_amount,
2513     'percent'     => $self->discountnum_percent,
2514     'months'      => $self->discountnum_months,
2515     #'disabled'    => $self->discountnum_disabled,
2516   };
2517
2518   $cust_pkg_discount->insert;
2519 }
2520
2521 =item set_usage USAGE_VALUE_HASHREF
2522
2523 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2524 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2525 upbytes, downbytes, and totalbytes are appropriate keys.
2526
2527 All svc_accts which are part of this package have their values reset.
2528
2529 =cut
2530
2531 sub set_usage {
2532   my ($self, $valueref, %opt) = @_;
2533
2534   foreach my $cust_svc ($self->cust_svc){
2535     my $svc_x = $cust_svc->svc_x;
2536     $svc_x->set_usage($valueref, %opt)
2537       if $svc_x->can("set_usage");
2538   }
2539 }
2540
2541 =item recharge USAGE_VALUE_HASHREF
2542
2543 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2544 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2545 upbytes, downbytes, and totalbytes are appropriate keys.
2546
2547 All svc_accts which are part of this package have their values incremented.
2548
2549 =cut
2550
2551 sub recharge {
2552   my ($self, $valueref) = @_;
2553
2554   foreach my $cust_svc ($self->cust_svc){
2555     my $svc_x = $cust_svc->svc_x;
2556     $svc_x->recharge($valueref)
2557       if $svc_x->can("recharge");
2558   }
2559 }
2560
2561 =item cust_pkg_discount
2562
2563 =cut
2564
2565 sub cust_pkg_discount {
2566   my $self = shift;
2567   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2568 }
2569
2570 =item cust_pkg_discount_active
2571
2572 =cut
2573
2574 sub cust_pkg_discount_active {
2575   my $self = shift;
2576   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2577 }
2578
2579 =back
2580
2581 =head1 CLASS METHODS
2582
2583 =over 4
2584
2585 =item recurring_sql
2586
2587 Returns an SQL expression identifying recurring packages.
2588
2589 =cut
2590
2591 sub recurring_sql { "
2592   '0' != ( select freq from part_pkg
2593              where cust_pkg.pkgpart = part_pkg.pkgpart )
2594 "; }
2595
2596 =item onetime_sql
2597
2598 Returns an SQL expression identifying one-time packages.
2599
2600 =cut
2601
2602 sub onetime_sql { "
2603   '0' = ( select freq from part_pkg
2604             where cust_pkg.pkgpart = part_pkg.pkgpart )
2605 "; }
2606
2607 =item ordered_sql
2608
2609 Returns an SQL expression identifying ordered packages (recurring packages not
2610 yet billed).
2611
2612 =cut
2613
2614 sub ordered_sql {
2615    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2616 }
2617
2618 =item active_sql
2619
2620 Returns an SQL expression identifying active packages.
2621
2622 =cut
2623
2624 sub active_sql {
2625   $_[0]->recurring_sql. "
2626   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2627   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2628   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2629 "; }
2630
2631 =item not_yet_billed_sql
2632
2633 Returns an SQL expression identifying packages which have not yet been billed.
2634
2635 =cut
2636
2637 sub not_yet_billed_sql { "
2638       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2639   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2640   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2641 "; }
2642
2643 =item inactive_sql
2644
2645 Returns an SQL expression identifying inactive packages (one-time packages
2646 that are otherwise unsuspended/uncancelled).
2647
2648 =cut
2649
2650 sub inactive_sql { "
2651   ". $_[0]->onetime_sql(). "
2652   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2653   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2654   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2655 "; }
2656
2657 =item susp_sql
2658 =item suspended_sql
2659
2660 Returns an SQL expression identifying suspended packages.
2661
2662 =cut
2663
2664 sub suspended_sql { susp_sql(@_); }
2665 sub susp_sql {
2666   #$_[0]->recurring_sql(). ' AND '.
2667   "
2668         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2669     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2670   ";
2671 }
2672
2673 =item cancel_sql
2674 =item cancelled_sql
2675
2676 Returns an SQL exprression identifying cancelled packages.
2677
2678 =cut
2679
2680 sub cancelled_sql { cancel_sql(@_); }
2681 sub cancel_sql {
2682   #$_[0]->recurring_sql(). ' AND '.
2683   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2684 }
2685
2686 =item status_sql
2687
2688 Returns an SQL expression to give the package status as a string.
2689
2690 =cut
2691
2692 sub status_sql {
2693 "CASE
2694   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2695   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2696   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2697   WHEN ".onetime_sql()." THEN 'one-time charge'
2698   ELSE 'active'
2699 END"
2700 }
2701
2702 =item search HASHREF
2703
2704 (Class method)
2705
2706 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2707 Valid parameters are
2708
2709 =over 4
2710
2711 =item agentnum
2712
2713 =item magic
2714
2715 active, inactive, suspended, cancel (or cancelled)
2716
2717 =item status
2718
2719 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2720
2721 =item custom
2722
2723  boolean selects custom packages
2724
2725 =item classnum
2726
2727 =item pkgpart
2728
2729 pkgpart or arrayref or hashref of pkgparts
2730
2731 =item setup
2732
2733 arrayref of beginning and ending epoch date
2734
2735 =item last_bill
2736
2737 arrayref of beginning and ending epoch date
2738
2739 =item bill
2740
2741 arrayref of beginning and ending epoch date
2742
2743 =item adjourn
2744
2745 arrayref of beginning and ending epoch date
2746
2747 =item susp
2748
2749 arrayref of beginning and ending epoch date
2750
2751 =item expire
2752
2753 arrayref of beginning and ending epoch date
2754
2755 =item cancel
2756
2757 arrayref of beginning and ending epoch date
2758
2759 =item query
2760
2761 pkgnum or APKG_pkgnum
2762
2763 =item cust_fields
2764
2765 a value suited to passing to FS::UI::Web::cust_header
2766
2767 =item CurrentUser
2768
2769 specifies the user for agent virtualization
2770
2771 =item fcc_line
2772
2773  boolean selects packages containing fcc form 477 telco lines
2774
2775 =back
2776
2777 =cut
2778
2779 sub search {
2780   my ($class, $params) = @_;
2781   my @where = ();
2782
2783   ##
2784   # parse agent
2785   ##
2786
2787   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2788     push @where,
2789       "cust_main.agentnum = $1";
2790   }
2791
2792   ##
2793   # parse custnum
2794   ##
2795
2796   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2797     push @where,
2798       "cust_pkg.custnum = $1";
2799   }
2800
2801   ##
2802   # custbatch
2803   ##
2804
2805   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2806     push @where,
2807       "cust_pkg.pkgbatch = '$1'";
2808   }
2809
2810   ##
2811   # parse status
2812   ##
2813
2814   if (    $params->{'magic'}  eq 'active'
2815        || $params->{'status'} eq 'active' ) {
2816
2817     push @where, FS::cust_pkg->active_sql();
2818
2819   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2820             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2821
2822     push @where, FS::cust_pkg->not_yet_billed_sql();
2823
2824   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2825             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2826
2827     push @where, FS::cust_pkg->inactive_sql();
2828
2829   } elsif (    $params->{'magic'}  eq 'suspended'
2830             || $params->{'status'} eq 'suspended'  ) {
2831
2832     push @where, FS::cust_pkg->suspended_sql();
2833
2834   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2835             || $params->{'status'} =~ /^cancell?ed$/ ) {
2836
2837     push @where, FS::cust_pkg->cancelled_sql();
2838
2839   }
2840
2841   ###
2842   # parse package class
2843   ###
2844
2845   #false lazinessish w/graph/cust_bill_pkg.cgi
2846   my $classnum = 0;
2847   my @pkg_class = ();
2848   if ( exists($params->{'classnum'})
2849        && $params->{'classnum'} =~ /^(\d*)$/
2850      )
2851   {
2852     $classnum = $1;
2853     if ( $classnum ) { #a specific class
2854       push @where, "part_pkg.classnum = $classnum";
2855
2856       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2857       #die "classnum $classnum not found!" unless $pkg_class[0];
2858       #$title .= $pkg_class[0]->classname.' ';
2859
2860     } elsif ( $classnum eq '' ) { #the empty class
2861
2862       push @where, "part_pkg.classnum IS NULL";
2863       #$title .= 'Empty class ';
2864       #@pkg_class = ( '(empty class)' );
2865     } elsif ( $classnum eq '0' ) {
2866       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2867       #push @pkg_class, '(empty class)';
2868     } else {
2869       die "illegal classnum";
2870     }
2871   }
2872   #eslaf
2873
2874   ###
2875   # parse package report options
2876   ###
2877
2878   my @report_option = ();
2879   if ( exists($params->{'report_option'})
2880        && $params->{'report_option'} =~ /^([,\d]*)$/
2881      )
2882   {
2883     @report_option = split(',', $1);
2884   }
2885
2886   if (@report_option) {
2887     # this will result in the empty set for the dangling comma case as it should
2888     push @where,
2889       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2890                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2891                     AND optionname = 'report_option_$_'
2892                     AND optionvalue = '1' )"
2893          } @report_option;
2894   }
2895
2896   #eslaf
2897
2898   ###
2899   # parse custom
2900   ###
2901
2902   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2903
2904   ###
2905   # parse fcc_line
2906   ###
2907
2908   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2909
2910   ###
2911   # parse censustract
2912   ###
2913
2914   if ( exists($params->{'censustract'}) ) {
2915     $params->{'censustract'} =~ /^([.\d]*)$/;
2916     my $censustract = "cust_main.censustract = '$1'";
2917     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2918     push @where,  "( $censustract )";
2919   }
2920
2921   ###
2922   # parse part_pkg
2923   ###
2924
2925   if ( ref($params->{'pkgpart'}) ) {
2926
2927     my @pkgpart = ();
2928     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2929       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2930     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2931       @pkgpart = @{ $params->{'pkgpart'} };
2932     } else {
2933       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2934     }
2935
2936     @pkgpart = grep /^(\d+)$/, @pkgpart;
2937
2938     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2939
2940   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2941     push @where, "pkgpart = $1";
2942   }
2943
2944   ###
2945   # parse dates
2946   ###
2947
2948   my $orderby = '';
2949
2950   #false laziness w/report_cust_pkg.html
2951   my %disable = (
2952     'all'             => {},
2953     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2954     'active'          => { 'susp'=>1, 'cancel'=>1 },
2955     'suspended'       => { 'cancel' => 1 },
2956     'cancelled'       => {},
2957     ''                => {},
2958   );
2959
2960   if( exists($params->{'active'} ) ) {
2961     # This overrides all the other date-related fields
2962     my($beginning, $ending) = @{$params->{'active'}};
2963     push @where,
2964       "cust_pkg.setup IS NOT NULL",
2965       "cust_pkg.setup <= $ending",
2966       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2967       "NOT (".FS::cust_pkg->onetime_sql . ")";
2968   }
2969   else {
2970     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2971
2972       next unless exists($params->{$field});
2973
2974       my($beginning, $ending) = @{$params->{$field}};
2975
2976       next if $beginning == 0 && $ending == 4294967295;
2977
2978       push @where,
2979         "cust_pkg.$field IS NOT NULL",
2980         "cust_pkg.$field >= $beginning",
2981         "cust_pkg.$field <= $ending";
2982
2983       $orderby ||= "ORDER BY cust_pkg.$field";
2984
2985     }
2986   }
2987
2988   $orderby ||= 'ORDER BY bill';
2989
2990   ###
2991   # parse magic, legacy, etc.
2992   ###
2993
2994   if ( $params->{'magic'} &&
2995        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2996   ) {
2997
2998     $orderby = 'ORDER BY pkgnum';
2999
3000     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3001       push @where, "pkgpart = $1";
3002     }
3003
3004   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3005
3006     $orderby = 'ORDER BY pkgnum';
3007
3008   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3009
3010     $orderby = 'ORDER BY pkgnum';
3011
3012     push @where, '0 < (
3013       SELECT count(*) FROM pkg_svc
3014        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3015          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3016                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3017                                      AND cust_svc.svcpart = pkg_svc.svcpart
3018                                 )
3019     )';
3020
3021   }
3022
3023   ##
3024   # setup queries, links, subs, etc. for the search
3025   ##
3026
3027   # here is the agent virtualization
3028   if ($params->{CurrentUser}) {
3029     my $access_user =
3030       qsearchs('access_user', { username => $params->{CurrentUser} });
3031
3032     if ($access_user) {
3033       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3034     } else {
3035       push @where, "1=0";
3036     }
3037   } else {
3038     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3039   }
3040
3041   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3042
3043   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
3044                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3045                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3046
3047   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3048
3049   my $sql_query = {
3050     'table'       => 'cust_pkg',
3051     'hashref'     => {},
3052     'select'      => join(', ',
3053                                 'cust_pkg.*',
3054                                 ( map "part_pkg.$_", qw( pkg freq ) ),
3055                                 'pkg_class.classname',
3056                                 'cust_main.custnum AS cust_main_custnum',
3057                                 FS::UI::Web::cust_sql_fields(
3058                                   $params->{'cust_fields'}
3059                                 ),
3060                      ),
3061     'extra_sql'   => "$extra_sql $orderby",
3062     'addl_from'   => $addl_from,
3063     'count_query' => $count_query,
3064   };
3065
3066 }
3067
3068 =item fcc_477_count
3069
3070 Returns a list of two package counts.  The first is a count of packages
3071 based on the supplied criteria and the second is the count of residential
3072 packages with those same criteria.  Criteria are specified as in the search
3073 method.
3074
3075 =cut
3076
3077 sub fcc_477_count {
3078   my ($class, $params) = @_;
3079
3080   my $sql_query = $class->search( $params );
3081
3082   my $count_sql = delete($sql_query->{'count_query'});
3083   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3084     or die "couldn't parse count_sql";
3085
3086   my $count_sth = dbh->prepare($count_sql)
3087     or die "Error preparing $count_sql: ". dbh->errstr;
3088   $count_sth->execute
3089     or die "Error executing $count_sql: ". $count_sth->errstr;
3090   my $count_arrayref = $count_sth->fetchrow_arrayref;
3091
3092   return ( @$count_arrayref );
3093
3094 }
3095
3096
3097 =item location_sql
3098
3099 Returns a list: the first item is an SQL fragment identifying matching
3100 packages/customers via location (taking into account shipping and package
3101 address taxation, if enabled), and subsequent items are the parameters to
3102 substitute for the placeholders in that fragment.
3103
3104 =cut
3105
3106 sub location_sql {
3107   my($class, %opt) = @_;
3108   my $ornull = $opt{'ornull'};
3109
3110   my $conf = new FS::Conf;
3111
3112   # '?' placeholders in _location_sql_where
3113   my $x = $ornull ? 3 : 2;
3114   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3115
3116   my $main_where;
3117   my @main_param;
3118   if ( $conf->exists('tax-ship_address') ) {
3119
3120     $main_where = "(
3121          (     ( ship_last IS NULL     OR  ship_last  = '' )
3122            AND ". _location_sql_where('cust_main', '', $ornull ). "
3123          )
3124       OR (       ship_last IS NOT NULL AND ship_last != ''
3125            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3126          )
3127     )";
3128     #    AND payby != 'COMP'
3129
3130     @main_param = ( @bill_param, @bill_param );
3131
3132   } else {
3133
3134     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3135     @main_param = @bill_param;
3136
3137   }
3138
3139   my $where;
3140   my @param;
3141   if ( $conf->exists('tax-pkg_address') ) {
3142
3143     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3144
3145     $where = " (
3146                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3147                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3148                )
3149              ";
3150     @param = ( @main_param, @bill_param );
3151
3152   } else {
3153
3154     $where = $main_where;
3155     @param = @main_param;
3156
3157   }
3158
3159   ( $where, @param );
3160
3161 }
3162
3163 #subroutine, helper for location_sql
3164 sub _location_sql_where {
3165   my $table  = shift;
3166   my $prefix = @_ ? shift : '';
3167   my $ornull = @_ ? shift : '';
3168
3169 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3170
3171   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3172
3173   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3174   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3175   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3176
3177 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3178   "
3179         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3180     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3181     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3182     AND   $table.${prefix}country = ?
3183   ";
3184 }
3185
3186 =head1 SUBROUTINES
3187
3188 =over 4
3189
3190 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3191
3192 CUSTNUM is a customer (see L<FS::cust_main>)
3193
3194 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3195 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3196 permitted.
3197
3198 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3199 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3200 new billing items.  An error is returned if this is not possible (see
3201 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3202 parameter.
3203
3204 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3205 newly-created cust_pkg objects.
3206
3207 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3208 and inserted.  Multiple FS::pkg_referral records can be created by
3209 setting I<refnum> to an array reference of refnums or a hash reference with
3210 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3211 record will be created corresponding to cust_main.refnum.
3212
3213 =cut
3214
3215 sub order {
3216   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3217
3218   my $conf = new FS::Conf;
3219
3220   # Transactionize this whole mess
3221   local $SIG{HUP} = 'IGNORE';
3222   local $SIG{INT} = 'IGNORE';
3223   local $SIG{QUIT} = 'IGNORE';
3224   local $SIG{TERM} = 'IGNORE';
3225   local $SIG{TSTP} = 'IGNORE';
3226   local $SIG{PIPE} = 'IGNORE';
3227
3228   my $oldAutoCommit = $FS::UID::AutoCommit;
3229   local $FS::UID::AutoCommit = 0;
3230   my $dbh = dbh;
3231
3232   my $error;
3233 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3234 #  return "Customer not found: $custnum" unless $cust_main;
3235
3236   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3237     if $DEBUG;
3238
3239   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3240                          @$remove_pkgnum;
3241
3242   my $change = scalar(@old_cust_pkg) != 0;
3243
3244   my %hash = ();
3245   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3246
3247     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3248          " to pkgpart ". $pkgparts->[0]. "\n"
3249       if $DEBUG;
3250
3251     my $err_or_cust_pkg =
3252       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3253                                 'refnum'  => $refnum,
3254                               );
3255
3256     unless (ref($err_or_cust_pkg)) {
3257       $dbh->rollback if $oldAutoCommit;
3258       return $err_or_cust_pkg;
3259     }
3260
3261     push @$return_cust_pkg, $err_or_cust_pkg;
3262     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3263     return '';
3264
3265   }
3266
3267   # Create the new packages.
3268   foreach my $pkgpart (@$pkgparts) {
3269
3270     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3271
3272     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3273                                       pkgpart => $pkgpart,
3274                                       refnum  => $refnum,
3275                                       %hash,
3276                                     };
3277     $error = $cust_pkg->insert( 'change' => $change );
3278     if ($error) {
3279       $dbh->rollback if $oldAutoCommit;
3280       return $error;
3281     }
3282     push @$return_cust_pkg, $cust_pkg;
3283   }
3284   # $return_cust_pkg now contains refs to all of the newly
3285   # created packages.
3286
3287   # Transfer services and cancel old packages.
3288   foreach my $old_pkg (@old_cust_pkg) {
3289
3290     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3291       if $DEBUG;
3292
3293     foreach my $new_pkg (@$return_cust_pkg) {
3294       $error = $old_pkg->transfer($new_pkg);
3295       if ($error and $error == 0) {
3296         # $old_pkg->transfer failed.
3297         $dbh->rollback if $oldAutoCommit;
3298         return $error;
3299       }
3300     }
3301
3302     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3303       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3304       foreach my $new_pkg (@$return_cust_pkg) {
3305         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3306         if ($error and $error == 0) {
3307           # $old_pkg->transfer failed.
3308         $dbh->rollback if $oldAutoCommit;
3309         return $error;
3310         }
3311       }
3312     }
3313
3314     if ($error > 0) {
3315       # Transfers were successful, but we went through all of the
3316       # new packages and still had services left on the old package.
3317       # We can't cancel the package under the circumstances, so abort.
3318       $dbh->rollback if $oldAutoCommit;
3319       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3320     }
3321     $error = $old_pkg->cancel( quiet=>1 );
3322     if ($error) {
3323       $dbh->rollback;
3324       return $error;
3325     }
3326   }
3327   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3328   '';
3329 }
3330
3331 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3332
3333 A bulk change method to change packages for multiple customers.
3334
3335 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3336 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3337 permitted.
3338
3339 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3340 replace.  The services (see L<FS::cust_svc>) are moved to the
3341 new billing items.  An error is returned if this is not possible (see
3342 L<FS::pkg_svc>).
3343
3344 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3345 newly-created cust_pkg objects.
3346
3347 =cut
3348
3349 sub bulk_change {
3350   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3351
3352   # Transactionize this whole mess
3353   local $SIG{HUP} = 'IGNORE';
3354   local $SIG{INT} = 'IGNORE';
3355   local $SIG{QUIT} = 'IGNORE';
3356   local $SIG{TERM} = 'IGNORE';
3357   local $SIG{TSTP} = 'IGNORE';
3358   local $SIG{PIPE} = 'IGNORE';
3359
3360   my $oldAutoCommit = $FS::UID::AutoCommit;
3361   local $FS::UID::AutoCommit = 0;
3362   my $dbh = dbh;
3363
3364   my @errors;
3365   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3366                          @$remove_pkgnum;
3367
3368   while(scalar(@old_cust_pkg)) {
3369     my @return = ();
3370     my $custnum = $old_cust_pkg[0]->custnum;
3371     my (@remove) = map { $_->pkgnum }
3372                    grep { $_->custnum == $custnum } @old_cust_pkg;
3373     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3374
3375     my $error = order $custnum, $pkgparts, \@remove, \@return;
3376
3377     push @errors, $error
3378       if $error;
3379     push @$return_cust_pkg, @return;
3380   }
3381
3382   if (scalar(@errors)) {
3383     $dbh->rollback if $oldAutoCommit;
3384     return join(' / ', @errors);
3385   }
3386
3387   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3388   '';
3389 }
3390
3391 # Used by FS::Upgrade to migrate to a new database.
3392 sub _upgrade_data {  # class method
3393   my ($class, %opts) = @_;
3394   $class->_upgrade_otaker(%opts);
3395   my @statements = (
3396     # RT#10139, bug resulting in contract_end being set when it shouldn't
3397   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3398     # RT#10830, bad calculation of prorate date near end of year
3399     # the date range for bill is December 2009, and we move it forward
3400     # one year if it's before the previous bill date (which it should
3401     # never be)
3402   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3403   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3404   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3405   );
3406   foreach my $sql (@statements) {
3407     my $sth = dbh->prepare($sql);
3408     $sth->execute or die $sth->errstr;
3409   }
3410 }
3411
3412 =back
3413
3414 =head1 BUGS
3415
3416 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3417
3418 In sub order, the @pkgparts array (passed by reference) is clobbered.
3419
3420 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3421 method to pass dates to the recur_prog expression, it should do so.
3422
3423 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3424 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3425 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3426 configuration values.  Probably need a subroutine which decides what to do
3427 based on whether or not we've fetched the user yet, rather than a hash.  See
3428 FS::UID and the TODO.
3429
3430 Now that things are transactional should the check in the insert method be
3431 moved to check ?
3432
3433 =head1 SEE ALSO
3434
3435 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3436 L<FS::pkg_svc>, schema.html from the base documentation
3437
3438 =cut
3439
3440 1;
3441