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