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