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