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