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