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