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