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