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