FS/FS/cust_pkg.pm

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