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