FS/FS/cust_pkg.pm

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