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