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