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 @cust_svc = $self->_sort_cust_svc(
1654     [ qsearch( 'h_cust_svc',
1655       { 'pkgnum' => $self->pkgnum, },
1656       FS::h_cust_svc->sql_h_search(@_),
1657     ) ]
1658   );
1659   if ( $mode eq 'I' ) {
1660     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
1661     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
1662   }
1663   else {
1664     return @cust_svc;
1665   }
1666 }
1667
1668 sub _sort_cust_svc {
1669   my( $self, $arrayref ) = @_;
1670
1671   my $sort =
1672     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1673
1674   map  { $_->[0] }
1675   sort $sort
1676   map {
1677         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1678                                              'svcpart' => $_->svcpart     } );
1679         [ $_,
1680           $pkg_svc ? $pkg_svc->primary_svc : '',
1681           $pkg_svc ? $pkg_svc->quantity : 0,
1682         ];
1683       }
1684   @$arrayref;
1685
1686 }
1687
1688 =item num_cust_svc [ SVCPART ]
1689
1690 Returns the number of provisioned services for this package.  If a svcpart is
1691 specified, counts only the matching services.
1692
1693 =cut
1694
1695 sub num_cust_svc {
1696   my $self = shift;
1697
1698   return $self->{'_num_cust_svc'}
1699     if !scalar(@_)
1700        && exists($self->{'_num_cust_svc'})
1701        && $self->{'_num_cust_svc'} =~ /\d/;
1702
1703   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1704     if $DEBUG > 2;
1705
1706   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1707   $sql .= ' AND svcpart = ?' if @_;
1708
1709   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1710   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1711   $sth->fetchrow_arrayref->[0];
1712 }
1713
1714 =item available_part_svc
1715
1716 Returns a list of FS::part_svc objects representing services included in this
1717 package but not yet provisioned.  Each FS::part_svc object also has an extra
1718 field, I<num_avail>, which specifies the number of available services.
1719
1720 =cut
1721
1722 sub available_part_svc {
1723   my $self = shift;
1724   grep { $_->num_avail > 0 }
1725     map {
1726           my $part_svc = $_->part_svc;
1727           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1728             $_->quantity - $self->num_cust_svc($_->svcpart);
1729           $part_svc;
1730         }
1731       $self->part_pkg->pkg_svc;
1732 }
1733
1734 =item part_svc
1735
1736 Returns a list of FS::part_svc objects representing provisioned and available
1737 services included in this package.  Each FS::part_svc object also has the
1738 following extra fields:
1739
1740 =over 4
1741
1742 =item num_cust_svc  (count)
1743
1744 =item num_avail     (quantity - count)
1745
1746 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1747
1748 svcnum
1749 label -> ($cust_svc->label)[1]
1750
1751 =back
1752
1753 =cut
1754
1755 sub part_svc {
1756   my $self = shift;
1757
1758   #XXX some sort of sort order besides numeric by svcpart...
1759   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1760     my $pkg_svc = $_;
1761     my $part_svc = $pkg_svc->part_svc;
1762     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1763     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1764     $part_svc->{'Hash'}{'num_avail'}    =
1765       max( 0, $pkg_svc->quantity - $num_cust_svc );
1766     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1767       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1768     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
1769     $part_svc;
1770   } $self->part_pkg->pkg_svc;
1771
1772   #extras
1773   push @part_svc, map {
1774     my $part_svc = $_;
1775     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1776     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1777     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1778     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1779       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1780     $part_svc;
1781   } $self->extra_part_svc;
1782
1783   @part_svc;
1784
1785 }
1786
1787 =item extra_part_svc
1788
1789 Returns a list of FS::part_svc objects corresponding to services in this
1790 package which are still provisioned but not (any longer) available in the
1791 package definition.
1792
1793 =cut
1794
1795 sub extra_part_svc {
1796   my $self = shift;
1797
1798   my $pkgnum  = $self->pkgnum;
1799   my $pkgpart = $self->pkgpart;
1800
1801 #  qsearch( {
1802 #    'table'     => 'part_svc',
1803 #    'hashref'   => {},
1804 #    'extra_sql' =>
1805 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1806 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1807 #                       AND pkg_svc.pkgpart = ?
1808 #                       AND quantity > 0
1809 #                 )
1810 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1811 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1812 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1813 #                       AND pkgnum = ?
1814 #                 )",
1815 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1816 #  } );
1817
1818 #seems to benchmark slightly faster...
1819   qsearch( {
1820     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1821     #MySQL doesn't grok DISINCT ON
1822     'select'      => 'DISTINCT part_svc.*',
1823     'table'       => 'part_svc',
1824     'addl_from'   =>
1825       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1826                                AND pkg_svc.pkgpart   = ?
1827                                AND quantity > 0
1828                              )
1829        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1830        LEFT JOIN cust_pkg USING ( pkgnum )
1831       ',
1832     'hashref'     => {},
1833     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1834     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1835   } );
1836 }
1837
1838 =item status
1839
1840 Returns a short status string for this package, currently:
1841
1842 =over 4
1843
1844 =item not yet billed
1845
1846 =item one-time charge
1847
1848 =item active
1849
1850 =item suspended
1851
1852 =item cancelled
1853
1854 =back
1855
1856 =cut
1857
1858 sub status {
1859   my $self = shift;
1860
1861   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1862
1863   return 'cancelled' if $self->get('cancel');
1864   return 'suspended' if $self->susp;
1865   return 'not yet billed' unless $self->setup;
1866   return 'one-time charge' if $freq =~ /^(0|$)/;
1867   return 'active';
1868 }
1869
1870 =item ucfirst_status
1871
1872 Returns the status with the first character capitalized.
1873
1874 =cut
1875
1876 sub ucfirst_status {
1877   ucfirst(shift->status);
1878 }
1879
1880 =item statuses
1881
1882 Class method that returns the list of possible status strings for packages
1883 (see L<the status method|/status>).  For example:
1884
1885   @statuses = FS::cust_pkg->statuses();
1886
1887 =cut
1888
1889 tie my %statuscolor, 'Tie::IxHash',
1890   'not yet billed'  => '009999', #teal? cyan?
1891   'one-time charge' => '000000',
1892   'active'          => '00CC00',
1893   'suspended'       => 'FF9900',
1894   'cancelled'       => 'FF0000',
1895 ;
1896
1897 sub statuses {
1898   my $self = shift; #could be class...
1899   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1900   #                                    # mayble split btw one-time vs. recur
1901     keys %statuscolor;
1902 }
1903
1904 =item statuscolor
1905
1906 Returns a hex triplet color string for this package's status.
1907
1908 =cut
1909
1910 sub statuscolor {
1911   my $self = shift;
1912   $statuscolor{$self->status};
1913 }
1914
1915 =item pkg_label
1916
1917 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1918 "pkg-comment" depending on user preference).
1919
1920 =cut
1921
1922 sub pkg_label {
1923   my $self = shift;
1924   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1925   $label = $self->pkgnum. ": $label"
1926     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1927   $label;
1928 }
1929
1930 =item pkg_label_long
1931
1932 Returns a long label for this package, adding the primary service's label to
1933 pkg_label.
1934
1935 =cut
1936
1937 sub pkg_label_long {
1938   my $self = shift;
1939   my $label = $self->pkg_label;
1940   my $cust_svc = $self->primary_cust_svc;
1941   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1942   $label;
1943 }
1944
1945 =item primary_cust_svc
1946
1947 Returns a primary service (as FS::cust_svc object) if one can be identified.
1948
1949 =cut
1950
1951 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1952
1953 sub primary_cust_svc {
1954   my $self = shift;
1955
1956   my @cust_svc = $self->cust_svc;
1957
1958   return '' unless @cust_svc; #no serivces - irrelevant then
1959
1960   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1961
1962   # primary service as specified in the package definition
1963   # or exactly one service definition with quantity one
1964   my $svcpart = $self->part_pkg->svcpart;
1965   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1966   return $cust_svc[0] if scalar(@cust_svc) == 1;
1967
1968   #couldn't identify one thing..
1969   return '';
1970 }
1971
1972 =item labels
1973
1974 Returns a list of lists, calling the label method for all services
1975 (see L<FS::cust_svc>) of this billing item.
1976
1977 =cut
1978
1979 sub labels {
1980   my $self = shift;
1981   map { [ $_->label ] } $self->cust_svc;
1982 }
1983
1984 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
1985
1986 Like the labels method, but returns historical information on services that
1987 were active as of END_TIMESTAMP and (optionally) not cancelled before
1988 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
1989 I<pkg_svc.hidden> flag will be omitted.
1990
1991 Returns a list of lists, calling the label method for all (historical) services
1992 (see L<FS::h_cust_svc>) of this billing item.
1993
1994 =cut
1995
1996 sub h_labels {
1997   my $self = shift;
1998   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1999 }
2000
2001 =item labels_short
2002
2003 Like labels, except returns a simple flat list, and shortens long
2004 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2005 identical services to one line that lists the service label and the number of
2006 individual services rather than individual items.
2007
2008 =cut
2009
2010 sub labels_short {
2011   shift->_labels_short( 'labels', @_ );
2012 }
2013
2014 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2015
2016 Like h_labels, except returns a simple flat list, and shortens long
2017 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2018 identical services to one line that lists the service label and the number of
2019 individual services rather than individual items.
2020
2021 =cut
2022
2023 sub h_labels_short {
2024   shift->_labels_short( 'h_labels', @_ );
2025 }
2026
2027 sub _labels_short {
2028   my( $self, $method ) = ( shift, shift );
2029
2030   my $conf = new FS::Conf;
2031   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2032
2033   my %labels;
2034   #tie %labels, 'Tie::IxHash';
2035   push @{ $labels{$_->[0]} }, $_->[1]
2036     foreach $self->$method(@_);
2037   my @labels;
2038   foreach my $label ( keys %labels ) {
2039     my %seen = ();
2040     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2041     my $num = scalar(@values);
2042     if ( $num > $max_same_services ) {
2043       push @labels, "$label ($num)";
2044     } else {
2045       if ( $conf->exists('cust_bill-consolidate_services') ) {
2046         # push @labels, "$label: ". join(', ', @values);
2047         while ( @values ) {
2048           my $detail = "$label: ";
2049           $detail .= shift(@values). ', '
2050             while @values && length($detail.$values[0]) < 78;
2051           $detail =~ s/, $//;
2052           push @labels, $detail;
2053         }
2054       } else {
2055         push @labels, map { "$label: $_" } @values;
2056       }
2057     }
2058   }
2059
2060  @labels;
2061
2062 }
2063
2064 =item cust_main
2065
2066 Returns the parent customer object (see L<FS::cust_main>).
2067
2068 =cut
2069
2070 sub cust_main {
2071   my $self = shift;
2072   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2073 }
2074
2075 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2076
2077 =item cust_location
2078
2079 Returns the location object, if any (see L<FS::cust_location>).
2080
2081 =item cust_location_or_main
2082
2083 If this package is associated with a location, returns the locaiton (see
2084 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2085
2086 =item location_label [ OPTION => VALUE ... ]
2087
2088 Returns the label of the location object (see L<FS::cust_location>).
2089
2090 =cut
2091
2092 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2093
2094 =item seconds_since TIMESTAMP
2095
2096 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2097 package have been online since TIMESTAMP, according to the session monitor.
2098
2099 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2100 L<Time::Local> and L<Date::Parse> for conversion functions.
2101
2102 =cut
2103
2104 sub seconds_since {
2105   my($self, $since) = @_;
2106   my $seconds = 0;
2107
2108   foreach my $cust_svc (
2109     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2110   ) {
2111     $seconds += $cust_svc->seconds_since($since);
2112   }
2113
2114   $seconds;
2115
2116 }
2117
2118 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2119
2120 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2121 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2122 (exclusive).
2123
2124 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2125 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2126 functions.
2127
2128
2129 =cut
2130
2131 sub seconds_since_sqlradacct {
2132   my($self, $start, $end) = @_;
2133
2134   my $seconds = 0;
2135
2136   foreach my $cust_svc (
2137     grep {
2138       my $part_svc = $_->part_svc;
2139       $part_svc->svcdb eq 'svc_acct'
2140         && scalar($part_svc->part_export('sqlradius'));
2141     } $self->cust_svc
2142   ) {
2143     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2144   }
2145
2146   $seconds;
2147
2148 }
2149
2150 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2151
2152 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2153 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2154 TIMESTAMP_END
2155 (exclusive).
2156
2157 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2158 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2159 functions.
2160
2161 =cut
2162
2163 sub attribute_since_sqlradacct {
2164   my($self, $start, $end, $attrib) = @_;
2165
2166   my $sum = 0;
2167
2168   foreach my $cust_svc (
2169     grep {
2170       my $part_svc = $_->part_svc;
2171       $part_svc->svcdb eq 'svc_acct'
2172         && scalar($part_svc->part_export('sqlradius'));
2173     } $self->cust_svc
2174   ) {
2175     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2176   }
2177
2178   $sum;
2179
2180 }
2181
2182 =item quantity
2183
2184 =cut
2185
2186 sub quantity {
2187   my( $self, $value ) = @_;
2188   if ( defined($value) ) {
2189     $self->setfield('quantity', $value);
2190   }
2191   $self->getfield('quantity') || 1;
2192 }
2193
2194 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2195
2196 Transfers as many services as possible from this package to another package.
2197
2198 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2199 object.  The destination package must already exist.
2200
2201 Services are moved only if the destination allows services with the correct
2202 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2203 this option with caution!  No provision is made for export differences
2204 between the old and new service definitions.  Probably only should be used
2205 when your exports for all service definitions of a given svcdb are identical.
2206 (attempt a transfer without it first, to move all possible svcpart-matching
2207 services)
2208
2209 Any services that can't be moved remain in the original package.
2210
2211 Returns an error, if there is one; otherwise, returns the number of services
2212 that couldn't be moved.
2213
2214 =cut
2215
2216 sub transfer {
2217   my ($self, $dest_pkgnum, %opt) = @_;
2218
2219   my $remaining = 0;
2220   my $dest;
2221   my %target;
2222
2223   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2224     $dest = $dest_pkgnum;
2225     $dest_pkgnum = $dest->pkgnum;
2226   } else {
2227     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2228   }
2229
2230   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2231
2232   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2233     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2234   }
2235
2236   foreach my $cust_svc ($dest->cust_svc) {
2237     $target{$cust_svc->svcpart}--;
2238   }
2239
2240   my %svcpart2svcparts = ();
2241   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2242     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2243     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2244       next if exists $svcpart2svcparts{$svcpart};
2245       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2246       $svcpart2svcparts{$svcpart} = [
2247         map  { $_->[0] }
2248         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2249         map {
2250               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2251                                                    'svcpart' => $_          } );
2252               [ $_,
2253                 $pkg_svc ? $pkg_svc->primary_svc : '',
2254                 $pkg_svc ? $pkg_svc->quantity : 0,
2255               ];
2256             }
2257
2258         grep { $_ != $svcpart }
2259         map  { $_->svcpart }
2260         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2261       ];
2262       warn "alternates for svcpart $svcpart: ".
2263            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2264         if $DEBUG;
2265     }
2266   }
2267
2268   foreach my $cust_svc ($self->cust_svc) {
2269     if($target{$cust_svc->svcpart} > 0) {
2270       $target{$cust_svc->svcpart}--;
2271       my $new = new FS::cust_svc { $cust_svc->hash };
2272       $new->pkgnum($dest_pkgnum);
2273       my $error = $new->replace($cust_svc);
2274       return $error if $error;
2275     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2276       if ( $DEBUG ) {
2277         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2278         warn "alternates to consider: ".
2279              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2280       }
2281       my @alternate = grep {
2282                              warn "considering alternate svcpart $_: ".
2283                                   "$target{$_} available in new package\n"
2284                                if $DEBUG;
2285                              $target{$_} > 0;
2286                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2287       if ( @alternate ) {
2288         warn "alternate(s) found\n" if $DEBUG;
2289         my $change_svcpart = $alternate[0];
2290         $target{$change_svcpart}--;
2291         my $new = new FS::cust_svc { $cust_svc->hash };
2292         $new->svcpart($change_svcpart);
2293         $new->pkgnum($dest_pkgnum);
2294         my $error = $new->replace($cust_svc);
2295         return $error if $error;
2296       } else {
2297         $remaining++;
2298       }
2299     } else {
2300       $remaining++
2301     }
2302   }
2303   return $remaining;
2304 }
2305
2306 =item reexport
2307
2308 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2309 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2310
2311 =cut
2312
2313 sub reexport {
2314   my $self = shift;
2315
2316   local $SIG{HUP} = 'IGNORE';
2317   local $SIG{INT} = 'IGNORE';
2318   local $SIG{QUIT} = 'IGNORE';
2319   local $SIG{TERM} = 'IGNORE';
2320   local $SIG{TSTP} = 'IGNORE';
2321   local $SIG{PIPE} = 'IGNORE';
2322
2323   my $oldAutoCommit = $FS::UID::AutoCommit;
2324   local $FS::UID::AutoCommit = 0;
2325   my $dbh = dbh;
2326
2327   foreach my $cust_svc ( $self->cust_svc ) {
2328     #false laziness w/svc_Common::insert
2329     my $svc_x = $cust_svc->svc_x;
2330     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2331       my $error = $part_export->export_insert($svc_x);
2332       if ( $error ) {
2333         $dbh->rollback if $oldAutoCommit;
2334         return $error;
2335       }
2336     }
2337   }
2338
2339   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2340   '';
2341
2342 }
2343
2344 =item insert_reason
2345
2346 Associates this package with a (suspension or cancellation) reason (see
2347 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2348 L<FS::reason>).
2349
2350 Available options are:
2351
2352 =over 4
2353
2354 =item reason
2355
2356 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.
2357
2358 =item reason_otaker
2359
2360 the access_user (see L<FS::access_user>) providing the reason
2361
2362 =item date
2363
2364 a unix timestamp
2365
2366 =item action
2367
2368 the action (cancel, susp, adjourn, expire) associated with the reason
2369
2370 =back
2371
2372 If there is an error, returns the error, otherwise returns false.
2373
2374 =cut
2375
2376 sub insert_reason {
2377   my ($self, %options) = @_;
2378
2379   my $otaker = $options{reason_otaker} ||
2380                $FS::CurrentUser::CurrentUser->username;
2381
2382   my $reasonnum;
2383   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2384
2385     $reasonnum = $1;
2386
2387   } elsif ( ref($options{'reason'}) ) {
2388
2389     return 'Enter a new reason (or select an existing one)'
2390       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2391
2392     my $reason = new FS::reason({
2393       'reason_type' => $options{'reason'}->{'typenum'},
2394       'reason'      => $options{'reason'}->{'reason'},
2395     });
2396     my $error = $reason->insert;
2397     return $error if $error;
2398
2399     $reasonnum = $reason->reasonnum;
2400
2401   } else {
2402     return "Unparsable reason: ". $options{'reason'};
2403   }
2404
2405   my $cust_pkg_reason =
2406     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2407                               'reasonnum' => $reasonnum,
2408                               'otaker'    => $otaker,
2409                               'action'    => substr(uc($options{'action'}),0,1),
2410                               'date'      => $options{'date'}
2411                                                ? $options{'date'}
2412                                                : time,
2413                             });
2414
2415   $cust_pkg_reason->insert;
2416 }
2417
2418 =item insert_discount
2419
2420 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2421 inserting a new discount on the fly (see L<FS::discount>).
2422
2423 Available options are:
2424
2425 =over 4
2426
2427 =item discountnum
2428
2429 =back
2430
2431 If there is an error, returns the error, otherwise returns false.
2432
2433 =cut
2434
2435 sub insert_discount {
2436   #my ($self, %options) = @_;
2437   my $self = shift;
2438
2439   my $cust_pkg_discount = new FS::cust_pkg_discount {
2440     'pkgnum'      => $self->pkgnum,
2441     'discountnum' => $self->discountnum,
2442     'months_used' => 0,
2443     'end_date'    => '', #XXX
2444     'otaker'      => $self->otaker,
2445     #for the create a new discount case
2446     '_type'       => $self->discountnum__type,
2447     'amount'      => $self->discountnum_amount,
2448     'percent'     => $self->discountnum_percent,
2449     'months'      => $self->discountnum_months,
2450     #'disabled'    => $self->discountnum_disabled,
2451   };
2452
2453   $cust_pkg_discount->insert;
2454 }
2455
2456 =item set_usage USAGE_VALUE_HASHREF
2457
2458 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2459 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2460 upbytes, downbytes, and totalbytes are appropriate keys.
2461
2462 All svc_accts which are part of this package have their values reset.
2463
2464 =cut
2465
2466 sub set_usage {
2467   my ($self, $valueref, %opt) = @_;
2468
2469   foreach my $cust_svc ($self->cust_svc){
2470     my $svc_x = $cust_svc->svc_x;
2471     $svc_x->set_usage($valueref, %opt)
2472       if $svc_x->can("set_usage");
2473   }
2474 }
2475
2476 =item recharge USAGE_VALUE_HASHREF
2477
2478 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2479 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2480 upbytes, downbytes, and totalbytes are appropriate keys.
2481
2482 All svc_accts which are part of this package have their values incremented.
2483
2484 =cut
2485
2486 sub recharge {
2487   my ($self, $valueref) = @_;
2488
2489   foreach my $cust_svc ($self->cust_svc){
2490     my $svc_x = $cust_svc->svc_x;
2491     $svc_x->recharge($valueref)
2492       if $svc_x->can("recharge");
2493   }
2494 }
2495
2496 =item cust_pkg_discount
2497
2498 =cut
2499
2500 sub cust_pkg_discount {
2501   my $self = shift;
2502   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2503 }
2504
2505 =item cust_pkg_discount_active
2506
2507 =cut
2508
2509 sub cust_pkg_discount_active {
2510   my $self = shift;
2511   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2512 }
2513
2514 =back
2515
2516 =head1 CLASS METHODS
2517
2518 =over 4
2519
2520 =item recurring_sql
2521
2522 Returns an SQL expression identifying recurring packages.
2523
2524 =cut
2525
2526 sub recurring_sql { "
2527   '0' != ( select freq from part_pkg
2528              where cust_pkg.pkgpart = part_pkg.pkgpart )
2529 "; }
2530
2531 =item onetime_sql
2532
2533 Returns an SQL expression identifying one-time packages.
2534
2535 =cut
2536
2537 sub onetime_sql { "
2538   '0' = ( select freq from part_pkg
2539             where cust_pkg.pkgpart = part_pkg.pkgpart )
2540 "; }
2541
2542 =item ordered_sql
2543
2544 Returns an SQL expression identifying ordered packages (recurring packages not
2545 yet billed).
2546
2547 =cut
2548
2549 sub ordered_sql {
2550    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2551 }
2552
2553 =item active_sql
2554
2555 Returns an SQL expression identifying active packages.
2556
2557 =cut
2558
2559 sub active_sql {
2560   $_[0]->recurring_sql. "
2561   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2562   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2563   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2564 "; }
2565
2566 =item not_yet_billed_sql
2567
2568 Returns an SQL expression identifying packages which have not yet been billed.
2569
2570 =cut
2571
2572 sub not_yet_billed_sql { "
2573       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2574   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2575   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2576 "; }
2577
2578 =item inactive_sql
2579
2580 Returns an SQL expression identifying inactive packages (one-time packages
2581 that are otherwise unsuspended/uncancelled).
2582
2583 =cut
2584
2585 sub inactive_sql { "
2586   ". $_[0]->onetime_sql(). "
2587   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2588   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2589   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2590 "; }
2591
2592 =item susp_sql
2593 =item suspended_sql
2594
2595 Returns an SQL expression identifying suspended packages.
2596
2597 =cut
2598
2599 sub suspended_sql { susp_sql(@_); }
2600 sub susp_sql {
2601   #$_[0]->recurring_sql(). ' AND '.
2602   "
2603         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2604     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2605   ";
2606 }
2607
2608 =item cancel_sql
2609 =item cancelled_sql
2610
2611 Returns an SQL exprression identifying cancelled packages.
2612
2613 =cut
2614
2615 sub cancelled_sql { cancel_sql(@_); }
2616 sub cancel_sql {
2617   #$_[0]->recurring_sql(). ' AND '.
2618   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2619 }
2620
2621 =item status_sql
2622
2623 Returns an SQL expression to give the package status as a string.
2624
2625 =cut
2626
2627 sub status_sql {
2628 "CASE
2629   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2630   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2631   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2632   WHEN ".onetime_sql()." THEN 'one-time charge'
2633   ELSE 'active'
2634 END"
2635 }
2636
2637 =item search HASHREF
2638
2639 (Class method)
2640
2641 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2642 Valid parameters are
2643
2644 =over 4
2645
2646 =item agentnum
2647
2648 =item magic
2649
2650 active, inactive, suspended, cancel (or cancelled)
2651
2652 =item status
2653
2654 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2655
2656 =item custom
2657
2658  boolean selects custom packages
2659
2660 =item classnum
2661
2662 =item pkgpart
2663
2664 pkgpart or arrayref or hashref of pkgparts
2665
2666 =item setup
2667
2668 arrayref of beginning and ending epoch date
2669
2670 =item last_bill
2671
2672 arrayref of beginning and ending epoch date
2673
2674 =item bill
2675
2676 arrayref of beginning and ending epoch date
2677
2678 =item adjourn
2679
2680 arrayref of beginning and ending epoch date
2681
2682 =item susp
2683
2684 arrayref of beginning and ending epoch date
2685
2686 =item expire
2687
2688 arrayref of beginning and ending epoch date
2689
2690 =item cancel
2691
2692 arrayref of beginning and ending epoch date
2693
2694 =item query
2695
2696 pkgnum or APKG_pkgnum
2697
2698 =item cust_fields
2699
2700 a value suited to passing to FS::UI::Web::cust_header
2701
2702 =item CurrentUser
2703
2704 specifies the user for agent virtualization
2705
2706 =item fcc_line
2707
2708  boolean selects packages containing fcc form 477 telco lines
2709
2710 =back
2711
2712 =cut
2713
2714 sub search {
2715   my ($class, $params) = @_;
2716   my @where = ();
2717
2718   ##
2719   # parse agent
2720   ##
2721
2722   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2723     push @where,
2724       "cust_main.agentnum = $1";
2725   }
2726
2727   ##
2728   # parse custnum
2729   ##
2730
2731   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2732     push @where,
2733       "cust_pkg.custnum = $1";
2734   }
2735
2736   ##
2737   # custbatch
2738   ##
2739
2740   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2741     push @where,
2742       "cust_pkg.pkgbatch = '$1'";
2743   }
2744
2745   ##
2746   # parse status
2747   ##
2748
2749   if (    $params->{'magic'}  eq 'active'
2750        || $params->{'status'} eq 'active' ) {
2751
2752     push @where, FS::cust_pkg->active_sql();
2753
2754   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2755             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2756
2757     push @where, FS::cust_pkg->not_yet_billed_sql();
2758
2759   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2760             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2761
2762     push @where, FS::cust_pkg->inactive_sql();
2763
2764   } elsif (    $params->{'magic'}  eq 'suspended'
2765             || $params->{'status'} eq 'suspended'  ) {
2766
2767     push @where, FS::cust_pkg->suspended_sql();
2768
2769   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2770             || $params->{'status'} =~ /^cancell?ed$/ ) {
2771
2772     push @where, FS::cust_pkg->cancelled_sql();
2773
2774   }
2775
2776   ###
2777   # parse package class
2778   ###
2779
2780   #false lazinessish w/graph/cust_bill_pkg.cgi
2781   my $classnum = 0;
2782   my @pkg_class = ();
2783   if ( exists($params->{'classnum'})
2784        && $params->{'classnum'} =~ /^(\d*)$/
2785      )
2786   {
2787     $classnum = $1;
2788     if ( $classnum ) { #a specific class
2789       push @where, "part_pkg.classnum = $classnum";
2790
2791       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2792       #die "classnum $classnum not found!" unless $pkg_class[0];
2793       #$title .= $pkg_class[0]->classname.' ';
2794
2795     } elsif ( $classnum eq '' ) { #the empty class
2796
2797       push @where, "part_pkg.classnum IS NULL";
2798       #$title .= 'Empty class ';
2799       #@pkg_class = ( '(empty class)' );
2800     } elsif ( $classnum eq '0' ) {
2801       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2802       #push @pkg_class, '(empty class)';
2803     } else {
2804       die "illegal classnum";
2805     }
2806   }
2807   #eslaf
2808
2809   ###
2810   # parse package report options
2811   ###
2812
2813   my @report_option = ();
2814   if ( exists($params->{'report_option'})
2815        && $params->{'report_option'} =~ /^([,\d]*)$/
2816      )
2817   {
2818     @report_option = split(',', $1);
2819   }
2820
2821   if (@report_option) {
2822     # this will result in the empty set for the dangling comma case as it should
2823     push @where,
2824       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2825                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2826                     AND optionname = 'report_option_$_'
2827                     AND optionvalue = '1' )"
2828          } @report_option;
2829   }
2830
2831   #eslaf
2832
2833   ###
2834   # parse custom
2835   ###
2836
2837   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2838
2839   ###
2840   # parse fcc_line
2841   ###
2842
2843   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2844
2845   ###
2846   # parse censustract
2847   ###
2848
2849   if ( exists($params->{'censustract'}) ) {
2850     $params->{'censustract'} =~ /^([.\d]*)$/;
2851     my $censustract = "cust_main.censustract = '$1'";
2852     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2853     push @where,  "( $censustract )";
2854   }
2855
2856   ###
2857   # parse part_pkg
2858   ###
2859
2860   if ( ref($params->{'pkgpart'}) ) {
2861
2862     my @pkgpart = ();
2863     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2864       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2865     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2866       @pkgpart = @{ $params->{'pkgpart'} };
2867     } else {
2868       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2869     }
2870
2871     @pkgpart = grep /^(\d+)$/, @pkgpart;
2872
2873     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2874
2875   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2876     push @where, "pkgpart = $1";
2877   }
2878
2879   ###
2880   # parse dates
2881   ###
2882
2883   my $orderby = '';
2884
2885   #false laziness w/report_cust_pkg.html
2886   my %disable = (
2887     'all'             => {},
2888     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2889     'active'          => { 'susp'=>1, 'cancel'=>1 },
2890     'suspended'       => { 'cancel' => 1 },
2891     'cancelled'       => {},
2892     ''                => {},
2893   );
2894
2895   if( exists($params->{'active'} ) ) {
2896     # This overrides all the other date-related fields
2897     my($beginning, $ending) = @{$params->{'active'}};
2898     push @where,
2899       "cust_pkg.setup IS NOT NULL",
2900       "cust_pkg.setup <= $ending",
2901       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2902       "NOT (".FS::cust_pkg->onetime_sql . ")";
2903   }
2904   else {
2905     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2906
2907       next unless exists($params->{$field});
2908
2909       my($beginning, $ending) = @{$params->{$field}};
2910
2911       next if $beginning == 0 && $ending == 4294967295;
2912
2913       push @where,
2914         "cust_pkg.$field IS NOT NULL",
2915         "cust_pkg.$field >= $beginning",
2916         "cust_pkg.$field <= $ending";
2917
2918       $orderby ||= "ORDER BY cust_pkg.$field";
2919
2920     }
2921   }
2922
2923   $orderby ||= 'ORDER BY bill';
2924
2925   ###
2926   # parse magic, legacy, etc.
2927   ###
2928
2929   if ( $params->{'magic'} &&
2930        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2931   ) {
2932
2933     $orderby = 'ORDER BY pkgnum';
2934
2935     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2936       push @where, "pkgpart = $1";
2937     }
2938
2939   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2940
2941     $orderby = 'ORDER BY pkgnum';
2942
2943   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2944
2945     $orderby = 'ORDER BY pkgnum';
2946
2947     push @where, '0 < (
2948       SELECT count(*) FROM pkg_svc
2949        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2950          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2951                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2952                                      AND cust_svc.svcpart = pkg_svc.svcpart
2953                                 )
2954     )';
2955
2956   }
2957
2958   ##
2959   # setup queries, links, subs, etc. for the search
2960   ##
2961
2962   # here is the agent virtualization
2963   if ($params->{CurrentUser}) {
2964     my $access_user =
2965       qsearchs('access_user', { username => $params->{CurrentUser} });
2966
2967     if ($access_user) {
2968       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2969     } else {
2970       push @where, "1=0";
2971     }
2972   } else {
2973     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2974   }
2975
2976   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2977
2978   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2979                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2980                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2981
2982   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2983
2984   my $sql_query = {
2985     'table'       => 'cust_pkg',
2986     'hashref'     => {},
2987     'select'      => join(', ',
2988                                 'cust_pkg.*',
2989                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2990                                 'pkg_class.classname',
2991                                 'cust_main.custnum AS cust_main_custnum',
2992                                 FS::UI::Web::cust_sql_fields(
2993                                   $params->{'cust_fields'}
2994                                 ),
2995                      ),
2996     'extra_sql'   => "$extra_sql $orderby",
2997     'addl_from'   => $addl_from,
2998     'count_query' => $count_query,
2999   };
3000
3001 }
3002
3003 =item fcc_477_count
3004
3005 Returns a list of two package counts.  The first is a count of packages
3006 based on the supplied criteria and the second is the count of residential
3007 packages with those same criteria.  Criteria are specified as in the search
3008 method.
3009
3010 =cut
3011
3012 sub fcc_477_count {
3013   my ($class, $params) = @_;
3014
3015   my $sql_query = $class->search( $params );
3016
3017   my $count_sql = delete($sql_query->{'count_query'});
3018   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3019     or die "couldn't parse count_sql";
3020
3021   my $count_sth = dbh->prepare($count_sql)
3022     or die "Error preparing $count_sql: ". dbh->errstr;
3023   $count_sth->execute
3024     or die "Error executing $count_sql: ". $count_sth->errstr;
3025   my $count_arrayref = $count_sth->fetchrow_arrayref;
3026
3027   return ( @$count_arrayref );
3028
3029 }
3030
3031
3032 =item location_sql
3033
3034 Returns a list: the first item is an SQL fragment identifying matching
3035 packages/customers via location (taking into account shipping and package
3036 address taxation, if enabled), and subsequent items are the parameters to
3037 substitute for the placeholders in that fragment.
3038
3039 =cut
3040
3041 sub location_sql {
3042   my($class, %opt) = @_;
3043   my $ornull = $opt{'ornull'};
3044
3045   my $conf = new FS::Conf;
3046
3047   # '?' placeholders in _location_sql_where
3048   my $x = $ornull ? 3 : 2;
3049   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
3050
3051   my $main_where;
3052   my @main_param;
3053   if ( $conf->exists('tax-ship_address') ) {
3054
3055     $main_where = "(
3056          (     ( ship_last IS NULL     OR  ship_last  = '' )
3057            AND ". _location_sql_where('cust_main', '', $ornull ). "
3058          )
3059       OR (       ship_last IS NOT NULL AND ship_last != ''
3060            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3061          )
3062     )";
3063     #    AND payby != 'COMP'
3064
3065     @main_param = ( @bill_param, @bill_param );
3066
3067   } else {
3068
3069     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3070     @main_param = @bill_param;
3071
3072   }
3073
3074   my $where;
3075   my @param;
3076   if ( $conf->exists('tax-pkg_address') ) {
3077
3078     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3079
3080     $where = " (
3081                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3082                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3083                )
3084              ";
3085     @param = ( @main_param, @bill_param );
3086
3087   } else {
3088
3089     $where = $main_where;
3090     @param = @main_param;
3091
3092   }
3093
3094   ( $where, @param );
3095
3096 }
3097
3098 #subroutine, helper for location_sql
3099 sub _location_sql_where {
3100   my $table  = shift;
3101   my $prefix = @_ ? shift : '';
3102   my $ornull = @_ ? shift : '';
3103
3104 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3105
3106   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3107
3108   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3109   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3110   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3111
3112 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3113   "
3114         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3115     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3116     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3117     AND   $table.${prefix}country = ?
3118   ";
3119 }
3120
3121 =head1 SUBROUTINES
3122
3123 =over 4
3124
3125 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3126
3127 CUSTNUM is a customer (see L<FS::cust_main>)
3128
3129 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3130 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3131 permitted.
3132
3133 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3134 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3135 new billing items.  An error is returned if this is not possible (see
3136 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3137 parameter.
3138
3139 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3140 newly-created cust_pkg objects.
3141
3142 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3143 and inserted.  Multiple FS::pkg_referral records can be created by
3144 setting I<refnum> to an array reference of refnums or a hash reference with
3145 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3146 record will be created corresponding to cust_main.refnum.
3147
3148 =cut
3149
3150 sub order {
3151   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3152
3153   my $conf = new FS::Conf;
3154
3155   # Transactionize this whole mess
3156   local $SIG{HUP} = 'IGNORE';
3157   local $SIG{INT} = 'IGNORE';
3158   local $SIG{QUIT} = 'IGNORE';
3159   local $SIG{TERM} = 'IGNORE';
3160   local $SIG{TSTP} = 'IGNORE';
3161   local $SIG{PIPE} = 'IGNORE';
3162
3163   my $oldAutoCommit = $FS::UID::AutoCommit;
3164   local $FS::UID::AutoCommit = 0;
3165   my $dbh = dbh;
3166
3167   my $error;
3168 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3169 #  return "Customer not found: $custnum" unless $cust_main;
3170
3171   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3172     if $DEBUG;
3173
3174   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3175                          @$remove_pkgnum;
3176
3177   my $change = scalar(@old_cust_pkg) != 0;
3178
3179   my %hash = ();
3180   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3181
3182     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3183          " to pkgpart ". $pkgparts->[0]. "\n"
3184       if $DEBUG;
3185
3186     my $err_or_cust_pkg =
3187       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3188                                 'refnum'  => $refnum,
3189                               );
3190
3191     unless (ref($err_or_cust_pkg)) {
3192       $dbh->rollback if $oldAutoCommit;
3193       return $err_or_cust_pkg;
3194     }
3195
3196     push @$return_cust_pkg, $err_or_cust_pkg;
3197     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3198     return '';
3199
3200   }
3201
3202   # Create the new packages.
3203   foreach my $pkgpart (@$pkgparts) {
3204
3205     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3206
3207     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3208                                       pkgpart => $pkgpart,
3209                                       refnum  => $refnum,
3210                                       %hash,
3211                                     };
3212     $error = $cust_pkg->insert( 'change' => $change );
3213     if ($error) {
3214       $dbh->rollback if $oldAutoCommit;
3215       return $error;
3216     }
3217     push @$return_cust_pkg, $cust_pkg;
3218   }
3219   # $return_cust_pkg now contains refs to all of the newly
3220   # created packages.
3221
3222   # Transfer services and cancel old packages.
3223   foreach my $old_pkg (@old_cust_pkg) {
3224
3225     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3226       if $DEBUG;
3227
3228     foreach my $new_pkg (@$return_cust_pkg) {
3229       $error = $old_pkg->transfer($new_pkg);
3230       if ($error and $error == 0) {
3231         # $old_pkg->transfer failed.
3232         $dbh->rollback if $oldAutoCommit;
3233         return $error;
3234       }
3235     }
3236
3237     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3238       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3239       foreach my $new_pkg (@$return_cust_pkg) {
3240         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3241         if ($error and $error == 0) {
3242           # $old_pkg->transfer failed.
3243         $dbh->rollback if $oldAutoCommit;
3244         return $error;
3245         }
3246       }
3247     }
3248
3249     if ($error > 0) {
3250       # Transfers were successful, but we went through all of the
3251       # new packages and still had services left on the old package.
3252       # We can't cancel the package under the circumstances, so abort.
3253       $dbh->rollback if $oldAutoCommit;
3254       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3255     }
3256     $error = $old_pkg->cancel( quiet=>1 );
3257     if ($error) {
3258       $dbh->rollback;
3259       return $error;
3260     }
3261   }
3262   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3263   '';
3264 }
3265
3266 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3267
3268 A bulk change method to change packages for multiple customers.
3269
3270 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3271 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3272 permitted.
3273
3274 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3275 replace.  The services (see L<FS::cust_svc>) are moved to the
3276 new billing items.  An error is returned if this is not possible (see
3277 L<FS::pkg_svc>).
3278
3279 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3280 newly-created cust_pkg objects.
3281
3282 =cut
3283
3284 sub bulk_change {
3285   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3286
3287   # Transactionize this whole mess
3288   local $SIG{HUP} = 'IGNORE';
3289   local $SIG{INT} = 'IGNORE';
3290   local $SIG{QUIT} = 'IGNORE';
3291   local $SIG{TERM} = 'IGNORE';
3292   local $SIG{TSTP} = 'IGNORE';
3293   local $SIG{PIPE} = 'IGNORE';
3294
3295   my $oldAutoCommit = $FS::UID::AutoCommit;
3296   local $FS::UID::AutoCommit = 0;
3297   my $dbh = dbh;
3298
3299   my @errors;
3300   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3301                          @$remove_pkgnum;
3302
3303   while(scalar(@old_cust_pkg)) {
3304     my @return = ();
3305     my $custnum = $old_cust_pkg[0]->custnum;
3306     my (@remove) = map { $_->pkgnum }
3307                    grep { $_->custnum == $custnum } @old_cust_pkg;
3308     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3309
3310     my $error = order $custnum, $pkgparts, \@remove, \@return;
3311
3312     push @errors, $error
3313       if $error;
3314     push @$return_cust_pkg, @return;
3315   }
3316
3317   if (scalar(@errors)) {
3318     $dbh->rollback if $oldAutoCommit;
3319     return join(' / ', @errors);
3320   }
3321
3322   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3323   '';
3324 }
3325
3326 # Used by FS::Upgrade to migrate to a new database.
3327 sub _upgrade_data {  # class method
3328   my ($class, %opts) = @_;
3329   $class->_upgrade_otaker(%opts);
3330   my $sql =('UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1');
3331   my $sth = dbh->prepare($sql);
3332   $sth->execute or die $sth->errstr;
3333 }
3334
3335 =back
3336
3337 =head1 BUGS
3338
3339 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3340
3341 In sub order, the @pkgparts array (passed by reference) is clobbered.
3342
3343 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3344 method to pass dates to the recur_prog expression, it should do so.
3345
3346 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3347 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3348 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3349 configuration values.  Probably need a subroutine which decides what to do
3350 based on whether or not we've fetched the user yet, rather than a hash.  See
3351 FS::UID and the TODO.
3352
3353 Now that things are transactional should the check in the insert method be
3354 moved to check ?
3355
3356 =head1 SEE ALSO
3357
3358 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3359 L<FS::pkg_svc>, schema.html from the base documentation
3360
3361 =cut
3362
3363 1;
3364