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