FS/FS/cust_pkg.pm

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