FS/FS/cust_pkg.pm

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