FS/FS/cust_pkg.pm

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