FS/FS/cust_pkg.pm

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