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