FS/FS/cust_pkg.pm

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