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