FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use base qw( FS::otaker_Mixin FS::cust_main_Mixin FS::location_Mixin
   5              FS::m2m_Common FS::option_Common );
   6 use vars qw($disable_agentcheck $DEBUG $me);
   7 use Carp qw(cluck);
   8 use Scalar::Util qw( blessed );
   9 use List::Util qw(max);
  10 use Tie::IxHash;
  11 use Time::Local qw( timelocal_nocheck );
  12 use MIME::Entity;
  13 use FS::UID qw( getotaker dbh );
  14 use FS::Misc qw( send_email );
  15 use FS::Record qw( qsearch qsearchs );
  16 use FS::cust_svc;
  17 use FS::part_pkg;
  18 use FS::cust_main;
  19 use FS::cust_location;
  20 use FS::pkg_svc;
  21 use FS::cust_bill_pkg;
  22 use FS::cust_pkg_detail;
  23 use FS::cust_event;
  24 use FS::h_cust_svc;
  25 use FS::reg_code;
  26 use FS::part_svc;
  27 use FS::cust_pkg_reason;
  28 use FS::reason;
  29 use FS::cust_pkg_discount;
  30 use FS::discount;
  31 use FS::UI::Web;
  32
  33 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  34 # setup }
  35 # because they load configuration by setting FS::UID::callback (see TODO)
  36 use FS::svc_acct;
  37 use FS::svc_domain;
  38 use FS::svc_www;
  39 use FS::svc_forward;
  40
  41 # for sending cancel emails in sub cancel
  42 use FS::Conf;
  43
  44 $DEBUG = 0;
  45 $me = '[FS::cust_pkg]';
  46
  47 $disable_agentcheck = 0;
  48
  49 sub _cache {
  50   my $self = shift;
  51   my ( $hashref, $cache ) = @_;
  52   #if ( $hashref->{'pkgpart'} ) {
  53   if ( $hashref->{'pkg'} ) {
  54     # #@{ $self->{'_pkgnum'} } = ();
  55     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  56     # $self->{'_pkgpart'} = $subcache;
  57     # #push @{ $self->{'_pkgnum'} },
  58     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  59     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  60   }
  61   if ( exists $hashref->{'svcnum'} ) {
  62     #@{ $self->{'_pkgnum'} } = ();
  63     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  64     $self->{'_svcnum'} = $subcache;
  65     #push @{ $self->{'_pkgnum'} },
  66     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  67   }
  68 }
  69
  70 =head1 NAME
  71
  72 FS::cust_pkg - Object methods for cust_pkg objects
  73
  74 =head1 SYNOPSIS
  75
  76   use FS::cust_pkg;
  77
  78   $record = new FS::cust_pkg \%hash;
  79   $record = new FS::cust_pkg { 'column' => 'value' };
  80
  81   $error = $record->insert;
  82
  83   $error = $new_record->replace($old_record);
  84
  85   $error = $record->delete;
  86
  87   $error = $record->check;
  88
  89   $error = $record->cancel;
  90
  91   $error = $record->suspend;
  92
  93   $error = $record->unsuspend;
  94
  95   $part_pkg = $record->part_pkg;
  96
  97   @labels = $record->labels;
  98
  99   $seconds = $record->seconds_since($timestamp);
 100
 101   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
 102   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
 103
 104 =head1 DESCRIPTION
 105
 106 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
 107 inherits from FS::Record.  The following fields are currently supported:
 108
 109 =over 4
 110
 111 =item pkgnum
 112
 113 Primary key (assigned automatically for new billing items)
 114
 115 =item custnum
 116
 117 Customer (see L<FS::cust_main>)
 118
 119 =item pkgpart
 120
 121 Billing item definition (see L<FS::part_pkg>)
 122
 123 =item locationnum
 124
 125 Optional link to package location (see L<FS::location>)
 126
 127 =item start_date
 128
 129 date
 130
 131 =item setup
 132
 133 date
 134
 135 =item bill
 136
 137 date (next bill date)
 138
 139 =item last_bill
 140
 141 last bill date
 142
 143 =item adjourn
 144
 145 date
 146
 147 =item susp
 148
 149 date
 150
 151 =item expire
 152
 153 date
 154
 155 =item cancel
 156
 157 date
 158
 159 =item usernum
 160
 161 order taker (see L<FS::access_user>)
 162
 163 =item manual_flag
 164
 165 If this field is set to 1, disables the automatic
 166 unsuspension of this package when using the B<unsuspendauto> config option.
 167
 168 =item quantity
 169
 170 If not set, defaults to 1
 171
 172 =item change_date
 173
 174 Date of change from previous package
 175
 176 =item change_pkgnum
 177
 178 Previous pkgnum
 179
 180 =item change_pkgpart
 181
 182 Previous pkgpart
 183
 184 =item change_locationnum
 185
 186 Previous locationnum
 187
 188 =back
 189
 190 Note: setup, last_bill, bill, adjourn, susp, expire, cancel and change_date
 191 are specified as UNIX timestamps; see L<perlfunc/"time">.  Also see
 192 L<Time::Local> and L<Date::Parse> for conversion functions.
 193
 194 =head1 METHODS
 195
 196 =over 4
 197
 198 =item new HASHREF
 199
 200 Create a new billing item.  To add the item to the database, see L<"insert">.
 201
 202 =cut
 203
 204 sub table { 'cust_pkg'; }
 205 sub cust_linked { $_[0]->cust_main_custnum; }
 206 sub cust_unlinked_msg {
 207   my $self = shift;
 208   "WARNING: can't find cust_main.custnum ". $self->custnum.
 209   ' (cust_pkg.pkgnum '. $self->pkgnum. ')';
 210 }
 211
 212 =item insert [ OPTION => VALUE ... ]
 213
 214 Adds this billing item to the database ("Orders" the item).  If there is an
 215 error, returns the error, otherwise returns false.
 216
 217 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 218 will be used to look up the package definition and agent restrictions will be
 219 ignored.
 220
 221 If the additional field I<refnum> is defined, an FS::pkg_referral record will
 222 be created and inserted.  Multiple FS::pkg_referral records can be created by
 223 setting I<refnum> to an array reference of refnums or a hash reference with
 224 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
 225 record will be created corresponding to cust_main.refnum.
 226
 227 The following options are available:
 228
 229 =over 4
 230
 231 =item change
 232
 233 If set true, supresses any referral credit to a referring customer.
 234
 235 =item options
 236
 237 cust_pkg_option records will be created
 238
 239 =item ticket_subject
 240
 241 a ticket will be added to this customer with this subject
 242
 243 =item ticket_queue
 244
 245 an optional queue name for ticket additions
 246
 247 =back
 248
 249 =cut
 250
 251 sub insert {
 252   my( $self, %options ) = @_;
 253
 254   if ( $self->part_pkg->option('start_1st', 1) && !$self->start_date ) {
 255     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime(time) )[0,1,2,3,4,5];
 256     $mon += 1 unless $mday == 1;
 257     until ( $mon < 12 ) { $mon -= 12; $year++; }
 258     $self->start_date( timelocal_nocheck(0,0,0,1,$mon,$year) );
 259   }
 260
 261   my $expire_months = $self->part_pkg->option('expire_months', 1);
 262   if ( $expire_months && !$self->expire ) {
 263     my $start = $self->start_date || $self->setup || time;
 264
 265     #false laziness w/part_pkg::add_freq
 266     my ($sec,$min,$hour,$mday,$mon,$year) = (localtime($start) )[0,1,2,3,4,5];
 267     $mon += $expire_months;
 268     until ( $mon < 12 ) { $mon -= 12; $year++; }
 269
 270     #$self->expire( timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year) );
 271     $self->expire( timelocal_nocheck(0,0,0,$mday,$mon,$year) );
 272   }
 273
 274   local $SIG{HUP} = 'IGNORE';
 275   local $SIG{INT} = 'IGNORE';
 276   local $SIG{QUIT} = 'IGNORE';
 277   local $SIG{TERM} = 'IGNORE';
 278   local $SIG{TSTP} = 'IGNORE';
 279   local $SIG{PIPE} = 'IGNORE';
 280
 281   my $oldAutoCommit = $FS::UID::AutoCommit;
 282   local $FS::UID::AutoCommit = 0;
 283   my $dbh = dbh;
 284
 285   my $error = $self->SUPER::insert($options{options} ? %{$options{options}} : ());
 286   if ( $error ) {
 287     $dbh->rollback if $oldAutoCommit;
 288     return $error;
 289   }
 290
 291   $self->refnum($self->cust_main->refnum) unless $self->refnum;
 292   $self->refnum( [ $self->refnum ] ) unless ref($self->refnum);
 293   $self->process_m2m( 'link_table'   => 'pkg_referral',
 294                       'target_table' => 'part_referral',
 295                       'params'       => $self->refnum,
 296                     );
 297
 298   if ( $self->discountnum ) {
 299     my $error = $self->insert_discount();
 300     if ( $error ) {
 301       $dbh->rollback if $oldAutoCommit;
 302       return $error;
 303     }
 304   }
 305
 306   #if ( $self->reg_code ) {
 307   #  my $reg_code = qsearchs('reg_code', { 'code' => $self->reg_code } );
 308   #  $error = $reg_code->delete;
 309   #  if ( $error ) {
 310   #    $dbh->rollback if $oldAutoCommit;
 311   #    return $error;
 312   #  }
 313   #}
 314
 315   my $conf = new FS::Conf;
 316
 317   if ( $conf->config('ticket_system') && $options{ticket_subject} ) {
 318
 319     #eval '
 320     #  use lib ( "/opt/rt3/local/lib", "/opt/rt3/lib" );
 321     #  use RT;
 322     #';
 323     #die $@ if $@;
 324     #
 325     #RT::LoadConfig();
 326     #RT::Init();
 327     use FS::TicketSystem;
 328     FS::TicketSystem->init();
 329
 330     my $q = new RT::Queue($RT::SystemUser);
 331     $q->Load($options{ticket_queue}) if $options{ticket_queue};
 332     my $t = new RT::Ticket($RT::SystemUser);
 333     my $mime = new MIME::Entity;
 334     $mime->build( Type => 'text/plain', Data => $options{ticket_subject} );
 335     $t->Create( $options{ticket_queue} ? (Queue => $q) : (),
 336                 Subject => $options{ticket_subject},
 337                 MIMEObj => $mime,
 338               );
 339     $t->AddLink( Type   => 'MemberOf',
 340                  Target => 'freeside://freeside/cust_main/'. $self->custnum,
 341                );
 342   }
 343
 344   if ($conf->config('welcome_letter') && $self->cust_main->num_pkgs == 1) {
 345     my $queue = new FS::queue {
 346       'job'     => 'FS::cust_main::queueable_print',
 347     };
 348     $error = $queue->insert(
 349       'custnum'  => $self->custnum,
 350       'template' => 'welcome_letter',
 351     );
 352
 353     if ($error) {
 354       warn "can't send welcome letter: $error";
 355     }
 356
 357   }
 358
 359   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 360   '';
 361
 362 }
 363
 364 =item delete
 365
 366 This method now works but you probably shouldn't use it.
 367
 368 You don't want to delete billing items, because there would then be no record
 369 the customer ever purchased the item.  Instead, see the cancel method.
 370
 371 =cut
 372
 373 #sub delete {
 374 #  return "Can't delete cust_pkg records!";
 375 #}
 376
 377 =item replace [ OLD_RECORD ] [ HASHREF | OPTION => VALUE ... ]
 378
 379 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 380 returns the error, otherwise returns false.
 381
 382 Currently, custnum, setup, bill, adjourn, susp, expire, and cancel may be changed.
 383
 384 Changing pkgpart may have disasterous effects.  See the order subroutine.
 385
 386 setup and bill are normally updated by calling the bill method of a customer
 387 object (see L<FS::cust_main>).
 388
 389 suspend is normally updated by the suspend and unsuspend methods.
 390
 391 cancel is normally updated by the cancel method (and also the order subroutine
 392 in some cases).
 393
 394 Available options are:
 395
 396 =over 4
 397
 398 =item reason
 399
 400 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.
 401
 402 =item reason_otaker
 403
 404 the access_user (see L<FS::access_user>) providing the reason
 405
 406 =item options
 407
 408 hashref of keys and values - cust_pkg_option records will be created, updated or removed as appopriate
 409
 410 =back
 411
 412 =cut
 413
 414 sub replace {
 415   my $new = shift;
 416
 417   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 418               ? shift
 419               : $new->replace_old;
 420
 421   my $options =
 422     ( ref($_[0]) eq 'HASH' )
 423       ? shift
 424       : { @_ };
 425
 426   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 427   #return "Can't change otaker!" if $old->otaker ne $new->otaker;
 428
 429   #allow this *sigh*
 430   #return "Can't change setup once it exists!"
 431   #  if $old->getfield('setup') &&
 432   #     $old->getfield('setup') != $new->getfield('setup');
 433
 434   #some logic for bill, susp, cancel?
 435
 436   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 437
 438   local $SIG{HUP} = 'IGNORE';
 439   local $SIG{INT} = 'IGNORE';
 440   local $SIG{QUIT} = 'IGNORE';
 441   local $SIG{TERM} = 'IGNORE';
 442   local $SIG{TSTP} = 'IGNORE';
 443   local $SIG{PIPE} = 'IGNORE';
 444
 445   my $oldAutoCommit = $FS::UID::AutoCommit;
 446   local $FS::UID::AutoCommit = 0;
 447   my $dbh = dbh;
 448
 449   foreach my $method ( qw(adjourn expire) ) {  # How many reasons?
 450     if ($options->{'reason'} && $new->$method && $old->$method ne $new->$method) {
 451       my $error = $new->insert_reason(
 452         'reason'        => $options->{'reason'},
 453         'date'          => $new->$method,
 454         'action'        => $method,
 455         'reason_otaker' => $options->{'reason_otaker'},
 456       );
 457       if ( $error ) {
 458         dbh->rollback if $oldAutoCommit;
 459         return "Error inserting cust_pkg_reason: $error";
 460       }
 461     }
 462   }
 463
 464   #save off and freeze RADIUS attributes for any associated svc_acct records
 465   my @svc_acct = ();
 466   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 467
 468                 #also check for specific exports?
 469                 # to avoid spurious modify export events
 470     @svc_acct = map  { $_->svc_x }
 471                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 472                      $old->cust_svc;
 473
 474     $_->snapshot foreach @svc_acct;
 475
 476   }
 477
 478   my $error = $new->SUPER::replace($old,
 479                                    $options->{options} ? $options->{options} : ()
 480                                   );
 481   if ( $error ) {
 482     $dbh->rollback if $oldAutoCommit;
 483     return $error;
 484   }
 485
 486   #for prepaid packages,
 487   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 488   foreach my $old_svc_acct ( @svc_acct ) {
 489     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 490     my $s_error = $new_svc_acct->replace($old_svc_acct);
 491     if ( $s_error ) {
 492       $dbh->rollback if $oldAutoCommit;
 493       return $s_error;
 494     }
 495   }
 496
 497   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 498   '';
 499
 500 }
 501
 502 =item check
 503
 504 Checks all fields to make sure this is a valid billing item.  If there is an
 505 error, returns the error, otherwise returns false.  Called by the insert and
 506 replace methods.
 507
 508 =cut
 509
 510 sub check {
 511   my $self = shift;
 512
 513   $self->locationnum('') if !$self->locationnum || $self->locationnum == -1;
 514
 515   my $error =
 516     $self->ut_numbern('pkgnum')
 517     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 518     || $self->ut_numbern('pkgpart')
 519     || $self->ut_foreign_keyn('locationnum', 'cust_location', 'locationnum')
 520     || $self->ut_numbern('start_date')
 521     || $self->ut_numbern('setup')
 522     || $self->ut_numbern('bill')
 523     || $self->ut_numbern('susp')
 524     || $self->ut_numbern('cancel')
 525     || $self->ut_numbern('adjourn')
 526     || $self->ut_numbern('expire')
 527     || $self->ut_enum('no_auto', [ '', 'Y' ])
 528   ;
 529   return $error if $error;
 530
 531   if ( $self->reg_code ) {
 532
 533     unless ( grep { $self->pkgpart == $_->pkgpart }
 534              map  { $_->reg_code_pkg }
 535              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 536                                      'agentnum' => $self->cust_main->agentnum })
 537            ) {
 538       return "Unknown registration code";
 539     }
 540
 541   } elsif ( $self->promo_code ) {
 542
 543     my $promo_part_pkg =
 544       qsearchs('part_pkg', {
 545         'pkgpart'    => $self->pkgpart,
 546         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 547       } );
 548     return 'Unknown promotional code' unless $promo_part_pkg;
 549
 550   } else {
 551
 552     unless ( $disable_agentcheck ) {
 553       my $agent =
 554         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 555       return "agent ". $agent->agentnum. ':'. $agent->agent.
 556              " can't purchase pkgpart ". $self->pkgpart
 557         unless $agent->pkgpart_hashref->{ $self->pkgpart }
 558             || $agent->agentnum == $self->part_pkg->agentnum;
 559     }
 560
 561     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 562     return $error if $error;
 563
 564   }
 565
 566   $self->otaker(getotaker) unless $self->otaker;
 567
 568   if ( $self->dbdef_table->column('manual_flag') ) {
 569     $self->manual_flag('') if $self->manual_flag eq ' ';
 570     $self->manual_flag =~ /^([01]?)$/
 571       or return "Illegal manual_flag ". $self->manual_flag;
 572     $self->manual_flag($1);
 573   }
 574
 575   $self->SUPER::check;
 576 }
 577
 578 =item cancel [ OPTION => VALUE ... ]
 579
 580 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 581 in this package, then cancels the package itself (sets the cancel field to
 582 now).
 583
 584 Available options are:
 585
 586 =over 4
 587
 588 =item quiet - can be set true to supress email cancellation notices.
 589
 590 =item time -  can be set to cancel the package based on a specific future or historical date.  Using time ensures that the remaining amount is calculated correctly.  Note however that this is an immediate cancel and just changes the date.  You are PROBABLY looking to expire the account instead of using this.
 591
 592 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 593
 594 =item date - can be set to a unix style timestamp to specify when to cancel (expire)
 595
 596 =item nobill - can be set true to skip billing if it might otherwise be done.
 597
 598 =back
 599
 600 If there is an error, returns the error, otherwise returns false.
 601
 602 =cut
 603
 604 sub cancel {
 605   my( $self, %options ) = @_;
 606   my $error;
 607
 608   my $conf = new FS::Conf;
 609
 610   warn "cust_pkg::cancel called with options".
 611        join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
 612     if $DEBUG;
 613
 614   local $SIG{HUP} = 'IGNORE';
 615   local $SIG{INT} = 'IGNORE';
 616   local $SIG{QUIT} = 'IGNORE';
 617   local $SIG{TERM} = 'IGNORE';
 618   local $SIG{TSTP} = 'IGNORE';
 619   local $SIG{PIPE} = 'IGNORE';
 620
 621   my $oldAutoCommit = $FS::UID::AutoCommit;
 622   local $FS::UID::AutoCommit = 0;
 623   my $dbh = dbh;
 624
 625   my $old = $self->select_for_update;
 626
 627   if ( $old->get('cancel') || $self->get('cancel') ) {
 628     dbh->rollback if $oldAutoCommit;
 629     return "";  # no error
 630   }
 631
 632   my $date = $options{date} if $options{date}; # expire/cancel later
 633   $date = '' if ($date && $date <= time);      # complain instead?
 634
 635   #race condition: usage could be ongoing until unprovisioned
 636   #resolved by performing a change package instead (which unprovisions) and
 637   #later cancelling
 638   if ( !$options{nobill} && !$date && $conf->exists('bill_usage_on_cancel') ) {
 639       my $copy = $self->new({$self->hash});
 640       my $error =
 641         $copy->cust_main->bill( pkg_list => [ $copy ], cancel => 1 );
 642       warn "Error billing during cancel, custnum ".
 643         #$self->cust_main->custnum. ": $error"
 644         ": $error"
 645         if $error;
 646   }
 647
 648
 649   my $cancel_time = $options{'time'} || time;
 650
 651   if ( $options{'reason'} ) {
 652     $error = $self->insert_reason( 'reason' => $options{'reason'},
 653                                    'action' => $date ? 'expire' : 'cancel',
 654                                    'date'   => $date ? $date : $cancel_time,
 655                                    'reason_otaker' => $options{'reason_otaker'},
 656                                  );
 657     if ( $error ) {
 658       dbh->rollback if $oldAutoCommit;
 659       return "Error inserting cust_pkg_reason: $error";
 660     }
 661   }
 662
 663   my %svc;
 664   unless ( $date ) {
 665     foreach my $cust_svc (
 666       #schwartz
 667       map  { $_->[0] }
 668       sort { $a->[1] <=> $b->[1] }
 669       map  { [ $_, $_->svc_x->table_info->{'cancel_weight'} ]; }
 670       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 671     ) {
 672
 673       my $error = $cust_svc->cancel;
 674
 675       if ( $error ) {
 676         $dbh->rollback if $oldAutoCommit;
 677         return "Error cancelling cust_svc: $error";
 678       }
 679     }
 680
 681     # Add a credit for remaining service
 682     my $remaining_value = $self->calc_remain(time=>$cancel_time);
 683     if ( $remaining_value > 0 && !$options{'no_credit'} ) {
 684       my $error = $self->cust_main->credit(
 685         $remaining_value,
 686         'Credit for unused time on '. $self->part_pkg->pkg,
 687         'reason_type' => $conf->config('cancel_credit_type'),
 688       );
 689       if ($error) {
 690         $dbh->rollback if $oldAutoCommit;
 691         return "Error crediting customer \$$remaining_value for unused time on".
 692                $self->part_pkg->pkg. ": $error";
 693       }
 694     }
 695   }
 696
 697   my %hash = $self->hash;
 698   $date ? ($hash{'expire'} = $date) : ($hash{'cancel'} = $cancel_time);
 699   my $new = new FS::cust_pkg ( \%hash );
 700   $error = $new->replace( $self, options => { $self->options } );
 701   if ( $error ) {
 702     $dbh->rollback if $oldAutoCommit;
 703     return $error;
 704   }
 705
 706   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 707   return '' if $date; #no errors
 708
 709   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 710   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 711     my $msgnum = $conf->config('cancel_msgnum', $self->cust_main->agentnum);
 712     my $error = '';
 713     if ( $msgnum ) {
 714       my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 715       $error = $msg_template->send( 'cust_main' => $self->cust_main,
 716                                     'object'    => $self );
 717     }
 718     else {
 719       $error = send_email(
 720         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 721         'to'      => \@invoicing_list,
 722         'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 723         'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 724       );
 725     }
 726     #should this do something on errors?
 727   }
 728
 729   ''; #no errors
 730
 731 }
 732
 733 =item cancel_if_expired [ NOW_TIMESTAMP ]
 734
 735 Cancels this package if its expire date has been reached.
 736
 737 =cut
 738
 739 sub cancel_if_expired {
 740   my $self = shift;
 741   my $time = shift || time;
 742   return '' unless $self->expire && $self->expire <= $time;
 743   my $error = $self->cancel;
 744   if ( $error ) {
 745     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 746            $self->custnum. ": $error";
 747   }
 748   '';
 749 }
 750
 751 =item unexpire
 752
 753 Cancels any pending expiration (sets the expire field to null).
 754
 755 If there is an error, returns the error, otherwise returns false.
 756
 757 =cut
 758
 759 sub unexpire {
 760   my( $self, %options ) = @_;
 761   my $error;
 762
 763   local $SIG{HUP} = 'IGNORE';
 764   local $SIG{INT} = 'IGNORE';
 765   local $SIG{QUIT} = 'IGNORE';
 766   local $SIG{TERM} = 'IGNORE';
 767   local $SIG{TSTP} = 'IGNORE';
 768   local $SIG{PIPE} = 'IGNORE';
 769
 770   my $oldAutoCommit = $FS::UID::AutoCommit;
 771   local $FS::UID::AutoCommit = 0;
 772   my $dbh = dbh;
 773
 774   my $old = $self->select_for_update;
 775
 776   my $pkgnum = $old->pkgnum;
 777   if ( $old->get('cancel') || $self->get('cancel') ) {
 778     dbh->rollback if $oldAutoCommit;
 779     return "Can't unexpire cancelled package $pkgnum";
 780     # or at least it's pointless
 781   }
 782
 783   unless ( $old->get('expire') && $self->get('expire') ) {
 784     dbh->rollback if $oldAutoCommit;
 785     return "";  # no error
 786   }
 787
 788   my %hash = $self->hash;
 789   $hash{'expire'} = '';
 790   my $new = new FS::cust_pkg ( \%hash );
 791   $error = $new->replace( $self, options => { $self->options } );
 792   if ( $error ) {
 793     $dbh->rollback if $oldAutoCommit;
 794     return $error;
 795   }
 796
 797   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 798
 799   ''; #no errors
 800
 801 }
 802
 803 =item suspend [ OPTION => VALUE ... ]
 804
 805 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 806 package, then suspends the package itself (sets the susp field to now).
 807
 808 Available options are:
 809
 810 =over 4
 811
 812 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason.  The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
 813
 814 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 815
 816 =back
 817
 818 If there is an error, returns the error, otherwise returns false.
 819
 820 =cut
 821
 822 sub suspend {
 823   my( $self, %options ) = @_;
 824   my $error;
 825
 826   local $SIG{HUP} = 'IGNORE';
 827   local $SIG{INT} = 'IGNORE';
 828   local $SIG{QUIT} = 'IGNORE';
 829   local $SIG{TERM} = 'IGNORE';
 830   local $SIG{TSTP} = 'IGNORE';
 831   local $SIG{PIPE} = 'IGNORE';
 832
 833   my $oldAutoCommit = $FS::UID::AutoCommit;
 834   local $FS::UID::AutoCommit = 0;
 835   my $dbh = dbh;
 836
 837   my $old = $self->select_for_update;
 838
 839   my $pkgnum = $old->pkgnum;
 840   if ( $old->get('cancel') || $self->get('cancel') ) {
 841     dbh->rollback if $oldAutoCommit;
 842     return "Can't suspend cancelled package $pkgnum";
 843   }
 844
 845   if ( $old->get('susp') || $self->get('susp') ) {
 846     dbh->rollback if $oldAutoCommit;
 847     return "";  # no error                     # complain on adjourn?
 848   }
 849
 850   my $date = $options{date} if $options{date}; # adjourn/suspend later
 851   $date = '' if ($date && $date <= time);      # complain instead?
 852
 853   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 854     dbh->rollback if $oldAutoCommit;
 855     return "Package $pkgnum expires before it would be suspended.";
 856   }
 857
 858   my $suspend_time = $options{'time'} || time;
 859
 860   if ( $options{'reason'} ) {
 861     $error = $self->insert_reason( 'reason' => $options{'reason'},
 862                                    'action' => $date ? 'adjourn' : 'suspend',
 863                                    'date'   => $date ? $date : $suspend_time,
 864                                    'reason_otaker' => $options{'reason_otaker'},
 865                                  );
 866     if ( $error ) {
 867       dbh->rollback if $oldAutoCommit;
 868       return "Error inserting cust_pkg_reason: $error";
 869     }
 870   }
 871
 872   unless ( $date ) {
 873
 874     my @labels = ();
 875
 876     foreach my $cust_svc (
 877       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 878     ) {
 879       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 880
 881       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 882         $dbh->rollback if $oldAutoCommit;
 883         return "Illegal svcdb value in part_svc!";
 884       };
 885       my $svcdb = $1;
 886       require "FS/$svcdb.pm";
 887
 888       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 889       if ($svc) {
 890         $error = $svc->suspend;
 891         if ( $error ) {
 892           $dbh->rollback if $oldAutoCommit;
 893           return $error;
 894         }
 895         my( $label, $value ) = $cust_svc->label;
 896         push @labels, "$label: $value";
 897       }
 898     }
 899
 900     my $conf = new FS::Conf;
 901     if ( $conf->config('suspend_email_admin') ) {
 902
 903       my $error = send_email(
 904         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 905                                    #invoice_from ??? well as good as any
 906         'to'      => $conf->config('suspend_email_admin'),
 907         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 908         'body'    => [
 909           "This is an automatic message from your Freeside installation\n",
 910           "informing you that the following customer package has been suspended:\n",
 911           "\n",
 912           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 913           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 914           ( map { "Service : $_\n" } @labels ),
 915         ],
 916       );
 917
 918       if ( $error ) {
 919         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 920              "$error\n";
 921       }
 922
 923     }
 924
 925   }
 926
 927   my %hash = $self->hash;
 928   if ( $date ) {
 929     $hash{'adjourn'} = $date;
 930   } else {
 931     $hash{'susp'} = $suspend_time;
 932   }
 933   my $new = new FS::cust_pkg ( \%hash );
 934   $error = $new->replace( $self, options => { $self->options } );
 935   if ( $error ) {
 936     $dbh->rollback if $oldAutoCommit;
 937     return $error;
 938   }
 939
 940   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 941
 942   ''; #no errors
 943 }
 944
 945 =item unsuspend [ OPTION => VALUE ... ]
 946
 947 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 948 package, then unsuspends the package itself (clears the susp field and the
 949 adjourn field if it is in the past).
 950
 951 Available options are:
 952
 953 =over 4
 954
 955 =item adjust_next_bill
 956
 957 Can be set true to adjust the next bill date forward by
 958 the amount of time the account was inactive.  This was set true by default
 959 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 960 explicitly requested.  Price plans for which this makes sense (anniversary-date
 961 based than prorate or subscription) could have an option to enable this
 962 behaviour?
 963
 964 =back
 965
 966 If there is an error, returns the error, otherwise returns false.
 967
 968 =cut
 969
 970 sub unsuspend {
 971   my( $self, %opt ) = @_;
 972   my $error;
 973
 974   local $SIG{HUP} = 'IGNORE';
 975   local $SIG{INT} = 'IGNORE';
 976   local $SIG{QUIT} = 'IGNORE';
 977   local $SIG{TERM} = 'IGNORE';
 978   local $SIG{TSTP} = 'IGNORE';
 979   local $SIG{PIPE} = 'IGNORE';
 980
 981   my $oldAutoCommit = $FS::UID::AutoCommit;
 982   local $FS::UID::AutoCommit = 0;
 983   my $dbh = dbh;
 984
 985   my $old = $self->select_for_update;
 986
 987   my $pkgnum = $old->pkgnum;
 988   if ( $old->get('cancel') || $self->get('cancel') ) {
 989     dbh->rollback if $oldAutoCommit;
 990     return "Can't unsuspend cancelled package $pkgnum";
 991   }
 992
 993   unless ( $old->get('susp') && $self->get('susp') ) {
 994     dbh->rollback if $oldAutoCommit;
 995     return "";  # no error                     # complain instead?
 996   }
 997
 998   foreach my $cust_svc (
 999     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
1000   ) {
1001     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
1002
1003     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
1004       $dbh->rollback if $oldAutoCommit;
1005       return "Illegal svcdb value in part_svc!";
1006     };
1007     my $svcdb = $1;
1008     require "FS/$svcdb.pm";
1009
1010     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1011     if ($svc) {
1012       $error = $svc->unsuspend;
1013       if ( $error ) {
1014         $dbh->rollback if $oldAutoCommit;
1015         return $error;
1016       }
1017     }
1018
1019   }
1020
1021   my %hash = $self->hash;
1022   my $inactive = time - $hash{'susp'};
1023
1024   my $conf = new FS::Conf;
1025
1026   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1027     if ( $opt{'adjust_next_bill'}
1028          || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1029     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1030
1031   $hash{'susp'} = '';
1032   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1033   my $new = new FS::cust_pkg ( \%hash );
1034   $error = $new->replace( $self, options => { $self->options } );
1035   if ( $error ) {
1036     $dbh->rollback if $oldAutoCommit;
1037     return $error;
1038   }
1039
1040   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1041
1042   ''; #no errors
1043 }
1044
1045 =item unadjourn
1046
1047 Cancels any pending suspension (sets the adjourn field to null).
1048
1049 If there is an error, returns the error, otherwise returns false.
1050
1051 =cut
1052
1053 sub unadjourn {
1054   my( $self, %options ) = @_;
1055   my $error;
1056
1057   local $SIG{HUP} = 'IGNORE';
1058   local $SIG{INT} = 'IGNORE';
1059   local $SIG{QUIT} = 'IGNORE';
1060   local $SIG{TERM} = 'IGNORE';
1061   local $SIG{TSTP} = 'IGNORE';
1062   local $SIG{PIPE} = 'IGNORE';
1063
1064   my $oldAutoCommit = $FS::UID::AutoCommit;
1065   local $FS::UID::AutoCommit = 0;
1066   my $dbh = dbh;
1067
1068   my $old = $self->select_for_update;
1069
1070   my $pkgnum = $old->pkgnum;
1071   if ( $old->get('cancel') || $self->get('cancel') ) {
1072     dbh->rollback if $oldAutoCommit;
1073     return "Can't unadjourn cancelled package $pkgnum";
1074     # or at least it's pointless
1075   }
1076
1077   if ( $old->get('susp') || $self->get('susp') ) {
1078     dbh->rollback if $oldAutoCommit;
1079     return "Can't unadjourn suspended package $pkgnum";
1080     # perhaps this is arbitrary
1081   }
1082
1083   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1084     dbh->rollback if $oldAutoCommit;
1085     return "";  # no error
1086   }
1087
1088   my %hash = $self->hash;
1089   $hash{'adjourn'} = '';
1090   my $new = new FS::cust_pkg ( \%hash );
1091   $error = $new->replace( $self, options => { $self->options } );
1092   if ( $error ) {
1093     $dbh->rollback if $oldAutoCommit;
1094     return $error;
1095   }
1096
1097   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1098
1099   ''; #no errors
1100
1101 }
1102
1103
1104 =item change HASHREF | OPTION => VALUE ...
1105
1106 Changes this package: cancels it and creates a new one, with a different
1107 pkgpart or locationnum or both.  All services are transferred to the new
1108 package (no change will be made if this is not possible).
1109
1110 Options may be passed as a list of key/value pairs or as a hash reference.
1111 Options are:
1112
1113 =over 4
1114
1115 =item locaitonnum
1116
1117 New locationnum, to change the location for this package.
1118
1119 =item cust_location
1120
1121 New FS::cust_location object, to create a new location and assign it
1122 to this package.
1123
1124 =item pkgpart
1125
1126 New pkgpart (see L<FS::part_pkg>).
1127
1128 =item refnum
1129
1130 New refnum (see L<FS::part_referral>).
1131
1132 =back
1133
1134 At least one option must be specified (otherwise, what's the point?)
1135
1136 Returns either the new FS::cust_pkg object or a scalar error.
1137
1138 For example:
1139
1140   my $err_or_new_cust_pkg = $old_cust_pkg->change
1141
1142 =cut
1143
1144 #some false laziness w/order
1145 sub change {
1146   my $self = shift;
1147   my $opt = ref($_[0]) ? shift : { @_ };
1148
1149 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1150 #
1151
1152   my $conf = new FS::Conf;
1153
1154   # Transactionize this whole mess
1155   local $SIG{HUP} = 'IGNORE';
1156   local $SIG{INT} = 'IGNORE';
1157   local $SIG{QUIT} = 'IGNORE';
1158   local $SIG{TERM} = 'IGNORE';
1159   local $SIG{TSTP} = 'IGNORE';
1160   local $SIG{PIPE} = 'IGNORE';
1161
1162   my $oldAutoCommit = $FS::UID::AutoCommit;
1163   local $FS::UID::AutoCommit = 0;
1164   my $dbh = dbh;
1165
1166   my $error;
1167
1168   my %hash = ();
1169
1170   my $time = time;
1171
1172   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1173
1174   #$hash{$_} = $self->$_() foreach qw( setup );
1175
1176   $hash{'setup'} = $time if $self->setup;
1177
1178   $hash{'change_date'} = $time;
1179   $hash{"change_$_"}  = $self->$_()
1180     foreach qw( pkgnum pkgpart locationnum );
1181
1182   if ( $opt->{'cust_location'} &&
1183        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1184     $error = $opt->{'cust_location'}->insert;
1185     if ( $error ) {
1186       $dbh->rollback if $oldAutoCommit;
1187       return "inserting cust_location (transaction rolled back): $error";
1188     }
1189     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1190   }
1191
1192   # Create the new package.
1193   my $cust_pkg = new FS::cust_pkg {
1194     custnum      => $self->custnum,
1195     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1196     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1197     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1198     %hash,
1199   };
1200
1201   $error = $cust_pkg->insert( 'change' => 1 );
1202   if ($error) {
1203     $dbh->rollback if $oldAutoCommit;
1204     return $error;
1205   }
1206
1207   # Transfer services and cancel old package.
1208
1209   $error = $self->transfer($cust_pkg);
1210   if ($error and $error == 0) {
1211     # $old_pkg->transfer failed.
1212     $dbh->rollback if $oldAutoCommit;
1213     return $error;
1214   }
1215
1216   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1217     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1218     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1219     if ($error and $error == 0) {
1220       # $old_pkg->transfer failed.
1221       $dbh->rollback if $oldAutoCommit;
1222       return $error;
1223     }
1224   }
1225
1226   if ($error > 0) {
1227     # Transfers were successful, but we still had services left on the old
1228     # package.  We can't change the package under this circumstances, so abort.
1229     $dbh->rollback if $oldAutoCommit;
1230     return "Unable to transfer all services from package ". $self->pkgnum;
1231   }
1232
1233   #reset usage if changing pkgpart
1234   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1235   if ($self->pkgpart != $cust_pkg->pkgpart) {
1236     my $part_pkg = $cust_pkg->part_pkg;
1237     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1238                                                  ? ()
1239                                                  : ( 'null' => 1 )
1240                                    )
1241       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1242
1243     if ($error) {
1244       $dbh->rollback if $oldAutoCommit;
1245       return "Error setting usage values: $error";
1246     }
1247   }
1248
1249   #Good to go, cancel old package.
1250   $error = $self->cancel( quiet=>1 );
1251   if ($error) {
1252     $dbh->rollback if $oldAutoCommit;
1253     return $error;
1254   }
1255
1256   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1257     #$self->cust_main
1258     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1259     if ( $error ) {
1260       $dbh->rollback if $oldAutoCommit;
1261       return $error;
1262     }
1263   }
1264
1265   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1266
1267   $cust_pkg;
1268
1269 }
1270
1271 =item last_bill
1272
1273 Returns the last bill date, or if there is no last bill date, the setup date.
1274 Useful for billing metered services.
1275
1276 =cut
1277
1278 sub last_bill {
1279   my $self = shift;
1280   return $self->setfield('last_bill', $_[0]) if @_;
1281   return $self->getfield('last_bill') if $self->getfield('last_bill');
1282   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1283                                                   'edate'  => $self->bill,  } );
1284   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1285 }
1286
1287 =item last_cust_pkg_reason ACTION
1288
1289 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1290 Returns false if there is no reason or the package is not currenly ACTION'd
1291 ACTION is one of adjourn, susp, cancel, or expire.
1292
1293 =cut
1294
1295 sub last_cust_pkg_reason {
1296   my ( $self, $action ) = ( shift, shift );
1297   my $date = $self->get($action);
1298   qsearchs( {
1299               'table' => 'cust_pkg_reason',
1300               'hashref' => { 'pkgnum' => $self->pkgnum,
1301                              'action' => substr(uc($action), 0, 1),
1302                              'date'   => $date,
1303                            },
1304               'order_by' => 'ORDER BY num DESC LIMIT 1',
1305            } );
1306 }
1307
1308 =item last_reason ACTION
1309
1310 Returns the most recent ACTION FS::reason associated with the package.
1311 Returns false if there is no reason or the package is not currenly ACTION'd
1312 ACTION is one of adjourn, susp, cancel, or expire.
1313
1314 =cut
1315
1316 sub last_reason {
1317   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1318   $cust_pkg_reason->reason
1319     if $cust_pkg_reason;
1320 }
1321
1322 =item part_pkg
1323
1324 Returns the definition for this billing item, as an FS::part_pkg object (see
1325 L<FS::part_pkg>).
1326
1327 =cut
1328
1329 sub part_pkg {
1330   my $self = shift;
1331   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1332   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1333   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1334 }
1335
1336 =item old_cust_pkg
1337
1338 Returns the cancelled package this package was changed from, if any.
1339
1340 =cut
1341
1342 sub old_cust_pkg {
1343   my $self = shift;
1344   return '' unless $self->change_pkgnum;
1345   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1346 }
1347
1348 =item calc_setup
1349
1350 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1351 item.
1352
1353 =cut
1354
1355 sub calc_setup {
1356   my $self = shift;
1357   $self->part_pkg->calc_setup($self, @_);
1358 }
1359
1360 =item calc_recur
1361
1362 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1363 item.
1364
1365 =cut
1366
1367 sub calc_recur {
1368   my $self = shift;
1369   $self->part_pkg->calc_recur($self, @_);
1370 }
1371
1372 =item calc_remain
1373
1374 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1375 billing item.
1376
1377 =cut
1378
1379 sub calc_remain {
1380   my $self = shift;
1381   $self->part_pkg->calc_remain($self, @_);
1382 }
1383
1384 =item calc_cancel
1385
1386 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1387 billing item.
1388
1389 =cut
1390
1391 sub calc_cancel {
1392   my $self = shift;
1393   $self->part_pkg->calc_cancel($self, @_);
1394 }
1395
1396 =item cust_bill_pkg
1397
1398 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1399
1400 =cut
1401
1402 sub cust_bill_pkg {
1403   my $self = shift;
1404   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1405 }
1406
1407 =item cust_pkg_detail [ DETAILTYPE ]
1408
1409 Returns any customer package details for this package (see
1410 L<FS::cust_pkg_detail>).
1411
1412 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1413
1414 =cut
1415
1416 sub cust_pkg_detail {
1417   my $self = shift;
1418   my %hash = ( 'pkgnum' => $self->pkgnum );
1419   $hash{detailtype} = shift if @_;
1420   qsearch({
1421     'table'    => 'cust_pkg_detail',
1422     'hashref'  => \%hash,
1423     'order_by' => 'ORDER BY weight, pkgdetailnum',
1424   });
1425 }
1426
1427 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1428
1429 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1430
1431 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1432
1433 If there is an error, returns the error, otherwise returns false.
1434
1435 =cut
1436
1437 sub set_cust_pkg_detail {
1438   my( $self, $detailtype, @details ) = @_;
1439
1440   local $SIG{HUP} = 'IGNORE';
1441   local $SIG{INT} = 'IGNORE';
1442   local $SIG{QUIT} = 'IGNORE';
1443   local $SIG{TERM} = 'IGNORE';
1444   local $SIG{TSTP} = 'IGNORE';
1445   local $SIG{PIPE} = 'IGNORE';
1446
1447   my $oldAutoCommit = $FS::UID::AutoCommit;
1448   local $FS::UID::AutoCommit = 0;
1449   my $dbh = dbh;
1450
1451   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1452     my $error = $current->delete;
1453     if ( $error ) {
1454       $dbh->rollback if $oldAutoCommit;
1455       return "error removing old detail: $error";
1456     }
1457   }
1458
1459   foreach my $detail ( @details ) {
1460     my $cust_pkg_detail = new FS::cust_pkg_detail {
1461       'pkgnum'     => $self->pkgnum,
1462       'detailtype' => $detailtype,
1463       'detail'     => $detail,
1464     };
1465     my $error = $cust_pkg_detail->insert;
1466     if ( $error ) {
1467       $dbh->rollback if $oldAutoCommit;
1468       return "error adding new detail: $error";
1469     }
1470
1471   }
1472
1473   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1474   '';
1475
1476 }
1477
1478 =item cust_event
1479
1480 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1481
1482 =cut
1483
1484 #false laziness w/cust_bill.pm
1485 sub cust_event {
1486   my $self = shift;
1487   qsearch({
1488     'table'     => 'cust_event',
1489     'addl_from' => 'JOIN part_event USING ( eventpart )',
1490     'hashref'   => { 'tablenum' => $self->pkgnum },
1491     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1492   });
1493 }
1494
1495 =item num_cust_event
1496
1497 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1498
1499 =cut
1500
1501 #false laziness w/cust_bill.pm
1502 sub num_cust_event {
1503   my $self = shift;
1504   my $sql =
1505     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1506     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1507   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1508   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1509   $sth->fetchrow_arrayref->[0];
1510 }
1511
1512 =item cust_svc [ SVCPART ]
1513
1514 Returns the services for this package, as FS::cust_svc objects (see
1515 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1516 services.
1517
1518 =cut
1519
1520 sub cust_svc {
1521   my $self = shift;
1522
1523   return () unless $self->num_cust_svc(@_);
1524
1525   if ( @_ ) {
1526     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1527                                   'svcpart' => shift,          } );
1528   }
1529
1530   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1531
1532   #if ( $self->{'_svcnum'} ) {
1533   #  values %{ $self->{'_svcnum'}->cache };
1534   #} else {
1535     $self->_sort_cust_svc(
1536       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1537     );
1538   #}
1539
1540 }
1541
1542 =item overlimit [ SVCPART ]
1543
1544 Returns the services for this package which have exceeded their
1545 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1546 is specified, return only the matching services.
1547
1548 =cut
1549
1550 sub overlimit {
1551   my $self = shift;
1552   return () unless $self->num_cust_svc(@_);
1553   grep { $_->overlimit } $self->cust_svc(@_);
1554 }
1555
1556 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1557
1558 Returns historical services for this package created before END TIMESTAMP and
1559 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1560 (see L<FS::h_cust_svc>).
1561
1562 =cut
1563
1564 sub h_cust_svc {
1565   my $self = shift;
1566
1567   $self->_sort_cust_svc(
1568     [ qsearch( 'h_cust_svc',
1569                { 'pkgnum' => $self->pkgnum, },
1570                FS::h_cust_svc->sql_h_search(@_),
1571              )
1572     ]
1573   );
1574 }
1575
1576 sub _sort_cust_svc {
1577   my( $self, $arrayref ) = @_;
1578
1579   my $sort =
1580     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1581
1582   map  { $_->[0] }
1583   sort $sort
1584   map {
1585         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1586                                              'svcpart' => $_->svcpart     } );
1587         [ $_,
1588           $pkg_svc ? $pkg_svc->primary_svc : '',
1589           $pkg_svc ? $pkg_svc->quantity : 0,
1590         ];
1591       }
1592   @$arrayref;
1593
1594 }
1595
1596 =item num_cust_svc [ SVCPART ]
1597
1598 Returns the number of provisioned services for this package.  If a svcpart is
1599 specified, counts only the matching services.
1600
1601 =cut
1602
1603 sub num_cust_svc {
1604   my $self = shift;
1605
1606   return $self->{'_num_cust_svc'}
1607     if !scalar(@_)
1608        && exists($self->{'_num_cust_svc'})
1609        && $self->{'_num_cust_svc'} =~ /\d/;
1610
1611   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1612     if $DEBUG > 2;
1613
1614   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1615   $sql .= ' AND svcpart = ?' if @_;
1616
1617   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1618   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1619   $sth->fetchrow_arrayref->[0];
1620 }
1621
1622 =item available_part_svc
1623
1624 Returns a list of FS::part_svc objects representing services included in this
1625 package but not yet provisioned.  Each FS::part_svc object also has an extra
1626 field, I<num_avail>, which specifies the number of available services.
1627
1628 =cut
1629
1630 sub available_part_svc {
1631   my $self = shift;
1632   grep { $_->num_avail > 0 }
1633     map {
1634           my $part_svc = $_->part_svc;
1635           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1636             $_->quantity - $self->num_cust_svc($_->svcpart);
1637           $part_svc;
1638         }
1639       $self->part_pkg->pkg_svc;
1640 }
1641
1642 =item part_svc
1643
1644 Returns a list of FS::part_svc objects representing provisioned and available
1645 services included in this package.  Each FS::part_svc object also has the
1646 following extra fields:
1647
1648 =over 4
1649
1650 =item num_cust_svc  (count)
1651
1652 =item num_avail     (quantity - count)
1653
1654 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1655
1656 svcnum
1657 label -> ($cust_svc->label)[1]
1658
1659 =back
1660
1661 =cut
1662
1663 sub part_svc {
1664   my $self = shift;
1665
1666   #XXX some sort of sort order besides numeric by svcpart...
1667   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1668     my $pkg_svc = $_;
1669     my $part_svc = $pkg_svc->part_svc;
1670     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1671     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1672     $part_svc->{'Hash'}{'num_avail'}    =
1673       max( 0, $pkg_svc->quantity - $num_cust_svc );
1674     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1675       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1676     $part_svc;
1677   } $self->part_pkg->pkg_svc;
1678
1679   #extras
1680   push @part_svc, map {
1681     my $part_svc = $_;
1682     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1683     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1684     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1685     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1686       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1687     $part_svc;
1688   } $self->extra_part_svc;
1689
1690   @part_svc;
1691
1692 }
1693
1694 =item extra_part_svc
1695
1696 Returns a list of FS::part_svc objects corresponding to services in this
1697 package which are still provisioned but not (any longer) available in the
1698 package definition.
1699
1700 =cut
1701
1702 sub extra_part_svc {
1703   my $self = shift;
1704
1705   my $pkgnum  = $self->pkgnum;
1706   my $pkgpart = $self->pkgpart;
1707
1708 #  qsearch( {
1709 #    'table'     => 'part_svc',
1710 #    'hashref'   => {},
1711 #    'extra_sql' =>
1712 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1713 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1714 #                       AND pkg_svc.pkgpart = ?
1715 #                       AND quantity > 0
1716 #                 )
1717 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1718 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1719 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1720 #                       AND pkgnum = ?
1721 #                 )",
1722 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1723 #  } );
1724
1725 #seems to benchmark slightly faster...
1726   qsearch( {
1727     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1728     #MySQL doesn't grok DISINCT ON
1729     'select'      => 'DISTINCT part_svc.*',
1730     'table'       => 'part_svc',
1731     'addl_from'   =>
1732       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1733                                AND pkg_svc.pkgpart   = ?
1734                                AND quantity > 0
1735                              )
1736        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1737        LEFT JOIN cust_pkg USING ( pkgnum )
1738       ',
1739     'hashref'     => {},
1740     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1741     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1742   } );
1743 }
1744
1745 =item status
1746
1747 Returns a short status string for this package, currently:
1748
1749 =over 4
1750
1751 =item not yet billed
1752
1753 =item one-time charge
1754
1755 =item active
1756
1757 =item suspended
1758
1759 =item cancelled
1760
1761 =back
1762
1763 =cut
1764
1765 sub status {
1766   my $self = shift;
1767
1768   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1769
1770   return 'cancelled' if $self->get('cancel');
1771   return 'suspended' if $self->susp;
1772   return 'not yet billed' unless $self->setup;
1773   return 'one-time charge' if $freq =~ /^(0|$)/;
1774   return 'active';
1775 }
1776
1777 =item ucfirst_status
1778
1779 Returns the status with the first character capitalized.
1780
1781 =cut
1782
1783 sub ucfirst_status {
1784   ucfirst(shift->status);
1785 }
1786
1787 =item statuses
1788
1789 Class method that returns the list of possible status strings for packages
1790 (see L<the status method|/status>).  For example:
1791
1792   @statuses = FS::cust_pkg->statuses();
1793
1794 =cut
1795
1796 tie my %statuscolor, 'Tie::IxHash',
1797   'not yet billed'  => '000000',
1798   'one-time charge' => '000000',
1799   'active'          => '00CC00',
1800   'suspended'       => 'FF9900',
1801   'cancelled'       => 'FF0000',
1802 ;
1803
1804 sub statuses {
1805   my $self = shift; #could be class...
1806   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1807   #                                    # mayble split btw one-time vs. recur
1808     keys %statuscolor;
1809 }
1810
1811 =item statuscolor
1812
1813 Returns a hex triplet color string for this package's status.
1814
1815 =cut
1816
1817 sub statuscolor {
1818   my $self = shift;
1819   $statuscolor{$self->status};
1820 }
1821
1822 =item pkg_label
1823
1824 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1825 "pkg-comment" depending on user preference).
1826
1827 =cut
1828
1829 sub pkg_label {
1830   my $self = shift;
1831   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1832   $label = $self->pkgnum. ": $label"
1833     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1834   $label;
1835 }
1836
1837 =item pkg_label_long
1838
1839 Returns a long label for this package, adding the primary service's label to
1840 pkg_label.
1841
1842 =cut
1843
1844 sub pkg_label_long {
1845   my $self = shift;
1846   my $label = $self->pkg_label;
1847   my $cust_svc = $self->primary_cust_svc;
1848   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1849   $label;
1850 }
1851
1852 =item primary_cust_svc
1853
1854 Returns a primary service (as FS::cust_svc object) if one can be identified.
1855
1856 =cut
1857
1858 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1859
1860 sub primary_cust_svc {
1861   my $self = shift;
1862
1863   my @cust_svc = $self->cust_svc;
1864
1865   return '' unless @cust_svc; #no serivces - irrelevant then
1866
1867   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1868
1869   # primary service as specified in the package definition
1870   # or exactly one service definition with quantity one
1871   my $svcpart = $self->part_pkg->svcpart;
1872   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1873   return $cust_svc[0] if scalar(@cust_svc) == 1;
1874
1875   #couldn't identify one thing..
1876   return '';
1877 }
1878
1879 =item labels
1880
1881 Returns a list of lists, calling the label method for all services
1882 (see L<FS::cust_svc>) of this billing item.
1883
1884 =cut
1885
1886 sub labels {
1887   my $self = shift;
1888   map { [ $_->label ] } $self->cust_svc;
1889 }
1890
1891 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1892
1893 Like the labels method, but returns historical information on services that
1894 were active as of END_TIMESTAMP and (optionally) not cancelled before
1895 START_TIMESTAMP.
1896
1897 Returns a list of lists, calling the label method for all (historical) services
1898 (see L<FS::h_cust_svc>) of this billing item.
1899
1900 =cut
1901
1902 sub h_labels {
1903   my $self = shift;
1904   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1905 }
1906
1907 =item labels_short
1908
1909 Like labels, except returns a simple flat list, and shortens long
1910 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1911 identical services to one line that lists the service label and the number of
1912 individual services rather than individual items.
1913
1914 =cut
1915
1916 sub labels_short {
1917   shift->_labels_short( 'labels', @_ );
1918 }
1919
1920 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1921
1922 Like h_labels, except returns a simple flat list, and shortens long
1923 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1924 identical services to one line that lists the service label and the number of
1925 individual services rather than individual items.
1926
1927 =cut
1928
1929 sub h_labels_short {
1930   shift->_labels_short( 'h_labels', @_ );
1931 }
1932
1933 sub _labels_short {
1934   my( $self, $method ) = ( shift, shift );
1935
1936   my $conf = new FS::Conf;
1937   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1938
1939   my %labels;
1940   #tie %labels, 'Tie::IxHash';
1941   push @{ $labels{$_->[0]} }, $_->[1]
1942     foreach $self->$method(@_);
1943   my @labels;
1944   foreach my $label ( keys %labels ) {
1945     my %seen = ();
1946     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1947     my $num = scalar(@values);
1948     if ( $num > $max_same_services ) {
1949       push @labels, "$label ($num)";
1950     } else {
1951       if ( $conf->exists('cust_bill-consolidate_services') ) {
1952         # push @labels, "$label: ". join(', ', @values);
1953         while ( @values ) {
1954           my $detail = "$label: ";
1955           $detail .= shift(@values). ', '
1956             while @values && length($detail.$values[0]) < 78;
1957           $detail =~ s/, $//;
1958           push @labels, $detail;
1959         }
1960       } else {
1961         push @labels, map { "$label: $_" } @values;
1962       }
1963     }
1964   }
1965
1966  @labels;
1967
1968 }
1969
1970 =item cust_main
1971
1972 Returns the parent customer object (see L<FS::cust_main>).
1973
1974 =cut
1975
1976 sub cust_main {
1977   my $self = shift;
1978   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1979 }
1980
1981 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1982
1983 =item cust_location
1984
1985 Returns the location object, if any (see L<FS::cust_location>).
1986
1987 =item cust_location_or_main
1988
1989 If this package is associated with a location, returns the locaiton (see
1990 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1991
1992 =item location_label [ OPTION => VALUE ... ]
1993
1994 Returns the label of the location object (see L<FS::cust_location>).
1995
1996 =cut
1997
1998 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
1999
2000 =item seconds_since TIMESTAMP
2001
2002 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2003 package have been online since TIMESTAMP, according to the session monitor.
2004
2005 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2006 L<Time::Local> and L<Date::Parse> for conversion functions.
2007
2008 =cut
2009
2010 sub seconds_since {
2011   my($self, $since) = @_;
2012   my $seconds = 0;
2013
2014   foreach my $cust_svc (
2015     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2016   ) {
2017     $seconds += $cust_svc->seconds_since($since);
2018   }
2019
2020   $seconds;
2021
2022 }
2023
2024 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2025
2026 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2027 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2028 (exclusive).
2029
2030 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2031 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2032 functions.
2033
2034
2035 =cut
2036
2037 sub seconds_since_sqlradacct {
2038   my($self, $start, $end) = @_;
2039
2040   my $seconds = 0;
2041
2042   foreach my $cust_svc (
2043     grep {
2044       my $part_svc = $_->part_svc;
2045       $part_svc->svcdb eq 'svc_acct'
2046         && scalar($part_svc->part_export('sqlradius'));
2047     } $self->cust_svc
2048   ) {
2049     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2050   }
2051
2052   $seconds;
2053
2054 }
2055
2056 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2057
2058 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2059 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2060 TIMESTAMP_END
2061 (exclusive).
2062
2063 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2064 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2065 functions.
2066
2067 =cut
2068
2069 sub attribute_since_sqlradacct {
2070   my($self, $start, $end, $attrib) = @_;
2071
2072   my $sum = 0;
2073
2074   foreach my $cust_svc (
2075     grep {
2076       my $part_svc = $_->part_svc;
2077       $part_svc->svcdb eq 'svc_acct'
2078         && scalar($part_svc->part_export('sqlradius'));
2079     } $self->cust_svc
2080   ) {
2081     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2082   }
2083
2084   $sum;
2085
2086 }
2087
2088 =item quantity
2089
2090 =cut
2091
2092 sub quantity {
2093   my( $self, $value ) = @_;
2094   if ( defined($value) ) {
2095     $self->setfield('quantity', $value);
2096   }
2097   $self->getfield('quantity') || 1;
2098 }
2099
2100 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2101
2102 Transfers as many services as possible from this package to another package.
2103
2104 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2105 object.  The destination package must already exist.
2106
2107 Services are moved only if the destination allows services with the correct
2108 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2109 this option with caution!  No provision is made for export differences
2110 between the old and new service definitions.  Probably only should be used
2111 when your exports for all service definitions of a given svcdb are identical.
2112 (attempt a transfer without it first, to move all possible svcpart-matching
2113 services)
2114
2115 Any services that can't be moved remain in the original package.
2116
2117 Returns an error, if there is one; otherwise, returns the number of services
2118 that couldn't be moved.
2119
2120 =cut
2121
2122 sub transfer {
2123   my ($self, $dest_pkgnum, %opt) = @_;
2124
2125   my $remaining = 0;
2126   my $dest;
2127   my %target;
2128
2129   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2130     $dest = $dest_pkgnum;
2131     $dest_pkgnum = $dest->pkgnum;
2132   } else {
2133     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2134   }
2135
2136   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2137
2138   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2139     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2140   }
2141
2142   foreach my $cust_svc ($dest->cust_svc) {
2143     $target{$cust_svc->svcpart}--;
2144   }
2145
2146   my %svcpart2svcparts = ();
2147   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2148     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2149     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2150       next if exists $svcpart2svcparts{$svcpart};
2151       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2152       $svcpart2svcparts{$svcpart} = [
2153         map  { $_->[0] }
2154         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2155         map {
2156               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2157                                                    'svcpart' => $_          } );
2158               [ $_,
2159                 $pkg_svc ? $pkg_svc->primary_svc : '',
2160                 $pkg_svc ? $pkg_svc->quantity : 0,
2161               ];
2162             }
2163
2164         grep { $_ != $svcpart }
2165         map  { $_->svcpart }
2166         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2167       ];
2168       warn "alternates for svcpart $svcpart: ".
2169            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2170         if $DEBUG;
2171     }
2172   }
2173
2174   foreach my $cust_svc ($self->cust_svc) {
2175     if($target{$cust_svc->svcpart} > 0) {
2176       $target{$cust_svc->svcpart}--;
2177       my $new = new FS::cust_svc { $cust_svc->hash };
2178       $new->pkgnum($dest_pkgnum);
2179       my $error = $new->replace($cust_svc);
2180       return $error if $error;
2181     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2182       if ( $DEBUG ) {
2183         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2184         warn "alternates to consider: ".
2185              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2186       }
2187       my @alternate = grep {
2188                              warn "considering alternate svcpart $_: ".
2189                                   "$target{$_} available in new package\n"
2190                                if $DEBUG;
2191                              $target{$_} > 0;
2192                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2193       if ( @alternate ) {
2194         warn "alternate(s) found\n" if $DEBUG;
2195         my $change_svcpart = $alternate[0];
2196         $target{$change_svcpart}--;
2197         my $new = new FS::cust_svc { $cust_svc->hash };
2198         $new->svcpart($change_svcpart);
2199         $new->pkgnum($dest_pkgnum);
2200         my $error = $new->replace($cust_svc);
2201         return $error if $error;
2202       } else {
2203         $remaining++;
2204       }
2205     } else {
2206       $remaining++
2207     }
2208   }
2209   return $remaining;
2210 }
2211
2212 =item reexport
2213
2214 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2215 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2216
2217 =cut
2218
2219 sub reexport {
2220   my $self = shift;
2221
2222   local $SIG{HUP} = 'IGNORE';
2223   local $SIG{INT} = 'IGNORE';
2224   local $SIG{QUIT} = 'IGNORE';
2225   local $SIG{TERM} = 'IGNORE';
2226   local $SIG{TSTP} = 'IGNORE';
2227   local $SIG{PIPE} = 'IGNORE';
2228
2229   my $oldAutoCommit = $FS::UID::AutoCommit;
2230   local $FS::UID::AutoCommit = 0;
2231   my $dbh = dbh;
2232
2233   foreach my $cust_svc ( $self->cust_svc ) {
2234     #false laziness w/svc_Common::insert
2235     my $svc_x = $cust_svc->svc_x;
2236     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2237       my $error = $part_export->export_insert($svc_x);
2238       if ( $error ) {
2239         $dbh->rollback if $oldAutoCommit;
2240         return $error;
2241       }
2242     }
2243   }
2244
2245   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2246   '';
2247
2248 }
2249
2250 =item insert_reason
2251
2252 Associates this package with a (suspension or cancellation) reason (see
2253 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2254 L<FS::reason>).
2255
2256 Available options are:
2257
2258 =over 4
2259
2260 =item reason
2261
2262 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.
2263
2264 =item reason_otaker
2265
2266 the access_user (see L<FS::access_user>) providing the reason
2267
2268 =item date
2269
2270 a unix timestamp
2271
2272 =item action
2273
2274 the action (cancel, susp, adjourn, expire) associated with the reason
2275
2276 =back
2277
2278 If there is an error, returns the error, otherwise returns false.
2279
2280 =cut
2281
2282 sub insert_reason {
2283   my ($self, %options) = @_;
2284
2285   my $otaker = $options{reason_otaker} ||
2286                $FS::CurrentUser::CurrentUser->username;
2287
2288   my $reasonnum;
2289   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2290
2291     $reasonnum = $1;
2292
2293   } elsif ( ref($options{'reason'}) ) {
2294
2295     return 'Enter a new reason (or select an existing one)'
2296       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2297
2298     my $reason = new FS::reason({
2299       'reason_type' => $options{'reason'}->{'typenum'},
2300       'reason'      => $options{'reason'}->{'reason'},
2301     });
2302     my $error = $reason->insert;
2303     return $error if $error;
2304
2305     $reasonnum = $reason->reasonnum;
2306
2307   } else {
2308     return "Unparsable reason: ". $options{'reason'};
2309   }
2310
2311   my $cust_pkg_reason =
2312     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2313                               'reasonnum' => $reasonnum,
2314                               'otaker'    => $otaker,
2315                               'action'    => substr(uc($options{'action'}),0,1),
2316                               'date'      => $options{'date'}
2317                                                ? $options{'date'}
2318                                                : time,
2319                             });
2320
2321   $cust_pkg_reason->insert;
2322 }
2323
2324 =item insert_discount
2325
2326 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2327 inserting a new discount on the fly (see L<FS::discount>).
2328
2329 Available options are:
2330
2331 =over 4
2332
2333 =item discountnum
2334
2335 =back
2336
2337 If there is an error, returns the error, otherwise returns false.
2338
2339 =cut
2340
2341 sub insert_discount {
2342   #my ($self, %options) = @_;
2343   my $self = shift;
2344
2345   my $cust_pkg_discount = new FS::cust_pkg_discount {
2346     'pkgnum'      => $self->pkgnum,
2347     'discountnum' => $self->discountnum,
2348     'months_used' => 0,
2349     'end_date'    => '', #XXX
2350     'otaker'      => $self->otaker,
2351     #for the create a new discount case
2352     '_type'       => $self->discountnum__type,
2353     'amount'      => $self->discountnum_amount,
2354     'percent'     => $self->discountnum_percent,
2355     'months'      => $self->discountnum_months,
2356     #'disabled'    => $self->discountnum_disabled,
2357   };
2358
2359   $cust_pkg_discount->insert;
2360 }
2361
2362 =item set_usage USAGE_VALUE_HASHREF
2363
2364 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2365 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2366 upbytes, downbytes, and totalbytes are appropriate keys.
2367
2368 All svc_accts which are part of this package have their values reset.
2369
2370 =cut
2371
2372 sub set_usage {
2373   my ($self, $valueref, %opt) = @_;
2374
2375   foreach my $cust_svc ($self->cust_svc){
2376     my $svc_x = $cust_svc->svc_x;
2377     $svc_x->set_usage($valueref, %opt)
2378       if $svc_x->can("set_usage");
2379   }
2380 }
2381
2382 =item recharge USAGE_VALUE_HASHREF
2383
2384 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2385 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2386 upbytes, downbytes, and totalbytes are appropriate keys.
2387
2388 All svc_accts which are part of this package have their values incremented.
2389
2390 =cut
2391
2392 sub recharge {
2393   my ($self, $valueref) = @_;
2394
2395   foreach my $cust_svc ($self->cust_svc){
2396     my $svc_x = $cust_svc->svc_x;
2397     $svc_x->recharge($valueref)
2398       if $svc_x->can("recharge");
2399   }
2400 }
2401
2402 =item cust_pkg_discount
2403
2404 =cut
2405
2406 sub cust_pkg_discount {
2407   my $self = shift;
2408   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2409 }
2410
2411 =item cust_pkg_discount_active
2412
2413 =cut
2414
2415 sub cust_pkg_discount_active {
2416   my $self = shift;
2417   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2418 }
2419
2420 =back
2421
2422 =head1 CLASS METHODS
2423
2424 =over 4
2425
2426 =item recurring_sql
2427
2428 Returns an SQL expression identifying recurring packages.
2429
2430 =cut
2431
2432 sub recurring_sql { "
2433   '0' != ( select freq from part_pkg
2434              where cust_pkg.pkgpart = part_pkg.pkgpart )
2435 "; }
2436
2437 =item onetime_sql
2438
2439 Returns an SQL expression identifying one-time packages.
2440
2441 =cut
2442
2443 sub onetime_sql { "
2444   '0' = ( select freq from part_pkg
2445             where cust_pkg.pkgpart = part_pkg.pkgpart )
2446 "; }
2447
2448 =item ordered_sql
2449
2450 Returns an SQL expression identifying ordered packages (recurring packages not
2451 yet billed).
2452
2453 =cut
2454
2455 sub ordered_sql {
2456    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2457 }
2458
2459 =item active_sql
2460
2461 Returns an SQL expression identifying active packages.
2462
2463 =cut
2464
2465 sub active_sql {
2466   $_[0]->recurring_sql. "
2467   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2468   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2469   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2470 "; }
2471
2472 =item not_yet_billed_sql
2473
2474 Returns an SQL expression identifying packages which have not yet been billed.
2475
2476 =cut
2477
2478 sub not_yet_billed_sql { "
2479       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2480   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2481   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2482 "; }
2483
2484 =item inactive_sql
2485
2486 Returns an SQL expression identifying inactive packages (one-time packages
2487 that are otherwise unsuspended/uncancelled).
2488
2489 =cut
2490
2491 sub inactive_sql { "
2492   ". $_[0]->onetime_sql(). "
2493   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2494   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2495   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2496 "; }
2497
2498 =item susp_sql
2499 =item suspended_sql
2500
2501 Returns an SQL expression identifying suspended packages.
2502
2503 =cut
2504
2505 sub suspended_sql { susp_sql(@_); }
2506 sub susp_sql {
2507   #$_[0]->recurring_sql(). ' AND '.
2508   "
2509         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2510     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2511   ";
2512 }
2513
2514 =item cancel_sql
2515 =item cancelled_sql
2516
2517 Returns an SQL exprression identifying cancelled packages.
2518
2519 =cut
2520
2521 sub cancelled_sql { cancel_sql(@_); }
2522 sub cancel_sql {
2523   #$_[0]->recurring_sql(). ' AND '.
2524   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2525 }
2526
2527 =item search HASHREF
2528
2529 (Class method)
2530
2531 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2532 Valid parameters are
2533
2534 =over 4
2535
2536 =item agentnum
2537
2538 =item magic
2539
2540 active, inactive, suspended, cancel (or cancelled)
2541
2542 =item status
2543
2544 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2545
2546 =item custom
2547
2548  boolean selects custom packages
2549
2550 =item classnum
2551
2552 =item pkgpart
2553
2554 pkgpart or arrayref or hashref of pkgparts
2555
2556 =item setup
2557
2558 arrayref of beginning and ending epoch date
2559
2560 =item last_bill
2561
2562 arrayref of beginning and ending epoch date
2563
2564 =item bill
2565
2566 arrayref of beginning and ending epoch date
2567
2568 =item adjourn
2569
2570 arrayref of beginning and ending epoch date
2571
2572 =item susp
2573
2574 arrayref of beginning and ending epoch date
2575
2576 =item expire
2577
2578 arrayref of beginning and ending epoch date
2579
2580 =item cancel
2581
2582 arrayref of beginning and ending epoch date
2583
2584 =item query
2585
2586 pkgnum or APKG_pkgnum
2587
2588 =item cust_fields
2589
2590 a value suited to passing to FS::UI::Web::cust_header
2591
2592 =item CurrentUser
2593
2594 specifies the user for agent virtualization
2595
2596 =item fcc_line
2597
2598  boolean selects packages containing fcc form 477 telco lines
2599
2600 =back
2601
2602 =cut
2603
2604 sub search {
2605   my ($class, $params) = @_;
2606   my @where = ();
2607
2608   ##
2609   # parse agent
2610   ##
2611
2612   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2613     push @where,
2614       "cust_main.agentnum = $1";
2615   }
2616
2617   ##
2618   # parse custnum
2619   ##
2620
2621   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2622     push @where,
2623       "cust_pkg.custnum = $1";
2624   }
2625
2626   ##
2627   # custbatch
2628   ##
2629
2630   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2631     push @where,
2632       "cust_pkg.pkgbatch = '$1'";
2633   }
2634
2635   ##
2636   # parse status
2637   ##
2638
2639   if (    $params->{'magic'}  eq 'active'
2640        || $params->{'status'} eq 'active' ) {
2641
2642     push @where, FS::cust_pkg->active_sql();
2643
2644   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2645             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2646
2647     push @where, FS::cust_pkg->not_yet_billed_sql();
2648
2649   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2650             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2651
2652     push @where, FS::cust_pkg->inactive_sql();
2653
2654   } elsif (    $params->{'magic'}  eq 'suspended'
2655             || $params->{'status'} eq 'suspended'  ) {
2656
2657     push @where, FS::cust_pkg->suspended_sql();
2658
2659   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2660             || $params->{'status'} =~ /^cancell?ed$/ ) {
2661
2662     push @where, FS::cust_pkg->cancelled_sql();
2663
2664   }
2665
2666   ###
2667   # parse package class
2668   ###
2669
2670   #false lazinessish w/graph/cust_bill_pkg.cgi
2671   my $classnum = 0;
2672   my @pkg_class = ();
2673   if ( exists($params->{'classnum'})
2674        && $params->{'classnum'} =~ /^(\d*)$/
2675      )
2676   {
2677     $classnum = $1;
2678     if ( $classnum ) { #a specific class
2679       push @where, "part_pkg.classnum = $classnum";
2680
2681       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2682       #die "classnum $classnum not found!" unless $pkg_class[0];
2683       #$title .= $pkg_class[0]->classname.' ';
2684
2685     } elsif ( $classnum eq '' ) { #the empty class
2686
2687       push @where, "part_pkg.classnum IS NULL";
2688       #$title .= 'Empty class ';
2689       #@pkg_class = ( '(empty class)' );
2690     } elsif ( $classnum eq '0' ) {
2691       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2692       #push @pkg_class, '(empty class)';
2693     } else {
2694       die "illegal classnum";
2695     }
2696   }
2697   #eslaf
2698
2699   ###
2700   # parse package report options
2701   ###
2702
2703   my @report_option = ();
2704   if ( exists($params->{'report_option'})
2705        && $params->{'report_option'} =~ /^([,\d]*)$/
2706      )
2707   {
2708     @report_option = split(',', $1);
2709   }
2710
2711   if (@report_option) {
2712     # this will result in the empty set for the dangling comma case as it should
2713     push @where,
2714       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2715                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2716                     AND optionname = 'report_option_$_'
2717                     AND optionvalue = '1' )"
2718          } @report_option;
2719   }
2720
2721   #eslaf
2722
2723   ###
2724   # parse custom
2725   ###
2726
2727   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2728
2729   ###
2730   # parse fcc_line
2731   ###
2732
2733   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2734
2735   ###
2736   # parse censustract
2737   ###
2738
2739   if ( exists($params->{'censustract'}) ) {
2740     $params->{'censustract'} =~ /^([.\d]*)$/;
2741     my $censustract = "cust_main.censustract = '$1'";
2742     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2743     push @where,  "( $censustract )";
2744   }
2745
2746   ###
2747   # parse part_pkg
2748   ###
2749
2750   if ( ref($params->{'pkgpart'}) ) {
2751
2752     my @pkgpart = ();
2753     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2754       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2755     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2756       @pkgpart = @{ $params->{'pkgpart'} };
2757     } else {
2758       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2759     }
2760
2761     @pkgpart = grep /^(\d+)$/, @pkgpart;
2762
2763     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2764
2765   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2766     push @where, "pkgpart = $1";
2767   }
2768
2769   ###
2770   # parse dates
2771   ###
2772
2773   my $orderby = '';
2774
2775   #false laziness w/report_cust_pkg.html
2776   my %disable = (
2777     'all'             => {},
2778     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2779     'active'          => { 'susp'=>1, 'cancel'=>1 },
2780     'suspended'       => { 'cancel' => 1 },
2781     'cancelled'       => {},
2782     ''                => {},
2783   );
2784
2785   if( exists($params->{'active'} ) ) {
2786     # This overrides all the other date-related fields
2787     my($beginning, $ending) = @{$params->{'active'}};
2788     push @where,
2789       "cust_pkg.setup IS NOT NULL",
2790       "cust_pkg.setup <= $ending",
2791       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2792       "NOT (".FS::cust_pkg->onetime_sql . ")";
2793   }
2794   else {
2795     foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2796
2797       next unless exists($params->{$field});
2798
2799       my($beginning, $ending) = @{$params->{$field}};
2800
2801       next if $beginning == 0 && $ending == 4294967295;
2802
2803       push @where,
2804         "cust_pkg.$field IS NOT NULL",
2805         "cust_pkg.$field >= $beginning",
2806         "cust_pkg.$field <= $ending";
2807
2808       $orderby ||= "ORDER BY cust_pkg.$field";
2809
2810     }
2811   }
2812
2813   $orderby ||= 'ORDER BY bill';
2814
2815   ###
2816   # parse magic, legacy, etc.
2817   ###
2818
2819   if ( $params->{'magic'} &&
2820        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2821   ) {
2822
2823     $orderby = 'ORDER BY pkgnum';
2824
2825     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2826       push @where, "pkgpart = $1";
2827     }
2828
2829   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2830
2831     $orderby = 'ORDER BY pkgnum';
2832
2833   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2834
2835     $orderby = 'ORDER BY pkgnum';
2836
2837     push @where, '0 < (
2838       SELECT count(*) FROM pkg_svc
2839        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2840          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2841                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2842                                      AND cust_svc.svcpart = pkg_svc.svcpart
2843                                 )
2844     )';
2845
2846   }
2847
2848   ##
2849   # setup queries, links, subs, etc. for the search
2850   ##
2851
2852   # here is the agent virtualization
2853   if ($params->{CurrentUser}) {
2854     my $access_user =
2855       qsearchs('access_user', { username => $params->{CurrentUser} });
2856
2857     if ($access_user) {
2858       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2859     } else {
2860       push @where, "1=0";
2861     }
2862   } else {
2863     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2864   }
2865
2866   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2867
2868   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2869                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2870                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2871
2872   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2873
2874   my $sql_query = {
2875     'table'       => 'cust_pkg',
2876     'hashref'     => {},
2877     'select'      => join(', ',
2878                                 'cust_pkg.*',
2879                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2880                                 'pkg_class.classname',
2881                                 'cust_main.custnum AS cust_main_custnum',
2882                                 FS::UI::Web::cust_sql_fields(
2883                                   $params->{'cust_fields'}
2884                                 ),
2885                      ),
2886     'extra_sql'   => "$extra_sql $orderby",
2887     'addl_from'   => $addl_from,
2888     'count_query' => $count_query,
2889   };
2890
2891 }
2892
2893 =item fcc_477_count
2894
2895 Returns a list of two package counts.  The first is a count of packages
2896 based on the supplied criteria and the second is the count of residential
2897 packages with those same criteria.  Criteria are specified as in the search
2898 method.
2899
2900 =cut
2901
2902 sub fcc_477_count {
2903   my ($class, $params) = @_;
2904
2905   my $sql_query = $class->search( $params );
2906
2907   my $count_sql = delete($sql_query->{'count_query'});
2908   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2909     or die "couldn't parse count_sql";
2910
2911   my $count_sth = dbh->prepare($count_sql)
2912     or die "Error preparing $count_sql: ". dbh->errstr;
2913   $count_sth->execute
2914     or die "Error executing $count_sql: ". $count_sth->errstr;
2915   my $count_arrayref = $count_sth->fetchrow_arrayref;
2916
2917   return ( @$count_arrayref );
2918
2919 }
2920
2921
2922 =item location_sql
2923
2924 Returns a list: the first item is an SQL fragment identifying matching
2925 packages/customers via location (taking into account shipping and package
2926 address taxation, if enabled), and subsequent items are the parameters to
2927 substitute for the placeholders in that fragment.
2928
2929 =cut
2930
2931 sub location_sql {
2932   my($class, %opt) = @_;
2933   my $ornull = $opt{'ornull'};
2934
2935   my $conf = new FS::Conf;
2936
2937   # '?' placeholders in _location_sql_where
2938   my $x = $ornull ? 3 : 2;
2939   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2940
2941   my $main_where;
2942   my @main_param;
2943   if ( $conf->exists('tax-ship_address') ) {
2944
2945     $main_where = "(
2946          (     ( ship_last IS NULL     OR  ship_last  = '' )
2947            AND ". _location_sql_where('cust_main', '', $ornull ). "
2948          )
2949       OR (       ship_last IS NOT NULL AND ship_last != ''
2950            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2951          )
2952     )";
2953     #    AND payby != 'COMP'
2954
2955     @main_param = ( @bill_param, @bill_param );
2956
2957   } else {
2958
2959     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2960     @main_param = @bill_param;
2961
2962   }
2963
2964   my $where;
2965   my @param;
2966   if ( $conf->exists('tax-pkg_address') ) {
2967
2968     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2969
2970     $where = " (
2971                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2972                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2973                )
2974              ";
2975     @param = ( @main_param, @bill_param );
2976
2977   } else {
2978
2979     $where = $main_where;
2980     @param = @main_param;
2981
2982   }
2983
2984   ( $where, @param );
2985
2986 }
2987
2988 #subroutine, helper for location_sql
2989 sub _location_sql_where {
2990   my $table  = shift;
2991   my $prefix = @_ ? shift : '';
2992   my $ornull = @_ ? shift : '';
2993
2994 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2995
2996   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2997
2998   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
2999   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3000   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3001
3002 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3003   "
3004         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3005     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3006     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3007     AND   $table.${prefix}country = ?
3008   ";
3009 }
3010
3011 =head1 SUBROUTINES
3012
3013 =over 4
3014
3015 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3016
3017 CUSTNUM is a customer (see L<FS::cust_main>)
3018
3019 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3020 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3021 permitted.
3022
3023 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3024 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3025 new billing items.  An error is returned if this is not possible (see
3026 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3027 parameter.
3028
3029 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3030 newly-created cust_pkg objects.
3031
3032 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3033 and inserted.  Multiple FS::pkg_referral records can be created by
3034 setting I<refnum> to an array reference of refnums or a hash reference with
3035 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3036 record will be created corresponding to cust_main.refnum.
3037
3038 =cut
3039
3040 sub order {
3041   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3042
3043   my $conf = new FS::Conf;
3044
3045   # Transactionize this whole mess
3046   local $SIG{HUP} = 'IGNORE';
3047   local $SIG{INT} = 'IGNORE';
3048   local $SIG{QUIT} = 'IGNORE';
3049   local $SIG{TERM} = 'IGNORE';
3050   local $SIG{TSTP} = 'IGNORE';
3051   local $SIG{PIPE} = 'IGNORE';
3052
3053   my $oldAutoCommit = $FS::UID::AutoCommit;
3054   local $FS::UID::AutoCommit = 0;
3055   my $dbh = dbh;
3056
3057   my $error;
3058 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3059 #  return "Customer not found: $custnum" unless $cust_main;
3060
3061   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3062     if $DEBUG;
3063
3064   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3065                          @$remove_pkgnum;
3066
3067   my $change = scalar(@old_cust_pkg) != 0;
3068
3069   my %hash = ();
3070   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3071
3072     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3073          " to pkgpart ". $pkgparts->[0]. "\n"
3074       if $DEBUG;
3075
3076     my $err_or_cust_pkg =
3077       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3078                                 'refnum'  => $refnum,
3079                               );
3080
3081     unless (ref($err_or_cust_pkg)) {
3082       $dbh->rollback if $oldAutoCommit;
3083       return $err_or_cust_pkg;
3084     }
3085
3086     push @$return_cust_pkg, $err_or_cust_pkg;
3087     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3088     return '';
3089
3090   }
3091
3092   # Create the new packages.
3093   foreach my $pkgpart (@$pkgparts) {
3094
3095     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3096
3097     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3098                                       pkgpart => $pkgpart,
3099                                       refnum  => $refnum,
3100                                       %hash,
3101                                     };
3102     $error = $cust_pkg->insert( 'change' => $change );
3103     if ($error) {
3104       $dbh->rollback if $oldAutoCommit;
3105       return $error;
3106     }
3107     push @$return_cust_pkg, $cust_pkg;
3108   }
3109   # $return_cust_pkg now contains refs to all of the newly
3110   # created packages.
3111
3112   # Transfer services and cancel old packages.
3113   foreach my $old_pkg (@old_cust_pkg) {
3114
3115     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3116       if $DEBUG;
3117
3118     foreach my $new_pkg (@$return_cust_pkg) {
3119       $error = $old_pkg->transfer($new_pkg);
3120       if ($error and $error == 0) {
3121         # $old_pkg->transfer failed.
3122         $dbh->rollback if $oldAutoCommit;
3123         return $error;
3124       }
3125     }
3126
3127     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3128       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3129       foreach my $new_pkg (@$return_cust_pkg) {
3130         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3131         if ($error and $error == 0) {
3132           # $old_pkg->transfer failed.
3133         $dbh->rollback if $oldAutoCommit;
3134         return $error;
3135         }
3136       }
3137     }
3138
3139     if ($error > 0) {
3140       # Transfers were successful, but we went through all of the
3141       # new packages and still had services left on the old package.
3142       # We can't cancel the package under the circumstances, so abort.
3143       $dbh->rollback if $oldAutoCommit;
3144       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3145     }
3146     $error = $old_pkg->cancel( quiet=>1 );
3147     if ($error) {
3148       $dbh->rollback;
3149       return $error;
3150     }
3151   }
3152   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3153   '';
3154 }
3155
3156 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3157
3158 A bulk change method to change packages for multiple customers.
3159
3160 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3161 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3162 permitted.
3163
3164 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3165 replace.  The services (see L<FS::cust_svc>) are moved to the
3166 new billing items.  An error is returned if this is not possible (see
3167 L<FS::pkg_svc>).
3168
3169 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3170 newly-created cust_pkg objects.
3171
3172 =cut
3173
3174 sub bulk_change {
3175   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3176
3177   # Transactionize this whole mess
3178   local $SIG{HUP} = 'IGNORE';
3179   local $SIG{INT} = 'IGNORE';
3180   local $SIG{QUIT} = 'IGNORE';
3181   local $SIG{TERM} = 'IGNORE';
3182   local $SIG{TSTP} = 'IGNORE';
3183   local $SIG{PIPE} = 'IGNORE';
3184
3185   my $oldAutoCommit = $FS::UID::AutoCommit;
3186   local $FS::UID::AutoCommit = 0;
3187   my $dbh = dbh;
3188
3189   my @errors;
3190   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3191                          @$remove_pkgnum;
3192
3193   while(scalar(@old_cust_pkg)) {
3194     my @return = ();
3195     my $custnum = $old_cust_pkg[0]->custnum;
3196     my (@remove) = map { $_->pkgnum }
3197                    grep { $_->custnum == $custnum } @old_cust_pkg;
3198     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3199
3200     my $error = order $custnum, $pkgparts, \@remove, \@return;
3201
3202     push @errors, $error
3203       if $error;
3204     push @$return_cust_pkg, @return;
3205   }
3206
3207   if (scalar(@errors)) {
3208     $dbh->rollback if $oldAutoCommit;
3209     return join(' / ', @errors);
3210   }
3211
3212   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3213   '';
3214 }
3215
3216 # Used by FS::Upgrade to migrate to a new database.
3217 sub _upgrade_data {  # class method
3218   my ($class, %opts) = @_;
3219   $class->_upgrade_otaker(%opts);
3220 }
3221
3222 =back
3223
3224 =head1 BUGS
3225
3226 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3227
3228 In sub order, the @pkgparts array (passed by reference) is clobbered.
3229
3230 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3231 method to pass dates to the recur_prog expression, it should do so.
3232
3233 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3234 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3235 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3236 configuration values.  Probably need a subroutine which decides what to do
3237 based on whether or not we've fetched the user yet, rather than a hash.  See
3238 FS::UID and the TODO.
3239
3240 Now that things are transactional should the check in the insert method be
3241 moved to check ?
3242
3243 =head1 SEE ALSO
3244
3245 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3246 L<FS::pkg_svc>, schema.html from the base documentation
3247
3248 =cut
3249
3250 1;
3251