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