FS/FS/cust_pkg.pm

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