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