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