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