FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common );
   6 use vars qw($disable_agentcheck $DEBUG $me);
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( getotaker dbh );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs );
  16 use FS::CurrentUser;
  17 use FS::cust_svc;
  18 use FS::part_pkg;
  19 use FS::cust_main;
  20 use FS::cust_location;
  21 use FS::pkg_svc;
  22 use FS::cust_bill_pkg;
  23 use FS::cust_pkg_detail;
  24 use FS::cust_event;
  25 use FS::h_cust_svc;
  26 use FS::reg_code;
  27 use FS::part_svc;
  28 use FS::cust_pkg_reason;
  29 use FS::reason;
  30 use FS::cust_pkg_discount;
  31 use FS::discount;
  32 use FS::UI::Web;
  33
  34 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  35 # setup }
  36 # because they load configuration by setting FS::UID::callback (see TODO)
  37 use FS::svc_acct;
  38 use FS::svc_domain;
  39 use FS::svc_www;
  40 use FS::svc_forward;
  41
  42 # for sending cancel emails in sub cancel
  43 use FS::Conf;
  44
  45 $DEBUG = 0;
  46 $me = '[FS::cust_pkg]';
  47
  48 $disable_agentcheck = 0;
  49
  50 sub _cache {
  51   my $self = shift;
  52   my ( $hashref, $cache ) = @_;
  53   #if ( $hashref->{'pkgpart'} ) {
  54   if ( $hashref->{'pkg'} ) {
  55     # #@{ $self->{'_pkgnum'} } = ();
  56     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  57     # $self->{'_pkgpart'} = $subcache;
  58     # #push @{ $self->{'_pkgnum'} },
  59     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  60     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  61   }
  62   if ( exists $hashref->{'svcnum'} ) {
  63     #@{ $self->{'_pkgnum'} } = ();
  64     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  65     $self->{'_svcnum'} = $subcache;
  66     #push @{ $self->{'_pkgnum'} },
  67     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  68   }
  69 }
  70
  71 =head1 NAME
  72
  73 FS::cust_pkg - Object methods for cust_pkg objects
  74
  75 =head1 SYNOPSIS
  76
  77   use FS::cust_pkg;
  78
  79   $record = new FS::cust_pkg \%hash;
  80   $record = new FS::cust_pkg { 'column' => 'value' };
  81
  82   $error = $record->insert;
  83
  84   $error = $new_record->replace($old_record);
  85
  86   $error = $record->delete;
  87
  88   $error = $record->check;
  89
  90   $error = $record->cancel;
  91
  92   $error = $record->suspend;
  93
  94   $error = $record->unsuspend;
  95
  96   $part_pkg = $record->part_pkg;
  97
  98   @labels = $record->labels;
  99
 100   $seconds = $record->seconds_since($timestamp);
 101
 102   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 103   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 104
 105 =head1 DESCRIPTION
 106
 107 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 108 inherits from FS::Record.  The following fields are currently supported:
 109
 110 =over 4
 111
 112 =item pkgnum
 113
 114 Primary key (assigned automatically for new billing items)
 115
 116 =item custnum
 117
 118 Customer (see L<FS::cust_main>)
 119
 120 =item pkgpart
 121
 122 Billing item definition (see L<FS::part_pkg>)
 123
 124 =item locationnum
 125
 126 Optional link to package location (see L<FS::location>)
 127
 128 =item start_date
 129
 130 date
 131
 132 =item setup
 133
 134 date
 135
 136 =item bill
 137
 138 date (next bill date)
 139
 140 =item last_bill
 141
 142 last bill date
 143
 144 =item adjourn
 145
 146 date
 147
 148 =item susp
 149
 150 date
 151
 152 =item expire
 153
 154 date
 155
 156 =item contract_end
 157
 158 date
 159
 160 =item cancel
 161
 162 date
 163
 164 =item usernum
 165
 166 order taker (see L<FS::access_user>)
 167
 168 =item manual_flag
 169
 170 If this field is set to 1, disables the automatic
 171 unsuspension of this package when using the B<unsuspendauto> config option.
 172
 173 =item quantity
 174
 175 If not set, defaults to 1
 176
 177 =item change_date
 178
 179 Date of change from previous package
 180
 181 =item change_pkgnum
 182
 183 Previous pkgnum
 184
 185 =item change_pkgpart
 186
 187 Previous pkgpart
 188
 189 =item change_locationnum
 190
 191 Previous locationnum
 192
 193 =back
 194
 195 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 196 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 197 L<Time::Local> and L<Date::Parse> for conversion functions.
 198
 199 =head1 METHODS
 200
 201 =over 4
 202
 203 =item new HASHREF
 204
 205 Create a new billing item.  To add the item to the database, see L<"insert">.
 206
 207 =cut
 208
 209 sub table { 'cust_pkg'; }
 210 sub cust_linked { $_[0]->cust_main_custnum; }
 211 sub cust_unlinked_msg {
 212   my $self = shift;
 213   "WARNING: can't find cust_main.custnum ". $self->custnum.
 214   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 215 }
 216
 217 =item insert [ OPTION => VALUE ... ]
 218
 219 Adds this billing item to the database ("Orders" the item).  If there is an
 220 error, returns the error, otherwise returns false.
 221
 222 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 223 will be used to look up the package definition and agent restrictions will be
 224 ignored.
 225
 226 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 227 be created and inserted.  Multiple FS::pkg_referral records can be created by
 228 setting I<refnum> to an array reference of refnums or a hash reference with
 229 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 230 record will be created corresponding to cust_main.refnum.
 231
 232 The following options are available:
 233
 234 =over 4
 235
 236 =item change
 237
 238 If set true, supresses any referral credit to a referring customer.
 239
 240 =item options
 241
 242 cust_pkg_option records will be created
 243
 244 =item ticket_subject
 245
 246 a ticket will be added to this customer with this subject
 247
 248 =item ticket_queue
 249
 250 an optional queue name for ticket additions
 251
 252 =back
 253
 254 =cut
 255
 256 sub insert {
 257   my( $self, %options ) = @_;
 258
 259   if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
 260     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 261     $mon += 1 unless $mday == 1;
 262     until ( $mon < 12 ) { $mon -= 12; $year++; }
 263     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 264   }
 265
 266   foreach my $action ( qw(expire adjourn contract_end) ) {
 267     my $months = $self->part_pkg->option("${action}_months",1);
 268     if($months and !$self->$action) {
 269       my $start = $self->start_date || $self->setup || time;
 270       $self->$action( $self->part_pkg->add_freq($start, $months) );
 271     }
 272   }
 273
 274   local $SIG{HUP} = 'IGNORE';
 275   local $SIG{INT} = 'IGNORE';
 276   local $SIG{QUIT} = 'IGNORE';
 277   local $SIG{TERM} = 'IGNORE';
 278   local $SIG{TSTP} = 'IGNORE';
 279   local $SIG{PIPE} = 'IGNORE';
 280
 281   my $oldAutoCommit = $FS::UID::AutoCommit;
 282   local $FS::UID::AutoCommit = 0;
 283   my $dbh = dbh;
 284
 285   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 286   if ( $error ) {
 287     $dbh->rollback if $oldAutoCommit;
 288     return $error;
 289   }
 290
 291   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 292   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 293   $self->process_m2m( 'link_table'   => 'pkg_referral',
 294                       'target_table' => 'part_referral',
 295                       'params'       => $self->refnum,
 296                     );
 297
 298   if ( $self->discountnum ) {
 299     my $error = $self->insert_discount();
 300     if ( $error ) {
 301       $dbh->rollback if $oldAutoCommit;
 302       return $error;
 303     }
 304   }
 305
 306   #if ( $self->reg_code ) {
 307   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 308   #  $error = $reg_code->delete;
 309   #  if ( $error ) {
 310   #    $dbh->rollback if $oldAutoCommit;
 311   #    return $error;
 312   #  }
 313   #}
 314
 315   my $conf = new FS::Conf;
 316
 317   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 318
 319     #eval '
 320     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 321     #  use RT;
 322     #';
 323     #die $@ if $@;
 324     #
 325     #RT::LoadConfig();
 326     #RT::Init();
 327     use FS::TicketSystem;
 328     FS::TicketSystem->init();
 329
 330     my $q = new RT::Queue($RT::SystemUser);
 331     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 332     my $t = new RT::Ticket($RT::SystemUser);
 333     my $mime = new MIME::Entity;
 334     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 335     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 336                 Subject => $options{ticket_subject},
 337                 MIMEObj => $mime,
 338               );
 339     $t->AddLink( Type   => 'MemberOf',
 340                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 341                );
 342   }
 343
 344   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 345     my $queue = new FS::queue {
 346       'job'     => 'FS::cust_main::queueable_print',
 347     };
 348     $error = $queue->insert(
 349       'custnum'  => $self->custnum,
 350       'template' => 'welcome_letter',
 351     );
 352
 353     if ($error) {
 354       warn "can't send welcome letter: $error";
 355     }
 356
 357   }
 358
 359   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 360   '';
 361
 362 }
 363
 364 =item delete
 365
 366 This method now works but you probably shouldn't use it.
 367
 368 You don't want to delete billing items, because there would then be no record
 369 the customer ever purchased the item.  Instead, see the cancel method.
 370
 371 =cut
 372
 373 #sub delete {
 374 #  return "Can't delete cust_pkg records!";
 375 #}
 376
 377 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 378
 379 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 380 returns the error, otherwise returns false.
 381
 382 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 383
 384 Changing pkgpart may have disasterous effects.  See the order subroutine.
 385
 386 setup and bill are normally updated by calling the bill method of a customer
 387 object (see L<FS::cust_main>).
 388
 389 suspend is normally updated by the suspend and unsuspend methods.
 390
 391 cancel is normally updated by the cancel method (and also the order subroutine
 392 in some cases).
 393
 394 Available options are:
 395
 396 =over 4
 397
 398 =item reason
 399
 400 can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 401
 402 =item reason_otaker
 403
 404 the access_user (see L<FS::access_user>) providing the reason
 405
 406 =item options
 407
 408 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 409
 410 =back
 411
 412 =cut
 413
 414 sub replace {
 415   my $new = shift;
 416
 417   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 418               ? shift
 419               : $new->replace_old;
 420
 421   my $options =
 422     ( ref($_[0]) eq 'HASH' )
 423       ? shift
 424       : { @_ };
 425
 426   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 427   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 428
 429   #allow this *sigh*
 430   #return "Can't change setup once it exists!"
 431   #  if $old->getfield('setup') &&
 432   #     $old->getfield('setup') != $new->getfield('setup');
 433
 434   #some logic for bill, susp, cancel?
 435
 436   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 437
 438   local $SIG{HUP} = 'IGNORE';
 439   local $SIG{INT} = 'IGNORE';
 440   local $SIG{QUIT} = 'IGNORE';
 441   local $SIG{TERM} = 'IGNORE';
 442   local $SIG{TSTP} = 'IGNORE';
 443   local $SIG{PIPE} = 'IGNORE';
 444
 445   my $oldAutoCommit = $FS::UID::AutoCommit;
 446   local $FS::UID::AutoCommit = 0;
 447   my $dbh = dbh;
 448
 449   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 450     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 451       my $error = $new->insert_reason(
 452         'reason'        => $options->{'reason'},
 453         'date'          => $new->$method,
 454         'action'        => $method,
 455         'reason_otaker' => $options->{'reason_otaker'},
 456       );
 457       if ( $error ) {
 458         dbh->rollback if $oldAutoCommit;
 459         return "Error inserting cust_pkg_reason: $error";
 460       }
 461     }
 462   }
 463
 464   #save off and freeze RADIUS attributes for any associated svc_acct records
 465   my @svc_acct = ();
 466   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 467
 468                 #also check for specific exports?
 469                 # to avoid spurious modify export events
 470     @svc_acct = map  { $_->svc_x }
 471                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 472                      $old->cust_svc;
 473
 474     $_->snapshot foreach @svc_acct;
 475
 476   }
 477
 478   my $error = $new->SUPER::replace($old,
 479                                    $options->{options} ? $options->{options} : ()
 480                                   );
 481   if ( $error ) {
 482     $dbh->rollback if $oldAutoCommit;
 483     return $error;
 484   }
 485
 486   #for prepaid packages,
 487   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 488   foreach my $old_svc_acct ( @svc_acct ) {
 489     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 490     my $s_error = $new_svc_acct->replace($old_svc_acct);
 491     if ( $s_error ) {
 492       $dbh->rollback if $oldAutoCommit;
 493       return $s_error;
 494     }
 495   }
 496
 497   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 498   '';
 499
 500 }
 501
 502 =item check
 503
 504 Checks all fields to make sure this is a valid billing item.  If there is an
 505 error, returns the error, otherwise returns false.  Called by the insert and
 506 replace methods.
 507
 508 =cut
 509
 510 sub check {
 511   my $self = shift;
 512
 513   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 514
 515   my $error =
 516     $self->ut_numbern('pkgnum')
 517     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 518     || $self->ut_numbern('pkgpart')
 519     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 520     || $self->ut_numbern('start_date')
 521     || $self->ut_numbern('setup')
 522     || $self->ut_numbern('bill')
 523     || $self->ut_numbern('susp')
 524     || $self->ut_numbern('cancel')
 525     || $self->ut_numbern('adjourn')
 526     || $self->ut_numbern('expire')
 527     || $self->ut_enum('no_auto', [ '', 'Y' ])
 528   ;
 529   return $error if $error;
 530
 531   if ( $self->reg_code ) {
 532
 533     unless ( grep { $self->pkgpart == $_->pkgpart }
 534              map  { $_->reg_code_pkg }
 535              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 536                                      'agentnum' => $self->cust_main->agentnum })
 537            ) {
 538       return "Unknown registration code";
 539     }
 540
 541   } elsif ( $self->promo_code ) {
 542
 543     my $promo_part_pkg =
 544       qsearchs('part_pkg', {
 545         'pkgpart'    => $self->pkgpart,
 546         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 547       } );
 548     return 'Unknown promotional code' unless $promo_part_pkg;
 549
 550   } else {
 551
 552     unless ( $disable_agentcheck ) {
 553       my $agent =
 554         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 555       return "agent ". $agent->agentnum. ':'. $agent->agent.
 556              " can't purchase pkgpart ". $self->pkgpart
 557         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 558             || $agent->agentnum == $self->part_pkg->agentnum;
 559     }
 560
 561     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 562     return $error if $error;
 563
 564   }
 565
 566   $self->usernum($FS::CurrentUser::CurrentUser->usernum) unless $self->usernum;
 567
 568   if ( $self->dbdef_table->column('manual_flag') ) {
 569     $self->manual_flag('') if $self->manual_flag eq ' ';
 570     $self->manual_flag =~ /^([01]?)$/
 571       or return "Illegal manual_flag ". $self->manual_flag;
 572     $self->manual_flag($1);
 573   }
 574
 575   $self->SUPER::check;
 576 }
 577
 578 =item cancel [ OPTION => VALUE ... ]
 579
 580 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 581 in this package, then cancels the package itself (sets the cancel field to
 582 now).
 583
 584 Available options are:
 585
 586 =over 4
 587
 588 =item quiet - can be set true to supress email cancellation notices.
 589
 590 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 591
 592 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 593
 594 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 595
 596 =item nobill - can be set true to skip billing if it might otherwise be done.
 597
 598 =back
 599
 600 If there is an error, returns the error, otherwise returns false.
 601
 602 =cut
 603
 604 sub cancel {
 605   my( $self, %options ) = @_;
 606   my $error;
 607
 608   my $conf = new FS::Conf;
 609
 610   warn "cust_pkg::cancel called with options".
 611        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 612     if $DEBUG;
 613
 614   local $SIG{HUP} = 'IGNORE';
 615   local $SIG{INT} = 'IGNORE';
 616   local $SIG{QUIT} = 'IGNORE';
 617   local $SIG{TERM} = 'IGNORE';
 618   local $SIG{TSTP} = 'IGNORE';
 619   local $SIG{PIPE} = 'IGNORE';
 620
 621   my $oldAutoCommit = $FS::UID::AutoCommit;
 622   local $FS::UID::AutoCommit = 0;
 623   my $dbh = dbh;
 624
 625   my $old = $self->select_for_update;
 626
 627   if ( $old->get('cancel') || $self->get('cancel') ) {
 628     dbh->rollback if $oldAutoCommit;
 629     return "";  # no error
 630   }
 631
 632   my $date = $options{date} if $options{date}; # expire/cancel later
 633   $date = '' if ($date && $date <= time);      # complain instead?
 634
 635   #race condition: usage could be ongoing until unprovisioned
 636   #resolved by performing a change package instead (which unprovisions) and
 637   #later cancelling
 638   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 639       my $copy = $self->new({$self->hash});
 640       my $error =
 641         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 642       warn "Error billing during cancel, custnum ".
 643         #$self->cust_main->custnum. ": $error"
 644         ": $error"
 645         if $error;
 646   }
 647
 648
 649   my $cancel_time = $options{'time'} || time;
 650
 651   if ( $options{'reason'} ) {
 652     $error = $self->insert_reason( 'reason' => $options{'reason'},
 653                                    'action' => $date ? 'expire' : 'cancel',
 654                                    'date'   => $date ? $date : $cancel_time,
 655                                    'reason_otaker' => $options{'reason_otaker'},
 656                                  );
 657     if ( $error ) {
 658       dbh->rollback if $oldAutoCommit;
 659       return "Error inserting cust_pkg_reason: $error";
 660     }
 661   }
 662
 663   my %svc;
 664   unless ( $date ) {
 665     foreach my $cust_svc (
 666       #schwartz
 667       map  { $_->[0] }
 668       sort { $a->[1] <=> $b->[1] }
 669       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 670       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 671     ) {
 672
 673       my $error = $cust_svc->cancel;
 674
 675       if ( $error ) {
 676         $dbh->rollback if $oldAutoCommit;
 677         return "Error cancelling cust_svc: $error";
 678       }
 679     }
 680
 681     # Add a credit for remaining service
 682     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 683     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 684       my $error = $self->cust_main->credit(
 685         $remaining_value,
 686         'Credit for unused time on '. $self->part_pkg->pkg,
 687         'reason_type' => $conf->config('cancel_credit_type'),
 688       );
 689       if ($error) {
 690         $dbh->rollback if $oldAutoCommit;
 691         return "Error crediting customer \$$remaining_value for unused time on".
 692                $self->part_pkg->pkg. ": $error";
 693       }
 694     }
 695   }
 696
 697   my %hash = $self->hash;
 698   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 699   my $new = new FS::cust_pkg ( \%hash );
 700   $error = $new->replace( $self, options => { $self->options } );
 701   if ( $error ) {
 702     $dbh->rollback if $oldAutoCommit;
 703     return $error;
 704   }
 705
 706   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 707   return '' if $date; #no errors
 708
 709   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 710   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 711     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 712     my $error = '';
 713     if ( $msgnum ) {
 714       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 715       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 716                                     'object'    => $self );
 717     }
 718     else {
 719       $error = send_email(
 720         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 721         'to'      => \@invoicing_list,
 722         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 723         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 724       );
 725     }
 726     #should this do something on errors?
 727   }
 728
 729   ''; #no errors
 730
 731 }
 732
 733 =item cancel_if_expired [ NOW_TIMESTAMP ]
 734
 735 Cancels this package if its expire date has been reached.
 736
 737 =cut
 738
 739 sub cancel_if_expired {
 740   my $self = shift;
 741   my $time = shift || time;
 742   return '' unless $self->expire && $self->expire <= $time;
 743   my $error = $self->cancel;
 744   if ( $error ) {
 745     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 746            $self->custnum. ": $error";
 747   }
 748   '';
 749 }
 750
 751 =item unexpire
 752
 753 Cancels any pending expiration (sets the expire field to null).
 754
 755 If there is an error, returns the error, otherwise returns false.
 756
 757 =cut
 758
 759 sub unexpire {
 760   my( $self, %options ) = @_;
 761   my $error;
 762
 763   local $SIG{HUP} = 'IGNORE';
 764   local $SIG{INT} = 'IGNORE';
 765   local $SIG{QUIT} = 'IGNORE';
 766   local $SIG{TERM} = 'IGNORE';
 767   local $SIG{TSTP} = 'IGNORE';
 768   local $SIG{PIPE} = 'IGNORE';
 769
 770   my $oldAutoCommit = $FS::UID::AutoCommit;
 771   local $FS::UID::AutoCommit = 0;
 772   my $dbh = dbh;
 773
 774   my $old = $self->select_for_update;
 775
 776   my $pkgnum = $old->pkgnum;
 777   if ( $old->get('cancel') || $self->get('cancel') ) {
 778     dbh->rollback if $oldAutoCommit;
 779     return "Can't unexpire cancelled package $pkgnum";
 780     # or at least it's pointless
 781   }
 782
 783   unless ( $old->get('expire') && $self->get('expire') ) {
 784     dbh->rollback if $oldAutoCommit;
 785     return "";  # no error
 786   }
 787
 788   my %hash = $self->hash;
 789   $hash{'expire'} = '';
 790   my $new = new FS::cust_pkg ( \%hash );
 791   $error = $new->replace( $self, options => { $self->options } );
 792   if ( $error ) {
 793     $dbh->rollback if $oldAutoCommit;
 794     return $error;
 795   }
 796
 797   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 798
 799   ''; #no errors
 800
 801 }
 802
 803 =item suspend [ OPTION => VALUE ... ]
 804
 805 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 806 package, then suspends the package itself (sets the susp field to now).
 807
 808 Available options are:
 809
 810 =over 4
 811
 812 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 813
 814 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 815
 816 =back
 817
 818 If there is an error, returns the error, otherwise returns false.
 819
 820 =cut
 821
 822 sub suspend {
 823   my( $self, %options ) = @_;
 824   my $error;
 825
 826   local $SIG{HUP} = 'IGNORE';
 827   local $SIG{INT} = 'IGNORE';
 828   local $SIG{QUIT} = 'IGNORE';
 829   local $SIG{TERM} = 'IGNORE';
 830   local $SIG{TSTP} = 'IGNORE';
 831   local $SIG{PIPE} = 'IGNORE';
 832
 833   my $oldAutoCommit = $FS::UID::AutoCommit;
 834   local $FS::UID::AutoCommit = 0;
 835   my $dbh = dbh;
 836
 837   my $old = $self->select_for_update;
 838
 839   my $pkgnum = $old->pkgnum;
 840   if ( $old->get('cancel') || $self->get('cancel') ) {
 841     dbh->rollback if $oldAutoCommit;
 842     return "Can't suspend cancelled package $pkgnum";
 843   }
 844
 845   if ( $old->get('susp') || $self->get('susp') ) {
 846     dbh->rollback if $oldAutoCommit;
 847     return "";  # no error                     # complain on adjourn?
 848   }
 849
 850   my $date = $options{date} if $options{date}; # adjourn/suspend later
 851   $date = '' if ($date && $date <= time);      # complain instead?
 852
 853   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 854     dbh->rollback if $oldAutoCommit;
 855     return "Package $pkgnum expires before it would be suspended.";
 856   }
 857
 858   my $suspend_time = $options{'time'} || time;
 859
 860   if ( $options{'reason'} ) {
 861     $error = $self->insert_reason( 'reason' => $options{'reason'},
 862                                    'action' => $date ? 'adjourn' : 'suspend',
 863                                    'date'   => $date ? $date : $suspend_time,
 864                                    'reason_otaker' => $options{'reason_otaker'},
 865                                  );
 866     if ( $error ) {
 867       dbh->rollback if $oldAutoCommit;
 868       return "Error inserting cust_pkg_reason: $error";
 869     }
 870   }
 871
 872   unless ( $date ) {
 873
 874     my @labels = ();
 875
 876     foreach my $cust_svc (
 877       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 878     ) {
 879       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 880
 881       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 882         $dbh->rollback if $oldAutoCommit;
 883         return "Illegal svcdb value in part_svc!";
 884       };
 885       my $svcdb = $1;
 886       require "FS/$svcdb.pm";
 887
 888       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 889       if ($svc) {
 890         $error = $svc->suspend;
 891         if ( $error ) {
 892           $dbh->rollback if $oldAutoCommit;
 893           return $error;
 894         }
 895         my( $label, $value ) = $cust_svc->label;
 896         push @labels, "$label: $value";
 897       }
 898     }
 899
 900     my $conf = new FS::Conf;
 901     if ( $conf->config('suspend_email_admin') ) {
 902
 903       my $error = send_email(
 904         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 905                                    #invoice_from ??? well as good as any
 906         'to'      => $conf->config('suspend_email_admin'),
 907         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 908         'body'    => [
 909           "This is an automatic message from your Freeside installation\n",
 910           "informing you that the following customer package has been suspended:\n",
 911           "\n",
 912           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 913           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 914           ( map { "Service : $_\n" } @labels ),
 915         ],
 916       );
 917
 918       if ( $error ) {
 919         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 920              "$error\n";
 921       }
 922
 923     }
 924
 925   }
 926
 927   my %hash = $self->hash;
 928   if ( $date ) {
 929     $hash{'adjourn'} = $date;
 930   } else {
 931     $hash{'susp'} = $suspend_time;
 932   }
 933   my $new = new FS::cust_pkg ( \%hash );
 934   $error = $new->replace( $self, options => { $self->options } );
 935   if ( $error ) {
 936     $dbh->rollback if $oldAutoCommit;
 937     return $error;
 938   }
 939
 940   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 941
 942   ''; #no errors
 943 }
 944
 945 =item unsuspend [ OPTION => VALUE ... ]
 946
 947 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 948 package, then unsuspends the package itself (clears the susp field and the
 949 adjourn field if it is in the past).
 950
 951 Available options are:
 952
 953 =over 4
 954
 955 =item adjust_next_bill
 956
 957 Can be set true to adjust the next bill date forward by
 958 the amount of time the account was inactive.  This was set true by default
 959 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 960 explicitly requested.  Price plans for which this makes sense (anniversary-date
 961 based than prorate or subscription) could have an option to enable this
 962 behaviour?
 963
 964 =back
 965
 966 If there is an error, returns the error, otherwise returns false.
 967
 968 =cut
 969
 970 sub unsuspend {
 971   my( $self, %opt ) = @_;
 972   my $error;
 973
 974   local $SIG{HUP} = 'IGNORE';
 975   local $SIG{INT} = 'IGNORE';
 976   local $SIG{QUIT} = 'IGNORE';
 977   local $SIG{TERM} = 'IGNORE';
 978   local $SIG{TSTP} = 'IGNORE';
 979   local $SIG{PIPE} = 'IGNORE';
 980
 981   my $oldAutoCommit = $FS::UID::AutoCommit;
 982   local $FS::UID::AutoCommit = 0;
 983   my $dbh = dbh;
 984
 985   my $old = $self->select_for_update;
 986
 987   my $pkgnum = $old->pkgnum;
 988   if ( $old->get('cancel') || $self->get('cancel') ) {
 989     dbh->rollback if $oldAutoCommit;
 990     return "Can't unsuspend cancelled package $pkgnum";
 991   }
 992
 993   unless ( $old->get('susp') && $self->get('susp') ) {
 994     dbh->rollback if $oldAutoCommit;
 995     return "";  # no error                     # complain instead?
 996   }
 997
 998   foreach my $cust_svc (
 999     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1000   ) {
1001     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1002
1003     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1004       $dbh->rollback if $oldAutoCommit;
1005       return "Illegal svcdb value in part_svc!";
1006     };
1007     my $svcdb = $1;
1008     require "FS/$svcdb.pm";
1009
1010     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1011     if ($svc) {
1012       $error = $svc->unsuspend;
1013       if ( $error ) {
1014         $dbh->rollback if $oldAutoCommit;
1015         return $error;
1016       }
1017     }
1018
1019   }
1020
1021   my %hash = $self->hash;
1022   my $inactive = time - $hash{'susp'};
1023
1024   my $conf = new FS::Conf;
1025
1026   if ( $inactive > 0 &&
1027        ( $hash{'bill'} || $hash{'setup'} ) &&
1028        ( $opt{'adjust_next_bill'} ||
1029          $conf->exists('unsuspend-always_adjust_next_bill_date') ||
1030          $self->part_pkg->option('unsuspend_adjust_bill', 1) )
1031      ) {
1032
1033     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive;
1034
1035   }
1036
1037   $hash{'susp'} = '';
1038   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1039   my $new = new FS::cust_pkg ( \%hash );
1040   $error = $new->replace( $self, options => { $self->options } );
1041   if ( $error ) {
1042     $dbh->rollback if $oldAutoCommit;
1043     return $error;
1044   }
1045
1046   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1047
1048   ''; #no errors
1049 }
1050
1051 =item unadjourn
1052
1053 Cancels any pending suspension (sets the adjourn field to null).
1054
1055 If there is an error, returns the error, otherwise returns false.
1056
1057 =cut
1058
1059 sub unadjourn {
1060   my( $self, %options ) = @_;
1061   my $error;
1062
1063   local $SIG{HUP} = 'IGNORE';
1064   local $SIG{INT} = 'IGNORE';
1065   local $SIG{QUIT} = 'IGNORE';
1066   local $SIG{TERM} = 'IGNORE';
1067   local $SIG{TSTP} = 'IGNORE';
1068   local $SIG{PIPE} = 'IGNORE';
1069
1070   my $oldAutoCommit = $FS::UID::AutoCommit;
1071   local $FS::UID::AutoCommit = 0;
1072   my $dbh = dbh;
1073
1074   my $old = $self->select_for_update;
1075
1076   my $pkgnum = $old->pkgnum;
1077   if ( $old->get('cancel') || $self->get('cancel') ) {
1078     dbh->rollback if $oldAutoCommit;
1079     return "Can't unadjourn cancelled package $pkgnum";
1080     # or at least it's pointless
1081   }
1082
1083   if ( $old->get('susp') || $self->get('susp') ) {
1084     dbh->rollback if $oldAutoCommit;
1085     return "Can't unadjourn suspended package $pkgnum";
1086     # perhaps this is arbitrary
1087   }
1088
1089   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1090     dbh->rollback if $oldAutoCommit;
1091     return "";  # no error
1092   }
1093
1094   my %hash = $self->hash;
1095   $hash{'adjourn'} = '';
1096   my $new = new FS::cust_pkg ( \%hash );
1097   $error = $new->replace( $self, options => { $self->options } );
1098   if ( $error ) {
1099     $dbh->rollback if $oldAutoCommit;
1100     return $error;
1101   }
1102
1103   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1104
1105   ''; #no errors
1106
1107 }
1108
1109
1110 =item change HASHREF | OPTION => VALUE ...
1111
1112 Changes this package: cancels it and creates a new one, with a different
1113 pkgpart or locationnum or both.  All services are transferred to the new
1114 package (no change will be made if this is not possible).
1115
1116 Options may be passed as a list of key/value pairs or as a hash reference.
1117 Options are:
1118
1119 =over 4
1120
1121 =item locationnum
1122
1123 New locationnum, to change the location for this package.
1124
1125 =item cust_location
1126
1127 New FS::cust_location object, to create a new location and assign it
1128 to this package.
1129
1130 =item pkgpart
1131
1132 New pkgpart (see L<FS::part_pkg>).
1133
1134 =item refnum
1135
1136 New refnum (see L<FS::part_referral>).
1137
1138 =item keep_dates
1139
1140 Set to true to transfer billing dates (start_date, setup, last_bill, bill,
1141 susp, adjourn, cancel, expire, and contract_end) to the new package.
1142
1143 =back
1144
1145 At least one of locationnum, cust_location, pkgpart, refnum must be specified
1146 (otherwise, what's the point?)
1147
1148 Returns either the new FS::cust_pkg object or a scalar error.
1149
1150 For example:
1151
1152   my $err_or_new_cust_pkg = $old_cust_pkg->change
1153
1154 =cut
1155
1156 #some false laziness w/order
1157 sub change {
1158   my $self = shift;
1159   my $opt = ref($_[0]) ? shift : { @_ };
1160
1161 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1162 #
1163
1164   my $conf = new FS::Conf;
1165
1166   # Transactionize this whole mess
1167   local $SIG{HUP} = 'IGNORE';
1168   local $SIG{INT} = 'IGNORE';
1169   local $SIG{QUIT} = 'IGNORE';
1170   local $SIG{TERM} = 'IGNORE';
1171   local $SIG{TSTP} = 'IGNORE';
1172   local $SIG{PIPE} = 'IGNORE';
1173
1174   my $oldAutoCommit = $FS::UID::AutoCommit;
1175   local $FS::UID::AutoCommit = 0;
1176   my $dbh = dbh;
1177
1178   my $error;
1179
1180   my %hash = ();
1181
1182   my $time = time;
1183
1184   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1185
1186   #$hash{$_} = $self->$_() foreach qw( setup );
1187
1188   $hash{'setup'} = $time if $self->setup;
1189
1190   $hash{'change_date'} = $time;
1191   $hash{"change_$_"}  = $self->$_()
1192     foreach qw( pkgnum pkgpart locationnum );
1193
1194   if ( $opt->{'cust_location'} &&
1195        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1196     $error = $opt->{'cust_location'}->insert;
1197     if ( $error ) {
1198       $dbh->rollback if $oldAutoCommit;
1199       return "inserting cust_location (transaction rolled back): $error";
1200     }
1201     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1202   }
1203
1204   if ( $opt->{'keep_dates'} ) {
1205     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1206                           start_date contract_end ) ) {
1207       $hash{$date} = $self->getfield($date);
1208     }
1209   }
1210
1211   # Create the new package.
1212   my $cust_pkg = new FS::cust_pkg {
1213     custnum      => $self->custnum,
1214     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1215     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1216     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1217     %hash,
1218   };
1219
1220   $error = $cust_pkg->insert( 'change' => 1 );
1221   if ($error) {
1222     $dbh->rollback if $oldAutoCommit;
1223     return $error;
1224   }
1225
1226   # Transfer services and cancel old package.
1227
1228   $error = $self->transfer($cust_pkg);
1229   if ($error and $error == 0) {
1230     # $old_pkg->transfer failed.
1231     $dbh->rollback if $oldAutoCommit;
1232     return $error;
1233   }
1234
1235   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1236     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1237     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1238     if ($error and $error == 0) {
1239       # $old_pkg->transfer failed.
1240       $dbh->rollback if $oldAutoCommit;
1241       return $error;
1242     }
1243   }
1244
1245   if ($error > 0) {
1246     # Transfers were successful, but we still had services left on the old
1247     # package.  We can't change the package under this circumstances, so abort.
1248     $dbh->rollback if $oldAutoCommit;
1249     return "Unable to transfer all services from package ". $self->pkgnum;
1250   }
1251
1252   #reset usage if changing pkgpart
1253   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1254   if ($self->pkgpart != $cust_pkg->pkgpart) {
1255     my $part_pkg = $cust_pkg->part_pkg;
1256     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1257                                                  ? ()
1258                                                  : ( 'null' => 1 )
1259                                    )
1260       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1261
1262     if ($error) {
1263       $dbh->rollback if $oldAutoCommit;
1264       return "Error setting usage values: $error";
1265     }
1266   }
1267
1268   #Good to go, cancel old package.
1269   $error = $self->cancel( quiet=>1 );
1270   if ($error) {
1271     $dbh->rollback if $oldAutoCommit;
1272     return $error;
1273   }
1274
1275   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1276     #$self->cust_main
1277     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1278     if ( $error ) {
1279       $dbh->rollback if $oldAutoCommit;
1280       return $error;
1281     }
1282   }
1283
1284   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1285
1286   $cust_pkg;
1287
1288 }
1289
1290 =item last_bill
1291
1292 Returns the last bill date, or if there is no last bill date, the setup date.
1293 Useful for billing metered services.
1294
1295 =cut
1296
1297 sub last_bill {
1298   my $self = shift;
1299   return $self->setfield('last_bill', $_[0]) if @_;
1300   return $self->getfield('last_bill') if $self->getfield('last_bill');
1301   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1302                                                   'edate'  => $self->bill,  } );
1303   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1304 }
1305
1306 =item last_cust_pkg_reason ACTION
1307
1308 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1309 Returns false if there is no reason or the package is not currenly ACTION'd
1310 ACTION is one of adjourn, susp, cancel, or expire.
1311
1312 =cut
1313
1314 sub last_cust_pkg_reason {
1315   my ( $self, $action ) = ( shift, shift );
1316   my $date = $self->get($action);
1317   qsearchs( {
1318               'table' => 'cust_pkg_reason',
1319               'hashref' => { 'pkgnum' => $self->pkgnum,
1320                              'action' => substr(uc($action), 0, 1),
1321                              'date'   => $date,
1322                            },
1323               'order_by' => 'ORDER BY num DESC LIMIT 1',
1324            } );
1325 }
1326
1327 =item last_reason ACTION
1328
1329 Returns the most recent ACTION FS::reason associated with the package.
1330 Returns false if there is no reason or the package is not currenly ACTION'd
1331 ACTION is one of adjourn, susp, cancel, or expire.
1332
1333 =cut
1334
1335 sub last_reason {
1336   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1337   $cust_pkg_reason->reason
1338     if $cust_pkg_reason;
1339 }
1340
1341 =item part_pkg
1342
1343 Returns the definition for this billing item, as an FS::part_pkg object (see
1344 L<FS::part_pkg>).
1345
1346 =cut
1347
1348 sub part_pkg {
1349   my $self = shift;
1350   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1351   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1352   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1353 }
1354
1355 =item old_cust_pkg
1356
1357 Returns the cancelled package this package was changed from, if any.
1358
1359 =cut
1360
1361 sub old_cust_pkg {
1362   my $self = shift;
1363   return '' unless $self->change_pkgnum;
1364   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1365 }
1366
1367 =item calc_setup
1368
1369 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1370 item.
1371
1372 =cut
1373
1374 sub calc_setup {
1375   my $self = shift;
1376   $self->part_pkg->calc_setup($self, @_);
1377 }
1378
1379 =item calc_recur
1380
1381 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1382 item.
1383
1384 =cut
1385
1386 sub calc_recur {
1387   my $self = shift;
1388   $self->part_pkg->calc_recur($self, @_);
1389 }
1390
1391 =item base_recur
1392
1393 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1394 item.
1395
1396 =cut
1397
1398 sub base_recur {
1399   my $self = shift;
1400   $self->part_pkg->base_recur($self, @_);
1401 }
1402
1403 =item calc_remain
1404
1405 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1406 billing item.
1407
1408 =cut
1409
1410 sub calc_remain {
1411   my $self = shift;
1412   $self->part_pkg->calc_remain($self, @_);
1413 }
1414
1415 =item calc_cancel
1416
1417 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1418 billing item.
1419
1420 =cut
1421
1422 sub calc_cancel {
1423   my $self = shift;
1424   $self->part_pkg->calc_cancel($self, @_);
1425 }
1426
1427 =item cust_bill_pkg
1428
1429 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1430
1431 =cut
1432
1433 sub cust_bill_pkg {
1434   my $self = shift;
1435   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1436 }
1437
1438 =item cust_pkg_detail [ DETAILTYPE ]
1439
1440 Returns any customer package details for this package (see
1441 L<FS::cust_pkg_detail>).
1442
1443 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1444
1445 =cut
1446
1447 sub cust_pkg_detail {
1448   my $self = shift;
1449   my %hash = ( 'pkgnum' => $self->pkgnum );
1450   $hash{detailtype} = shift if @_;
1451   qsearch({
1452     'table'    => 'cust_pkg_detail',
1453     'hashref'  => \%hash,
1454     'order_by' => 'ORDER BY weight, pkgdetailnum',
1455   });
1456 }
1457
1458 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1459
1460 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1461
1462 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1463
1464 If there is an error, returns the error, otherwise returns false.
1465
1466 =cut
1467
1468 sub set_cust_pkg_detail {
1469   my( $self, $detailtype, @details ) = @_;
1470
1471   local $SIG{HUP} = 'IGNORE';
1472   local $SIG{INT} = 'IGNORE';
1473   local $SIG{QUIT} = 'IGNORE';
1474   local $SIG{TERM} = 'IGNORE';
1475   local $SIG{TSTP} = 'IGNORE';
1476   local $SIG{PIPE} = 'IGNORE';
1477
1478   my $oldAutoCommit = $FS::UID::AutoCommit;
1479   local $FS::UID::AutoCommit = 0;
1480   my $dbh = dbh;
1481
1482   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1483     my $error = $current->delete;
1484     if ( $error ) {
1485       $dbh->rollback if $oldAutoCommit;
1486       return "error removing old detail: $error";
1487     }
1488   }
1489
1490   foreach my $detail ( @details ) {
1491     my $cust_pkg_detail = new FS::cust_pkg_detail {
1492       'pkgnum'     => $self->pkgnum,
1493       'detailtype' => $detailtype,
1494       'detail'     => $detail,
1495     };
1496     my $error = $cust_pkg_detail->insert;
1497     if ( $error ) {
1498       $dbh->rollback if $oldAutoCommit;
1499       return "error adding new detail: $error";
1500     }
1501
1502   }
1503
1504   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1505   '';
1506
1507 }
1508
1509 =item cust_event
1510
1511 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1512
1513 =cut
1514
1515 #false laziness w/cust_bill.pm
1516 sub cust_event {
1517   my $self = shift;
1518   qsearch({
1519     'table'     => 'cust_event',
1520     'addl_from' => 'JOIN part_event USING ( eventpart )',
1521     'hashref'   => { 'tablenum' => $self->pkgnum },
1522     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1523   });
1524 }
1525
1526 =item num_cust_event
1527
1528 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1529
1530 =cut
1531
1532 #false laziness w/cust_bill.pm
1533 sub num_cust_event {
1534   my $self = shift;
1535   my $sql =
1536     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1537     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1538   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1539   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1540   $sth->fetchrow_arrayref->[0];
1541 }
1542
1543 =item cust_svc [ SVCPART ]
1544
1545 Returns the services for this package, as FS::cust_svc objects (see
1546 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1547 services.
1548
1549 =cut
1550
1551 sub cust_svc {
1552   my $self = shift;
1553
1554   return () unless $self->num_cust_svc(@_);
1555
1556   if ( @_ ) {
1557     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1558                                   'svcpart' => shift,          } );
1559   }
1560
1561   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1562
1563   #if ( $self->{'_svcnum'} ) {
1564   #  values %{ $self->{'_svcnum'}->cache };
1565   #} else {
1566     $self->_sort_cust_svc(
1567       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1568     );
1569   #}
1570
1571 }
1572
1573 =item overlimit [ SVCPART ]
1574
1575 Returns the services for this package which have exceeded their
1576 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1577 is specified, return only the matching services.
1578
1579 =cut
1580
1581 sub overlimit {
1582   my $self = shift;
1583   return () unless $self->num_cust_svc(@_);
1584   grep { $_->overlimit } $self->cust_svc(@_);
1585 }
1586
1587 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1588
1589 Returns historical services for this package created before END TIMESTAMP and
1590 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1591 (see L<FS::h_cust_svc>).
1592
1593 =cut
1594
1595 sub h_cust_svc {
1596   my $self = shift;
1597
1598   $self->_sort_cust_svc(
1599     [ qsearch( 'h_cust_svc',
1600                { 'pkgnum' => $self->pkgnum, },
1601                FS::h_cust_svc->sql_h_search(@_),
1602              )
1603     ]
1604   );
1605 }
1606
1607 sub _sort_cust_svc {
1608   my( $self, $arrayref ) = @_;
1609
1610   my $sort =
1611     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1612
1613   map  { $_->[0] }
1614   sort $sort
1615   map {
1616         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1617                                              'svcpart' => $_->svcpart     } );
1618         [ $_,
1619           $pkg_svc ? $pkg_svc->primary_svc : '',
1620           $pkg_svc ? $pkg_svc->quantity : 0,
1621         ];
1622       }
1623   @$arrayref;
1624
1625 }
1626
1627 =item num_cust_svc [ SVCPART ]
1628
1629 Returns the number of provisioned services for this package.  If a svcpart is
1630 specified, counts only the matching services.
1631
1632 =cut
1633
1634 sub num_cust_svc {
1635   my $self = shift;
1636
1637   return $self->{'_num_cust_svc'}
1638     if !scalar(@_)
1639        && exists($self->{'_num_cust_svc'})
1640        && $self->{'_num_cust_svc'} =~ /\d/;
1641
1642   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1643     if $DEBUG > 2;
1644
1645   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1646   $sql .= ' AND svcpart = ?' if @_;
1647
1648   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1649   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1650   $sth->fetchrow_arrayref->[0];
1651 }
1652
1653 =item available_part_svc
1654
1655 Returns a list of FS::part_svc objects representing services included in this
1656 package but not yet provisioned.  Each FS::part_svc object also has an extra
1657 field, I<num_avail>, which specifies the number of available services.
1658
1659 =cut
1660
1661 sub available_part_svc {
1662   my $self = shift;
1663   grep { $_->num_avail > 0 }
1664     map {
1665           my $part_svc = $_->part_svc;
1666           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1667             $_->quantity - $self->num_cust_svc($_->svcpart);
1668           $part_svc;
1669         }
1670       $self->part_pkg->pkg_svc;
1671 }
1672
1673 =item part_svc
1674
1675 Returns a list of FS::part_svc objects representing provisioned and available
1676 services included in this package.  Each FS::part_svc object also has the
1677 following extra fields:
1678
1679 =over 4
1680
1681 =item num_cust_svc  (count)
1682
1683 =item num_avail     (quantity - count)
1684
1685 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1686
1687 svcnum
1688 label -> ($cust_svc->label)[1]
1689
1690 =back
1691
1692 =cut
1693
1694 sub part_svc {
1695   my $self = shift;
1696
1697   #XXX some sort of sort order besides numeric by svcpart...
1698   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1699     my $pkg_svc = $_;
1700     my $part_svc = $pkg_svc->part_svc;
1701     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1702     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1703     $part_svc->{'Hash'}{'num_avail'}    =
1704       max( 0, $pkg_svc->quantity - $num_cust_svc );
1705     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1706       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1707     $part_svc;
1708   } $self->part_pkg->pkg_svc;
1709
1710   #extras
1711   push @part_svc, map {
1712     my $part_svc = $_;
1713     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1714     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1715     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1716     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1717       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1718     $part_svc;
1719   } $self->extra_part_svc;
1720
1721   @part_svc;
1722
1723 }
1724
1725 =item extra_part_svc
1726
1727 Returns a list of FS::part_svc objects corresponding to services in this
1728 package which are still provisioned but not (any longer) available in the
1729 package definition.
1730
1731 =cut
1732
1733 sub extra_part_svc {
1734   my $self = shift;
1735
1736   my $pkgnum  = $self->pkgnum;
1737   my $pkgpart = $self->pkgpart;
1738
1739 #  qsearch( {
1740 #    'table'     => 'part_svc',
1741 #    'hashref'   => {},
1742 #    'extra_sql' =>
1743 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1744 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1745 #                       AND pkg_svc.pkgpart = ?
1746 #                       AND quantity > 0
1747 #                 )
1748 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1749 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1750 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1751 #                       AND pkgnum = ?
1752 #                 )",
1753 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1754 #  } );
1755
1756 #seems to benchmark slightly faster...
1757   qsearch( {
1758     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1759     #MySQL doesn't grok DISINCT ON
1760     'select'      => 'DISTINCT part_svc.*',
1761     'table'       => 'part_svc',
1762     'addl_from'   =>
1763       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1764                                AND pkg_svc.pkgpart   = ?
1765                                AND quantity > 0
1766                              )
1767        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1768        LEFT JOIN cust_pkg USING ( pkgnum )
1769       ',
1770     'hashref'     => {},
1771     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1772     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1773   } );
1774 }
1775
1776 =item status
1777
1778 Returns a short status string for this package, currently:
1779
1780 =over 4
1781
1782 =item not yet billed
1783
1784 =item one-time charge
1785
1786 =item active
1787
1788 =item suspended
1789
1790 =item cancelled
1791
1792 =back
1793
1794 =cut
1795
1796 sub status {
1797   my $self = shift;
1798
1799   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1800
1801   return 'cancelled' if $self->get('cancel');
1802   return 'suspended' if $self->susp;
1803   return 'not yet billed' unless $self->setup;
1804   return 'one-time charge' if $freq =~ /^(0|$)/;
1805   return 'active';
1806 }
1807
1808 =item ucfirst_status
1809
1810 Returns the status with the first character capitalized.
1811
1812 =cut
1813
1814 sub ucfirst_status {
1815   ucfirst(shift->status);
1816 }
1817
1818 =item statuses
1819
1820 Class method that returns the list of possible status strings for packages
1821 (see L<the status method|/status>).  For example:
1822
1823   @statuses = FS::cust_pkg->statuses();
1824
1825 =cut
1826
1827 tie my %statuscolor, 'Tie::IxHash',
1828   'not yet billed'  => '009999', #teal? cyan?
1829   'one-time charge' => '000000',
1830   'active'          => '00CC00',
1831   'suspended'       => 'FF9900',
1832   'cancelled'       => 'FF0000',
1833 ;
1834
1835 sub statuses {
1836   my $self = shift; #could be class...
1837   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1838   #                                    # mayble split btw one-time vs. recur
1839     keys %statuscolor;
1840 }
1841
1842 =item statuscolor
1843
1844 Returns a hex triplet color string for this package's status.
1845
1846 =cut
1847
1848 sub statuscolor {
1849   my $self = shift;
1850   $statuscolor{$self->status};
1851 }
1852
1853 =item pkg_label
1854
1855 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1856 "pkg-comment" depending on user preference).
1857
1858 =cut
1859
1860 sub pkg_label {
1861   my $self = shift;
1862   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1863   $label = $self->pkgnum. ": $label"
1864     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1865   $label;
1866 }
1867
1868 =item pkg_label_long
1869
1870 Returns a long label for this package, adding the primary service's label to
1871 pkg_label.
1872
1873 =cut
1874
1875 sub pkg_label_long {
1876   my $self = shift;
1877   my $label = $self->pkg_label;
1878   my $cust_svc = $self->primary_cust_svc;
1879   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1880   $label;
1881 }
1882
1883 =item primary_cust_svc
1884
1885 Returns a primary service (as FS::cust_svc object) if one can be identified.
1886
1887 =cut
1888
1889 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1890
1891 sub primary_cust_svc {
1892   my $self = shift;
1893
1894   my @cust_svc = $self->cust_svc;
1895
1896   return '' unless @cust_svc; #no serivces - irrelevant then
1897
1898   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1899
1900   # primary service as specified in the package definition
1901   # or exactly one service definition with quantity one
1902   my $svcpart = $self->part_pkg->svcpart;
1903   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1904   return $cust_svc[0] if scalar(@cust_svc) == 1;
1905
1906   #couldn't identify one thing..
1907   return '';
1908 }
1909
1910 =item labels
1911
1912 Returns a list of lists, calling the label method for all services
1913 (see L<FS::cust_svc>) of this billing item.
1914
1915 =cut
1916
1917 sub labels {
1918   my $self = shift;
1919   map { [ $_->label ] } $self->cust_svc;
1920 }
1921
1922 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1923
1924 Like the labels method, but returns historical information on services that
1925 were active as of END_TIMESTAMP and (optionally) not cancelled before
1926 START_TIMESTAMP.
1927
1928 Returns a list of lists, calling the label method for all (historical) services
1929 (see L<FS::h_cust_svc>) of this billing item.
1930
1931 =cut
1932
1933 sub h_labels {
1934   my $self = shift;
1935   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1936 }
1937
1938 =item labels_short
1939
1940 Like labels, except returns a simple flat list, and shortens long
1941 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1942 identical services to one line that lists the service label and the number of
1943 individual services rather than individual items.
1944
1945 =cut
1946
1947 sub labels_short {
1948   shift->_labels_short( 'labels', @_ );
1949 }
1950
1951 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1952
1953 Like h_labels, except returns a simple flat list, and shortens long
1954 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1955 identical services to one line that lists the service label and the number of
1956 individual services rather than individual items.
1957
1958 =cut
1959
1960 sub h_labels_short {
1961   shift->_labels_short( 'h_labels', @_ );
1962 }
1963
1964 sub _labels_short {
1965   my( $self, $method ) = ( shift, shift );
1966
1967   my $conf = new FS::Conf;
1968   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1969
1970   my %labels;
1971   #tie %labels, 'Tie::IxHash';
1972   push @{ $labels{$_->[0]} }, $_->[1]
1973     foreach $self->$method(@_);
1974   my @labels;
1975   foreach my $label ( keys %labels ) {
1976     my %seen = ();
1977     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1978     my $num = scalar(@values);
1979     if ( $num > $max_same_services ) {
1980       push @labels, "$label ($num)";
1981     } else {
1982       if ( $conf->exists('cust_bill-consolidate_services') ) {
1983         # push @labels, "$label: ". join(', ', @values);
1984         while ( @values ) {
1985           my $detail = "$label: ";
1986           $detail .= shift(@values). ', '
1987             while @values && length($detail.$values[0]) < 78;
1988           $detail =~ s/, $//;
1989           push @labels, $detail;
1990         }
1991       } else {
1992         push @labels, map { "$label: $_" } @values;
1993       }
1994     }
1995   }
1996
1997  @labels;
1998
1999 }
2000
2001 =item cust_main
2002
2003 Returns the parent customer object (see L<FS::cust_main>).
2004
2005 =cut
2006
2007 sub cust_main {
2008   my $self = shift;
2009   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2010 }
2011
2012 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2013
2014 =item cust_location
2015
2016 Returns the location object, if any (see L<FS::cust_location>).
2017
2018 =item cust_location_or_main
2019
2020 If this package is associated with a location, returns the locaiton (see
2021 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2022
2023 =item location_label [ OPTION => VALUE ... ]
2024
2025 Returns the label of the location object (see L<FS::cust_location>).
2026
2027 =cut
2028
2029 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2030
2031 =item seconds_since TIMESTAMP
2032
2033 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2034 package have been online since TIMESTAMP, according to the session monitor.
2035
2036 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2037 L<Time::Local> and L<Date::Parse> for conversion functions.
2038
2039 =cut
2040
2041 sub seconds_since {
2042   my($self, $since) = @_;
2043   my $seconds = 0;
2044
2045   foreach my $cust_svc (
2046     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2047   ) {
2048     $seconds += $cust_svc->seconds_since($since);
2049   }
2050
2051   $seconds;
2052
2053 }
2054
2055 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2056
2057 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2058 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2059 (exclusive).
2060
2061 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2062 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2063 functions.
2064
2065
2066 =cut
2067
2068 sub seconds_since_sqlradacct {
2069   my($self, $start, $end) = @_;
2070
2071   my $seconds = 0;
2072
2073   foreach my $cust_svc (
2074     grep {
2075       my $part_svc = $_->part_svc;
2076       $part_svc->svcdb eq 'svc_acct'
2077         && scalar($part_svc->part_export('sqlradius'));
2078     } $self->cust_svc
2079   ) {
2080     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2081   }
2082
2083   $seconds;
2084
2085 }
2086
2087 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2088
2089 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2090 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2091 TIMESTAMP_END
2092 (exclusive).
2093
2094 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2095 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2096 functions.
2097
2098 =cut
2099
2100 sub attribute_since_sqlradacct {
2101   my($self, $start, $end, $attrib) = @_;
2102
2103   my $sum = 0;
2104
2105   foreach my $cust_svc (
2106     grep {
2107       my $part_svc = $_->part_svc;
2108       $part_svc->svcdb eq 'svc_acct'
2109         && scalar($part_svc->part_export('sqlradius'));
2110     } $self->cust_svc
2111   ) {
2112     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2113   }
2114
2115   $sum;
2116
2117 }
2118
2119 =item quantity
2120
2121 =cut
2122
2123 sub quantity {
2124   my( $self, $value ) = @_;
2125   if ( defined($value) ) {
2126     $self->setfield('quantity', $value);
2127   }
2128   $self->getfield('quantity') || 1;
2129 }
2130
2131 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2132
2133 Transfers as many services as possible from this package to another package.
2134
2135 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2136 object.  The destination package must already exist.
2137
2138 Services are moved only if the destination allows services with the correct
2139 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2140 this option with caution!  No provision is made for export differences
2141 between the old and new service definitions.  Probably only should be used
2142 when your exports for all service definitions of a given svcdb are identical.
2143 (attempt a transfer without it first, to move all possible svcpart-matching
2144 services)
2145
2146 Any services that can't be moved remain in the original package.
2147
2148 Returns an error, if there is one; otherwise, returns the number of services
2149 that couldn't be moved.
2150
2151 =cut
2152
2153 sub transfer {
2154   my ($self, $dest_pkgnum, %opt) = @_;
2155
2156   my $remaining = 0;
2157   my $dest;
2158   my %target;
2159
2160   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2161     $dest = $dest_pkgnum;
2162     $dest_pkgnum = $dest->pkgnum;
2163   } else {
2164     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2165   }
2166
2167   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2168
2169   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2170     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2171   }
2172
2173   foreach my $cust_svc ($dest->cust_svc) {
2174     $target{$cust_svc->svcpart}--;
2175   }
2176
2177   my %svcpart2svcparts = ();
2178   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2179     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2180     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2181       next if exists $svcpart2svcparts{$svcpart};
2182       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2183       $svcpart2svcparts{$svcpart} = [
2184         map  { $_->[0] }
2185         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2186         map {
2187               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2188                                                    'svcpart' => $_          } );
2189               [ $_,
2190                 $pkg_svc ? $pkg_svc->primary_svc : '',
2191                 $pkg_svc ? $pkg_svc->quantity : 0,
2192               ];
2193             }
2194
2195         grep { $_ != $svcpart }
2196         map  { $_->svcpart }
2197         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2198       ];
2199       warn "alternates for svcpart $svcpart: ".
2200            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2201         if $DEBUG;
2202     }
2203   }
2204
2205   foreach my $cust_svc ($self->cust_svc) {
2206     if($target{$cust_svc->svcpart} > 0) {
2207       $target{$cust_svc->svcpart}--;
2208       my $new = new FS::cust_svc { $cust_svc->hash };
2209       $new->pkgnum($dest_pkgnum);
2210       my $error = $new->replace($cust_svc);
2211       return $error if $error;
2212     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2213       if ( $DEBUG ) {
2214         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2215         warn "alternates to consider: ".
2216              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2217       }
2218       my @alternate = grep {
2219                              warn "considering alternate svcpart $_: ".
2220                                   "$target{$_} available in new package\n"
2221                                if $DEBUG;
2222                              $target{$_} > 0;
2223                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2224       if ( @alternate ) {
2225         warn "alternate(s) found\n" if $DEBUG;
2226         my $change_svcpart = $alternate[0];
2227         $target{$change_svcpart}--;
2228         my $new = new FS::cust_svc { $cust_svc->hash };
2229         $new->svcpart($change_svcpart);
2230         $new->pkgnum($dest_pkgnum);
2231         my $error = $new->replace($cust_svc);
2232         return $error if $error;
2233       } else {
2234         $remaining++;
2235       }
2236     } else {
2237       $remaining++
2238     }
2239   }
2240   return $remaining;
2241 }
2242
2243 =item reexport
2244
2245 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2246 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2247
2248 =cut
2249
2250 sub reexport {
2251   my $self = shift;
2252
2253   local $SIG{HUP} = 'IGNORE';
2254   local $SIG{INT} = 'IGNORE';
2255   local $SIG{QUIT} = 'IGNORE';
2256   local $SIG{TERM} = 'IGNORE';
2257   local $SIG{TSTP} = 'IGNORE';
2258   local $SIG{PIPE} = 'IGNORE';
2259
2260   my $oldAutoCommit = $FS::UID::AutoCommit;
2261   local $FS::UID::AutoCommit = 0;
2262   my $dbh = dbh;
2263
2264   foreach my $cust_svc ( $self->cust_svc ) {
2265     #false laziness w/svc_Common::insert
2266     my $svc_x = $cust_svc->svc_x;
2267     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2268       my $error = $part_export->export_insert($svc_x);
2269       if ( $error ) {
2270         $dbh->rollback if $oldAutoCommit;
2271         return $error;
2272       }
2273     }
2274   }
2275
2276   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2277   '';
2278
2279 }
2280
2281 =item insert_reason
2282
2283 Associates this package with a (suspension or cancellation) reason (see
2284 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2285 L<FS::reason>).
2286
2287 Available options are:
2288
2289 =over 4
2290
2291 =item reason
2292
2293 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.
2294
2295 =item reason_otaker
2296
2297 the access_user (see L<FS::access_user>) providing the reason
2298
2299 =item date
2300
2301 a unix timestamp
2302
2303 =item action
2304
2305 the action (cancel, susp, adjourn, expire) associated with the reason
2306
2307 =back
2308
2309 If there is an error, returns the error, otherwise returns false.
2310
2311 =cut
2312
2313 sub insert_reason {
2314   my ($self, %options) = @_;
2315
2316   my $otaker = $options{reason_otaker} ||
2317                $FS::CurrentUser::CurrentUser->username;
2318
2319   my $reasonnum;
2320   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2321
2322     $reasonnum = $1;
2323
2324   } elsif ( ref($options{'reason'}) ) {
2325
2326     return 'Enter a new reason (or select an existing one)'
2327       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2328
2329     my $reason = new FS::reason({
2330       'reason_type' => $options{'reason'}->{'typenum'},
2331       'reason'      => $options{'reason'}->{'reason'},
2332     });
2333     my $error = $reason->insert;
2334     return $error if $error;
2335
2336     $reasonnum = $reason->reasonnum;
2337
2338   } else {
2339     return "Unparsable reason: ". $options{'reason'};
2340   }
2341
2342   my $cust_pkg_reason =
2343     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2344                               'reasonnum' => $reasonnum,
2345                               'otaker'    => $otaker,
2346                               'action'    => substr(uc($options{'action'}),0,1),
2347                               'date'      => $options{'date'}
2348                                                ? $options{'date'}
2349                                                : time,
2350                             });
2351
2352   $cust_pkg_reason->insert;
2353 }
2354
2355 =item insert_discount
2356
2357 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2358 inserting a new discount on the fly (see L<FS::discount>).
2359
2360 Available options are:
2361
2362 =over 4
2363
2364 =item discountnum
2365
2366 =back
2367
2368 If there is an error, returns the error, otherwise returns false.
2369
2370 =cut
2371
2372 sub insert_discount {
2373   #my ($self, %options) = @_;
2374   my $self = shift;
2375
2376   my $cust_pkg_discount = new FS::cust_pkg_discount {
2377     'pkgnum'      => $self->pkgnum,
2378     'discountnum' => $self->discountnum,
2379     'months_used' => 0,
2380     'end_date'    => '', #XXX
2381     'otaker'      => $self->otaker,
2382     #for the create a new discount case
2383     '_type'       => $self->discountnum__type,
2384     'amount'      => $self->discountnum_amount,
2385     'percent'     => $self->discountnum_percent,
2386     'months'      => $self->discountnum_months,
2387     #'disabled'    => $self->discountnum_disabled,
2388   };
2389
2390   $cust_pkg_discount->insert;
2391 }
2392
2393 =item set_usage USAGE_VALUE_HASHREF
2394
2395 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2396 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2397 upbytes, downbytes, and totalbytes are appropriate keys.
2398
2399 All svc_accts which are part of this package have their values reset.
2400
2401 =cut
2402
2403 sub set_usage {
2404   my ($self, $valueref, %opt) = @_;
2405
2406   foreach my $cust_svc ($self->cust_svc){
2407     my $svc_x = $cust_svc->svc_x;
2408     $svc_x->set_usage($valueref, %opt)
2409       if $svc_x->can("set_usage");
2410   }
2411 }
2412
2413 =item recharge USAGE_VALUE_HASHREF
2414
2415 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2416 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2417 upbytes, downbytes, and totalbytes are appropriate keys.
2418
2419 All svc_accts which are part of this package have their values incremented.
2420
2421 =cut
2422
2423 sub recharge {
2424   my ($self, $valueref) = @_;
2425
2426   foreach my $cust_svc ($self->cust_svc){
2427     my $svc_x = $cust_svc->svc_x;
2428     $svc_x->recharge($valueref)
2429       if $svc_x->can("recharge");
2430   }
2431 }
2432
2433 =item cust_pkg_discount
2434
2435 =cut
2436
2437 sub cust_pkg_discount {
2438   my $self = shift;
2439   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2440 }
2441
2442 =item cust_pkg_discount_active
2443
2444 =cut
2445
2446 sub cust_pkg_discount_active {
2447   my $self = shift;
2448   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2449 }
2450
2451 =back
2452
2453 =head1 CLASS METHODS
2454
2455 =over 4
2456
2457 =item recurring_sql
2458
2459 Returns an SQL expression identifying recurring packages.
2460
2461 =cut
2462
2463 sub recurring_sql { "
2464   '0' != ( select freq from part_pkg
2465              where cust_pkg.pkgpart = part_pkg.pkgpart )
2466 "; }
2467
2468 =item onetime_sql
2469
2470 Returns an SQL expression identifying one-time packages.
2471
2472 =cut
2473
2474 sub onetime_sql { "
2475   '0' = ( select freq from part_pkg
2476             where cust_pkg.pkgpart = part_pkg.pkgpart )
2477 "; }
2478
2479 =item ordered_sql
2480
2481 Returns an SQL expression identifying ordered packages (recurring packages not
2482 yet billed).
2483
2484 =cut
2485
2486 sub ordered_sql {
2487    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2488 }
2489
2490 =item active_sql
2491
2492 Returns an SQL expression identifying active packages.
2493
2494 =cut
2495
2496 sub active_sql {
2497   $_[0]->recurring_sql. "
2498   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2499   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2500   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2501 "; }
2502
2503 =item not_yet_billed_sql
2504
2505 Returns an SQL expression identifying packages which have not yet been billed.
2506
2507 =cut
2508
2509 sub not_yet_billed_sql { "
2510       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2511   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2512   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2513 "; }
2514
2515 =item inactive_sql
2516
2517 Returns an SQL expression identifying inactive packages (one-time packages
2518 that are otherwise unsuspended/uncancelled).
2519
2520 =cut
2521
2522 sub inactive_sql { "
2523   ". $_[0]->onetime_sql(). "
2524   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2525   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2526   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2527 "; }
2528
2529 =item susp_sql
2530 =item suspended_sql
2531
2532 Returns an SQL expression identifying suspended packages.
2533
2534 =cut
2535
2536 sub suspended_sql { susp_sql(@_); }
2537 sub susp_sql {
2538   #$_[0]->recurring_sql(). ' AND '.
2539   "
2540         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2541     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2542   ";
2543 }
2544
2545 =item cancel_sql
2546 =item cancelled_sql
2547
2548 Returns an SQL exprression identifying cancelled packages.
2549
2550 =cut
2551
2552 sub cancelled_sql { cancel_sql(@_); }
2553 sub cancel_sql {
2554   #$_[0]->recurring_sql(). ' AND '.
2555   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2556 }
2557
2558 =item status_sql
2559
2560 Returns an SQL expression to give the package status as a string.
2561
2562 =cut
2563
2564 sub status_sql {
2565 "CASE
2566   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
2567   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
2568   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
2569   WHEN ".onetime_sql()." THEN 'one-time charge'
2570   ELSE 'active'
2571 END"
2572 }
2573
2574 =item search HASHREF
2575
2576 (Class method)
2577
2578 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2579 Valid parameters are
2580
2581 =over 4
2582
2583 =item agentnum
2584
2585 =item magic
2586
2587 active, inactive, suspended, cancel (or cancelled)
2588
2589 =item status
2590
2591 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2592
2593 =item custom
2594
2595  boolean selects custom packages
2596
2597 =item classnum
2598
2599 =item pkgpart
2600
2601 pkgpart or arrayref or hashref of pkgparts
2602
2603 =item setup
2604
2605 arrayref of beginning and ending epoch date
2606
2607 =item last_bill
2608
2609 arrayref of beginning and ending epoch date
2610
2611 =item bill
2612
2613 arrayref of beginning and ending epoch date
2614
2615 =item adjourn
2616
2617 arrayref of beginning and ending epoch date
2618
2619 =item susp
2620
2621 arrayref of beginning and ending epoch date
2622
2623 =item expire
2624
2625 arrayref of beginning and ending epoch date
2626
2627 =item cancel
2628
2629 arrayref of beginning and ending epoch date
2630
2631 =item query
2632
2633 pkgnum or APKG_pkgnum
2634
2635 =item cust_fields
2636
2637 a value suited to passing to FS::UI::Web::cust_header
2638
2639 =item CurrentUser
2640
2641 specifies the user for agent virtualization
2642
2643 =item fcc_line
2644
2645  boolean selects packages containing fcc form 477 telco lines
2646
2647 =back
2648
2649 =cut
2650
2651 sub search {
2652   my ($class, $params) = @_;
2653   my @where = ();
2654
2655   ##
2656   # parse agent
2657   ##
2658
2659   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2660     push @where,
2661       "cust_main.agentnum = $1";
2662   }
2663
2664   ##
2665   # parse custnum
2666   ##
2667
2668   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2669     push @where,
2670       "cust_pkg.custnum = $1";
2671   }
2672
2673   ##
2674   # custbatch
2675   ##
2676
2677   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2678     push @where,
2679       "cust_pkg.pkgbatch = '$1'";
2680   }
2681
2682   ##
2683   # parse status
2684   ##
2685
2686   if (    $params->{'magic'}  eq 'active'
2687        || $params->{'status'} eq 'active' ) {
2688
2689     push @where, FS::cust_pkg->active_sql();
2690
2691   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2692             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2693
2694     push @where, FS::cust_pkg->not_yet_billed_sql();
2695
2696   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2697             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2698
2699     push @where, FS::cust_pkg->inactive_sql();
2700
2701   } elsif (    $params->{'magic'}  eq 'suspended'
2702             || $params->{'status'} eq 'suspended'  ) {
2703
2704     push @where, FS::cust_pkg->suspended_sql();
2705
2706   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2707             || $params->{'status'} =~ /^cancell?ed$/ ) {
2708
2709     push @where, FS::cust_pkg->cancelled_sql();
2710
2711   }
2712
2713   ###
2714   # parse package class
2715   ###
2716
2717   #false lazinessish w/graph/cust_bill_pkg.cgi
2718   my $classnum = 0;
2719   my @pkg_class = ();
2720   if ( exists($params->{'classnum'})
2721        && $params->{'classnum'} =~ /^(\d*)$/
2722      )
2723   {
2724     $classnum = $1;
2725     if ( $classnum ) { #a specific class
2726       push @where, "part_pkg.classnum = $classnum";
2727
2728       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2729       #die "classnum $classnum not found!" unless $pkg_class[0];
2730       #$title .= $pkg_class[0]->classname.' ';
2731
2732     } elsif ( $classnum eq '' ) { #the empty class
2733
2734       push @where, "part_pkg.classnum IS NULL";
2735       #$title .= 'Empty class ';
2736       #@pkg_class = ( '(empty class)' );
2737     } elsif ( $classnum eq '0' ) {
2738       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2739       #push @pkg_class, '(empty class)';
2740     } else {
2741       die "illegal classnum";
2742     }
2743   }
2744   #eslaf
2745
2746   ###
2747   # parse package report options
2748   ###
2749
2750   my @report_option = ();
2751   if ( exists($params->{'report_option'})
2752        && $params->{'report_option'} =~ /^([,\d]*)$/
2753      )
2754   {
2755     @report_option = split(',', $1);
2756   }
2757
2758   if (@report_option) {
2759     # this will result in the empty set for the dangling comma case as it should
2760     push @where,
2761       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2762                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2763                     AND optionname = 'report_option_$_'
2764                     AND optionvalue = '1' )"
2765          } @report_option;
2766   }
2767
2768   #eslaf
2769
2770   ###
2771   # parse custom
2772   ###
2773
2774   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2775
2776   ###
2777   # parse fcc_line
2778   ###
2779
2780   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2781
2782   ###
2783   # parse censustract
2784   ###
2785
2786   if ( exists($params->{'censustract'}) ) {
2787     $params->{'censustract'} =~ /^([.\d]*)$/;
2788     my $censustract = "cust_main.censustract = '$1'";
2789     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2790     push @where,  "( $censustract )";
2791   }
2792
2793   ###
2794   # parse part_pkg
2795   ###
2796
2797   if ( ref($params->{'pkgpart'}) ) {
2798
2799     my @pkgpart = ();
2800     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2801       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2802     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2803       @pkgpart = @{ $params->{'pkgpart'} };
2804     } else {
2805       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2806     }
2807
2808     @pkgpart = grep /^(\d+)$/, @pkgpart;
2809
2810     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2811
2812   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2813     push @where, "pkgpart = $1";
2814   }
2815
2816   ###
2817   # parse dates
2818   ###
2819
2820   my $orderby = '';
2821
2822   #false laziness w/report_cust_pkg.html
2823   my %disable = (
2824     'all'             => {},
2825     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2826     'active'          => { 'susp'=>1, 'cancel'=>1 },
2827     'suspended'       => { 'cancel' => 1 },
2828     'cancelled'       => {},
2829     ''                => {},
2830   );
2831
2832   if( exists($params->{'active'} ) ) {
2833     # This overrides all the other date-related fields
2834     my($beginning, $ending) = @{$params->{'active'}};
2835     push @where,
2836       "cust_pkg.setup IS NOT NULL",
2837       "cust_pkg.setup <= $ending",
2838       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2839       "NOT (".FS::cust_pkg->onetime_sql . ")";
2840   }
2841   else {
2842     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end cancel )) {
2843
2844       next unless exists($params->{$field});
2845
2846       my($beginning, $ending) = @{$params->{$field}};
2847
2848       next if $beginning == 0 && $ending == 4294967295;
2849
2850       push @where,
2851         "cust_pkg.$field IS NOT NULL",
2852         "cust_pkg.$field >= $beginning",
2853         "cust_pkg.$field <= $ending";
2854
2855       $orderby ||= "ORDER BY cust_pkg.$field";
2856
2857     }
2858   }
2859
2860   $orderby ||= 'ORDER BY bill';
2861
2862   ###
2863   # parse magic, legacy, etc.
2864   ###
2865
2866   if ( $params->{'magic'} &&
2867        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2868   ) {
2869
2870     $orderby = 'ORDER BY pkgnum';
2871
2872     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2873       push @where, "pkgpart = $1";
2874     }
2875
2876   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2877
2878     $orderby = 'ORDER BY pkgnum';
2879
2880   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2881
2882     $orderby = 'ORDER BY pkgnum';
2883
2884     push @where, '0 < (
2885       SELECT count(*) FROM pkg_svc
2886        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2887          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2888                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2889                                      AND cust_svc.svcpart = pkg_svc.svcpart
2890                                 )
2891     )';
2892
2893   }
2894
2895   ##
2896   # setup queries, links, subs, etc. for the search
2897   ##
2898
2899   # here is the agent virtualization
2900   if ($params->{CurrentUser}) {
2901     my $access_user =
2902       qsearchs('access_user', { username => $params->{CurrentUser} });
2903
2904     if ($access_user) {
2905       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2906     } else {
2907       push @where, "1=0";
2908     }
2909   } else {
2910     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2911   }
2912
2913   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2914
2915   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2916                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2917                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2918
2919   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2920
2921   my $sql_query = {
2922     'table'       => 'cust_pkg',
2923     'hashref'     => {},
2924     'select'      => join(', ',
2925                                 'cust_pkg.*',
2926                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2927                                 'pkg_class.classname',
2928                                 'cust_main.custnum AS cust_main_custnum',
2929                                 FS::UI::Web::cust_sql_fields(
2930                                   $params->{'cust_fields'}
2931                                 ),
2932                      ),
2933     'extra_sql'   => "$extra_sql $orderby",
2934     'addl_from'   => $addl_from,
2935     'count_query' => $count_query,
2936   };
2937
2938 }
2939
2940 =item fcc_477_count
2941
2942 Returns a list of two package counts.  The first is a count of packages
2943 based on the supplied criteria and the second is the count of residential
2944 packages with those same criteria.  Criteria are specified as in the search
2945 method.
2946
2947 =cut
2948
2949 sub fcc_477_count {
2950   my ($class, $params) = @_;
2951
2952   my $sql_query = $class->search( $params );
2953
2954   my $count_sql = delete($sql_query->{'count_query'});
2955   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2956     or die "couldn't parse count_sql";
2957
2958   my $count_sth = dbh->prepare($count_sql)
2959     or die "Error preparing $count_sql: ". dbh->errstr;
2960   $count_sth->execute
2961     or die "Error executing $count_sql: ". $count_sth->errstr;
2962   my $count_arrayref = $count_sth->fetchrow_arrayref;
2963
2964   return ( @$count_arrayref );
2965
2966 }
2967
2968
2969 =item location_sql
2970
2971 Returns a list: the first item is an SQL fragment identifying matching
2972 packages/customers via location (taking into account shipping and package
2973 address taxation, if enabled), and subsequent items are the parameters to
2974 substitute for the placeholders in that fragment.
2975
2976 =cut
2977
2978 sub location_sql {
2979   my($class, %opt) = @_;
2980   my $ornull = $opt{'ornull'};
2981
2982   my $conf = new FS::Conf;
2983
2984   # '?' placeholders in _location_sql_where
2985   my $x = $ornull ? 3 : 2;
2986   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2987
2988   my $main_where;
2989   my @main_param;
2990   if ( $conf->exists('tax-ship_address') ) {
2991
2992     $main_where = "(
2993          (     ( ship_last IS NULL     OR  ship_last  = '' )
2994            AND ". _location_sql_where('cust_main', '', $ornull ). "
2995          )
2996       OR (       ship_last IS NOT NULL AND ship_last != ''
2997            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2998          )
2999     )";
3000     #    AND payby != 'COMP'
3001
3002     @main_param = ( @bill_param, @bill_param );
3003
3004   } else {
3005
3006     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3007     @main_param = @bill_param;
3008
3009   }
3010
3011   my $where;
3012   my @param;
3013   if ( $conf->exists('tax-pkg_address') ) {
3014
3015     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3016
3017     $where = " (
3018                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3019                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3020                )
3021              ";
3022     @param = ( @main_param, @bill_param );
3023
3024   } else {
3025
3026     $where = $main_where;
3027     @param = @main_param;
3028
3029   }
3030
3031   ( $where, @param );
3032
3033 }
3034
3035 #subroutine, helper for location_sql
3036 sub _location_sql_where {
3037   my $table  = shift;
3038   my $prefix = @_ ? shift : '';
3039   my $ornull = @_ ? shift : '';
3040
3041 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3042
3043   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3044
3045   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3046   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3047   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3048
3049 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3050   "
3051         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3052     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3053     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3054     AND   $table.${prefix}country = ?
3055   ";
3056 }
3057
3058 =head1 SUBROUTINES
3059
3060 =over 4
3061
3062 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3063
3064 CUSTNUM is a customer (see L<FS::cust_main>)
3065
3066 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3067 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3068 permitted.
3069
3070 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3071 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3072 new billing items.  An error is returned if this is not possible (see
3073 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3074 parameter.
3075
3076 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3077 newly-created cust_pkg objects.
3078
3079 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3080 and inserted.  Multiple FS::pkg_referral records can be created by
3081 setting I<refnum> to an array reference of refnums or a hash reference with
3082 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3083 record will be created corresponding to cust_main.refnum.
3084
3085 =cut
3086
3087 sub order {
3088   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3089
3090   my $conf = new FS::Conf;
3091
3092   # Transactionize this whole mess
3093   local $SIG{HUP} = 'IGNORE';
3094   local $SIG{INT} = 'IGNORE';
3095   local $SIG{QUIT} = 'IGNORE';
3096   local $SIG{TERM} = 'IGNORE';
3097   local $SIG{TSTP} = 'IGNORE';
3098   local $SIG{PIPE} = 'IGNORE';
3099
3100   my $oldAutoCommit = $FS::UID::AutoCommit;
3101   local $FS::UID::AutoCommit = 0;
3102   my $dbh = dbh;
3103
3104   my $error;
3105 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3106 #  return "Customer not found: $custnum" unless $cust_main;
3107
3108   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3109     if $DEBUG;
3110
3111   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3112                          @$remove_pkgnum;
3113
3114   my $change = scalar(@old_cust_pkg) != 0;
3115
3116   my %hash = ();
3117   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3118
3119     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3120          " to pkgpart ". $pkgparts->[0]. "\n"
3121       if $DEBUG;
3122
3123     my $err_or_cust_pkg =
3124       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3125                                 'refnum'  => $refnum,
3126                               );
3127
3128     unless (ref($err_or_cust_pkg)) {
3129       $dbh->rollback if $oldAutoCommit;
3130       return $err_or_cust_pkg;
3131     }
3132
3133     push @$return_cust_pkg, $err_or_cust_pkg;
3134     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3135     return '';
3136
3137   }
3138
3139   # Create the new packages.
3140   foreach my $pkgpart (@$pkgparts) {
3141
3142     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3143
3144     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3145                                       pkgpart => $pkgpart,
3146                                       refnum  => $refnum,
3147                                       %hash,
3148                                     };
3149     $error = $cust_pkg->insert( 'change' => $change );
3150     if ($error) {
3151       $dbh->rollback if $oldAutoCommit;
3152       return $error;
3153     }
3154     push @$return_cust_pkg, $cust_pkg;
3155   }
3156   # $return_cust_pkg now contains refs to all of the newly
3157   # created packages.
3158
3159   # Transfer services and cancel old packages.
3160   foreach my $old_pkg (@old_cust_pkg) {
3161
3162     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3163       if $DEBUG;
3164
3165     foreach my $new_pkg (@$return_cust_pkg) {
3166       $error = $old_pkg->transfer($new_pkg);
3167       if ($error and $error == 0) {
3168         # $old_pkg->transfer failed.
3169         $dbh->rollback if $oldAutoCommit;
3170         return $error;
3171       }
3172     }
3173
3174     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3175       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3176       foreach my $new_pkg (@$return_cust_pkg) {
3177         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3178         if ($error and $error == 0) {
3179           # $old_pkg->transfer failed.
3180         $dbh->rollback if $oldAutoCommit;
3181         return $error;
3182         }
3183       }
3184     }
3185
3186     if ($error > 0) {
3187       # Transfers were successful, but we went through all of the
3188       # new packages and still had services left on the old package.
3189       # We can't cancel the package under the circumstances, so abort.
3190       $dbh->rollback if $oldAutoCommit;
3191       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3192     }
3193     $error = $old_pkg->cancel( quiet=>1 );
3194     if ($error) {
3195       $dbh->rollback;
3196       return $error;
3197     }
3198   }
3199   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3200   '';
3201 }
3202
3203 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3204
3205 A bulk change method to change packages for multiple customers.
3206
3207 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3208 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3209 permitted.
3210
3211 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3212 replace.  The services (see L<FS::cust_svc>) are moved to the
3213 new billing items.  An error is returned if this is not possible (see
3214 L<FS::pkg_svc>).
3215
3216 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3217 newly-created cust_pkg objects.
3218
3219 =cut
3220
3221 sub bulk_change {
3222   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3223
3224   # Transactionize this whole mess
3225   local $SIG{HUP} = 'IGNORE';
3226   local $SIG{INT} = 'IGNORE';
3227   local $SIG{QUIT} = 'IGNORE';
3228   local $SIG{TERM} = 'IGNORE';
3229   local $SIG{TSTP} = 'IGNORE';
3230   local $SIG{PIPE} = 'IGNORE';
3231
3232   my $oldAutoCommit = $FS::UID::AutoCommit;
3233   local $FS::UID::AutoCommit = 0;
3234   my $dbh = dbh;
3235
3236   my @errors;
3237   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3238                          @$remove_pkgnum;
3239
3240   while(scalar(@old_cust_pkg)) {
3241     my @return = ();
3242     my $custnum = $old_cust_pkg[0]->custnum;
3243     my (@remove) = map { $_->pkgnum }
3244                    grep { $_->custnum == $custnum } @old_cust_pkg;
3245     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3246
3247     my $error = order $custnum, $pkgparts, \@remove, \@return;
3248
3249     push @errors, $error
3250       if $error;
3251     push @$return_cust_pkg, @return;
3252   }
3253
3254   if (scalar(@errors)) {
3255     $dbh->rollback if $oldAutoCommit;
3256     return join(' / ', @errors);
3257   }
3258
3259   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3260   '';
3261 }
3262
3263 # Used by FS::Upgrade to migrate to a new database.
3264 sub _upgrade_data {  # class method
3265   my ($class, %opts) = @_;
3266   $class->_upgrade_otaker(%opts);
3267   my $sql =('UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1');
3268   my $sth = dbh->prepare($sql);
3269   $sth->execute or die $sth->errstr;
3270 }
3271
3272 =back
3273
3274 =head1 BUGS
3275
3276 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3277
3278 In sub order, the @pkgparts array (passed by reference) is clobbered.
3279
3280 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3281 method to pass dates to the recur_prog expression, it should do so.
3282
3283 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3284 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3285 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3286 configuration values.  Probably need a subroutine which decides what to do
3287 based on whether or not we've fetched the user yet, rather than a hash.  See
3288 FS::UID and the TODO.
3289
3290 Now that things are transactional should the check in the insert method be
3291 moved to check ?
3292
3293 =head1 SEE ALSO
3294
3295 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3296 L<FS::pkg_svc>, schema.html from the base documentation
3297
3298 =cut
3299
3300 1;
3301