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