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