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