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