FS/FS/cust_pkg.pm

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