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     #for the create a new discount case
2510     '_type'       => $self->discountnum__type,
2511     'amount'      => $self->discountnum_amount,
2512     'percent'     => $self->discountnum_percent,
2513     'months'      => $self->discountnum_months,
2514     #'disabled'    => $self->discountnum_disabled,
2515   };
2516
2517   $cust_pkg_discount->insert;
2518 }
2519
2520 =item set_usage USAGE_VALUE_HASHREF
2521
2522 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2523 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2524 upbytes, downbytes, and totalbytes are appropriate keys.
2525
2526 All svc_accts which are part of this package have their values reset.
2527
2528 =cut
2529
2530 sub set_usage {
2531   my ($self, $valueref, %opt) = @_;
2532
2533   foreach my $cust_svc ($self->cust_svc){
2534     my $svc_x = $cust_svc->svc_x;
2535     $svc_x->set_usage($valueref, %opt)
2536       if $svc_x->can("set_usage");
2537   }
2538 }
2539
2540 =item recharge USAGE_VALUE_HASHREF
2541
2542 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2543 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2544 upbytes, downbytes, and totalbytes are appropriate keys.
2545
2546 All svc_accts which are part of this package have their values incremented.
2547
2548 =cut
2549
2550 sub recharge {
2551   my ($self, $valueref) = @_;
2552
2553   foreach my $cust_svc ($self->cust_svc){
2554     my $svc_x = $cust_svc->svc_x;
2555     $svc_x->recharge($valueref)
2556       if $svc_x->can("recharge");
2557   }
2558 }
2559
2560 =item cust_pkg_discount
2561
2562 =cut
2563
2564 sub cust_pkg_discount {
2565   my $self = shift;
2566   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2567 }
2568
2569 =item cust_pkg_discount_active
2570
2571 =cut
2572
2573 sub cust_pkg_discount_active {
2574   my $self = shift;
2575   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2576 }
2577
2578 =back
2579
2580 =head1 CLASS METHODS
2581
2582 =over 4
2583
2584 =item recurring_sql
2585
2586 Returns an SQL expression identifying recurring packages.
2587
2588 =cut
2589
2590 sub recurring_sql { "
2591   '0' != ( select freq from part_pkg
2592              where cust_pkg.pkgpart = part_pkg.pkgpart )
2593 "; }
2594
2595 =item onetime_sql
2596
2597 Returns an SQL expression identifying one-time packages.
2598
2599 =cut
2600
2601 sub onetime_sql { "
2602   '0' = ( select freq from part_pkg
2603             where cust_pkg.pkgpart = part_pkg.pkgpart )
2604 "; }
2605
2606 =item ordered_sql
2607
2608 Returns an SQL expression identifying ordered packages (recurring packages not
2609 yet billed).
2610
2611 =cut
2612
2613 sub ordered_sql {
2614    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2615 }
2616
2617 =item active_sql
2618
2619 Returns an SQL expression identifying active packages.
2620
2621 =cut
2622
2623 sub active_sql {
2624   $_[0]->recurring_sql. "
2625   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2626   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2627   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2628 "; }
2629
2630 =item not_yet_billed_sql
2631
2632 Returns an SQL expression identifying packages which have not yet been billed.
2633
2634 =cut
2635
2636 sub not_yet_billed_sql { "
2637       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2638   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2639   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2640 "; }
2641
2642 =item inactive_sql
2643
2644 Returns an SQL expression identifying inactive packages (one-time packages
2645 that are otherwise unsuspended/uncancelled).
2646
2647 =cut
2648
2649 sub inactive_sql { "
2650   ". $_[0]->onetime_sql(). "
2651   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2652   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2653   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2654 "; }
2655
2656 =item susp_sql
2657 =item suspended_sql
2658
2659 Returns an SQL expression identifying suspended packages.
2660
2661 =cut
2662
2663 sub suspended_sql { susp_sql(@_); }
2664 sub susp_sql {
2665   #$_[0]->recurring_sql(). ' AND '.
2666   "
2667         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2668     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2669   ";
2670 }
2671
2672 =item cancel_sql
2673 =item cancelled_sql
2674
2675 Returns an SQL exprression identifying cancelled packages.
2676
2677 =cut
2678
2679 sub cancelled_sql { cancel_sql(@_); }
2680 sub cancel_sql {
2681   #$_[0]->recurring_sql(). ' AND '.
2682   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2683 }
2684
2685 =item status_sql
2686
2687 Returns an SQL expression to give the package status as a string.
2688
2689 =cut
2690
2691 sub status_sql {
2692 "CASE
2693   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2694   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2695   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2696   WHEN ".onetime_sql()." THEN 'one-time charge'
2697   ELSE 'active'
2698 END"
2699 }
2700
2701 =item search HASHREF
2702
2703 (Class method)
2704
2705 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2706 Valid parameters are
2707
2708 =over 4
2709
2710 =item agentnum
2711
2712 =item magic
2713
2714 active, inactive, suspended, cancel (or cancelled)
2715
2716 =item status
2717
2718 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2719
2720 =item custom
2721
2722  boolean selects custom packages
2723
2724 =item classnum
2725
2726 =item pkgpart
2727
2728 pkgpart or arrayref or hashref of pkgparts
2729
2730 =item setup
2731
2732 arrayref of beginning and ending epoch date
2733
2734 =item last_bill
2735
2736 arrayref of beginning and ending epoch date
2737
2738 =item bill
2739
2740 arrayref of beginning and ending epoch date
2741
2742 =item adjourn
2743
2744 arrayref of beginning and ending epoch date
2745
2746 =item susp
2747
2748 arrayref of beginning and ending epoch date
2749
2750 =item expire
2751
2752 arrayref of beginning and ending epoch date
2753
2754 =item cancel
2755
2756 arrayref of beginning and ending epoch date
2757
2758 =item query
2759
2760 pkgnum or APKG_pkgnum
2761
2762 =item cust_fields
2763
2764 a value suited to passing to FS::UI::Web::cust_header
2765
2766 =item CurrentUser
2767
2768 specifies the user for agent virtualization
2769
2770 =item fcc_line
2771
2772  boolean selects packages containing fcc form 477 telco lines
2773
2774 =back
2775
2776 =cut
2777
2778 sub search {
2779   my ($class, $params) = @_;
2780   my @where = ();
2781
2782   ##
2783   # parse agent
2784   ##
2785
2786   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2787     push @where,
2788       "cust_main.agentnum = $1";
2789   }
2790
2791   ##
2792   # parse custnum
2793   ##
2794
2795   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2796     push @where,
2797       "cust_pkg.custnum = $1";
2798   }
2799
2800   ##
2801   # custbatch
2802   ##
2803
2804   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2805     push @where,
2806       "cust_pkg.pkgbatch = '$1'";
2807   }
2808
2809   ##
2810   # parse status
2811   ##
2812
2813   if (    $params->{'magic'}  eq 'active'
2814        || $params->{'status'} eq 'active' ) {
2815
2816     push @where, FS::cust_pkg->active_sql();
2817
2818   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2819             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2820
2821     push @where, FS::cust_pkg->not_yet_billed_sql();
2822
2823   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2824             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2825
2826     push @where, FS::cust_pkg->inactive_sql();
2827
2828   } elsif (    $params->{'magic'}  eq 'suspended'
2829             || $params->{'status'} eq 'suspended'  ) {
2830
2831     push @where, FS::cust_pkg->suspended_sql();
2832
2833   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2834             || $params->{'status'} =~ /^cancell?ed$/ ) {
2835
2836     push @where, FS::cust_pkg->cancelled_sql();
2837
2838   }
2839
2840   ###
2841   # parse package class
2842   ###
2843
2844   #false lazinessish w/graph/cust_bill_pkg.cgi
2845   my $classnum = 0;
2846   my @pkg_class = ();
2847   if ( exists($params->{'classnum'})
2848        && $params->{'classnum'} =~ /^(\d*)$/
2849      )
2850   {
2851     $classnum = $1;
2852     if ( $classnum ) { #a specific class
2853       push @where, "part_pkg.classnum = $classnum";
2854
2855       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2856       #die "classnum $classnum not found!" unless $pkg_class[0];
2857       #$title .= $pkg_class[0]->classname.' ';
2858
2859     } elsif ( $classnum eq '' ) { #the empty class
2860
2861       push @where, "part_pkg.classnum IS NULL";
2862       #$title .= 'Empty class ';
2863       #@pkg_class = ( '(empty class)' );
2864     } elsif ( $classnum eq '0' ) {
2865       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2866       #push @pkg_class, '(empty class)';
2867     } else {
2868       die "illegal classnum";
2869     }
2870   }
2871   #eslaf
2872
2873   ###
2874   # parse package report options
2875   ###
2876
2877   my @report_option = ();
2878   if ( exists($params->{'report_option'})
2879        && $params->{'report_option'} =~ /^([,\d]*)$/
2880      )
2881   {
2882     @report_option = split(',', $1);
2883   }
2884
2885   if (@report_option) {
2886     # this will result in the empty set for the dangling comma case as it should
2887     push @where,
2888       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2889                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2890                     AND optionname = 'report_option_$_'
2891                     AND optionvalue = '1' )"
2892          } @report_option;
2893   }
2894
2895   #eslaf
2896
2897   ###
2898   # parse custom
2899   ###
2900
2901   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2902
2903   ###
2904   # parse fcc_line
2905   ###
2906
2907   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2908
2909   ###
2910   # parse censustract
2911   ###
2912
2913   if ( exists($params->{'censustract'}) ) {
2914     $params->{'censustract'} =~ /^([.\d]*)$/;
2915     my $censustract = "cust_main.censustract = '$1'";
2916     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2917     push @where,  "( $censustract )";
2918   }
2919
2920   ###
2921   # parse part_pkg
2922   ###
2923
2924   if ( ref($params->{'pkgpart'}) ) {
2925
2926     my @pkgpart = ();
2927     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2928       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2929     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2930       @pkgpart = @{ $params->{'pkgpart'} };
2931     } else {
2932       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2933     }
2934
2935     @pkgpart = grep /^(\d+)$/, @pkgpart;
2936
2937     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2938
2939   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2940     push @where, "pkgpart = $1";
2941   }
2942
2943   ###
2944   # parse dates
2945   ###
2946
2947   my $orderby = '';
2948
2949   #false laziness w/report_cust_pkg.html
2950   my %disable = (
2951     'all'             => {},
2952     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2953     'active'          => { 'susp'=>1, 'cancel'=>1 },
2954     'suspended'       => { 'cancel' => 1 },
2955     'cancelled'       => {},
2956     ''                => {},
2957   );
2958
2959   if( exists($params->{'active'} ) ) {
2960     # This overrides all the other date-related fields
2961     my($beginning, $ending) = @{$params->{'active'}};
2962     push @where,
2963       "cust_pkg.setup IS NOT NULL",
2964       "cust_pkg.setup <= $ending",
2965       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2966       "NOT (".FS::cust_pkg->onetime_sql . ")";
2967   }
2968   else {
2969     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2970
2971       next unless exists($params->{$field});
2972
2973       my($beginning, $ending) = @{$params->{$field}};
2974
2975       next if $beginning == 0 && $ending == 4294967295;
2976
2977       push @where,
2978         "cust_pkg.$field IS NOT NULL",
2979         "cust_pkg.$field >= $beginning",
2980         "cust_pkg.$field <= $ending";
2981
2982       $orderby ||= "ORDER BY cust_pkg.$field";
2983
2984     }
2985   }
2986
2987   $orderby ||= 'ORDER BY bill';
2988
2989   ###
2990   # parse magic, legacy, etc.
2991   ###
2992
2993   if ( $params->{'magic'} &&
2994        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2995   ) {
2996
2997     $orderby = 'ORDER BY pkgnum';
2998
2999     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3000       push @where, "pkgpart = $1";
3001     }
3002
3003   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3004
3005     $orderby = 'ORDER BY pkgnum';
3006
3007   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3008
3009     $orderby = 'ORDER BY pkgnum';
3010
3011     push @where, '0 < (
3012       SELECT count(*) FROM pkg_svc
3013        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3014          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3015                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3016                                      AND cust_svc.svcpart = pkg_svc.svcpart
3017                                 )
3018     )';
3019
3020   }
3021
3022   ##
3023   # setup queries, links, subs, etc. for the search
3024   ##
3025
3026   # here is the agent virtualization
3027   if ($params->{CurrentUser}) {
3028     my $access_user =
3029       qsearchs('access_user', { username => $params->{CurrentUser} });
3030
3031     if ($access_user) {
3032       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3033     } else {
3034       push @where, "1=0";
3035     }
3036   } else {
3037     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3038   }
3039
3040   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3041
3042   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
3043                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3044                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
3045
3046   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
3047
3048   my $sql_query = {
3049     'table'       => 'cust_pkg',
3050     'hashref'     => {},
3051     'select'      => join(', ',
3052                                 'cust_pkg.*',
3053                                 ( map "part_pkg.$_", qw( pkg freq ) ),
3054                                 'pkg_class.classname',
3055                                 'cust_main.custnum AS cust_main_custnum',
3056                                 FS::UI::Web::cust_sql_fields(
3057                                   $params->{'cust_fields'}
3058                                 ),
3059                      ),
3060     'extra_sql'   => "$extra_sql $orderby",
3061     'addl_from'   => $addl_from,
3062     'count_query' => $count_query,
3063   };
3064
3065 }
3066
3067 =item fcc_477_count
3068
3069 Returns a list of two package counts.  The first is a count of packages
3070 based on the supplied criteria and the second is the count of residential
3071 packages with those same criteria.  Criteria are specified as in the search
3072 method.
3073
3074 =cut
3075
3076 sub fcc_477_count {
3077   my ($class, $params) = @_;
3078
3079   my $sql_query = $class->search( $params );
3080
3081   my $count_sql = delete($sql_query->{'count_query'});
3082   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3083     or die "couldn't parse count_sql";
3084
3085   my $count_sth = dbh->prepare($count_sql)
3086     or die "Error preparing $count_sql: ". dbh->errstr;
3087   $count_sth->execute
3088     or die "Error executing $count_sql: ". $count_sth->errstr;
3089   my $count_arrayref = $count_sth->fetchrow_arrayref;
3090
3091   return ( @$count_arrayref );
3092
3093 }
3094
3095
3096 =item location_sql
3097
3098 Returns a list: the first item is an SQL fragment identifying matching
3099 packages/customers via location (taking into account shipping and package
3100 address taxation, if enabled), and subsequent items are the parameters to
3101 substitute for the placeholders in that fragment.
3102
3103 =cut
3104
3105 sub location_sql {
3106   my($class, %opt) = @_;
3107   my $ornull = $opt{'ornull'};
3108
3109   my $conf = new FS::Conf;
3110
3111   # '?' placeholders in _location_sql_where
3112   my $x = $ornull ? 3 : 2;
3113   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3114
3115   my $main_where;
3116   my @main_param;
3117   if ( $conf->exists('tax-ship_address') ) {
3118
3119     $main_where = "(
3120          (     ( ship_last IS NULL     OR  ship_last  = '' )
3121            AND ". _location_sql_where('cust_main', '', $ornull ). "
3122          )
3123       OR (       ship_last IS NOT NULL AND ship_last != ''
3124            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3125          )
3126     )";
3127     #    AND payby != 'COMP'
3128
3129     @main_param = ( @bill_param, @bill_param );
3130
3131   } else {
3132
3133     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3134     @main_param = @bill_param;
3135
3136   }
3137
3138   my $where;
3139   my @param;
3140   if ( $conf->exists('tax-pkg_address') ) {
3141
3142     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3143
3144     $where = " (
3145                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3146                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3147                )
3148              ";
3149     @param = ( @main_param, @bill_param );
3150
3151   } else {
3152
3153     $where = $main_where;
3154     @param = @main_param;
3155
3156   }
3157
3158   ( $where, @param );
3159
3160 }
3161
3162 #subroutine, helper for location_sql
3163 sub _location_sql_where {
3164   my $table  = shift;
3165   my $prefix = @_ ? shift : '';
3166   my $ornull = @_ ? shift : '';
3167
3168 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3169
3170   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3171
3172   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3173   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3174   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3175
3176 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3177   "
3178         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3179     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3180     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3181     AND   $table.${prefix}country = ?
3182   ";
3183 }
3184
3185 =head1 SUBROUTINES
3186
3187 =over 4
3188
3189 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3190
3191 CUSTNUM is a customer (see L<FS::cust_main>)
3192
3193 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3194 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3195 permitted.
3196
3197 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3198 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3199 new billing items.  An error is returned if this is not possible (see
3200 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3201 parameter.
3202
3203 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3204 newly-created cust_pkg objects.
3205
3206 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3207 and inserted.  Multiple FS::pkg_referral records can be created by
3208 setting I<refnum> to an array reference of refnums or a hash reference with
3209 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3210 record will be created corresponding to cust_main.refnum.
3211
3212 =cut
3213
3214 sub order {
3215   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3216
3217   my $conf = new FS::Conf;
3218
3219   # Transactionize this whole mess
3220   local $SIG{HUP} = 'IGNORE';
3221   local $SIG{INT} = 'IGNORE';
3222   local $SIG{QUIT} = 'IGNORE';
3223   local $SIG{TERM} = 'IGNORE';
3224   local $SIG{TSTP} = 'IGNORE';
3225   local $SIG{PIPE} = 'IGNORE';
3226
3227   my $oldAutoCommit = $FS::UID::AutoCommit;
3228   local $FS::UID::AutoCommit = 0;
3229   my $dbh = dbh;
3230
3231   my $error;
3232 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3233 #  return "Customer not found: $custnum" unless $cust_main;
3234
3235   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3236     if $DEBUG;
3237
3238   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3239                          @$remove_pkgnum;
3240
3241   my $change = scalar(@old_cust_pkg) != 0;
3242
3243   my %hash = ();
3244   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3245
3246     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3247          " to pkgpart ". $pkgparts->[0]. "\n"
3248       if $DEBUG;
3249
3250     my $err_or_cust_pkg =
3251       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3252                                 'refnum'  => $refnum,
3253                               );
3254
3255     unless (ref($err_or_cust_pkg)) {
3256       $dbh->rollback if $oldAutoCommit;
3257       return $err_or_cust_pkg;
3258     }
3259
3260     push @$return_cust_pkg, $err_or_cust_pkg;
3261     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3262     return '';
3263
3264   }
3265
3266   # Create the new packages.
3267   foreach my $pkgpart (@$pkgparts) {
3268
3269     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3270
3271     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3272                                       pkgpart => $pkgpart,
3273                                       refnum  => $refnum,
3274                                       %hash,
3275                                     };
3276     $error = $cust_pkg->insert( 'change' => $change );
3277     if ($error) {
3278       $dbh->rollback if $oldAutoCommit;
3279       return $error;
3280     }
3281     push @$return_cust_pkg, $cust_pkg;
3282   }
3283   # $return_cust_pkg now contains refs to all of the newly
3284   # created packages.
3285
3286   # Transfer services and cancel old packages.
3287   foreach my $old_pkg (@old_cust_pkg) {
3288
3289     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3290       if $DEBUG;
3291
3292     foreach my $new_pkg (@$return_cust_pkg) {
3293       $error = $old_pkg->transfer($new_pkg);
3294       if ($error and $error == 0) {
3295         # $old_pkg->transfer failed.
3296         $dbh->rollback if $oldAutoCommit;
3297         return $error;
3298       }
3299     }
3300
3301     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3302       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3303       foreach my $new_pkg (@$return_cust_pkg) {
3304         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3305         if ($error and $error == 0) {
3306           # $old_pkg->transfer failed.
3307         $dbh->rollback if $oldAutoCommit;
3308         return $error;
3309         }
3310       }
3311     }
3312
3313     if ($error > 0) {
3314       # Transfers were successful, but we went through all of the
3315       # new packages and still had services left on the old package.
3316       # We can't cancel the package under the circumstances, so abort.
3317       $dbh->rollback if $oldAutoCommit;
3318       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3319     }
3320     $error = $old_pkg->cancel( quiet=>1 );
3321     if ($error) {
3322       $dbh->rollback;
3323       return $error;
3324     }
3325   }
3326   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3327   '';
3328 }
3329
3330 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3331
3332 A bulk change method to change packages for multiple customers.
3333
3334 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3335 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3336 permitted.
3337
3338 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3339 replace.  The services (see L<FS::cust_svc>) are moved to the
3340 new billing items.  An error is returned if this is not possible (see
3341 L<FS::pkg_svc>).
3342
3343 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3344 newly-created cust_pkg objects.
3345
3346 =cut
3347
3348 sub bulk_change {
3349   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3350
3351   # Transactionize this whole mess
3352   local $SIG{HUP} = 'IGNORE';
3353   local $SIG{INT} = 'IGNORE';
3354   local $SIG{QUIT} = 'IGNORE';
3355   local $SIG{TERM} = 'IGNORE';
3356   local $SIG{TSTP} = 'IGNORE';
3357   local $SIG{PIPE} = 'IGNORE';
3358
3359   my $oldAutoCommit = $FS::UID::AutoCommit;
3360   local $FS::UID::AutoCommit = 0;
3361   my $dbh = dbh;
3362
3363   my @errors;
3364   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3365                          @$remove_pkgnum;
3366
3367   while(scalar(@old_cust_pkg)) {
3368     my @return = ();
3369     my $custnum = $old_cust_pkg[0]->custnum;
3370     my (@remove) = map { $_->pkgnum }
3371                    grep { $_->custnum == $custnum } @old_cust_pkg;
3372     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3373
3374     my $error = order $custnum, $pkgparts, \@remove, \@return;
3375
3376     push @errors, $error
3377       if $error;
3378     push @$return_cust_pkg, @return;
3379   }
3380
3381   if (scalar(@errors)) {
3382     $dbh->rollback if $oldAutoCommit;
3383     return join(' / ', @errors);
3384   }
3385
3386   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3387   '';
3388 }
3389
3390 # Used by FS::Upgrade to migrate to a new database.
3391 sub _upgrade_data {  # class method
3392   my ($class, %opts) = @_;
3393   $class->_upgrade_otaker(%opts);
3394   my @statements = (
3395     # RT#10139, bug resulting in contract_end being set when it shouldn't
3396   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
3397     # RT#10830, bad calculation of prorate date near end of year
3398     # the date range for bill is December 2009, and we move it forward
3399     # one year if it's before the previous bill date (which it should
3400     # never be)
3401   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
3402   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
3403   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
3404     # RT6628, add order_date to cust_pkg
3405     'update cust_pkg set order_date = (select history_date from h_cust_pkg
3406         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
3407         history_action = \'insert\') where order_date is null',
3408   );
3409   foreach my $sql (@statements) {
3410     my $sth = dbh->prepare($sql);
3411     $sth->execute or die $sth->errstr;
3412   }
3413 }
3414
3415 =back
3416
3417 =head1 BUGS
3418
3419 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3420
3421 In sub order, the @pkgparts array (passed by reference) is clobbered.
3422
3423 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3424 method to pass dates to the recur_prog expression, it should do so.
3425
3426 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3427 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3428 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3429 configuration values.  Probably need a subroutine which decides what to do
3430 based on whether or not we've fetched the user yet, rather than a hash.  See
3431 FS::UID and the TODO.
3432
3433 Now that things are transactional should the check in the insert method be
3434 moved to check ?
3435
3436 =head1 SEE ALSO
3437
3438 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3439 L<FS::pkg_svc>, schema.html from the base documentation
3440
3441 =cut
3442
3443 1;
3444