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