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