FS/FS/cust_pkg.pm

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