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