FS/FS/cust_pkg.pm

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