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