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