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 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2654
2655 =item cust_location
2656
2657 Returns the location object, if any (see L<FS::cust_location>).
2658
2659 =item cust_location_or_main
2660
2661 If this package is associated with a location, returns the locaiton (see
2662 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2663
2664 =item location_label [ OPTION => VALUE ... ]
2665
2666 Returns the label of the location object (see L<FS::cust_location>).
2667
2668 =cut
2669
2670 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2671
2672 =item tax_locationnum
2673
2674 Returns the foreign key to a L<FS::cust_location> object for calculating
2675 tax on this package, as determined by the C<tax-pkg_address> and
2676 C<tax-ship_address> configuration flags.
2677
2678 =cut
2679
2680 sub tax_locationnum {
2681   my $self = shift;
2682   my $conf = FS::Conf->new;
2683   if ( $conf->exists('tax-pkg_address') ) {
2684     return $self->locationnum;
2685   }
2686   elsif ( $conf->exists('tax-ship_address') ) {
2687     return $self->cust_main->ship_locationnum;
2688   }
2689   else {
2690     return $self->cust_main->bill_locationnum;
2691   }
2692 }
2693
2694 =item tax_location
2695
2696 Returns the L<FS::cust_location> object for tax_locationnum.
2697
2698 =cut
2699
2700 sub tax_location {
2701   my $self = shift;
2702   FS::cust_location->by_key( $self->tax_locationnum )
2703 }
2704
2705 =item seconds_since TIMESTAMP
2706
2707 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2708 package have been online since TIMESTAMP, according to the session monitor.
2709
2710 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2711 L<Time::Local> and L<Date::Parse> for conversion functions.
2712
2713 =cut
2714
2715 sub seconds_since {
2716   my($self, $since) = @_;
2717   my $seconds = 0;
2718
2719   foreach my $cust_svc (
2720     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2721   ) {
2722     $seconds += $cust_svc->seconds_since($since);
2723   }
2724
2725   $seconds;
2726
2727 }
2728
2729 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2730
2731 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2732 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2733 (exclusive).
2734
2735 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2736 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2737 functions.
2738
2739
2740 =cut
2741
2742 sub seconds_since_sqlradacct {
2743   my($self, $start, $end) = @_;
2744
2745   my $seconds = 0;
2746
2747   foreach my $cust_svc (
2748     grep {
2749       my $part_svc = $_->part_svc;
2750       $part_svc->svcdb eq 'svc_acct'
2751         && scalar($part_svc->part_export_usage);
2752     } $self->cust_svc
2753   ) {
2754     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2755   }
2756
2757   $seconds;
2758
2759 }
2760
2761 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2762
2763 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2764 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2765 TIMESTAMP_END
2766 (exclusive).
2767
2768 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2769 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2770 functions.
2771
2772 =cut
2773
2774 sub attribute_since_sqlradacct {
2775   my($self, $start, $end, $attrib) = @_;
2776
2777   my $sum = 0;
2778
2779   foreach my $cust_svc (
2780     grep {
2781       my $part_svc = $_->part_svc;
2782       $part_svc->svcdb eq 'svc_acct'
2783         && scalar($part_svc->part_export_usage);
2784     } $self->cust_svc
2785   ) {
2786     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2787   }
2788
2789   $sum;
2790
2791 }
2792
2793 =item quantity
2794
2795 =cut
2796
2797 sub quantity {
2798   my( $self, $value ) = @_;
2799   if ( defined($value) ) {
2800     $self->setfield('quantity', $value);
2801   }
2802   $self->getfield('quantity') || 1;
2803 }
2804
2805 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2806
2807 Transfers as many services as possible from this package to another package.
2808
2809 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2810 object.  The destination package must already exist.
2811
2812 Services are moved only if the destination allows services with the correct
2813 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2814 this option with caution!  No provision is made for export differences
2815 between the old and new service definitions.  Probably only should be used
2816 when your exports for all service definitions of a given svcdb are identical.
2817 (attempt a transfer without it first, to move all possible svcpart-matching
2818 services)
2819
2820 Any services that can't be moved remain in the original package.
2821
2822 Returns an error, if there is one; otherwise, returns the number of services
2823 that couldn't be moved.
2824
2825 =cut
2826
2827 sub transfer {
2828   my ($self, $dest_pkgnum, %opt) = @_;
2829
2830   my $remaining = 0;
2831   my $dest;
2832   my %target;
2833
2834   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2835     $dest = $dest_pkgnum;
2836     $dest_pkgnum = $dest->pkgnum;
2837   } else {
2838     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2839   }
2840
2841   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2842
2843   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2844     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2845   }
2846
2847   foreach my $cust_svc ($dest->cust_svc) {
2848     $target{$cust_svc->svcpart}--;
2849   }
2850
2851   my %svcpart2svcparts = ();
2852   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2853     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2854     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2855       next if exists $svcpart2svcparts{$svcpart};
2856       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2857       $svcpart2svcparts{$svcpart} = [
2858         map  { $_->[0] }
2859         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2860         map {
2861               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2862                                                    'svcpart' => $_          } );
2863               [ $_,
2864                 $pkg_svc ? $pkg_svc->primary_svc : '',
2865                 $pkg_svc ? $pkg_svc->quantity : 0,
2866               ];
2867             }
2868
2869         grep { $_ != $svcpart }
2870         map  { $_->svcpart }
2871         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2872       ];
2873       warn "alternates for svcpart $svcpart: ".
2874            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2875         if $DEBUG;
2876     }
2877   }
2878
2879   foreach my $cust_svc ($self->cust_svc) {
2880     if($target{$cust_svc->svcpart} > 0) {
2881       $target{$cust_svc->svcpart}--;
2882       my $new = new FS::cust_svc { $cust_svc->hash };
2883       $new->pkgnum($dest_pkgnum);
2884       my $error = $new->replace($cust_svc);
2885       return $error if $error;
2886     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2887       if ( $DEBUG ) {
2888         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2889         warn "alternates to consider: ".
2890              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2891       }
2892       my @alternate = grep {
2893                              warn "considering alternate svcpart $_: ".
2894                                   "$target{$_} available in new package\n"
2895                                if $DEBUG;
2896                              $target{$_} > 0;
2897                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2898       if ( @alternate ) {
2899         warn "alternate(s) found\n" if $DEBUG;
2900         my $change_svcpart = $alternate[0];
2901         $target{$change_svcpart}--;
2902         my $new = new FS::cust_svc { $cust_svc->hash };
2903         $new->svcpart($change_svcpart);
2904         $new->pkgnum($dest_pkgnum);
2905         my $error = $new->replace($cust_svc);
2906         return $error if $error;
2907       } else {
2908         $remaining++;
2909       }
2910     } else {
2911       $remaining++
2912     }
2913   }
2914   return $remaining;
2915 }
2916
2917 =item reexport
2918
2919 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2920 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2921
2922 =cut
2923
2924 sub reexport {
2925   my $self = shift;
2926
2927   local $SIG{HUP} = 'IGNORE';
2928   local $SIG{INT} = 'IGNORE';
2929   local $SIG{QUIT} = 'IGNORE';
2930   local $SIG{TERM} = 'IGNORE';
2931   local $SIG{TSTP} = 'IGNORE';
2932   local $SIG{PIPE} = 'IGNORE';
2933
2934   my $oldAutoCommit = $FS::UID::AutoCommit;
2935   local $FS::UID::AutoCommit = 0;
2936   my $dbh = dbh;
2937
2938   foreach my $cust_svc ( $self->cust_svc ) {
2939     #false laziness w/svc_Common::insert
2940     my $svc_x = $cust_svc->svc_x;
2941     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2942       my $error = $part_export->export_insert($svc_x);
2943       if ( $error ) {
2944         $dbh->rollback if $oldAutoCommit;
2945         return $error;
2946       }
2947     }
2948   }
2949
2950   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2951   '';
2952
2953 }
2954
2955 =item insert_reason
2956
2957 Associates this package with a (suspension or cancellation) reason (see
2958 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2959 L<FS::reason>).
2960
2961 Available options are:
2962
2963 =over 4
2964
2965 =item reason
2966
2967 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.
2968
2969 =item reason_otaker
2970
2971 the access_user (see L<FS::access_user>) providing the reason
2972
2973 =item date
2974
2975 a unix timestamp
2976
2977 =item action
2978
2979 the action (cancel, susp, adjourn, expire) associated with the reason
2980
2981 =back
2982
2983 If there is an error, returns the error, otherwise returns false.
2984
2985 =cut
2986
2987 sub insert_reason {
2988   my ($self, %options) = @_;
2989
2990   my $otaker = $options{reason_otaker} ||
2991                $FS::CurrentUser::CurrentUser->username;
2992
2993   my $reasonnum;
2994   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2995
2996     $reasonnum = $1;
2997
2998   } elsif ( ref($options{'reason'}) ) {
2999
3000     return 'Enter a new reason (or select an existing one)'
3001       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3002
3003     my $reason = new FS::reason({
3004       'reason_type' => $options{'reason'}->{'typenum'},
3005       'reason'      => $options{'reason'}->{'reason'},
3006     });
3007     my $error = $reason->insert;
3008     return $error if $error;
3009
3010     $reasonnum = $reason->reasonnum;
3011
3012   } else {
3013     return "Unparsable reason: ". $options{'reason'};
3014   }
3015
3016   my $cust_pkg_reason =
3017     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3018                               'reasonnum' => $reasonnum,
3019                               'otaker'    => $otaker,
3020                               'action'    => substr(uc($options{'action'}),0,1),
3021                               'date'      => $options{'date'}
3022                                                ? $options{'date'}
3023                                                : time,
3024                             });
3025
3026   $cust_pkg_reason->insert;
3027 }
3028
3029 =item insert_discount
3030
3031 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3032 inserting a new discount on the fly (see L<FS::discount>).
3033
3034 Available options are:
3035
3036 =over 4
3037
3038 =item discountnum
3039
3040 =back
3041
3042 If there is an error, returns the error, otherwise returns false.
3043
3044 =cut
3045
3046 sub insert_discount {
3047   #my ($self, %options) = @_;
3048   my $self = shift;
3049
3050   my $cust_pkg_discount = new FS::cust_pkg_discount {
3051     'pkgnum'      => $self->pkgnum,
3052     'discountnum' => $self->discountnum,
3053     'months_used' => 0,
3054     'end_date'    => '', #XXX
3055     #for the create a new discount case
3056     '_type'       => $self->discountnum__type,
3057     'amount'      => $self->discountnum_amount,
3058     'percent'     => $self->discountnum_percent,
3059     'months'      => $self->discountnum_months,
3060     'setup'      => $self->discountnum_setup,
3061     #'disabled'    => $self->discountnum_disabled,
3062   };
3063
3064   $cust_pkg_discount->insert;
3065 }
3066
3067 =item set_usage USAGE_VALUE_HASHREF
3068
3069 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3070 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3071 upbytes, downbytes, and totalbytes are appropriate keys.
3072
3073 All svc_accts which are part of this package have their values reset.
3074
3075 =cut
3076
3077 sub set_usage {
3078   my ($self, $valueref, %opt) = @_;
3079
3080   #only svc_acct can set_usage for now
3081   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3082     my $svc_x = $cust_svc->svc_x;
3083     $svc_x->set_usage($valueref, %opt)
3084       if $svc_x->can("set_usage");
3085   }
3086 }
3087
3088 =item recharge USAGE_VALUE_HASHREF
3089
3090 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3091 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3092 upbytes, downbytes, and totalbytes are appropriate keys.
3093
3094 All svc_accts which are part of this package have their values incremented.
3095
3096 =cut
3097
3098 sub recharge {
3099   my ($self, $valueref) = @_;
3100
3101   #only svc_acct can set_usage for now
3102   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3103     my $svc_x = $cust_svc->svc_x;
3104     $svc_x->recharge($valueref)
3105       if $svc_x->can("recharge");
3106   }
3107 }
3108
3109 =item cust_pkg_discount
3110
3111 =cut
3112
3113 sub cust_pkg_discount {
3114   my $self = shift;
3115   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3116 }
3117
3118 =item cust_pkg_discount_active
3119
3120 =cut
3121
3122 sub cust_pkg_discount_active {
3123   my $self = shift;
3124   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3125 }
3126
3127 =back
3128
3129 =head1 CLASS METHODS
3130
3131 =over 4
3132
3133 =item recurring_sql
3134
3135 Returns an SQL expression identifying recurring packages.
3136
3137 =cut
3138
3139 sub recurring_sql { "
3140   '0' != ( select freq from part_pkg
3141              where cust_pkg.pkgpart = part_pkg.pkgpart )
3142 "; }
3143
3144 =item onetime_sql
3145
3146 Returns an SQL expression identifying one-time packages.
3147
3148 =cut
3149
3150 sub onetime_sql { "
3151   '0' = ( select freq from part_pkg
3152             where cust_pkg.pkgpart = part_pkg.pkgpart )
3153 "; }
3154
3155 =item ordered_sql
3156
3157 Returns an SQL expression identifying ordered packages (recurring packages not
3158 yet billed).
3159
3160 =cut
3161
3162 sub ordered_sql {
3163    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3164 }
3165
3166 =item active_sql
3167
3168 Returns an SQL expression identifying active packages.
3169
3170 =cut
3171
3172 sub active_sql {
3173   $_[0]->recurring_sql. "
3174   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3175   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3176   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3177 "; }
3178
3179 =item not_yet_billed_sql
3180
3181 Returns an SQL expression identifying packages which have not yet been billed.
3182
3183 =cut
3184
3185 sub not_yet_billed_sql { "
3186       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
3187   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3188   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3189 "; }
3190
3191 =item inactive_sql
3192
3193 Returns an SQL expression identifying inactive packages (one-time packages
3194 that are otherwise unsuspended/uncancelled).
3195
3196 =cut
3197
3198 sub inactive_sql { "
3199   ". $_[0]->onetime_sql(). "
3200   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3201   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3202   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3203 "; }
3204
3205 =item susp_sql
3206 =item suspended_sql
3207
3208 Returns an SQL expression identifying suspended packages.
3209
3210 =cut
3211
3212 sub suspended_sql { susp_sql(@_); }
3213 sub susp_sql {
3214   #$_[0]->recurring_sql(). ' AND '.
3215   "
3216         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
3217     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
3218   ";
3219 }
3220
3221 =item cancel_sql
3222 =item cancelled_sql
3223
3224 Returns an SQL exprression identifying cancelled packages.
3225
3226 =cut
3227
3228 sub cancelled_sql { cancel_sql(@_); }
3229 sub cancel_sql {
3230   #$_[0]->recurring_sql(). ' AND '.
3231   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3232 }
3233
3234 =item status_sql
3235
3236 Returns an SQL expression to give the package status as a string.
3237
3238 =cut
3239
3240 sub status_sql {
3241 "CASE
3242   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3243   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3244   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3245   WHEN ".onetime_sql()." THEN 'one-time charge'
3246   ELSE 'active'
3247 END"
3248 }
3249
3250 =item search HASHREF
3251
3252 (Class method)
3253
3254 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3255 Valid parameters are
3256
3257 =over 4
3258
3259 =item agentnum
3260
3261 =item magic
3262
3263 active, inactive, suspended, cancel (or cancelled)
3264
3265 =item status
3266
3267 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3268
3269 =item custom
3270
3271  boolean selects custom packages
3272
3273 =item classnum
3274
3275 =item pkgpart
3276
3277 pkgpart or arrayref or hashref of pkgparts
3278
3279 =item setup
3280
3281 arrayref of beginning and ending epoch date
3282
3283 =item last_bill
3284
3285 arrayref of beginning and ending epoch date
3286
3287 =item bill
3288
3289 arrayref of beginning and ending epoch date
3290
3291 =item adjourn
3292
3293 arrayref of beginning and ending epoch date
3294
3295 =item susp
3296
3297 arrayref of beginning and ending epoch date
3298
3299 =item expire
3300
3301 arrayref of beginning and ending epoch date
3302
3303 =item cancel
3304
3305 arrayref of beginning and ending epoch date
3306
3307 =item query
3308
3309 pkgnum or APKG_pkgnum
3310
3311 =item cust_fields
3312
3313 a value suited to passing to FS::UI::Web::cust_header
3314
3315 =item CurrentUser
3316
3317 specifies the user for agent virtualization
3318
3319 =item fcc_line
3320
3321 boolean; if true, returns only packages with more than 0 FCC phone lines.
3322
3323 =item state, country
3324
3325 Limit to packages with a service location in the specified state and country.
3326 For FCC 477 reporting, mostly.
3327
3328 =back
3329
3330 =cut
3331
3332 sub search {
3333   my ($class, $params) = @_;
3334   my @where = ();
3335
3336   ##
3337   # parse agent
3338   ##
3339
3340   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3341     push @where,
3342       "cust_main.agentnum = $1";
3343   }
3344
3345   ##
3346   # parse custnum
3347   ##
3348
3349   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3350     push @where,
3351       "cust_pkg.custnum = $1";
3352   }
3353
3354   ##
3355   # custbatch
3356   ##
3357
3358   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3359     push @where,
3360       "cust_pkg.pkgbatch = '$1'";
3361   }
3362
3363   ##
3364   # parse status
3365   ##
3366
3367   if (    $params->{'magic'}  eq 'active'
3368        || $params->{'status'} eq 'active' ) {
3369
3370     push @where, FS::cust_pkg->active_sql();
3371
3372   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3373             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3374
3375     push @where, FS::cust_pkg->not_yet_billed_sql();
3376
3377   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3378             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3379
3380     push @where, FS::cust_pkg->inactive_sql();
3381
3382   } elsif (    $params->{'magic'}  eq 'suspended'
3383             || $params->{'status'} eq 'suspended'  ) {
3384
3385     push @where, FS::cust_pkg->suspended_sql();
3386
3387   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3388             || $params->{'status'} =~ /^cancell?ed$/ ) {
3389
3390     push @where, FS::cust_pkg->cancelled_sql();
3391
3392   }
3393
3394   ###
3395   # parse package class
3396   ###
3397
3398   if ( exists($params->{'classnum'}) ) {
3399
3400     my @classnum = ();
3401     if ( ref($params->{'classnum'}) ) {
3402
3403       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3404         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3405       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3406         @classnum = @{ $params->{'classnum'} };
3407       } else {
3408         die 'unhandled classnum ref '. $params->{'classnum'};
3409       }
3410
3411
3412     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3413       @classnum = ( $1 );
3414     }
3415
3416     if ( @classnum ) {
3417
3418       my @c_where = ();
3419       my @nums = grep $_, @classnum;
3420       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3421       my $null = scalar( grep { $_ eq '' } @classnum );
3422       push @c_where, 'part_pkg.classnum IS NULL' if $null;
3423
3424       if ( scalar(@c_where) == 1 ) {
3425         push @where, @c_where;
3426       } elsif ( @c_where ) {
3427         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3428       }
3429
3430     }
3431
3432
3433   }
3434
3435   ###
3436   # parse package report options
3437   ###
3438
3439   my @report_option = ();
3440   if ( exists($params->{'report_option'}) ) {
3441     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3442       @report_option = @{ $params->{'report_option'} };
3443     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3444       @report_option = split(',', $1);
3445     }
3446
3447   }
3448
3449   if (@report_option) {
3450     # this will result in the empty set for the dangling comma case as it should
3451     push @where,
3452       map{ "0 < ( SELECT count(*) FROM part_pkg_option
3453                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3454                     AND optionname = 'report_option_$_'
3455                     AND optionvalue = '1' )"
3456          } @report_option;
3457   }
3458
3459   foreach my $any ( grep /^report_option_any/, keys %$params ) {
3460
3461     my @report_option_any = ();
3462     if ( ref($params->{$any}) eq 'ARRAY' ) {
3463       @report_option_any = @{ $params->{$any} };
3464     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3465       @report_option_any = split(',', $1);
3466     }
3467
3468     if (@report_option_any) {
3469       # this will result in the empty set for the dangling comma case as it should
3470       push @where, ' ( '. join(' OR ',
3471         map{ "0 < ( SELECT count(*) FROM part_pkg_option
3472                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3473                       AND optionname = 'report_option_$_'
3474                       AND optionvalue = '1' )"
3475            } @report_option_any
3476       ). ' ) ';
3477     }
3478
3479   }
3480
3481   ###
3482   # parse custom
3483   ###
3484
3485   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3486
3487   ###
3488   # parse fcc_line
3489   ###
3490
3491   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3492                                                         if $params->{fcc_line};
3493
3494   ###
3495   # parse censustract
3496   ###
3497
3498   if ( exists($params->{'censustract'}) ) {
3499     $params->{'censustract'} =~ /^([.\d]*)$/;
3500     my $censustract = "cust_location.censustract = '$1'";
3501     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3502     push @where,  "( $censustract )";
3503   }
3504
3505   ###
3506   # parse censustract2
3507   ###
3508   if ( exists($params->{'censustract2'})
3509        && $params->{'censustract2'} =~ /^(\d*)$/
3510      )
3511   {
3512     if ($1) {
3513       push @where, "cust_location.censustract LIKE '$1%'";
3514     } else {
3515       push @where,
3516         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3517     }
3518   }
3519
3520   ###
3521   # parse country/state
3522   ###
3523   for (qw(state country)) { # parsing rules are the same for these
3524   if ( exists($params->{$_})
3525     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3526     {
3527       # XXX post-2.3 only--before that, state/country may be in cust_main
3528       push @where, "cust_location.$_ = '$1'";
3529     }
3530   }
3531
3532   ###
3533   # parse part_pkg
3534   ###
3535
3536   if ( ref($params->{'pkgpart'}) ) {
3537
3538     my @pkgpart = ();
3539     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3540       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3541     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3542       @pkgpart = @{ $params->{'pkgpart'} };
3543     } else {
3544       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3545     }
3546
3547     @pkgpart = grep /^(\d+)$/, @pkgpart;
3548
3549     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3550
3551   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3552     push @where, "pkgpart = $1";
3553   }
3554
3555   ###
3556   # parse dates
3557   ###
3558
3559   my $orderby = '';
3560
3561   #false laziness w/report_cust_pkg.html
3562   my %disable = (
3563     'all'             => {},
3564     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3565     'active'          => { 'susp'=>1, 'cancel'=>1 },
3566     'suspended'       => { 'cancel' => 1 },
3567     'cancelled'       => {},
3568     ''                => {},
3569   );
3570
3571   if( exists($params->{'active'} ) ) {
3572     # This overrides all the other date-related fields
3573     my($beginning, $ending) = @{$params->{'active'}};
3574     push @where,
3575       "cust_pkg.setup IS NOT NULL",
3576       "cust_pkg.setup <= $ending",
3577       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3578       "NOT (".FS::cust_pkg->onetime_sql . ")";
3579   }
3580   else {
3581     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
3582
3583       next unless exists($params->{$field});
3584
3585       my($beginning, $ending) = @{$params->{$field}};
3586
3587       next if $beginning == 0 && $ending == 4294967295;
3588
3589       push @where,
3590         "cust_pkg.$field IS NOT NULL",
3591         "cust_pkg.$field >= $beginning",
3592         "cust_pkg.$field <= $ending";
3593
3594       $orderby ||= "ORDER BY cust_pkg.$field";
3595
3596     }
3597   }
3598
3599   $orderby ||= 'ORDER BY bill';
3600
3601   ###
3602   # parse magic, legacy, etc.
3603   ###
3604
3605   if ( $params->{'magic'} &&
3606        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3607   ) {
3608
3609     $orderby = 'ORDER BY pkgnum';
3610
3611     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3612       push @where, "pkgpart = $1";
3613     }
3614
3615   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3616
3617     $orderby = 'ORDER BY pkgnum';
3618
3619   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3620
3621     $orderby = 'ORDER BY pkgnum';
3622
3623     push @where, '0 < (
3624       SELECT count(*) FROM pkg_svc
3625        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3626          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3627                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3628                                      AND cust_svc.svcpart = pkg_svc.svcpart
3629                                 )
3630     )';
3631
3632   }
3633
3634   ##
3635   # setup queries, links, subs, etc. for the search
3636   ##
3637
3638   # here is the agent virtualization
3639   if ($params->{CurrentUser}) {
3640     my $access_user =
3641       qsearchs('access_user', { username => $params->{CurrentUser} });
3642
3643     if ($access_user) {
3644       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3645     } else {
3646       push @where, "1=0";
3647     }
3648   } else {
3649     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3650   }
3651
3652   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3653
3654   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
3655                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3656                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
3657                   'LEFT JOIN cust_location USING ( locationnum ) ';
3658
3659   my $select;
3660   my $count_query;
3661   if ( $params->{'select_zip5'} ) {
3662     my $zip = 'cust_location.zip';
3663
3664     $select = "DISTINCT substr($zip,1,5) as zip";
3665     $orderby = "ORDER BY substr($zip,1,5)";
3666     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
3667   } else {
3668     $select = join(', ',
3669                          'cust_pkg.*',
3670                          ( map "part_pkg.$_", qw( pkg freq ) ),
3671                          'pkg_class.classname',
3672                          'cust_main.custnum AS cust_main_custnum',
3673                          FS::UI::Web::cust_sql_fields(
3674                            $params->{'cust_fields'}
3675                          ),
3676                   );
3677     $count_query = 'SELECT COUNT(*)';
3678   }
3679
3680   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
3681
3682   my $sql_query = {
3683     'table'       => 'cust_pkg',
3684     'hashref'     => {},
3685     'select'      => $select,
3686     'extra_sql'   => $extra_sql,
3687     'order_by'    => $orderby,
3688     'addl_from'   => $addl_from,
3689     'count_query' => $count_query,
3690   };
3691
3692 }
3693
3694 =item fcc_477_count
3695
3696 Returns a list of two package counts.  The first is a count of packages
3697 based on the supplied criteria and the second is the count of residential
3698 packages with those same criteria.  Criteria are specified as in the search
3699 method.
3700
3701 =cut
3702
3703 sub fcc_477_count {
3704   my ($class, $params) = @_;
3705
3706   my $sql_query = $class->search( $params );
3707
3708   my $count_sql = delete($sql_query->{'count_query'});
3709   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3710     or die "couldn't parse count_sql";
3711
3712   my $count_sth = dbh->prepare($count_sql)
3713     or die "Error preparing $count_sql: ". dbh->errstr;
3714   $count_sth->execute
3715     or die "Error executing $count_sql: ". $count_sth->errstr;
3716   my $count_arrayref = $count_sth->fetchrow_arrayref;
3717
3718   return ( @$count_arrayref );
3719
3720 }
3721
3722 =item tax_locationnum_sql
3723
3724 Returns an SQL expression for the tax location for a package, based
3725 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
3726
3727 =cut
3728
3729 sub tax_locationnum_sql {
3730   my $conf = FS::Conf->new;
3731   if ( $conf->exists('tax-pkg_address') ) {
3732     'cust_pkg.locationnum';
3733   }
3734   elsif ( $conf->exists('tax-ship_address') ) {
3735     'cust_main.ship_locationnum';
3736   }
3737   else {
3738     'cust_main.bill_locationnum';
3739   }
3740 }
3741
3742 =item location_sql
3743
3744 Returns a list: the first item is an SQL fragment identifying matching
3745 packages/customers via location (taking into account shipping and package
3746 address taxation, if enabled), and subsequent items are the parameters to
3747 substitute for the placeholders in that fragment.
3748
3749 =cut
3750
3751 sub location_sql {
3752   my($class, %opt) = @_;
3753   my $ornull = $opt{'ornull'};
3754
3755   my $conf = new FS::Conf;
3756
3757   # '?' placeholders in _location_sql_where
3758   my $x = $ornull ? 3 : 2;
3759   my @bill_param = (
3760     ('district')x3,
3761     ('city')x3,
3762     ('county')x$x,
3763     ('state')x$x,
3764     'country'
3765   );
3766
3767   my $main_where;
3768   my @main_param;
3769   if ( $conf->exists('tax-ship_address') ) {
3770
3771     $main_where = "(
3772          (     ( ship_last IS NULL     OR  ship_last  = '' )
3773            AND ". _location_sql_where('cust_main', '', $ornull ). "
3774          )
3775       OR (       ship_last IS NOT NULL AND ship_last != ''
3776            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3777          )
3778     )";
3779     #    AND payby != 'COMP'
3780
3781     @main_param = ( @bill_param, @bill_param );
3782
3783   } else {
3784
3785     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3786     @main_param = @bill_param;
3787
3788   }
3789
3790   my $where;
3791   my @param;
3792   if ( $conf->exists('tax-pkg_address') ) {
3793
3794     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3795
3796     $where = " (
3797                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3798                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3799                )
3800              ";
3801     @param = ( @main_param, @bill_param );
3802
3803   } else {
3804
3805     $where = $main_where;
3806     @param = @main_param;
3807
3808   }
3809
3810   ( $where, @param );
3811
3812 }
3813
3814 #subroutine, helper for location_sql
3815 sub _location_sql_where {
3816   my $table  = shift;
3817   my $prefix = @_ ? shift : '';
3818   my $ornull = @_ ? shift : '';
3819
3820 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3821
3822   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3823
3824   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
3825   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
3826   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
3827
3828   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
3829
3830 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3831   "
3832         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
3833     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
3834     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
3835     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
3836     AND   $table.${prefix}country  = ?
3837   ";
3838 }
3839
3840 sub _X_show_zero {
3841   my( $self, $what ) = @_;
3842
3843   my $what_show_zero = $what. '_show_zero';
3844   length($self->$what_show_zero())
3845     ? ($self->$what_show_zero() eq 'Y')
3846     : $self->part_pkg->$what_show_zero();
3847 }
3848
3849 =head1 SUBROUTINES
3850
3851 =over 4
3852
3853 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3854
3855 CUSTNUM is a customer (see L<FS::cust_main>)
3856
3857 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3858 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3859 permitted.
3860
3861 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3862 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3863 new billing items.  An error is returned if this is not possible (see
3864 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3865 parameter.
3866
3867 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3868 newly-created cust_pkg objects.
3869
3870 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3871 and inserted.  Multiple FS::pkg_referral records can be created by
3872 setting I<refnum> to an array reference of refnums or a hash reference with
3873 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3874 record will be created corresponding to cust_main.refnum.
3875
3876 =cut
3877
3878 sub order {
3879   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3880
3881   my $conf = new FS::Conf;
3882
3883   # Transactionize this whole mess
3884   local $SIG{HUP} = 'IGNORE';
3885   local $SIG{INT} = 'IGNORE';
3886   local $SIG{QUIT} = 'IGNORE';
3887   local $SIG{TERM} = 'IGNORE';
3888   local $SIG{TSTP} = 'IGNORE';
3889   local $SIG{PIPE} = 'IGNORE';
3890
3891   my $oldAutoCommit = $FS::UID::AutoCommit;
3892   local $FS::UID::AutoCommit = 0;
3893   my $dbh = dbh;
3894
3895   my $error;
3896 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3897 #  return "Customer not found: $custnum" unless $cust_main;
3898
3899   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3900     if $DEBUG;
3901
3902   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3903                          @$remove_pkgnum;
3904
3905   my $change = scalar(@old_cust_pkg) != 0;
3906
3907   my %hash = ();
3908   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3909
3910     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3911          " to pkgpart ". $pkgparts->[0]. "\n"
3912       if $DEBUG;
3913
3914     my $err_or_cust_pkg =
3915       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3916                                 'refnum'  => $refnum,
3917                               );
3918
3919     unless (ref($err_or_cust_pkg)) {
3920       $dbh->rollback if $oldAutoCommit;
3921       return $err_or_cust_pkg;
3922     }
3923
3924     push @$return_cust_pkg, $err_or_cust_pkg;
3925     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3926     return '';
3927
3928   }
3929
3930   # Create the new packages.
3931   foreach my $pkgpart (@$pkgparts) {
3932
3933     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3934
3935     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3936                                       pkgpart => $pkgpart,
3937                                       refnum  => $refnum,
3938                                       %hash,
3939                                     };
3940     $error = $cust_pkg->insert( 'change' => $change );
3941     if ($error) {
3942       $dbh->rollback if $oldAutoCommit;
3943       return $error;
3944     }
3945     push @$return_cust_pkg, $cust_pkg;
3946   }
3947   # $return_cust_pkg now contains refs to all of the newly
3948   # created packages.
3949
3950   # Transfer services and cancel old packages.
3951   foreach my $old_pkg (@old_cust_pkg) {
3952
3953     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3954       if $DEBUG;
3955
3956     foreach my $new_pkg (@$return_cust_pkg) {
3957       $error = $old_pkg->transfer($new_pkg);
3958       if ($error and $error == 0) {
3959         # $old_pkg->transfer failed.
3960         $dbh->rollback if $oldAutoCommit;
3961         return $error;
3962       }
3963     }
3964
3965     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3966       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3967       foreach my $new_pkg (@$return_cust_pkg) {
3968         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3969         if ($error and $error == 0) {
3970           # $old_pkg->transfer failed.
3971         $dbh->rollback if $oldAutoCommit;
3972         return $error;
3973         }
3974       }
3975     }
3976
3977     if ($error > 0) {
3978       # Transfers were successful, but we went through all of the
3979       # new packages and still had services left on the old package.
3980       # We can't cancel the package under the circumstances, so abort.
3981       $dbh->rollback if $oldAutoCommit;
3982       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3983     }
3984     $error = $old_pkg->cancel( quiet=>1 );
3985     if ($error) {
3986       $dbh->rollback;
3987       return $error;
3988     }
3989   }
3990   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3991   '';
3992 }
3993
3994 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3995
3996 A bulk change method to change packages for multiple customers.
3997
3998 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3999 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4000 permitted.
4001
4002 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4003 replace.  The services (see L<FS::cust_svc>) are moved to the
4004 new billing items.  An error is returned if this is not possible (see
4005 L<FS::pkg_svc>).
4006
4007 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4008 newly-created cust_pkg objects.
4009
4010 =cut
4011
4012 sub bulk_change {
4013   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4014
4015   # Transactionize this whole mess
4016   local $SIG{HUP} = 'IGNORE';
4017   local $SIG{INT} = 'IGNORE';
4018   local $SIG{QUIT} = 'IGNORE';
4019   local $SIG{TERM} = 'IGNORE';
4020   local $SIG{TSTP} = 'IGNORE';
4021   local $SIG{PIPE} = 'IGNORE';
4022
4023   my $oldAutoCommit = $FS::UID::AutoCommit;
4024   local $FS::UID::AutoCommit = 0;
4025   my $dbh = dbh;
4026
4027   my @errors;
4028   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4029                          @$remove_pkgnum;
4030
4031   while(scalar(@old_cust_pkg)) {
4032     my @return = ();
4033     my $custnum = $old_cust_pkg[0]->custnum;
4034     my (@remove) = map { $_->pkgnum }
4035                    grep { $_->custnum == $custnum } @old_cust_pkg;
4036     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4037
4038     my $error = order $custnum, $pkgparts, \@remove, \@return;
4039
4040     push @errors, $error
4041       if $error;
4042     push @$return_cust_pkg, @return;
4043   }
4044
4045   if (scalar(@errors)) {
4046     $dbh->rollback if $oldAutoCommit;
4047     return join(' / ', @errors);
4048   }
4049
4050   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4051   '';
4052 }
4053
4054 # Used by FS::Upgrade to migrate to a new database.
4055 sub _upgrade_data {  # class method
4056   my ($class, %opts) = @_;
4057   $class->_upgrade_otaker(%opts);
4058   my @statements = (
4059     # RT#10139, bug resulting in contract_end being set when it shouldn't
4060   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4061     # RT#10830, bad calculation of prorate date near end of year
4062     # the date range for bill is December 2009, and we move it forward
4063     # one year if it's before the previous bill date (which it should
4064     # never be)
4065   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4066   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4067   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4068     # RT6628, add order_date to cust_pkg
4069     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4070         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4071         history_action = \'insert\') where order_date is null',
4072   );
4073   foreach my $sql (@statements) {
4074     my $sth = dbh->prepare($sql);
4075     $sth->execute or die $sth->errstr;
4076   }
4077 }
4078
4079 =back
4080
4081 =head1 BUGS
4082
4083 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4084
4085 In sub order, the @pkgparts array (passed by reference) is clobbered.
4086
4087 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4088 method to pass dates to the recur_prog expression, it should do so.
4089
4090 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4091 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4092 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4093 configuration values.  Probably need a subroutine which decides what to do
4094 based on whether or not we've fetched the user yet, rather than a hash.  See
4095 FS::UID and the TODO.
4096
4097 Now that things are transactional should the check in the insert method be
4098 moved to check ?
4099
4100 =head1 SEE ALSO
4101
4102 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4103 L<FS::pkg_svc>, schema.html from the base documentation
4104
4105 =cut
4106
4107 1;
4108