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