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'}
1757        and $opt->{'pkgpart'} != $self->pkgpart
1758        and $self->part_pkg->option('unused_credit_change', 1) ) {
1759     $unused_credit = 1;
1760     $keep_dates = 0;
1761     $hash{$_} = '' foreach qw(setup bill last_bill);
1762   }
1763
1764   if ( $keep_dates ) {
1765     foreach my $date ( qw(setup bill last_bill susp adjourn cancel expire
1766                           resume start_date contract_end ) ) {
1767       $hash{$date} = $self->getfield($date);
1768     }
1769   }
1770   # allow $opt->{'locationnum'} = '' to specifically set it to null
1771   # (i.e. customer default location)
1772   $opt->{'locationnum'} = $self->locationnum if !exists($opt->{'locationnum'});
1773
1774   # Create the new package.
1775   my $cust_pkg = new FS::cust_pkg {
1776     custnum      => $self->custnum,
1777     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1778     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1779     locationnum  => ( $opt->{'locationnum'}                        ),
1780     %hash,
1781   };
1782   $error = $cust_pkg->insert( 'change' => 1 );
1783   if ($error) {
1784     $dbh->rollback if $oldAutoCommit;
1785     return $error;
1786   }
1787
1788   # Transfer services and cancel old package.
1789
1790   $error = $self->transfer($cust_pkg);
1791   if ($error and $error == 0) {
1792     # $old_pkg->transfer failed.
1793     $dbh->rollback if $oldAutoCommit;
1794     return $error;
1795   }
1796
1797   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1798     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1799     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1800     if ($error and $error == 0) {
1801       # $old_pkg->transfer failed.
1802       $dbh->rollback if $oldAutoCommit;
1803       return $error;
1804     }
1805   }
1806
1807   if ($error > 0) {
1808     # Transfers were successful, but we still had services left on the old
1809     # package.  We can't change the package under this circumstances, so abort.
1810     $dbh->rollback if $oldAutoCommit;
1811     return "Unable to transfer all services from package ". $self->pkgnum;
1812   }
1813
1814   #reset usage if changing pkgpart
1815   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1816   if ($self->pkgpart != $cust_pkg->pkgpart) {
1817     my $part_pkg = $cust_pkg->part_pkg;
1818     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1819                                                  ? ()
1820                                                  : ( 'null' => 1 )
1821                                    )
1822       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover',1);
1823
1824     if ($error) {
1825       $dbh->rollback if $oldAutoCommit;
1826       return "Error setting usage values: $error";
1827     }
1828   }
1829
1830   # Order any supplemental packages.
1831   my $part_pkg = $cust_pkg->part_pkg;
1832   my @old_supp_pkgs = $self->supplemental_pkgs;
1833   my @new_supp_pkgs;
1834   foreach my $link ($part_pkg->supp_part_pkg_link) {
1835     my $old;
1836     foreach (@old_supp_pkgs) {
1837       if ($_->pkgpart == $link->dst_pkgpart) {
1838         $old = $_;
1839         $_->pkgpart(0); # so that it can't match more than once
1840       }
1841       last if $old;
1842     }
1843     # false laziness with FS::cust_main::Packages::order_pkg
1844     my $new = FS::cust_pkg->new({
1845         pkgpart       => $link->dst_pkgpart,
1846         pkglinknum    => $link->pkglinknum,
1847         custnum       => $self->custnum,
1848         main_pkgnum   => $cust_pkg->pkgnum,
1849         locationnum   => $cust_pkg->locationnum,
1850         start_date    => $cust_pkg->start_date,
1851         order_date    => $cust_pkg->order_date,
1852         expire        => $cust_pkg->expire,
1853         adjourn       => $cust_pkg->adjourn,
1854         contract_end  => $cust_pkg->contract_end,
1855         refnum        => $cust_pkg->refnum,
1856         discountnum   => $cust_pkg->discountnum,
1857         waive_setup   => $cust_pkg->waive_setup
1858     });
1859     if ( $old and $opt->{'keep_dates'} ) {
1860       foreach (qw(setup bill last_bill)) {
1861         $new->set($_, $old->get($_));
1862       }
1863     }
1864     $error = $new->insert;
1865     # transfer services
1866     if ( $old ) {
1867       $error ||= $old->transfer($new);
1868     }
1869     if ( $error and $error > 0 ) {
1870       # no reason why this should ever fail, but still...
1871       $error = "Unable to transfer all services from supplemental package ".
1872         $old->pkgnum;
1873     }
1874     if ( $error ) {
1875       $dbh->rollback if $oldAutoCommit;
1876       return $error;
1877     }
1878     push @new_supp_pkgs, $new;
1879   }
1880
1881   #Good to go, cancel old package.  Notify 'cancel' of whether to credit
1882   #remaining time.
1883   #Don't allow billing the package (preceding period packages and/or
1884   #outstanding usage) if we are keeping dates (i.e. location changing),
1885   #because the new package will be billed for the same date range.
1886   #Supplemental packages are also canceled here.
1887   $error = $self->cancel(
1888     quiet         => 1,
1889     unused_credit => $unused_credit,
1890     nobill        => $keep_dates
1891   );
1892   if ($error) {
1893     $dbh->rollback if $oldAutoCommit;
1894     return $error;
1895   }
1896
1897   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1898     #$self->cust_main
1899     my $error = $cust_pkg->cust_main->bill(
1900       'pkg_list' => [ $cust_pkg, @new_supp_pkgs ]
1901     );
1902     if ( $error ) {
1903       $dbh->rollback if $oldAutoCommit;
1904       return $error;
1905     }
1906   }
1907
1908   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1909
1910   $cust_pkg;
1911
1912 }
1913
1914 use Storable 'thaw';
1915 use MIME::Base64;
1916 sub process_bulk_cust_pkg {
1917   my $job = shift;
1918   my $param = thaw(decode_base64(shift));
1919   warn Dumper($param) if $DEBUG;
1920
1921   my $old_part_pkg = qsearchs('part_pkg',
1922                               { pkgpart => $param->{'old_pkgpart'} });
1923   my $new_part_pkg = qsearchs('part_pkg',
1924                               { pkgpart => $param->{'new_pkgpart'} });
1925   die "Must select a new package type\n" unless $new_part_pkg;
1926   #my $keep_dates = $param->{'keep_dates'} || 0;
1927   my $keep_dates = 1; # there is no good reason to turn this off
1928
1929   local $SIG{HUP} = 'IGNORE';
1930   local $SIG{INT} = 'IGNORE';
1931   local $SIG{QUIT} = 'IGNORE';
1932   local $SIG{TERM} = 'IGNORE';
1933   local $SIG{TSTP} = 'IGNORE';
1934   local $SIG{PIPE} = 'IGNORE';
1935
1936   my $oldAutoCommit = $FS::UID::AutoCommit;
1937   local $FS::UID::AutoCommit = 0;
1938   my $dbh = dbh;
1939
1940   my @cust_pkgs = qsearch('cust_pkg', { 'pkgpart' => $param->{'old_pkgpart'} } );
1941
1942   my $i = 0;
1943   foreach my $old_cust_pkg ( @cust_pkgs ) {
1944     $i++;
1945     $job->update_statustext(int(100*$i/(scalar @cust_pkgs)));
1946     if ( $old_cust_pkg->getfield('cancel') ) {
1947       warn '[process_bulk_cust_pkg ] skipping canceled pkgnum '.
1948         $old_cust_pkg->pkgnum."\n"
1949         if $DEBUG;
1950       next;
1951     }
1952     warn '[process_bulk_cust_pkg] changing pkgnum '.$old_cust_pkg->pkgnum."\n"
1953       if $DEBUG;
1954     my $error = $old_cust_pkg->change(
1955       'pkgpart'     => $param->{'new_pkgpart'},
1956       'keep_dates'  => $keep_dates
1957     );
1958     if ( !ref($error) ) { # change returns the cust_pkg on success
1959       $dbh->rollback;
1960       die "Error changing pkgnum ".$old_cust_pkg->pkgnum.": '$error'\n";
1961     }
1962   }
1963   $dbh->commit if $oldAutoCommit;
1964   return;
1965 }
1966
1967 =item last_bill
1968
1969 Returns the last bill date, or if there is no last bill date, the setup date.
1970 Useful for billing metered services.
1971
1972 =cut
1973
1974 sub last_bill {
1975   my $self = shift;
1976   return $self->setfield('last_bill', $_[0]) if @_;
1977   return $self->getfield('last_bill') if $self->getfield('last_bill');
1978   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1979                                                   'edate'  => $self->bill,  } );
1980   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1981 }
1982
1983 =item last_cust_pkg_reason ACTION
1984
1985 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1986 Returns false if there is no reason or the package is not currenly ACTION'd
1987 ACTION is one of adjourn, susp, cancel, or expire.
1988
1989 =cut
1990
1991 sub last_cust_pkg_reason {
1992   my ( $self, $action ) = ( shift, shift );
1993   my $date = $self->get($action);
1994   qsearchs( {
1995               'table' => 'cust_pkg_reason',
1996               'hashref' => { 'pkgnum' => $self->pkgnum,
1997                              'action' => substr(uc($action), 0, 1),
1998                              'date'   => $date,
1999                            },
2000               'order_by' => 'ORDER BY num DESC LIMIT 1',
2001            } );
2002 }
2003
2004 =item last_reason ACTION
2005
2006 Returns the most recent ACTION FS::reason associated with the package.
2007 Returns false if there is no reason or the package is not currenly ACTION'd
2008 ACTION is one of adjourn, susp, cancel, or expire.
2009
2010 =cut
2011
2012 sub last_reason {
2013   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
2014   $cust_pkg_reason->reason
2015     if $cust_pkg_reason;
2016 }
2017
2018 =item part_pkg
2019
2020 Returns the definition for this billing item, as an FS::part_pkg object (see
2021 L<FS::part_pkg>).
2022
2023 =cut
2024
2025 sub part_pkg {
2026   my $self = shift;
2027   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
2028   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
2029   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
2030 }
2031
2032 =item old_cust_pkg
2033
2034 Returns the cancelled package this package was changed from, if any.
2035
2036 =cut
2037
2038 sub old_cust_pkg {
2039   my $self = shift;
2040   return '' unless $self->change_pkgnum;
2041   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
2042 }
2043
2044 =item calc_setup
2045
2046 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
2047 item.
2048
2049 =cut
2050
2051 sub calc_setup {
2052   my $self = shift;
2053   $self->part_pkg->calc_setup($self, @_);
2054 }
2055
2056 =item calc_recur
2057
2058 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
2059 item.
2060
2061 =cut
2062
2063 sub calc_recur {
2064   my $self = shift;
2065   $self->part_pkg->calc_recur($self, @_);
2066 }
2067
2068 =item base_recur
2069
2070 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
2071 item.
2072
2073 =cut
2074
2075 sub base_recur {
2076   my $self = shift;
2077   $self->part_pkg->base_recur($self, @_);
2078 }
2079
2080 =item calc_remain
2081
2082 Calls the I<calc_remain> of the FS::part_pkg object associated with this
2083 billing item.
2084
2085 =cut
2086
2087 sub calc_remain {
2088   my $self = shift;
2089   $self->part_pkg->calc_remain($self, @_);
2090 }
2091
2092 =item calc_cancel
2093
2094 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
2095 billing item.
2096
2097 =cut
2098
2099 sub calc_cancel {
2100   my $self = shift;
2101   $self->part_pkg->calc_cancel($self, @_);
2102 }
2103
2104 =item cust_bill_pkg
2105
2106 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
2107
2108 =cut
2109
2110 sub cust_bill_pkg {
2111   my $self = shift;
2112   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
2113 }
2114
2115 =item cust_pkg_detail [ DETAILTYPE ]
2116
2117 Returns any customer package details for this package (see
2118 L<FS::cust_pkg_detail>).
2119
2120 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2121
2122 =cut
2123
2124 sub cust_pkg_detail {
2125   my $self = shift;
2126   my %hash = ( 'pkgnum' => $self->pkgnum );
2127   $hash{detailtype} = shift if @_;
2128   qsearch({
2129     'table'    => 'cust_pkg_detail',
2130     'hashref'  => \%hash,
2131     'order_by' => 'ORDER BY weight, pkgdetailnum',
2132   });
2133 }
2134
2135 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
2136
2137 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
2138
2139 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
2140
2141 If there is an error, returns the error, otherwise returns false.
2142
2143 =cut
2144
2145 sub set_cust_pkg_detail {
2146   my( $self, $detailtype, @details ) = @_;
2147
2148   local $SIG{HUP} = 'IGNORE';
2149   local $SIG{INT} = 'IGNORE';
2150   local $SIG{QUIT} = 'IGNORE';
2151   local $SIG{TERM} = 'IGNORE';
2152   local $SIG{TSTP} = 'IGNORE';
2153   local $SIG{PIPE} = 'IGNORE';
2154
2155   my $oldAutoCommit = $FS::UID::AutoCommit;
2156   local $FS::UID::AutoCommit = 0;
2157   my $dbh = dbh;
2158
2159   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
2160     my $error = $current->delete;
2161     if ( $error ) {
2162       $dbh->rollback if $oldAutoCommit;
2163       return "error removing old detail: $error";
2164     }
2165   }
2166
2167   foreach my $detail ( @details ) {
2168     my $cust_pkg_detail = new FS::cust_pkg_detail {
2169       'pkgnum'     => $self->pkgnum,
2170       'detailtype' => $detailtype,
2171       'detail'     => $detail,
2172     };
2173     my $error = $cust_pkg_detail->insert;
2174     if ( $error ) {
2175       $dbh->rollback if $oldAutoCommit;
2176       return "error adding new detail: $error";
2177     }
2178
2179   }
2180
2181   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2182   '';
2183
2184 }
2185
2186 =item cust_event
2187
2188 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
2189
2190 =cut
2191
2192 #false laziness w/cust_bill.pm
2193 sub cust_event {
2194   my $self = shift;
2195   qsearch({
2196     'table'     => 'cust_event',
2197     'addl_from' => 'JOIN part_event USING ( eventpart )',
2198     'hashref'   => { 'tablenum' => $self->pkgnum },
2199     'extra_sql' => " AND eventtable = 'cust_pkg' ",
2200   });
2201 }
2202
2203 =item num_cust_event
2204
2205 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
2206
2207 =cut
2208
2209 #false laziness w/cust_bill.pm
2210 sub num_cust_event {
2211   my $self = shift;
2212   my $sql =
2213     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
2214     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
2215   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
2216   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
2217   $sth->fetchrow_arrayref->[0];
2218 }
2219
2220 =item cust_svc [ SVCPART ] (old, deprecated usage)
2221
2222 =item cust_svc [ OPTION => VALUE ... ] (current usage)
2223
2224 Returns the services for this package, as FS::cust_svc objects (see
2225 L<FS::cust_svc>).  Available options are svcpart and svcdb.  If either is
2226 spcififed, returns only the matching services.
2227
2228 =cut
2229
2230 sub cust_svc {
2231   my $self = shift;
2232
2233   return () unless $self->num_cust_svc(@_);
2234
2235   my %opt = ();
2236   if ( @_ && $_[0] =~ /^\d+/ ) {
2237     $opt{svcpart} = shift;
2238   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2239     %opt = %{ $_[0] };
2240   } elsif ( @_ ) {
2241     %opt = @_;
2242   }
2243
2244   my %search = (
2245     'table'   => 'cust_svc',
2246     'hashref' => { 'pkgnum' => $self->pkgnum },
2247   );
2248   if ( $opt{svcpart} ) {
2249     $search{hashref}->{svcpart} = $opt{'svcpart'};
2250   }
2251   if ( $opt{'svcdb'} ) {
2252     $search{addl_from} = ' LEFT JOIN part_svc USING ( svcpart ) ';
2253     $search{extra_sql} = ' AND svcdb = '. dbh->quote( $opt{'svcdb'} );
2254   }
2255
2256   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
2257
2258   #if ( $self->{'_svcnum'} ) {
2259   #  values %{ $self->{'_svcnum'}->cache };
2260   #} else {
2261     $self->_sort_cust_svc( [ qsearch(\%search) ] );
2262   #}
2263
2264 }
2265
2266 =item overlimit [ SVCPART ]
2267
2268 Returns the services for this package which have exceeded their
2269 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
2270 is specified, return only the matching services.
2271
2272 =cut
2273
2274 sub overlimit {
2275   my $self = shift;
2276   return () unless $self->num_cust_svc(@_);
2277   grep { $_->overlimit } $self->cust_svc(@_);
2278 }
2279
2280 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2281
2282 Returns historical services for this package created before END TIMESTAMP and
2283 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
2284 (see L<FS::h_cust_svc>).  If MODE is 'I' (for 'invoice'), services with the
2285 I<pkg_svc.hidden> flag will be omitted.
2286
2287 =cut
2288
2289 sub h_cust_svc {
2290   my $self = shift;
2291   warn "$me _h_cust_svc called on $self\n"
2292     if $DEBUG;
2293
2294   my ($end, $start, $mode) = @_;
2295   my @cust_svc = $self->_sort_cust_svc(
2296     [ qsearch( 'h_cust_svc',
2297       { 'pkgnum' => $self->pkgnum, },
2298       FS::h_cust_svc->sql_h_search(@_),
2299     ) ]
2300   );
2301   if ( defined($mode) && $mode eq 'I' ) {
2302     my %hidden_svcpart = map { $_->svcpart => $_->hidden } $self->part_svc;
2303     return grep { !$hidden_svcpart{$_->svcpart} } @cust_svc;
2304   } else {
2305     return @cust_svc;
2306   }
2307 }
2308
2309 sub _sort_cust_svc {
2310   my( $self, $arrayref ) = @_;
2311
2312   my $sort =
2313     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
2314
2315   map  { $_->[0] }
2316   sort $sort
2317   map {
2318         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
2319                                              'svcpart' => $_->svcpart     } );
2320         [ $_,
2321           $pkg_svc ? $pkg_svc->primary_svc : '',
2322           $pkg_svc ? $pkg_svc->quantity : 0,
2323         ];
2324       }
2325   @$arrayref;
2326
2327 }
2328
2329 =item num_cust_svc [ SVCPART ] (old, deprecated usage)
2330
2331 =item num_cust_svc [ OPTION => VALUE ... ] (current usage)
2332
2333 Returns the number of services for this package.  Available options are svcpart
2334 and svcdb.  If either is spcififed, returns only the matching services.
2335
2336 =cut
2337
2338 sub num_cust_svc {
2339   my $self = shift;
2340
2341   return $self->{'_num_cust_svc'}
2342     if !scalar(@_)
2343        && exists($self->{'_num_cust_svc'})
2344        && $self->{'_num_cust_svc'} =~ /\d/;
2345
2346   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
2347     if $DEBUG > 2;
2348
2349   my %opt = ();
2350   if ( @_ && $_[0] =~ /^\d+/ ) {
2351     $opt{svcpart} = shift;
2352   } elsif ( @_ && ref($_[0]) eq 'HASH' ) {
2353     %opt = %{ $_[0] };
2354   } elsif ( @_ ) {
2355     %opt = @_;
2356   }
2357
2358   my $select = 'SELECT COUNT(*) FROM cust_svc ';
2359   my $where = ' WHERE pkgnum = ? ';
2360   my @param = ($self->pkgnum);
2361
2362   if ( $opt{'svcpart'} ) {
2363     $where .= ' AND svcpart = ? ';
2364     push @param, $opt{'svcpart'};
2365   }
2366   if ( $opt{'svcdb'} ) {
2367     $select .= ' LEFT JOIN part_svc USING ( svcpart ) ';
2368     $where .= ' AND svcdb = ? ';
2369     push @param, $opt{'svcdb'};
2370   }
2371
2372   my $sth = dbh->prepare("$select $where") or die  dbh->errstr;
2373   $sth->execute(@param) or die $sth->errstr;
2374   $sth->fetchrow_arrayref->[0];
2375 }
2376
2377 =item available_part_svc
2378
2379 Returns a list of FS::part_svc objects representing services included in this
2380 package but not yet provisioned.  Each FS::part_svc object also has an extra
2381 field, I<num_avail>, which specifies the number of available services.
2382
2383 =cut
2384
2385 sub available_part_svc {
2386   my $self = shift;
2387
2388   my $pkg_quantity = $self->quantity || 1;
2389
2390   grep { $_->num_avail > 0 }
2391     map {
2392           my $part_svc = $_->part_svc;
2393           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
2394             $pkg_quantity * $_->quantity - $self->num_cust_svc($_->svcpart);
2395
2396           # more evil encapsulation breakage
2397           if($part_svc->{'Hash'}{'num_avail'} > 0) {
2398             my @exports = $part_svc->part_export_did;
2399             $part_svc->{'Hash'}{'can_get_dids'} = scalar(@exports);
2400           }
2401
2402           $part_svc;
2403         }
2404       $self->part_pkg->pkg_svc;
2405 }
2406
2407 =item part_svc [ OPTION => VALUE ... ]
2408
2409 Returns a list of FS::part_svc objects representing provisioned and available
2410 services included in this package.  Each FS::part_svc object also has the
2411 following extra fields:
2412
2413 =over 4
2414
2415 =item num_cust_svc  (count)
2416
2417 =item num_avail     (quantity - count)
2418
2419 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
2420
2421 =back
2422
2423 Accepts one option: summarize_size.  If specified and non-zero, will omit the
2424 extra cust_pkg_svc option for objects where num_cust_svc is this size or
2425 greater.
2426
2427 =cut
2428
2429 #svcnum
2430 #label -> ($cust_svc->label)[1]
2431
2432 sub part_svc {
2433   my $self = shift;
2434   my %opt = @_;
2435
2436   my $pkg_quantity = $self->quantity || 1;
2437
2438   #XXX some sort of sort order besides numeric by svcpart...
2439   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
2440     my $pkg_svc = $_;
2441     my $part_svc = $pkg_svc->part_svc;
2442     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2443     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
2444     $part_svc->{'Hash'}{'num_avail'}    =
2445       max( 0, $pkg_quantity * $pkg_svc->quantity - $num_cust_svc );
2446     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2447         $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : []
2448       unless exists($opt{summarize_size}) && $opt{summarize_size} > 0
2449           && $num_cust_svc >= $opt{summarize_size};
2450     $part_svc->{'Hash'}{'hidden'} = $pkg_svc->hidden;
2451     $part_svc;
2452   } $self->part_pkg->pkg_svc;
2453
2454   #extras
2455   push @part_svc, map {
2456     my $part_svc = $_;
2457     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
2458     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
2459     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
2460     $part_svc->{'Hash'}{'cust_pkg_svc'} =
2461       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
2462     $part_svc;
2463   } $self->extra_part_svc;
2464
2465   @part_svc;
2466
2467 }
2468
2469 =item extra_part_svc
2470
2471 Returns a list of FS::part_svc objects corresponding to services in this
2472 package which are still provisioned but not (any longer) available in the
2473 package definition.
2474
2475 =cut
2476
2477 sub extra_part_svc {
2478   my $self = shift;
2479
2480   my $pkgnum  = $self->pkgnum;
2481   #my $pkgpart = $self->pkgpart;
2482
2483 #  qsearch( {
2484 #    'table'     => 'part_svc',
2485 #    'hashref'   => {},
2486 #    'extra_sql' =>
2487 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
2488 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
2489 #                       AND pkg_svc.pkgpart = ?
2490 #                       AND quantity > 0
2491 #                 )
2492 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
2493 #                       LEFT JOIN cust_pkg USING ( pkgnum )
2494 #                     WHERE cust_svc.svcpart = part_svc.svcpart
2495 #                       AND pkgnum = ?
2496 #                 )",
2497 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
2498 #  } );
2499
2500 #seems to benchmark slightly faster... (or did?)
2501
2502   my @pkgparts = map $_->pkgpart, $self->part_pkg->self_and_svc_linked;
2503   my $pkgparts = join(',', @pkgparts);
2504
2505   qsearch( {
2506     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
2507     #MySQL doesn't grok DISINCT ON
2508     'select'      => 'DISTINCT part_svc.*',
2509     'table'       => 'part_svc',
2510     'addl_from'   =>
2511       "LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
2512                                AND pkg_svc.pkgpart IN ($pkgparts)
2513                                AND quantity > 0
2514                              )
2515        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
2516        LEFT JOIN cust_pkg USING ( pkgnum )
2517       ",
2518     'hashref'     => {},
2519     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
2520     'extra_param' => [ [$self->pkgnum=>'int'] ],
2521   } );
2522 }
2523
2524 =item status
2525
2526 Returns a short status string for this package, currently:
2527
2528 =over 4
2529
2530 =item not yet billed
2531
2532 =item one-time charge
2533
2534 =item active
2535
2536 =item suspended
2537
2538 =item cancelled
2539
2540 =back
2541
2542 =cut
2543
2544 sub status {
2545   my $self = shift;
2546
2547   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
2548
2549   return 'cancelled' if $self->get('cancel');
2550   return 'suspended' if $self->susp;
2551   return 'not yet billed' unless $self->setup;
2552   return 'one-time charge' if $freq =~ /^(0|$)/;
2553   return 'active';
2554 }
2555
2556 =item ucfirst_status
2557
2558 Returns the status with the first character capitalized.
2559
2560 =cut
2561
2562 sub ucfirst_status {
2563   ucfirst(shift->status);
2564 }
2565
2566 =item statuses
2567
2568 Class method that returns the list of possible status strings for packages
2569 (see L<the status method|/status>).  For example:
2570
2571   @statuses = FS::cust_pkg->statuses();
2572
2573 =cut
2574
2575 tie my %statuscolor, 'Tie::IxHash',
2576   'not yet billed'  => '009999', #teal? cyan?
2577   'one-time charge' => '000000',
2578   'active'          => '00CC00',
2579   'suspended'       => 'FF9900',
2580   'cancelled'       => 'FF0000',
2581 ;
2582
2583 sub statuses {
2584   my $self = shift; #could be class...
2585   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
2586   #                                    # mayble split btw one-time vs. recur
2587     keys %statuscolor;
2588 }
2589
2590 =item statuscolor
2591
2592 Returns a hex triplet color string for this package's status.
2593
2594 =cut
2595
2596 sub statuscolor {
2597   my $self = shift;
2598   $statuscolor{$self->status};
2599 }
2600
2601 =item pkg_label
2602
2603 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
2604 "pkg-comment" depending on user preference).
2605
2606 =cut
2607
2608 sub pkg_label {
2609   my $self = shift;
2610   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
2611   $label = $self->pkgnum. ": $label"
2612     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
2613   $label;
2614 }
2615
2616 =item pkg_label_long
2617
2618 Returns a long label for this package, adding the primary service's label to
2619 pkg_label.
2620
2621 =cut
2622
2623 sub pkg_label_long {
2624   my $self = shift;
2625   my $label = $self->pkg_label;
2626   my $cust_svc = $self->primary_cust_svc;
2627   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
2628   $label;
2629 }
2630
2631 =item primary_cust_svc
2632
2633 Returns a primary service (as FS::cust_svc object) if one can be identified.
2634
2635 =cut
2636
2637 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
2638
2639 sub primary_cust_svc {
2640   my $self = shift;
2641
2642   my @cust_svc = $self->cust_svc;
2643
2644   return '' unless @cust_svc; #no serivces - irrelevant then
2645
2646   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
2647
2648   # primary service as specified in the package definition
2649   # or exactly one service definition with quantity one
2650   my $svcpart = $self->part_pkg->svcpart;
2651   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
2652   return $cust_svc[0] if scalar(@cust_svc) == 1;
2653
2654   #couldn't identify one thing..
2655   return '';
2656 }
2657
2658 =item labels
2659
2660 Returns a list of lists, calling the label method for all services
2661 (see L<FS::cust_svc>) of this billing item.
2662
2663 =cut
2664
2665 sub labels {
2666   my $self = shift;
2667   map { [ $_->label ] } $self->cust_svc;
2668 }
2669
2670 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ] [ MODE ]
2671
2672 Like the labels method, but returns historical information on services that
2673 were active as of END_TIMESTAMP and (optionally) not cancelled before
2674 START_TIMESTAMP.  If MODE is 'I' (for 'invoice'), services with the
2675 I<pkg_svc.hidden> flag will be omitted.
2676
2677 Returns a list of lists, calling the label method for all (historical) services
2678 (see L<FS::h_cust_svc>) of this billing item.
2679
2680 =cut
2681
2682 sub h_labels {
2683   my $self = shift;
2684   warn "$me _h_labels called on $self\n"
2685     if $DEBUG;
2686   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
2687 }
2688
2689 =item labels_short
2690
2691 Like labels, except returns a simple flat list, and shortens long
2692 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2693 identical services to one line that lists the service label and the number of
2694 individual services rather than individual items.
2695
2696 =cut
2697
2698 sub labels_short {
2699   shift->_labels_short( 'labels', @_ );
2700 }
2701
2702 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
2703
2704 Like h_labels, except returns a simple flat list, and shortens long
2705 (currently >5 or the cust_bill-max_same_services configuration value) lists of
2706 identical services to one line that lists the service label and the number of
2707 individual services rather than individual items.
2708
2709 =cut
2710
2711 sub h_labels_short {
2712   shift->_labels_short( 'h_labels', @_ );
2713 }
2714
2715 sub _labels_short {
2716   my( $self, $method ) = ( shift, shift );
2717
2718   warn "$me _labels_short called on $self with $method method\n"
2719     if $DEBUG;
2720
2721   my $conf = new FS::Conf;
2722   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
2723
2724   warn "$me _labels_short populating \%labels\n"
2725     if $DEBUG;
2726
2727   my %labels;
2728   #tie %labels, 'Tie::IxHash';
2729   push @{ $labels{$_->[0]} }, $_->[1]
2730     foreach $self->$method(@_);
2731
2732   warn "$me _labels_short populating \@labels\n"
2733     if $DEBUG;
2734
2735   my @labels;
2736   foreach my $label ( keys %labels ) {
2737     my %seen = ();
2738     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
2739     my $num = scalar(@values);
2740     warn "$me _labels_short $num items for $label\n"
2741       if $DEBUG;
2742
2743     if ( $num > $max_same_services ) {
2744       warn "$me _labels_short   more than $max_same_services, so summarizing\n"
2745         if $DEBUG;
2746       push @labels, "$label ($num)";
2747     } else {
2748       if ( $conf->exists('cust_bill-consolidate_services') ) {
2749         warn "$me _labels_short   consolidating services\n"
2750           if $DEBUG;
2751         # push @labels, "$label: ". join(', ', @values);
2752         while ( @values ) {
2753           my $detail = "$label: ";
2754           $detail .= shift(@values). ', '
2755             while @values
2756                && ( length($detail.$values[0]) < 78 || $detail eq "$label: " );
2757           $detail =~ s/, $//;
2758           push @labels, $detail;
2759         }
2760         warn "$me _labels_short   done consolidating services\n"
2761           if $DEBUG;
2762       } else {
2763         warn "$me _labels_short   adding service data\n"
2764           if $DEBUG;
2765         push @labels, map { "$label: $_" } @values;
2766       }
2767     }
2768   }
2769
2770  @labels;
2771
2772 }
2773
2774 =item cust_main
2775
2776 Returns the parent customer object (see L<FS::cust_main>).
2777
2778 =cut
2779
2780 sub cust_main {
2781   my $self = shift;
2782   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
2783 }
2784
2785 =item balance
2786
2787 Returns the balance for this specific package, when using
2788 experimental package balance.
2789
2790 =cut
2791
2792 sub balance {
2793   my $self = shift;
2794   $self->cust_main->balance_pkgnum( $self->pkgnum );
2795 }
2796
2797 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
2798
2799 =item cust_location
2800
2801 Returns the location object, if any (see L<FS::cust_location>).
2802
2803 =item cust_location_or_main
2804
2805 If this package is associated with a location, returns the locaiton (see
2806 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2807
2808 =item location_label [ OPTION => VALUE ... ]
2809
2810 Returns the label of the location object (see L<FS::cust_location>).
2811
2812 =cut
2813
2814 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2815
2816 =item tax_locationnum
2817
2818 Returns the foreign key to a L<FS::cust_location> object for calculating
2819 tax on this package, as determined by the C<tax-pkg_address> and
2820 C<tax-ship_address> configuration flags.
2821
2822 =cut
2823
2824 sub tax_locationnum {
2825   my $self = shift;
2826   my $conf = FS::Conf->new;
2827   if ( $conf->exists('tax-pkg_address') ) {
2828     return $self->locationnum;
2829   }
2830   elsif ( $conf->exists('tax-ship_address') ) {
2831     return $self->cust_main->ship_locationnum;
2832   }
2833   else {
2834     return $self->cust_main->bill_locationnum;
2835   }
2836 }
2837
2838 =item tax_location
2839
2840 Returns the L<FS::cust_location> object for tax_locationnum.
2841
2842 =cut
2843
2844 sub tax_location {
2845   my $self = shift;
2846   FS::cust_location->by_key( $self->tax_locationnum )
2847 }
2848
2849 =item seconds_since TIMESTAMP
2850
2851 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2852 package have been online since TIMESTAMP, according to the session monitor.
2853
2854 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2855 L<Time::Local> and L<Date::Parse> for conversion functions.
2856
2857 =cut
2858
2859 sub seconds_since {
2860   my($self, $since) = @_;
2861   my $seconds = 0;
2862
2863   foreach my $cust_svc (
2864     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2865   ) {
2866     $seconds += $cust_svc->seconds_since($since);
2867   }
2868
2869   $seconds;
2870
2871 }
2872
2873 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2874
2875 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2876 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2877 (exclusive).
2878
2879 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2880 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2881 functions.
2882
2883
2884 =cut
2885
2886 sub seconds_since_sqlradacct {
2887   my($self, $start, $end) = @_;
2888
2889   my $seconds = 0;
2890
2891   foreach my $cust_svc (
2892     grep {
2893       my $part_svc = $_->part_svc;
2894       $part_svc->svcdb eq 'svc_acct'
2895         && scalar($part_svc->part_export_usage);
2896     } $self->cust_svc
2897   ) {
2898     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2899   }
2900
2901   $seconds;
2902
2903 }
2904
2905 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2906
2907 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2908 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2909 TIMESTAMP_END
2910 (exclusive).
2911
2912 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2913 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2914 functions.
2915
2916 =cut
2917
2918 sub attribute_since_sqlradacct {
2919   my($self, $start, $end, $attrib) = @_;
2920
2921   my $sum = 0;
2922
2923   foreach my $cust_svc (
2924     grep {
2925       my $part_svc = $_->part_svc;
2926       $part_svc->svcdb eq 'svc_acct'
2927         && scalar($part_svc->part_export_usage);
2928     } $self->cust_svc
2929   ) {
2930     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2931   }
2932
2933   $sum;
2934
2935 }
2936
2937 =item quantity
2938
2939 =cut
2940
2941 sub quantity {
2942   my( $self, $value ) = @_;
2943   if ( defined($value) ) {
2944     $self->setfield('quantity', $value);
2945   }
2946   $self->getfield('quantity') || 1;
2947 }
2948
2949 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2950
2951 Transfers as many services as possible from this package to another package.
2952
2953 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2954 object.  The destination package must already exist.
2955
2956 Services are moved only if the destination allows services with the correct
2957 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2958 this option with caution!  No provision is made for export differences
2959 between the old and new service definitions.  Probably only should be used
2960 when your exports for all service definitions of a given svcdb are identical.
2961 (attempt a transfer without it first, to move all possible svcpart-matching
2962 services)
2963
2964 Any services that can't be moved remain in the original package.
2965
2966 Returns an error, if there is one; otherwise, returns the number of services
2967 that couldn't be moved.
2968
2969 =cut
2970
2971 sub transfer {
2972   my ($self, $dest_pkgnum, %opt) = @_;
2973
2974   my $remaining = 0;
2975   my $dest;
2976   my %target;
2977
2978   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2979     $dest = $dest_pkgnum;
2980     $dest_pkgnum = $dest->pkgnum;
2981   } else {
2982     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2983   }
2984
2985   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2986
2987   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2988     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2989   }
2990
2991   foreach my $cust_svc ($dest->cust_svc) {
2992     $target{$cust_svc->svcpart}--;
2993   }
2994
2995   my %svcpart2svcparts = ();
2996   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2997     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2998     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2999       next if exists $svcpart2svcparts{$svcpart};
3000       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
3001       $svcpart2svcparts{$svcpart} = [
3002         map  { $_->[0] }
3003         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
3004         map {
3005               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
3006                                                    'svcpart' => $_          } );
3007               [ $_,
3008                 $pkg_svc ? $pkg_svc->primary_svc : '',
3009                 $pkg_svc ? $pkg_svc->quantity : 0,
3010               ];
3011             }
3012
3013         grep { $_ != $svcpart }
3014         map  { $_->svcpart }
3015         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
3016       ];
3017       warn "alternates for svcpart $svcpart: ".
3018            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
3019         if $DEBUG;
3020     }
3021   }
3022
3023   foreach my $cust_svc ($self->cust_svc) {
3024     if($target{$cust_svc->svcpart} > 0
3025        or $FS::cust_svc::ignore_quantity) { # maybe should be a 'force' option
3026       $target{$cust_svc->svcpart}--;
3027       my $new = new FS::cust_svc { $cust_svc->hash };
3028       $new->pkgnum($dest_pkgnum);
3029       my $error = $new->replace($cust_svc);
3030       return $error if $error;
3031     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
3032       if ( $DEBUG ) {
3033         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
3034         warn "alternates to consider: ".
3035              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
3036       }
3037       my @alternate = grep {
3038                              warn "considering alternate svcpart $_: ".
3039                                   "$target{$_} available in new package\n"
3040                                if $DEBUG;
3041                              $target{$_} > 0;
3042                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
3043       if ( @alternate ) {
3044         warn "alternate(s) found\n" if $DEBUG;
3045         my $change_svcpart = $alternate[0];
3046         $target{$change_svcpart}--;
3047         my $new = new FS::cust_svc { $cust_svc->hash };
3048         $new->svcpart($change_svcpart);
3049         $new->pkgnum($dest_pkgnum);
3050         my $error = $new->replace($cust_svc);
3051         return $error if $error;
3052       } else {
3053         $remaining++;
3054       }
3055     } else {
3056       $remaining++
3057     }
3058   }
3059   return $remaining;
3060 }
3061
3062 =item reexport
3063
3064 This method is deprecated.  See the I<depend_jobnum> option to the insert and
3065 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
3066
3067 =cut
3068
3069 sub reexport {
3070   my $self = shift;
3071
3072   local $SIG{HUP} = 'IGNORE';
3073   local $SIG{INT} = 'IGNORE';
3074   local $SIG{QUIT} = 'IGNORE';
3075   local $SIG{TERM} = 'IGNORE';
3076   local $SIG{TSTP} = 'IGNORE';
3077   local $SIG{PIPE} = 'IGNORE';
3078
3079   my $oldAutoCommit = $FS::UID::AutoCommit;
3080   local $FS::UID::AutoCommit = 0;
3081   my $dbh = dbh;
3082
3083   foreach my $cust_svc ( $self->cust_svc ) {
3084     #false laziness w/svc_Common::insert
3085     my $svc_x = $cust_svc->svc_x;
3086     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
3087       my $error = $part_export->export_insert($svc_x);
3088       if ( $error ) {
3089         $dbh->rollback if $oldAutoCommit;
3090         return $error;
3091       }
3092     }
3093   }
3094
3095   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3096   '';
3097
3098 }
3099
3100 =item insert_reason
3101
3102 Associates this package with a (suspension or cancellation) reason (see
3103 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
3104 L<FS::reason>).
3105
3106 Available options are:
3107
3108 =over 4
3109
3110 =item reason
3111
3112 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.
3113
3114 =item reason_otaker
3115
3116 the access_user (see L<FS::access_user>) providing the reason
3117
3118 =item date
3119
3120 a unix timestamp
3121
3122 =item action
3123
3124 the action (cancel, susp, adjourn, expire) associated with the reason
3125
3126 =back
3127
3128 If there is an error, returns the error, otherwise returns false.
3129
3130 =cut
3131
3132 sub insert_reason {
3133   my ($self, %options) = @_;
3134
3135   my $otaker = $options{reason_otaker} ||
3136                $FS::CurrentUser::CurrentUser->username;
3137
3138   my $reasonnum;
3139   if ( $options{'reason'} =~ /^(\d+)$/ ) {
3140
3141     $reasonnum = $1;
3142
3143   } elsif ( ref($options{'reason'}) ) {
3144
3145     return 'Enter a new reason (or select an existing one)'
3146       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
3147
3148     my $reason = new FS::reason({
3149       'reason_type' => $options{'reason'}->{'typenum'},
3150       'reason'      => $options{'reason'}->{'reason'},
3151     });
3152     my $error = $reason->insert;
3153     return $error if $error;
3154
3155     $reasonnum = $reason->reasonnum;
3156
3157   } else {
3158     return "Unparsable reason: ". $options{'reason'};
3159   }
3160
3161   my $cust_pkg_reason =
3162     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
3163                               'reasonnum' => $reasonnum,
3164                               'otaker'    => $otaker,
3165                               'action'    => substr(uc($options{'action'}),0,1),
3166                               'date'      => $options{'date'}
3167                                                ? $options{'date'}
3168                                                : time,
3169                             });
3170
3171   $cust_pkg_reason->insert;
3172 }
3173
3174 =item insert_discount
3175
3176 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
3177 inserting a new discount on the fly (see L<FS::discount>).
3178
3179 Available options are:
3180
3181 =over 4
3182
3183 =item discountnum
3184
3185 =back
3186
3187 If there is an error, returns the error, otherwise returns false.
3188
3189 =cut
3190
3191 sub insert_discount {
3192   #my ($self, %options) = @_;
3193   my $self = shift;
3194
3195   my $cust_pkg_discount = new FS::cust_pkg_discount {
3196     'pkgnum'      => $self->pkgnum,
3197     'discountnum' => $self->discountnum,
3198     'months_used' => 0,
3199     'end_date'    => '', #XXX
3200     #for the create a new discount case
3201     '_type'       => $self->discountnum__type,
3202     'amount'      => $self->discountnum_amount,
3203     'percent'     => $self->discountnum_percent,
3204     'months'      => $self->discountnum_months,
3205     'setup'      => $self->discountnum_setup,
3206     #'disabled'    => $self->discountnum_disabled,
3207   };
3208
3209   $cust_pkg_discount->insert;
3210 }
3211
3212 =item set_usage USAGE_VALUE_HASHREF
3213
3214 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3215 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3216 upbytes, downbytes, and totalbytes are appropriate keys.
3217
3218 All svc_accts which are part of this package have their values reset.
3219
3220 =cut
3221
3222 sub set_usage {
3223   my ($self, $valueref, %opt) = @_;
3224
3225   #only svc_acct can set_usage for now
3226   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3227     my $svc_x = $cust_svc->svc_x;
3228     $svc_x->set_usage($valueref, %opt)
3229       if $svc_x->can("set_usage");
3230   }
3231 }
3232
3233 =item recharge USAGE_VALUE_HASHREF
3234
3235 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
3236 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
3237 upbytes, downbytes, and totalbytes are appropriate keys.
3238
3239 All svc_accts which are part of this package have their values incremented.
3240
3241 =cut
3242
3243 sub recharge {
3244   my ($self, $valueref) = @_;
3245
3246   #only svc_acct can set_usage for now
3247   foreach my $cust_svc ( $self->cust_svc( 'svcdb'=>'svc_acct' ) ) {
3248     my $svc_x = $cust_svc->svc_x;
3249     $svc_x->recharge($valueref)
3250       if $svc_x->can("recharge");
3251   }
3252 }
3253
3254 =item cust_pkg_discount
3255
3256 =cut
3257
3258 sub cust_pkg_discount {
3259   my $self = shift;
3260   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
3261 }
3262
3263 =item cust_pkg_discount_active
3264
3265 =cut
3266
3267 sub cust_pkg_discount_active {
3268   my $self = shift;
3269   grep { $_->status eq 'active' } $self->cust_pkg_discount;
3270 }
3271
3272 =back
3273
3274 =item supplemental_pkgs
3275
3276 Returns a list of all packages supplemental to this one.
3277
3278 =cut
3279
3280 sub supplemental_pkgs {
3281   my $self = shift;
3282   qsearch('cust_pkg', { 'main_pkgnum' => $self->pkgnum });
3283 }
3284
3285 =item main_pkg
3286
3287 Returns the package that this one is supplemental to, if any.
3288
3289 =cut
3290
3291 sub main_pkg {
3292   my $self = shift;
3293   if ( $self->main_pkgnum ) {
3294     return FS::cust_pkg->by_key($self->main_pkgnum);
3295   }
3296   return;
3297 }
3298
3299 =head1 CLASS METHODS
3300
3301 =over 4
3302
3303 =item recurring_sql
3304
3305 Returns an SQL expression identifying recurring packages.
3306
3307 =cut
3308
3309 sub recurring_sql { "
3310   '0' != ( select freq from part_pkg
3311              where cust_pkg.pkgpart = part_pkg.pkgpart )
3312 "; }
3313
3314 =item onetime_sql
3315
3316 Returns an SQL expression identifying one-time packages.
3317
3318 =cut
3319
3320 sub onetime_sql { "
3321   '0' = ( select freq from part_pkg
3322             where cust_pkg.pkgpart = part_pkg.pkgpart )
3323 "; }
3324
3325 =item ordered_sql
3326
3327 Returns an SQL expression identifying ordered packages (recurring packages not
3328 yet billed).
3329
3330 =cut
3331
3332 sub ordered_sql {
3333    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
3334 }
3335
3336 =item active_sql
3337
3338 Returns an SQL expression identifying active packages.
3339
3340 =cut
3341
3342 sub active_sql {
3343   $_[0]->recurring_sql. "
3344   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3345   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3346   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3347 "; }
3348
3349 =item not_yet_billed_sql
3350
3351 Returns an SQL expression identifying packages which have not yet been billed.
3352
3353 =cut
3354
3355 sub not_yet_billed_sql { "
3356       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
3357   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3358   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3359 "; }
3360
3361 =item inactive_sql
3362
3363 Returns an SQL expression identifying inactive packages (one-time packages
3364 that are otherwise unsuspended/uncancelled).
3365
3366 =cut
3367
3368 sub inactive_sql { "
3369   ". $_[0]->onetime_sql(). "
3370   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
3371   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
3372   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
3373 "; }
3374
3375 =item susp_sql
3376 =item suspended_sql
3377
3378 Returns an SQL expression identifying suspended packages.
3379
3380 =cut
3381
3382 sub suspended_sql { susp_sql(@_); }
3383 sub susp_sql {
3384   #$_[0]->recurring_sql(). ' AND '.
3385   "
3386         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
3387     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
3388   ";
3389 }
3390
3391 =item cancel_sql
3392 =item cancelled_sql
3393
3394 Returns an SQL exprression identifying cancelled packages.
3395
3396 =cut
3397
3398 sub cancelled_sql { cancel_sql(@_); }
3399 sub cancel_sql {
3400   #$_[0]->recurring_sql(). ' AND '.
3401   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
3402 }
3403
3404 =item status_sql
3405
3406 Returns an SQL expression to give the package status as a string.
3407
3408 =cut
3409
3410 sub status_sql {
3411 "CASE
3412   WHEN cust_pkg.cancel IS NOT NULL THEN 'cancelled'
3413   WHEN cust_pkg.susp IS NOT NULL THEN 'suspended'
3414   WHEN cust_pkg.setup IS NULL THEN 'not yet billed'
3415   WHEN ".onetime_sql()." THEN 'one-time charge'
3416   ELSE 'active'
3417 END"
3418 }
3419
3420 =item search HASHREF
3421
3422 (Class method)
3423
3424 Returns a qsearch hash expression to search for parameters specified in HASHREF.
3425 Valid parameters are
3426
3427 =over 4
3428
3429 =item agentnum
3430
3431 =item magic
3432
3433 active, inactive, suspended, cancel (or cancelled)
3434
3435 =item status
3436
3437 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
3438
3439 =item custom
3440
3441  boolean selects custom packages
3442
3443 =item classnum
3444
3445 =item pkgpart
3446
3447 pkgpart or arrayref or hashref of pkgparts
3448
3449 =item setup
3450
3451 arrayref of beginning and ending epoch date
3452
3453 =item last_bill
3454
3455 arrayref of beginning and ending epoch date
3456
3457 =item bill
3458
3459 arrayref of beginning and ending epoch date
3460
3461 =item adjourn
3462
3463 arrayref of beginning and ending epoch date
3464
3465 =item susp
3466
3467 arrayref of beginning and ending epoch date
3468
3469 =item expire
3470
3471 arrayref of beginning and ending epoch date
3472
3473 =item cancel
3474
3475 arrayref of beginning and ending epoch date
3476
3477 =item query
3478
3479 pkgnum or APKG_pkgnum
3480
3481 =item cust_fields
3482
3483 a value suited to passing to FS::UI::Web::cust_header
3484
3485 =item CurrentUser
3486
3487 specifies the user for agent virtualization
3488
3489 =item fcc_line
3490
3491 boolean; if true, returns only packages with more than 0 FCC phone lines.
3492
3493 =item state, country
3494
3495 Limit to packages with a service location in the specified state and country.
3496 For FCC 477 reporting, mostly.
3497
3498 =back
3499
3500 =cut
3501
3502 sub search {
3503   my ($class, $params) = @_;
3504   my @where = ();
3505
3506   ##
3507   # parse agent
3508   ##
3509
3510   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
3511     push @where,
3512       "cust_main.agentnum = $1";
3513   }
3514
3515   ##
3516   # parse custnum
3517   ##
3518
3519   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
3520     push @where,
3521       "cust_pkg.custnum = $1";
3522   }
3523
3524   ##
3525   # custbatch
3526   ##
3527
3528   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
3529     push @where,
3530       "cust_pkg.pkgbatch = '$1'";
3531   }
3532
3533   ##
3534   # parse status
3535   ##
3536
3537   if (    $params->{'magic'}  eq 'active'
3538        || $params->{'status'} eq 'active' ) {
3539
3540     push @where, FS::cust_pkg->active_sql();
3541
3542   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
3543             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
3544
3545     push @where, FS::cust_pkg->not_yet_billed_sql();
3546
3547   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
3548             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
3549
3550     push @where, FS::cust_pkg->inactive_sql();
3551
3552   } elsif (    $params->{'magic'}  eq 'suspended'
3553             || $params->{'status'} eq 'suspended'  ) {
3554
3555     push @where, FS::cust_pkg->suspended_sql();
3556
3557   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
3558             || $params->{'status'} =~ /^cancell?ed$/ ) {
3559
3560     push @where, FS::cust_pkg->cancelled_sql();
3561
3562   }
3563
3564   ###
3565   # parse package class
3566   ###
3567
3568   if ( exists($params->{'classnum'}) ) {
3569
3570     my @classnum = ();
3571     if ( ref($params->{'classnum'}) ) {
3572
3573       if ( ref($params->{'classnum'}) eq 'HASH' ) {
3574         @classnum = grep $params->{'classnum'}{$_}, keys %{ $params->{'classnum'} };
3575       } elsif ( ref($params->{'classnum'}) eq 'ARRAY' ) {
3576         @classnum = @{ $params->{'classnum'} };
3577       } else {
3578         die 'unhandled classnum ref '. $params->{'classnum'};
3579       }
3580
3581
3582     } elsif ( $params->{'classnum'} =~ /^(\d*)$/ && $1 ne '0' ) {
3583       @classnum = ( $1 );
3584     }
3585
3586     if ( @classnum ) {
3587
3588       my @c_where = ();
3589       my @nums = grep $_, @classnum;
3590       push @c_where, 'part_pkg.classnum IN ('. join(',',@nums). ')' if @nums;
3591       my $null = scalar( grep { $_ eq '' } @classnum );
3592       push @c_where, 'part_pkg.classnum IS NULL' if $null;
3593
3594       if ( scalar(@c_where) == 1 ) {
3595         push @where, @c_where;
3596       } elsif ( @c_where ) {
3597         push @where, ' ( '. join(' OR ', @c_where). ' ) ';
3598       }
3599
3600     }
3601
3602
3603   }
3604
3605   ###
3606   # parse package report options
3607   ###
3608
3609   my @report_option = ();
3610   if ( exists($params->{'report_option'}) ) {
3611     if ( ref($params->{'report_option'}) eq 'ARRAY' ) {
3612       @report_option = @{ $params->{'report_option'} };
3613     } elsif ( $params->{'report_option'} =~ /^([,\d]*)$/ ) {
3614       @report_option = split(',', $1);
3615     }
3616
3617   }
3618
3619   if (@report_option) {
3620     # this will result in the empty set for the dangling comma case as it should
3621     push @where,
3622       map{ "0 < ( SELECT count(*) FROM part_pkg_option
3623                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3624                     AND optionname = 'report_option_$_'
3625                     AND optionvalue = '1' )"
3626          } @report_option;
3627   }
3628
3629   foreach my $any ( grep /^report_option_any/, keys %$params ) {
3630
3631     my @report_option_any = ();
3632     if ( ref($params->{$any}) eq 'ARRAY' ) {
3633       @report_option_any = @{ $params->{$any} };
3634     } elsif ( $params->{$any} =~ /^([,\d]*)$/ ) {
3635       @report_option_any = split(',', $1);
3636     }
3637
3638     if (@report_option_any) {
3639       # this will result in the empty set for the dangling comma case as it should
3640       push @where, ' ( '. join(' OR ',
3641         map{ "0 < ( SELECT count(*) FROM part_pkg_option
3642                       WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
3643                       AND optionname = 'report_option_$_'
3644                       AND optionvalue = '1' )"
3645            } @report_option_any
3646       ). ' ) ';
3647     }
3648
3649   }
3650
3651   ###
3652   # parse custom
3653   ###
3654
3655   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
3656
3657   ###
3658   # parse fcc_line
3659   ###
3660
3661   push @where,  "(part_pkg.fcc_ds0s > 0 OR pkg_class.fcc_ds0s > 0)"
3662                                                         if $params->{fcc_line};
3663
3664   ###
3665   # parse censustract
3666   ###
3667
3668   if ( exists($params->{'censustract'}) ) {
3669     $params->{'censustract'} =~ /^([.\d]*)$/;
3670     my $censustract = "cust_location.censustract = '$1'";
3671     $censustract .= ' OR cust_location.censustract is NULL' unless $1;
3672     push @where,  "( $censustract )";
3673   }
3674
3675   ###
3676   # parse censustract2
3677   ###
3678   if ( exists($params->{'censustract2'})
3679        && $params->{'censustract2'} =~ /^(\d*)$/
3680      )
3681   {
3682     if ($1) {
3683       push @where, "cust_location.censustract LIKE '$1%'";
3684     } else {
3685       push @where,
3686         "( cust_location.censustract = '' OR cust_location.censustract IS NULL )";
3687     }
3688   }
3689
3690   ###
3691   # parse country/state
3692   ###
3693   for (qw(state country)) { # parsing rules are the same for these
3694   if ( exists($params->{$_})
3695     && uc($params->{$_}) =~ /^([A-Z]{2})$/ )
3696     {
3697       # XXX post-2.3 only--before that, state/country may be in cust_main
3698       push @where, "cust_location.$_ = '$1'";
3699     }
3700   }
3701
3702   ###
3703   # parse part_pkg
3704   ###
3705
3706   if ( ref($params->{'pkgpart'}) ) {
3707
3708     my @pkgpart = ();
3709     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
3710       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
3711     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
3712       @pkgpart = @{ $params->{'pkgpart'} };
3713     } else {
3714       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
3715     }
3716
3717     @pkgpart = grep /^(\d+)$/, @pkgpart;
3718
3719     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
3720
3721   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3722     push @where, "pkgpart = $1";
3723   }
3724
3725   ###
3726   # parse dates
3727   ###
3728
3729   my $orderby = '';
3730
3731   #false laziness w/report_cust_pkg.html
3732   my %disable = (
3733     'all'             => {},
3734     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
3735     'active'          => { 'susp'=>1, 'cancel'=>1 },
3736     'suspended'       => { 'cancel' => 1 },
3737     'cancelled'       => {},
3738     ''                => {},
3739   );
3740
3741   if( exists($params->{'active'} ) ) {
3742     # This overrides all the other date-related fields
3743     my($beginning, $ending) = @{$params->{'active'}};
3744     push @where,
3745       "cust_pkg.setup IS NOT NULL",
3746       "cust_pkg.setup <= $ending",
3747       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
3748       "NOT (".FS::cust_pkg->onetime_sql . ")";
3749   }
3750   else {
3751     foreach my $field (qw( setup last_bill bill adjourn susp expire contract_end change_date cancel )) {
3752
3753       next unless exists($params->{$field});
3754
3755       my($beginning, $ending) = @{$params->{$field}};
3756
3757       next if $beginning == 0 && $ending == 4294967295;
3758
3759       push @where,
3760         "cust_pkg.$field IS NOT NULL",
3761         "cust_pkg.$field >= $beginning",
3762         "cust_pkg.$field <= $ending";
3763
3764       $orderby ||= "ORDER BY cust_pkg.$field";
3765
3766     }
3767   }
3768
3769   $orderby ||= 'ORDER BY bill';
3770
3771   ###
3772   # parse magic, legacy, etc.
3773   ###
3774
3775   if ( $params->{'magic'} &&
3776        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
3777   ) {
3778
3779     $orderby = 'ORDER BY pkgnum';
3780
3781     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
3782       push @where, "pkgpart = $1";
3783     }
3784
3785   } elsif ( $params->{'query'} eq 'pkgnum' ) {
3786
3787     $orderby = 'ORDER BY pkgnum';
3788
3789   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
3790
3791     $orderby = 'ORDER BY pkgnum';
3792
3793     push @where, '0 < (
3794       SELECT count(*) FROM pkg_svc
3795        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
3796          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
3797                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
3798                                      AND cust_svc.svcpart = pkg_svc.svcpart
3799                                 )
3800     )';
3801
3802   }
3803
3804   ##
3805   # setup queries, links, subs, etc. for the search
3806   ##
3807
3808   # here is the agent virtualization
3809   if ($params->{CurrentUser}) {
3810     my $access_user =
3811       qsearchs('access_user', { username => $params->{CurrentUser} });
3812
3813     if ($access_user) {
3814       push @where, $access_user->agentnums_sql('table'=>'cust_main');
3815     } else {
3816       push @where, "1=0";
3817     }
3818   } else {
3819     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
3820   }
3821
3822   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
3823
3824   my $addl_from = 'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
3825                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) '.
3826                   'LEFT JOIN cust_location USING ( locationnum ) '.
3827                   FS::UI::Web::join_cust_main('cust_pkg', 'cust_pkg');
3828
3829   my $select;
3830   my $count_query;
3831   if ( $params->{'select_zip5'} ) {
3832     my $zip = 'cust_location.zip';
3833
3834     $select = "DISTINCT substr($zip,1,5) as zip";
3835     $orderby = "ORDER BY substr($zip,1,5)";
3836     $count_query = "SELECT COUNT( DISTINCT substr($zip,1,5) )";
3837   } else {
3838     $select = join(', ',
3839                          'cust_pkg.*',
3840                          ( map "part_pkg.$_", qw( pkg freq ) ),
3841                          'pkg_class.classname',
3842                          'cust_main.custnum AS cust_main_custnum',
3843                          FS::UI::Web::cust_sql_fields(
3844                            $params->{'cust_fields'}
3845                          ),
3846                   );
3847     $count_query = 'SELECT COUNT(*)';
3848   }
3849
3850   $count_query .= " FROM cust_pkg $addl_from $extra_sql";
3851
3852   my $sql_query = {
3853     'table'       => 'cust_pkg',
3854     'hashref'     => {},
3855     'select'      => $select,
3856     'extra_sql'   => $extra_sql,
3857     'order_by'    => $orderby,
3858     'addl_from'   => $addl_from,
3859     'count_query' => $count_query,
3860   };
3861
3862 }
3863
3864 =item fcc_477_count
3865
3866 Returns a list of two package counts.  The first is a count of packages
3867 based on the supplied criteria and the second is the count of residential
3868 packages with those same criteria.  Criteria are specified as in the search
3869 method.
3870
3871 =cut
3872
3873 sub fcc_477_count {
3874   my ($class, $params) = @_;
3875
3876   my $sql_query = $class->search( $params );
3877
3878   my $count_sql = delete($sql_query->{'count_query'});
3879   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
3880     or die "couldn't parse count_sql";
3881
3882   my $count_sth = dbh->prepare($count_sql)
3883     or die "Error preparing $count_sql: ". dbh->errstr;
3884   $count_sth->execute
3885     or die "Error executing $count_sql: ". $count_sth->errstr;
3886   my $count_arrayref = $count_sth->fetchrow_arrayref;
3887
3888   return ( @$count_arrayref );
3889
3890 }
3891
3892 =item tax_locationnum_sql
3893
3894 Returns an SQL expression for the tax location for a package, based
3895 on the settings of 'tax-pkg_address' and 'tax-ship_address'.
3896
3897 =cut
3898
3899 sub tax_locationnum_sql {
3900   my $conf = FS::Conf->new;
3901   if ( $conf->exists('tax-pkg_address') ) {
3902     'cust_pkg.locationnum';
3903   }
3904   elsif ( $conf->exists('tax-ship_address') ) {
3905     'cust_main.ship_locationnum';
3906   }
3907   else {
3908     'cust_main.bill_locationnum';
3909   }
3910 }
3911
3912 =item location_sql
3913
3914 Returns a list: the first item is an SQL fragment identifying matching
3915 packages/customers via location (taking into account shipping and package
3916 address taxation, if enabled), and subsequent items are the parameters to
3917 substitute for the placeholders in that fragment.
3918
3919 =cut
3920
3921 sub location_sql {
3922   my($class, %opt) = @_;
3923   my $ornull = $opt{'ornull'};
3924
3925   my $conf = new FS::Conf;
3926
3927   # '?' placeholders in _location_sql_where
3928   my $x = $ornull ? 3 : 2;
3929   my @bill_param = (
3930     ('district')x3,
3931     ('city')x3,
3932     ('county')x$x,
3933     ('state')x$x,
3934     'country'
3935   );
3936
3937   my $main_where;
3938   my @main_param;
3939   if ( $conf->exists('tax-ship_address') ) {
3940
3941     $main_where = "(
3942          (     ( ship_last IS NULL     OR  ship_last  = '' )
3943            AND ". _location_sql_where('cust_main', '', $ornull ). "
3944          )
3945       OR (       ship_last IS NOT NULL AND ship_last != ''
3946            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
3947          )
3948     )";
3949     #    AND payby != 'COMP'
3950
3951     @main_param = ( @bill_param, @bill_param );
3952
3953   } else {
3954
3955     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
3956     @main_param = @bill_param;
3957
3958   }
3959
3960   my $where;
3961   my @param;
3962   if ( $conf->exists('tax-pkg_address') ) {
3963
3964     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
3965
3966     $where = " (
3967                     ( cust_pkg.locationnum IS     NULL AND $main_where )
3968                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
3969                )
3970              ";
3971     @param = ( @main_param, @bill_param );
3972
3973   } else {
3974
3975     $where = $main_where;
3976     @param = @main_param;
3977
3978   }
3979
3980   ( $where, @param );
3981
3982 }
3983
3984 #subroutine, helper for location_sql
3985 sub _location_sql_where {
3986   my $table  = shift;
3987   my $prefix = @_ ? shift : '';
3988   my $ornull = @_ ? shift : '';
3989
3990 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3991
3992   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3993
3994   my $or_empty_city     = " OR ( ? = '' AND $table.${prefix}city     IS NULL )";
3995   my $or_empty_county   = " OR ( ? = '' AND $table.${prefix}county   IS NULL )";
3996   my $or_empty_state    = " OR ( ? = '' AND $table.${prefix}state    IS NULL )";
3997
3998   my $text = (driver_name =~ /^mysql/i) ? 'char' : 'text';
3999
4000 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
4001   "
4002         ( $table.district = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4003     AND ( $table.${prefix}city     = ? OR ? = '' OR CAST(? AS $text) IS NULL )
4004     AND ( $table.${prefix}county   = ? $or_empty_county $ornull )
4005     AND ( $table.${prefix}state    = ? $or_empty_state  $ornull )
4006     AND   $table.${prefix}country  = ?
4007   ";
4008 }
4009
4010 sub _X_show_zero {
4011   my( $self, $what ) = @_;
4012
4013   my $what_show_zero = $what. '_show_zero';
4014   length($self->$what_show_zero())
4015     ? ($self->$what_show_zero() eq 'Y')
4016     : $self->part_pkg->$what_show_zero();
4017 }
4018
4019 =head1 SUBROUTINES
4020
4021 =over 4
4022
4023 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
4024
4025 CUSTNUM is a customer (see L<FS::cust_main>)
4026
4027 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4028 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
4029 permitted.
4030
4031 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
4032 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
4033 new billing items.  An error is returned if this is not possible (see
4034 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
4035 parameter.
4036
4037 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4038 newly-created cust_pkg objects.
4039
4040 REFNUM, if specified, will specify the FS::pkg_referral record to be created
4041 and inserted.  Multiple FS::pkg_referral records can be created by
4042 setting I<refnum> to an array reference of refnums or a hash reference with
4043 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
4044 record will be created corresponding to cust_main.refnum.
4045
4046 =cut
4047
4048 sub order {
4049   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
4050
4051   my $conf = new FS::Conf;
4052
4053   # Transactionize this whole mess
4054   local $SIG{HUP} = 'IGNORE';
4055   local $SIG{INT} = 'IGNORE';
4056   local $SIG{QUIT} = 'IGNORE';
4057   local $SIG{TERM} = 'IGNORE';
4058   local $SIG{TSTP} = 'IGNORE';
4059   local $SIG{PIPE} = 'IGNORE';
4060
4061   my $oldAutoCommit = $FS::UID::AutoCommit;
4062   local $FS::UID::AutoCommit = 0;
4063   my $dbh = dbh;
4064
4065   my $error;
4066 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
4067 #  return "Customer not found: $custnum" unless $cust_main;
4068
4069   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
4070     if $DEBUG;
4071
4072   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4073                          @$remove_pkgnum;
4074
4075   my $change = scalar(@old_cust_pkg) != 0;
4076
4077   my %hash = ();
4078   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
4079
4080     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
4081          " to pkgpart ". $pkgparts->[0]. "\n"
4082       if $DEBUG;
4083
4084     my $err_or_cust_pkg =
4085       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
4086                                 'refnum'  => $refnum,
4087                               );
4088
4089     unless (ref($err_or_cust_pkg)) {
4090       $dbh->rollback if $oldAutoCommit;
4091       return $err_or_cust_pkg;
4092     }
4093
4094     push @$return_cust_pkg, $err_or_cust_pkg;
4095     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4096     return '';
4097
4098   }
4099
4100   # Create the new packages.
4101   foreach my $pkgpart (@$pkgparts) {
4102
4103     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
4104
4105     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
4106                                       pkgpart => $pkgpart,
4107                                       refnum  => $refnum,
4108                                       %hash,
4109                                     };
4110     $error = $cust_pkg->insert( 'change' => $change );
4111     push @$return_cust_pkg, $cust_pkg;
4112
4113     foreach my $link ($cust_pkg->part_pkg->supp_part_pkg_link) {
4114       my $supp_pkg = FS::cust_pkg->new({
4115           custnum => $custnum,
4116           pkgpart => $link->dst_pkgpart,
4117           refnum  => $refnum,
4118           main_pkgnum => $cust_pkg->pkgnum,
4119           %hash,
4120       });
4121       $error ||= $supp_pkg->insert( 'change' => $change );
4122       push @$return_cust_pkg, $supp_pkg;
4123     }
4124
4125     if ($error) {
4126       $dbh->rollback if $oldAutoCommit;
4127       return $error;
4128     }
4129
4130   }
4131   # $return_cust_pkg now contains refs to all of the newly
4132   # created packages.
4133
4134   # Transfer services and cancel old packages.
4135   foreach my $old_pkg (@old_cust_pkg) {
4136
4137     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
4138       if $DEBUG;
4139
4140     foreach my $new_pkg (@$return_cust_pkg) {
4141       $error = $old_pkg->transfer($new_pkg);
4142       if ($error and $error == 0) {
4143         # $old_pkg->transfer failed.
4144         $dbh->rollback if $oldAutoCommit;
4145         return $error;
4146       }
4147     }
4148
4149     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
4150       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
4151       foreach my $new_pkg (@$return_cust_pkg) {
4152         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
4153         if ($error and $error == 0) {
4154           # $old_pkg->transfer failed.
4155         $dbh->rollback if $oldAutoCommit;
4156         return $error;
4157         }
4158       }
4159     }
4160
4161     if ($error > 0) {
4162       # Transfers were successful, but we went through all of the
4163       # new packages and still had services left on the old package.
4164       # We can't cancel the package under the circumstances, so abort.
4165       $dbh->rollback if $oldAutoCommit;
4166       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
4167     }
4168     $error = $old_pkg->cancel( quiet=>1 );
4169     if ($error) {
4170       $dbh->rollback;
4171       return $error;
4172     }
4173   }
4174   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4175   '';
4176 }
4177
4178 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
4179
4180 A bulk change method to change packages for multiple customers.
4181
4182 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
4183 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
4184 permitted.
4185
4186 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
4187 replace.  The services (see L<FS::cust_svc>) are moved to the
4188 new billing items.  An error is returned if this is not possible (see
4189 L<FS::pkg_svc>).
4190
4191 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
4192 newly-created cust_pkg objects.
4193
4194 =cut
4195
4196 sub bulk_change {
4197   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
4198
4199   # Transactionize this whole mess
4200   local $SIG{HUP} = 'IGNORE';
4201   local $SIG{INT} = 'IGNORE';
4202   local $SIG{QUIT} = 'IGNORE';
4203   local $SIG{TERM} = 'IGNORE';
4204   local $SIG{TSTP} = 'IGNORE';
4205   local $SIG{PIPE} = 'IGNORE';
4206
4207   my $oldAutoCommit = $FS::UID::AutoCommit;
4208   local $FS::UID::AutoCommit = 0;
4209   my $dbh = dbh;
4210
4211   my @errors;
4212   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
4213                          @$remove_pkgnum;
4214
4215   while(scalar(@old_cust_pkg)) {
4216     my @return = ();
4217     my $custnum = $old_cust_pkg[0]->custnum;
4218     my (@remove) = map { $_->pkgnum }
4219                    grep { $_->custnum == $custnum } @old_cust_pkg;
4220     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
4221
4222     my $error = order $custnum, $pkgparts, \@remove, \@return;
4223
4224     push @errors, $error
4225       if $error;
4226     push @$return_cust_pkg, @return;
4227   }
4228
4229   if (scalar(@errors)) {
4230     $dbh->rollback if $oldAutoCommit;
4231     return join(' / ', @errors);
4232   }
4233
4234   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4235   '';
4236 }
4237
4238 # Used by FS::Upgrade to migrate to a new database.
4239 sub _upgrade_data {  # class method
4240   my ($class, %opts) = @_;
4241   $class->_upgrade_otaker(%opts);
4242   my @statements = (
4243     # RT#10139, bug resulting in contract_end being set when it shouldn't
4244   'UPDATE cust_pkg SET contract_end = NULL WHERE contract_end = -1',
4245     # RT#10830, bad calculation of prorate date near end of year
4246     # the date range for bill is December 2009, and we move it forward
4247     # one year if it's before the previous bill date (which it should
4248     # never be)
4249   'UPDATE cust_pkg SET bill = bill + (365*24*60*60) WHERE bill < last_bill
4250   AND bill > 1259654400 AND bill < 1262332800 AND (SELECT plan FROM part_pkg
4251   WHERE part_pkg.pkgpart = cust_pkg.pkgpart) = \'prorate\'',
4252     # RT6628, add order_date to cust_pkg
4253     'update cust_pkg set order_date = (select history_date from h_cust_pkg
4254         where h_cust_pkg.pkgnum = cust_pkg.pkgnum and
4255         history_action = \'insert\') where order_date is null',
4256   );
4257   foreach my $sql (@statements) {
4258     my $sth = dbh->prepare($sql);
4259     $sth->execute or die $sth->errstr;
4260   }
4261 }
4262
4263 =back
4264
4265 =head1 BUGS
4266
4267 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
4268
4269 In sub order, the @pkgparts array (passed by reference) is clobbered.
4270
4271 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
4272 method to pass dates to the recur_prog expression, it should do so.
4273
4274 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
4275 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
4276 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
4277 configuration values.  Probably need a subroutine which decides what to do
4278 based on whether or not we've fetched the user yet, rather than a hash.  See
4279 FS::UID and the TODO.
4280
4281 Now that things are transactional should the check in the insert method be
4282 moved to check ?
4283
4284 =head1 SEE ALSO
4285
4286 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
4287 L<FS::pkg_svc>, schema.html from the base documentation
4288
4289 =cut
4290
4291 1;
4292