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