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 $error = send_email(
 712       'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 713       'to'      => \@invoicing_list,
 714       'subject' => ( $conf->config('cancelsubject') || 'Cancellation Notice' ),
 715       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 716     );
 717     #should this do something on errors?
 718   }
 719
 720   ''; #no errors
 721
 722 }
 723
 724 =item cancel_if_expired [ NOW_TIMESTAMP ]
 725
 726 Cancels this package if its expire date has been reached.
 727
 728 =cut
 729
 730 sub cancel_if_expired {
 731   my $self = shift;
 732   my $time = shift || time;
 733   return '' unless $self->expire && $self->expire <= $time;
 734   my $error = $self->cancel;
 735   if ( $error ) {
 736     return "Error cancelling expired pkg ". $self->pkgnum. " for custnum ".
 737            $self->custnum. ": $error";
 738   }
 739   '';
 740 }
 741
 742 =item unexpire
 743
 744 Cancels any pending expiration (sets the expire field to null).
 745
 746 If there is an error, returns the error, otherwise returns false.
 747
 748 =cut
 749
 750 sub unexpire {
 751   my( $self, %options ) = @_;
 752   my $error;
 753
 754   local $SIG{HUP} = 'IGNORE';
 755   local $SIG{INT} = 'IGNORE';
 756   local $SIG{QUIT} = 'IGNORE';
 757   local $SIG{TERM} = 'IGNORE';
 758   local $SIG{TSTP} = 'IGNORE';
 759   local $SIG{PIPE} = 'IGNORE';
 760
 761   my $oldAutoCommit = $FS::UID::AutoCommit;
 762   local $FS::UID::AutoCommit = 0;
 763   my $dbh = dbh;
 764
 765   my $old = $self->select_for_update;
 766
 767   my $pkgnum = $old->pkgnum;
 768   if ( $old->get('cancel') || $self->get('cancel') ) {
 769     dbh->rollback if $oldAutoCommit;
 770     return "Can't unexpire cancelled package $pkgnum";
 771     # or at least it's pointless
 772   }
 773
 774   unless ( $old->get('expire') && $self->get('expire') ) {
 775     dbh->rollback if $oldAutoCommit;
 776     return "";  # no error
 777   }
 778
 779   my %hash = $self->hash;
 780   $hash{'expire'} = '';
 781   my $new = new FS::cust_pkg ( \%hash );
 782   $error = $new->replace( $self, options => { $self->options } );
 783   if ( $error ) {
 784     $dbh->rollback if $oldAutoCommit;
 785     return $error;
 786   }
 787
 788   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 789
 790   ''; #no errors
 791
 792 }
 793
 794 =item suspend [ OPTION => VALUE ... ]
 795
 796 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 797 package, then suspends the package itself (sets the susp field to now).
 798
 799 Available options are:
 800
 801 =over 4
 802
 803 =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.
 804
 805 =item date - can be set to a unix style timestamp to specify when to suspend (adjourn)
 806
 807 =back
 808
 809 If there is an error, returns the error, otherwise returns false.
 810
 811 =cut
 812
 813 sub suspend {
 814   my( $self, %options ) = @_;
 815   my $error;
 816
 817   local $SIG{HUP} = 'IGNORE';
 818   local $SIG{INT} = 'IGNORE';
 819   local $SIG{QUIT} = 'IGNORE';
 820   local $SIG{TERM} = 'IGNORE';
 821   local $SIG{TSTP} = 'IGNORE';
 822   local $SIG{PIPE} = 'IGNORE';
 823
 824   my $oldAutoCommit = $FS::UID::AutoCommit;
 825   local $FS::UID::AutoCommit = 0;
 826   my $dbh = dbh;
 827
 828   my $old = $self->select_for_update;
 829
 830   my $pkgnum = $old->pkgnum;
 831   if ( $old->get('cancel') || $self->get('cancel') ) {
 832     dbh->rollback if $oldAutoCommit;
 833     return "Can't suspend cancelled package $pkgnum";
 834   }
 835
 836   if ( $old->get('susp') || $self->get('susp') ) {
 837     dbh->rollback if $oldAutoCommit;
 838     return "";  # no error                     # complain on adjourn?
 839   }
 840
 841   my $date = $options{date} if $options{date}; # adjourn/suspend later
 842   $date = '' if ($date && $date <= time);      # complain instead?
 843
 844   if ( $date && $old->get('expire') && $old->get('expire') < $date ) {
 845     dbh->rollback if $oldAutoCommit;
 846     return "Package $pkgnum expires before it would be suspended.";
 847   }
 848
 849   my $suspend_time = $options{'time'} || time;
 850
 851   if ( $options{'reason'} ) {
 852     $error = $self->insert_reason( 'reason' => $options{'reason'},
 853                                    'action' => $date ? 'adjourn' : 'suspend',
 854                                    'date'   => $date ? $date : $suspend_time,
 855                                    'reason_otaker' => $options{'reason_otaker'},
 856                                  );
 857     if ( $error ) {
 858       dbh->rollback if $oldAutoCommit;
 859       return "Error inserting cust_pkg_reason: $error";
 860     }
 861   }
 862
 863   unless ( $date ) {
 864
 865     my @labels = ();
 866
 867     foreach my $cust_svc (
 868       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 869     ) {
 870       my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 871
 872       $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 873         $dbh->rollback if $oldAutoCommit;
 874         return "Illegal svcdb value in part_svc!";
 875       };
 876       my $svcdb = $1;
 877       require "FS/$svcdb.pm";
 878
 879       my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 880       if ($svc) {
 881         $error = $svc->suspend;
 882         if ( $error ) {
 883           $dbh->rollback if $oldAutoCommit;
 884           return $error;
 885         }
 886         my( $label, $value ) = $cust_svc->label;
 887         push @labels, "$label: $value";
 888       }
 889     }
 890
 891     my $conf = new FS::Conf;
 892     if ( $conf->config('suspend_email_admin') ) {
 893
 894       my $error = send_email(
 895         'from'    => $conf->config('invoice_from', $self->cust_main->agentnum),
 896                                    #invoice_from ??? well as good as any
 897         'to'      => $conf->config('suspend_email_admin'),
 898         'subject' => 'FREESIDE NOTIFICATION: Customer package suspended',
 899         'body'    => [
 900           "This is an automatic message from your Freeside installation\n",
 901           "informing you that the following customer package has been suspended:\n",
 902           "\n",
 903           'Customer: #'. $self->custnum. ' '. $self->cust_main->name. "\n",
 904           'Package : #'. $self->pkgnum. " (". $self->part_pkg->pkg_comment. ")\n",
 905           ( map { "Service : $_\n" } @labels ),
 906         ],
 907       );
 908
 909       if ( $error ) {
 910         warn "WARNING: can't send suspension admin email (suspending anyway): ".
 911              "$error\n";
 912       }
 913
 914     }
 915
 916   }
 917
 918   my %hash = $self->hash;
 919   if ( $date ) {
 920     $hash{'adjourn'} = $date;
 921   } else {
 922     $hash{'susp'} = $suspend_time;
 923   }
 924   my $new = new FS::cust_pkg ( \%hash );
 925   $error = $new->replace( $self, options => { $self->options } );
 926   if ( $error ) {
 927     $dbh->rollback if $oldAutoCommit;
 928     return $error;
 929   }
 930
 931   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 932
 933   ''; #no errors
 934 }
 935
 936 =item unsuspend [ OPTION => VALUE ... ]
 937
 938 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 939 package, then unsuspends the package itself (clears the susp field and the
 940 adjourn field if it is in the past).
 941
 942 Available options are:
 943
 944 =over 4
 945
 946 =item adjust_next_bill
 947
 948 Can be set true to adjust the next bill date forward by
 949 the amount of time the account was inactive.  This was set true by default
 950 since 1.4.2 and 1.5.0pre6; however, starting with 1.7.0 this needs to be
 951 explicitly requested.  Price plans for which this makes sense (anniversary-date
 952 based than prorate or subscription) could have an option to enable this
 953 behaviour?
 954
 955 =back
 956
 957 If there is an error, returns the error, otherwise returns false.
 958
 959 =cut
 960
 961 sub unsuspend {
 962   my( $self, %opt ) = @_;
 963   my $error;
 964
 965   local $SIG{HUP} = 'IGNORE';
 966   local $SIG{INT} = 'IGNORE';
 967   local $SIG{QUIT} = 'IGNORE';
 968   local $SIG{TERM} = 'IGNORE';
 969   local $SIG{TSTP} = 'IGNORE';
 970   local $SIG{PIPE} = 'IGNORE';
 971
 972   my $oldAutoCommit = $FS::UID::AutoCommit;
 973   local $FS::UID::AutoCommit = 0;
 974   my $dbh = dbh;
 975
 976   my $old = $self->select_for_update;
 977
 978   my $pkgnum = $old->pkgnum;
 979   if ( $old->get('cancel') || $self->get('cancel') ) {
 980     dbh->rollback if $oldAutoCommit;
 981     return "Can't unsuspend cancelled package $pkgnum";
 982   }
 983
 984   unless ( $old->get('susp') && $self->get('susp') ) {
 985     dbh->rollback if $oldAutoCommit;
 986     return "";  # no error                     # complain instead?
 987   }
 988
 989   foreach my $cust_svc (
 990     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 991   ) {
 992     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 993
 994     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 995       $dbh->rollback if $oldAutoCommit;
 996       return "Illegal svcdb value in part_svc!";
 997     };
 998     my $svcdb = $1;
 999     require "FS/$svcdb.pm";
1000
1001     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
1002     if ($svc) {
1003       $error = $svc->unsuspend;
1004       if ( $error ) {
1005         $dbh->rollback if $oldAutoCommit;
1006         return $error;
1007       }
1008     }
1009
1010   }
1011
1012   my %hash = $self->hash;
1013   my $inactive = time - $hash{'susp'};
1014
1015   my $conf = new FS::Conf;
1016
1017   $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
1018     if ( $opt{'adjust_next_bill'}
1019          || $conf->exists('unsuspend-always_adjust_next_bill_date') )
1020     && $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
1021
1022   $hash{'susp'} = '';
1023   $hash{'adjourn'} = '' if $hash{'adjourn'} < time;
1024   my $new = new FS::cust_pkg ( \%hash );
1025   $error = $new->replace( $self, options => { $self->options } );
1026   if ( $error ) {
1027     $dbh->rollback if $oldAutoCommit;
1028     return $error;
1029   }
1030
1031   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1032
1033   ''; #no errors
1034 }
1035
1036 =item unadjourn
1037
1038 Cancels any pending suspension (sets the adjourn field to null).
1039
1040 If there is an error, returns the error, otherwise returns false.
1041
1042 =cut
1043
1044 sub unadjourn {
1045   my( $self, %options ) = @_;
1046   my $error;
1047
1048   local $SIG{HUP} = 'IGNORE';
1049   local $SIG{INT} = 'IGNORE';
1050   local $SIG{QUIT} = 'IGNORE';
1051   local $SIG{TERM} = 'IGNORE';
1052   local $SIG{TSTP} = 'IGNORE';
1053   local $SIG{PIPE} = 'IGNORE';
1054
1055   my $oldAutoCommit = $FS::UID::AutoCommit;
1056   local $FS::UID::AutoCommit = 0;
1057   my $dbh = dbh;
1058
1059   my $old = $self->select_for_update;
1060
1061   my $pkgnum = $old->pkgnum;
1062   if ( $old->get('cancel') || $self->get('cancel') ) {
1063     dbh->rollback if $oldAutoCommit;
1064     return "Can't unadjourn cancelled package $pkgnum";
1065     # or at least it's pointless
1066   }
1067
1068   if ( $old->get('susp') || $self->get('susp') ) {
1069     dbh->rollback if $oldAutoCommit;
1070     return "Can't unadjourn suspended package $pkgnum";
1071     # perhaps this is arbitrary
1072   }
1073
1074   unless ( $old->get('adjourn') && $self->get('adjourn') ) {
1075     dbh->rollback if $oldAutoCommit;
1076     return "";  # no error
1077   }
1078
1079   my %hash = $self->hash;
1080   $hash{'adjourn'} = '';
1081   my $new = new FS::cust_pkg ( \%hash );
1082   $error = $new->replace( $self, options => { $self->options } );
1083   if ( $error ) {
1084     $dbh->rollback if $oldAutoCommit;
1085     return $error;
1086   }
1087
1088   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1089
1090   ''; #no errors
1091
1092 }
1093
1094
1095 =item change HASHREF | OPTION => VALUE ...
1096
1097 Changes this package: cancels it and creates a new one, with a different
1098 pkgpart or locationnum or both.  All services are transferred to the new
1099 package (no change will be made if this is not possible).
1100
1101 Options may be passed as a list of key/value pairs or as a hash reference.
1102 Options are:
1103
1104 =over 4
1105
1106 =item locaitonnum
1107
1108 New locationnum, to change the location for this package.
1109
1110 =item cust_location
1111
1112 New FS::cust_location object, to create a new location and assign it
1113 to this package.
1114
1115 =item pkgpart
1116
1117 New pkgpart (see L<FS::part_pkg>).
1118
1119 =item refnum
1120
1121 New refnum (see L<FS::part_referral>).
1122
1123 =back
1124
1125 At least one option must be specified (otherwise, what's the point?)
1126
1127 Returns either the new FS::cust_pkg object or a scalar error.
1128
1129 For example:
1130
1131   my $err_or_new_cust_pkg = $old_cust_pkg->change
1132
1133 =cut
1134
1135 #some false laziness w/order
1136 sub change {
1137   my $self = shift;
1138   my $opt = ref($_[0]) ? shift : { @_ };
1139
1140 #  my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
1141 #
1142
1143   my $conf = new FS::Conf;
1144
1145   # Transactionize this whole mess
1146   local $SIG{HUP} = 'IGNORE';
1147   local $SIG{INT} = 'IGNORE';
1148   local $SIG{QUIT} = 'IGNORE';
1149   local $SIG{TERM} = 'IGNORE';
1150   local $SIG{TSTP} = 'IGNORE';
1151   local $SIG{PIPE} = 'IGNORE';
1152
1153   my $oldAutoCommit = $FS::UID::AutoCommit;
1154   local $FS::UID::AutoCommit = 0;
1155   my $dbh = dbh;
1156
1157   my $error;
1158
1159   my %hash = ();
1160
1161   my $time = time;
1162
1163   #$hash{$_} = $self->$_() foreach qw( last_bill bill );
1164
1165   #$hash{$_} = $self->$_() foreach qw( setup );
1166
1167   $hash{'setup'} = $time if $self->setup;
1168
1169   $hash{'change_date'} = $time;
1170   $hash{"change_$_"}  = $self->$_()
1171     foreach qw( pkgnum pkgpart locationnum );
1172
1173   if ( $opt->{'cust_location'} &&
1174        ( ! $opt->{'locationnum'} || $opt->{'locationnum'} == -1 ) ) {
1175     $error = $opt->{'cust_location'}->insert;
1176     if ( $error ) {
1177       $dbh->rollback if $oldAutoCommit;
1178       return "inserting cust_location (transaction rolled back): $error";
1179     }
1180     $opt->{'locationnum'} = $opt->{'cust_location'}->locationnum;
1181   }
1182
1183   # Create the new package.
1184   my $cust_pkg = new FS::cust_pkg {
1185     custnum      => $self->custnum,
1186     pkgpart      => ( $opt->{'pkgpart'}     || $self->pkgpart      ),
1187     refnum       => ( $opt->{'refnum'}      || $self->refnum       ),
1188     locationnum  => ( $opt->{'locationnum'} || $self->locationnum  ),
1189     %hash,
1190   };
1191
1192   $error = $cust_pkg->insert( 'change' => 1 );
1193   if ($error) {
1194     $dbh->rollback if $oldAutoCommit;
1195     return $error;
1196   }
1197
1198   # Transfer services and cancel old package.
1199
1200   $error = $self->transfer($cust_pkg);
1201   if ($error and $error == 0) {
1202     # $old_pkg->transfer failed.
1203     $dbh->rollback if $oldAutoCommit;
1204     return $error;
1205   }
1206
1207   if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1208     warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1209     $error = $self->transfer($cust_pkg, 'change_svcpart'=>1 );
1210     if ($error and $error == 0) {
1211       # $old_pkg->transfer failed.
1212       $dbh->rollback if $oldAutoCommit;
1213       return $error;
1214     }
1215   }
1216
1217   if ($error > 0) {
1218     # Transfers were successful, but we still had services left on the old
1219     # package.  We can't change the package under this circumstances, so abort.
1220     $dbh->rollback if $oldAutoCommit;
1221     return "Unable to transfer all services from package ". $self->pkgnum;
1222   }
1223
1224   #reset usage if changing pkgpart
1225   # AND usage rollover is off (otherwise adds twice, now and at package bill)
1226   if ($self->pkgpart != $cust_pkg->pkgpart) {
1227     my $part_pkg = $cust_pkg->part_pkg;
1228     $error = $part_pkg->reset_usage($cust_pkg, $part_pkg->is_prepaid
1229                                                  ? ()
1230                                                  : ( 'null' => 1 )
1231                                    )
1232       if $part_pkg->can('reset_usage') && ! $part_pkg->option('usage_rollover');
1233
1234     if ($error) {
1235       $dbh->rollback if $oldAutoCommit;
1236       return "Error setting usage values: $error";
1237     }
1238   }
1239
1240   #Good to go, cancel old package.
1241   $error = $self->cancel( quiet=>1 );
1242   if ($error) {
1243     $dbh->rollback if $oldAutoCommit;
1244     return $error;
1245   }
1246
1247   if ( $conf->exists('cust_pkg-change_pkgpart-bill_now') ) {
1248     #$self->cust_main
1249     my $error = $cust_pkg->cust_main->bill( 'pkg_list' => [ $cust_pkg ] );
1250     if ( $error ) {
1251       $dbh->rollback if $oldAutoCommit;
1252       return $error;
1253     }
1254   }
1255
1256   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1257
1258   $cust_pkg;
1259
1260 }
1261
1262 =item last_bill
1263
1264 Returns the last bill date, or if there is no last bill date, the setup date.
1265 Useful for billing metered services.
1266
1267 =cut
1268
1269 sub last_bill {
1270   my $self = shift;
1271   return $self->setfield('last_bill', $_[0]) if @_;
1272   return $self->getfield('last_bill') if $self->getfield('last_bill');
1273   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
1274                                                   'edate'  => $self->bill,  } );
1275   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
1276 }
1277
1278 =item last_cust_pkg_reason ACTION
1279
1280 Returns the most recent ACTION FS::cust_pkg_reason associated with the package.
1281 Returns false if there is no reason or the package is not currenly ACTION'd
1282 ACTION is one of adjourn, susp, cancel, or expire.
1283
1284 =cut
1285
1286 sub last_cust_pkg_reason {
1287   my ( $self, $action ) = ( shift, shift );
1288   my $date = $self->get($action);
1289   qsearchs( {
1290               'table' => 'cust_pkg_reason',
1291               'hashref' => { 'pkgnum' => $self->pkgnum,
1292                              'action' => substr(uc($action), 0, 1),
1293                              'date'   => $date,
1294                            },
1295               'order_by' => 'ORDER BY num DESC LIMIT 1',
1296            } );
1297 }
1298
1299 =item last_reason ACTION
1300
1301 Returns the most recent ACTION FS::reason associated with the package.
1302 Returns false if there is no reason or the package is not currenly ACTION'd
1303 ACTION is one of adjourn, susp, cancel, or expire.
1304
1305 =cut
1306
1307 sub last_reason {
1308   my $cust_pkg_reason = shift->last_cust_pkg_reason(@_);
1309   $cust_pkg_reason->reason
1310     if $cust_pkg_reason;
1311 }
1312
1313 =item part_pkg
1314
1315 Returns the definition for this billing item, as an FS::part_pkg object (see
1316 L<FS::part_pkg>).
1317
1318 =cut
1319
1320 sub part_pkg {
1321   my $self = shift;
1322   return $self->{'_pkgpart'} if $self->{'_pkgpart'};
1323   cluck "cust_pkg->part_pkg called" if $DEBUG > 1;
1324   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
1325 }
1326
1327 =item old_cust_pkg
1328
1329 Returns the cancelled package this package was changed from, if any.
1330
1331 =cut
1332
1333 sub old_cust_pkg {
1334   my $self = shift;
1335   return '' unless $self->change_pkgnum;
1336   qsearchs('cust_pkg', { 'pkgnum' => $self->change_pkgnum } );
1337 }
1338
1339 =item calc_setup
1340
1341 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
1342 item.
1343
1344 =cut
1345
1346 sub calc_setup {
1347   my $self = shift;
1348   $self->part_pkg->calc_setup($self, @_);
1349 }
1350
1351 =item calc_recur
1352
1353 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
1354 item.
1355
1356 =cut
1357
1358 sub calc_recur {
1359   my $self = shift;
1360   $self->part_pkg->calc_recur($self, @_);
1361 }
1362
1363 =item calc_remain
1364
1365 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1366 billing item.
1367
1368 =cut
1369
1370 sub calc_remain {
1371   my $self = shift;
1372   $self->part_pkg->calc_remain($self, @_);
1373 }
1374
1375 =item calc_cancel
1376
1377 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1378 billing item.
1379
1380 =cut
1381
1382 sub calc_cancel {
1383   my $self = shift;
1384   $self->part_pkg->calc_cancel($self, @_);
1385 }
1386
1387 =item cust_bill_pkg
1388
1389 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1390
1391 =cut
1392
1393 sub cust_bill_pkg {
1394   my $self = shift;
1395   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1396 }
1397
1398 =item cust_pkg_detail [ DETAILTYPE ]
1399
1400 Returns any customer package details for this package (see
1401 L<FS::cust_pkg_detail>).
1402
1403 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1404
1405 =cut
1406
1407 sub cust_pkg_detail {
1408   my $self = shift;
1409   my %hash = ( 'pkgnum' => $self->pkgnum );
1410   $hash{detailtype} = shift if @_;
1411   qsearch({
1412     'table'    => 'cust_pkg_detail',
1413     'hashref'  => \%hash,
1414     'order_by' => 'ORDER BY weight, pkgdetailnum',
1415   });
1416 }
1417
1418 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1419
1420 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1421
1422 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1423
1424 If there is an error, returns the error, otherwise returns false.
1425
1426 =cut
1427
1428 sub set_cust_pkg_detail {
1429   my( $self, $detailtype, @details ) = @_;
1430
1431   local $SIG{HUP} = 'IGNORE';
1432   local $SIG{INT} = 'IGNORE';
1433   local $SIG{QUIT} = 'IGNORE';
1434   local $SIG{TERM} = 'IGNORE';
1435   local $SIG{TSTP} = 'IGNORE';
1436   local $SIG{PIPE} = 'IGNORE';
1437
1438   my $oldAutoCommit = $FS::UID::AutoCommit;
1439   local $FS::UID::AutoCommit = 0;
1440   my $dbh = dbh;
1441
1442   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1443     my $error = $current->delete;
1444     if ( $error ) {
1445       $dbh->rollback if $oldAutoCommit;
1446       return "error removing old detail: $error";
1447     }
1448   }
1449
1450   foreach my $detail ( @details ) {
1451     my $cust_pkg_detail = new FS::cust_pkg_detail {
1452       'pkgnum'     => $self->pkgnum,
1453       'detailtype' => $detailtype,
1454       'detail'     => $detail,
1455     };
1456     my $error = $cust_pkg_detail->insert;
1457     if ( $error ) {
1458       $dbh->rollback if $oldAutoCommit;
1459       return "error adding new detail: $error";
1460     }
1461
1462   }
1463
1464   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1465   '';
1466
1467 }
1468
1469 =item cust_event
1470
1471 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1472
1473 =cut
1474
1475 #false laziness w/cust_bill.pm
1476 sub cust_event {
1477   my $self = shift;
1478   qsearch({
1479     'table'     => 'cust_event',
1480     'addl_from' => 'JOIN part_event USING ( eventpart )',
1481     'hashref'   => { 'tablenum' => $self->pkgnum },
1482     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1483   });
1484 }
1485
1486 =item num_cust_event
1487
1488 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1489
1490 =cut
1491
1492 #false laziness w/cust_bill.pm
1493 sub num_cust_event {
1494   my $self = shift;
1495   my $sql =
1496     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1497     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1498   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1499   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1500   $sth->fetchrow_arrayref->[0];
1501 }
1502
1503 =item cust_svc [ SVCPART ]
1504
1505 Returns the services for this package, as FS::cust_svc objects (see
1506 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1507 services.
1508
1509 =cut
1510
1511 sub cust_svc {
1512   my $self = shift;
1513
1514   return () unless $self->num_cust_svc(@_);
1515
1516   if ( @_ ) {
1517     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1518                                   'svcpart' => shift,          } );
1519   }
1520
1521   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1522
1523   #if ( $self->{'_svcnum'} ) {
1524   #  values %{ $self->{'_svcnum'}->cache };
1525   #} else {
1526     $self->_sort_cust_svc(
1527       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1528     );
1529   #}
1530
1531 }
1532
1533 =item overlimit [ SVCPART ]
1534
1535 Returns the services for this package which have exceeded their
1536 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1537 is specified, return only the matching services.
1538
1539 =cut
1540
1541 sub overlimit {
1542   my $self = shift;
1543   return () unless $self->num_cust_svc(@_);
1544   grep { $_->overlimit } $self->cust_svc(@_);
1545 }
1546
1547 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1548
1549 Returns historical services for this package created before END TIMESTAMP and
1550 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1551 (see L<FS::h_cust_svc>).
1552
1553 =cut
1554
1555 sub h_cust_svc {
1556   my $self = shift;
1557
1558   $self->_sort_cust_svc(
1559     [ qsearch( 'h_cust_svc',
1560                { 'pkgnum' => $self->pkgnum, },
1561                FS::h_cust_svc->sql_h_search(@_),
1562              )
1563     ]
1564   );
1565 }
1566
1567 sub _sort_cust_svc {
1568   my( $self, $arrayref ) = @_;
1569
1570   my $sort =
1571     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1572
1573   map  { $_->[0] }
1574   sort $sort
1575   map {
1576         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1577                                              'svcpart' => $_->svcpart     } );
1578         [ $_,
1579           $pkg_svc ? $pkg_svc->primary_svc : '',
1580           $pkg_svc ? $pkg_svc->quantity : 0,
1581         ];
1582       }
1583   @$arrayref;
1584
1585 }
1586
1587 =item num_cust_svc [ SVCPART ]
1588
1589 Returns the number of provisioned services for this package.  If a svcpart is
1590 specified, counts only the matching services.
1591
1592 =cut
1593
1594 sub num_cust_svc {
1595   my $self = shift;
1596
1597   return $self->{'_num_cust_svc'}
1598     if !scalar(@_)
1599        && exists($self->{'_num_cust_svc'})
1600        && $self->{'_num_cust_svc'} =~ /\d/;
1601
1602   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1603     if $DEBUG > 2;
1604
1605   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1606   $sql .= ' AND svcpart = ?' if @_;
1607
1608   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1609   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1610   $sth->fetchrow_arrayref->[0];
1611 }
1612
1613 =item available_part_svc
1614
1615 Returns a list of FS::part_svc objects representing services included in this
1616 package but not yet provisioned.  Each FS::part_svc object also has an extra
1617 field, I<num_avail>, which specifies the number of available services.
1618
1619 =cut
1620
1621 sub available_part_svc {
1622   my $self = shift;
1623   grep { $_->num_avail > 0 }
1624     map {
1625           my $part_svc = $_->part_svc;
1626           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1627             $_->quantity - $self->num_cust_svc($_->svcpart);
1628           $part_svc;
1629         }
1630       $self->part_pkg->pkg_svc;
1631 }
1632
1633 =item part_svc
1634
1635 Returns a list of FS::part_svc objects representing provisioned and available
1636 services included in this package.  Each FS::part_svc object also has the
1637 following extra fields:
1638
1639 =over 4
1640
1641 =item num_cust_svc  (count)
1642
1643 =item num_avail     (quantity - count)
1644
1645 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1646
1647 svcnum
1648 label -> ($cust_svc->label)[1]
1649
1650 =back
1651
1652 =cut
1653
1654 sub part_svc {
1655   my $self = shift;
1656
1657   #XXX some sort of sort order besides numeric by svcpart...
1658   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1659     my $pkg_svc = $_;
1660     my $part_svc = $pkg_svc->part_svc;
1661     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1662     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1663     $part_svc->{'Hash'}{'num_avail'}    =
1664       max( 0, $pkg_svc->quantity - $num_cust_svc );
1665     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1666       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1667     $part_svc;
1668   } $self->part_pkg->pkg_svc;
1669
1670   #extras
1671   push @part_svc, map {
1672     my $part_svc = $_;
1673     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1674     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1675     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1676     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1677       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1678     $part_svc;
1679   } $self->extra_part_svc;
1680
1681   @part_svc;
1682
1683 }
1684
1685 =item extra_part_svc
1686
1687 Returns a list of FS::part_svc objects corresponding to services in this
1688 package which are still provisioned but not (any longer) available in the
1689 package definition.
1690
1691 =cut
1692
1693 sub extra_part_svc {
1694   my $self = shift;
1695
1696   my $pkgnum  = $self->pkgnum;
1697   my $pkgpart = $self->pkgpart;
1698
1699 #  qsearch( {
1700 #    'table'     => 'part_svc',
1701 #    'hashref'   => {},
1702 #    'extra_sql' =>
1703 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1704 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1705 #                       AND pkg_svc.pkgpart = ?
1706 #                       AND quantity > 0
1707 #                 )
1708 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1709 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1710 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1711 #                       AND pkgnum = ?
1712 #                 )",
1713 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1714 #  } );
1715
1716 #seems to benchmark slightly faster...
1717   qsearch( {
1718     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1719     #MySQL doesn't grok DISINCT ON
1720     'select'      => 'DISTINCT part_svc.*',
1721     'table'       => 'part_svc',
1722     'addl_from'   =>
1723       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1724                                AND pkg_svc.pkgpart   = ?
1725                                AND quantity > 0
1726                              )
1727        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1728        LEFT JOIN cust_pkg USING ( pkgnum )
1729       ',
1730     'hashref'     => {},
1731     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1732     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1733   } );
1734 }
1735
1736 =item status
1737
1738 Returns a short status string for this package, currently:
1739
1740 =over 4
1741
1742 =item not yet billed
1743
1744 =item one-time charge
1745
1746 =item active
1747
1748 =item suspended
1749
1750 =item cancelled
1751
1752 =back
1753
1754 =cut
1755
1756 sub status {
1757   my $self = shift;
1758
1759   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1760
1761   return 'cancelled' if $self->get('cancel');
1762   return 'suspended' if $self->susp;
1763   return 'not yet billed' unless $self->setup;
1764   return 'one-time charge' if $freq =~ /^(0|$)/;
1765   return 'active';
1766 }
1767
1768 =item ucfirst_status
1769
1770 Returns the status with the first character capitalized.
1771
1772 =cut
1773
1774 sub ucfirst_status {
1775   ucfirst(shift->status);
1776 }
1777
1778 =item statuses
1779
1780 Class method that returns the list of possible status strings for packages
1781 (see L<the status method|/status>).  For example:
1782
1783   @statuses = FS::cust_pkg->statuses();
1784
1785 =cut
1786
1787 tie my %statuscolor, 'Tie::IxHash',
1788   'not yet billed'  => '000000',
1789   'one-time charge' => '000000',
1790   'active'          => '00CC00',
1791   'suspended'       => 'FF9900',
1792   'cancelled'       => 'FF0000',
1793 ;
1794
1795 sub statuses {
1796   my $self = shift; #could be class...
1797   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1798   #                                    # mayble split btw one-time vs. recur
1799     keys %statuscolor;
1800 }
1801
1802 =item statuscolor
1803
1804 Returns a hex triplet color string for this package's status.
1805
1806 =cut
1807
1808 sub statuscolor {
1809   my $self = shift;
1810   $statuscolor{$self->status};
1811 }
1812
1813 =item pkg_label
1814
1815 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1816 "pkg-comment" depending on user preference).
1817
1818 =cut
1819
1820 sub pkg_label {
1821   my $self = shift;
1822   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1823   $label = $self->pkgnum. ": $label"
1824     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1825   $label;
1826 }
1827
1828 =item pkg_label_long
1829
1830 Returns a long label for this package, adding the primary service's label to
1831 pkg_label.
1832
1833 =cut
1834
1835 sub pkg_label_long {
1836   my $self = shift;
1837   my $label = $self->pkg_label;
1838   my $cust_svc = $self->primary_cust_svc;
1839   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1840   $label;
1841 }
1842
1843 =item primary_cust_svc
1844
1845 Returns a primary service (as FS::cust_svc object) if one can be identified.
1846
1847 =cut
1848
1849 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1850
1851 sub primary_cust_svc {
1852   my $self = shift;
1853
1854   my @cust_svc = $self->cust_svc;
1855
1856   return '' unless @cust_svc; #no serivces - irrelevant then
1857
1858   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1859
1860   # primary service as specified in the package definition
1861   # or exactly one service definition with quantity one
1862   my $svcpart = $self->part_pkg->svcpart;
1863   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1864   return $cust_svc[0] if scalar(@cust_svc) == 1;
1865
1866   #couldn't identify one thing..
1867   return '';
1868 }
1869
1870 =item labels
1871
1872 Returns a list of lists, calling the label method for all services
1873 (see L<FS::cust_svc>) of this billing item.
1874
1875 =cut
1876
1877 sub labels {
1878   my $self = shift;
1879   map { [ $_->label ] } $self->cust_svc;
1880 }
1881
1882 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1883
1884 Like the labels method, but returns historical information on services that
1885 were active as of END_TIMESTAMP and (optionally) not cancelled before
1886 START_TIMESTAMP.
1887
1888 Returns a list of lists, calling the label method for all (historical) services
1889 (see L<FS::h_cust_svc>) of this billing item.
1890
1891 =cut
1892
1893 sub h_labels {
1894   my $self = shift;
1895   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1896 }
1897
1898 =item labels_short
1899
1900 Like labels, except returns a simple flat list, and shortens long
1901 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1902 identical services to one line that lists the service label and the number of
1903 individual services rather than individual items.
1904
1905 =cut
1906
1907 sub labels_short {
1908   shift->_labels_short( 'labels', @_ );
1909 }
1910
1911 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1912
1913 Like h_labels, except returns a simple flat list, and shortens long
1914 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1915 identical services to one line that lists the service label and the number of
1916 individual services rather than individual items.
1917
1918 =cut
1919
1920 sub h_labels_short {
1921   shift->_labels_short( 'h_labels', @_ );
1922 }
1923
1924 sub _labels_short {
1925   my( $self, $method ) = ( shift, shift );
1926
1927   my $conf = new FS::Conf;
1928   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1929
1930   my %labels;
1931   #tie %labels, 'Tie::IxHash';
1932   push @{ $labels{$_->[0]} }, $_->[1]
1933     foreach $self->h_labels(@_);
1934   my @labels;
1935   foreach my $label ( keys %labels ) {
1936     my %seen = ();
1937     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1938     my $num = scalar(@values);
1939     if ( $num > $max_same_services ) {
1940       push @labels, "$label ($num)";
1941     } else {
1942       if ( $conf->exists('cust_bill-consolidate_services') ) {
1943         # push @labels, "$label: ". join(', ', @values);
1944         while ( @values ) {
1945           my $detail = "$label: ";
1946           $detail .= shift(@values). ', '
1947             while @values && length($detail.$values[0]) < 78;
1948           $detail =~ s/, $//;
1949           push @labels, $detail;
1950         }
1951       } else {
1952         push @labels, map { "$label: $_" } @values;
1953       }
1954     }
1955   }
1956
1957  @labels;
1958
1959 }
1960
1961 =item cust_main
1962
1963 Returns the parent customer object (see L<FS::cust_main>).
1964
1965 =cut
1966
1967 sub cust_main {
1968   my $self = shift;
1969   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1970 }
1971
1972 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1973
1974 =item cust_location
1975
1976 Returns the location object, if any (see L<FS::cust_location>).
1977
1978 =item cust_location_or_main
1979
1980 If this package is associated with a location, returns the locaiton (see
1981 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
1982
1983 =item location_label [ OPTION => VALUE ... ]
1984
1985 Returns the label of the location object (see L<FS::cust_location>).
1986
1987 =cut
1988
1989 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
1990
1991 =item seconds_since TIMESTAMP
1992
1993 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
1994 package have been online since TIMESTAMP, according to the session monitor.
1995
1996 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1997 L<Time::Local> and L<Date::Parse> for conversion functions.
1998
1999 =cut
2000
2001 sub seconds_since {
2002   my($self, $since) = @_;
2003   my $seconds = 0;
2004
2005   foreach my $cust_svc (
2006     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2007   ) {
2008     $seconds += $cust_svc->seconds_since($since);
2009   }
2010
2011   $seconds;
2012
2013 }
2014
2015 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2016
2017 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2018 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2019 (exclusive).
2020
2021 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2022 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2023 functions.
2024
2025
2026 =cut
2027
2028 sub seconds_since_sqlradacct {
2029   my($self, $start, $end) = @_;
2030
2031   my $seconds = 0;
2032
2033   foreach my $cust_svc (
2034     grep {
2035       my $part_svc = $_->part_svc;
2036       $part_svc->svcdb eq 'svc_acct'
2037         && scalar($part_svc->part_export('sqlradius'));
2038     } $self->cust_svc
2039   ) {
2040     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2041   }
2042
2043   $seconds;
2044
2045 }
2046
2047 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2048
2049 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2050 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2051 TIMESTAMP_END
2052 (exclusive).
2053
2054 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2055 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2056 functions.
2057
2058 =cut
2059
2060 sub attribute_since_sqlradacct {
2061   my($self, $start, $end, $attrib) = @_;
2062
2063   my $sum = 0;
2064
2065   foreach my $cust_svc (
2066     grep {
2067       my $part_svc = $_->part_svc;
2068       $part_svc->svcdb eq 'svc_acct'
2069         && scalar($part_svc->part_export('sqlradius'));
2070     } $self->cust_svc
2071   ) {
2072     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2073   }
2074
2075   $sum;
2076
2077 }
2078
2079 =item quantity
2080
2081 =cut
2082
2083 sub quantity {
2084   my( $self, $value ) = @_;
2085   if ( defined($value) ) {
2086     $self->setfield('quantity', $value);
2087   }
2088   $self->getfield('quantity') || 1;
2089 }
2090
2091 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2092
2093 Transfers as many services as possible from this package to another package.
2094
2095 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2096 object.  The destination package must already exist.
2097
2098 Services are moved only if the destination allows services with the correct
2099 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2100 this option with caution!  No provision is made for export differences
2101 between the old and new service definitions.  Probably only should be used
2102 when your exports for all service definitions of a given svcdb are identical.
2103 (attempt a transfer without it first, to move all possible svcpart-matching
2104 services)
2105
2106 Any services that can't be moved remain in the original package.
2107
2108 Returns an error, if there is one; otherwise, returns the number of services
2109 that couldn't be moved.
2110
2111 =cut
2112
2113 sub transfer {
2114   my ($self, $dest_pkgnum, %opt) = @_;
2115
2116   my $remaining = 0;
2117   my $dest;
2118   my %target;
2119
2120   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2121     $dest = $dest_pkgnum;
2122     $dest_pkgnum = $dest->pkgnum;
2123   } else {
2124     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2125   }
2126
2127   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2128
2129   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2130     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2131   }
2132
2133   foreach my $cust_svc ($dest->cust_svc) {
2134     $target{$cust_svc->svcpart}--;
2135   }
2136
2137   my %svcpart2svcparts = ();
2138   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2139     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2140     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2141       next if exists $svcpart2svcparts{$svcpart};
2142       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2143       $svcpart2svcparts{$svcpart} = [
2144         map  { $_->[0] }
2145         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2146         map {
2147               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2148                                                    'svcpart' => $_          } );
2149               [ $_,
2150                 $pkg_svc ? $pkg_svc->primary_svc : '',
2151                 $pkg_svc ? $pkg_svc->quantity : 0,
2152               ];
2153             }
2154
2155         grep { $_ != $svcpart }
2156         map  { $_->svcpart }
2157         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2158       ];
2159       warn "alternates for svcpart $svcpart: ".
2160            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2161         if $DEBUG;
2162     }
2163   }
2164
2165   foreach my $cust_svc ($self->cust_svc) {
2166     if($target{$cust_svc->svcpart} > 0) {
2167       $target{$cust_svc->svcpart}--;
2168       my $new = new FS::cust_svc { $cust_svc->hash };
2169       $new->pkgnum($dest_pkgnum);
2170       my $error = $new->replace($cust_svc);
2171       return $error if $error;
2172     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2173       if ( $DEBUG ) {
2174         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2175         warn "alternates to consider: ".
2176              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2177       }
2178       my @alternate = grep {
2179                              warn "considering alternate svcpart $_: ".
2180                                   "$target{$_} available in new package\n"
2181                                if $DEBUG;
2182                              $target{$_} > 0;
2183                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2184       if ( @alternate ) {
2185         warn "alternate(s) found\n" if $DEBUG;
2186         my $change_svcpart = $alternate[0];
2187         $target{$change_svcpart}--;
2188         my $new = new FS::cust_svc { $cust_svc->hash };
2189         $new->svcpart($change_svcpart);
2190         $new->pkgnum($dest_pkgnum);
2191         my $error = $new->replace($cust_svc);
2192         return $error if $error;
2193       } else {
2194         $remaining++;
2195       }
2196     } else {
2197       $remaining++
2198     }
2199   }
2200   return $remaining;
2201 }
2202
2203 =item reexport
2204
2205 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2206 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2207
2208 =cut
2209
2210 sub reexport {
2211   my $self = shift;
2212
2213   local $SIG{HUP} = 'IGNORE';
2214   local $SIG{INT} = 'IGNORE';
2215   local $SIG{QUIT} = 'IGNORE';
2216   local $SIG{TERM} = 'IGNORE';
2217   local $SIG{TSTP} = 'IGNORE';
2218   local $SIG{PIPE} = 'IGNORE';
2219
2220   my $oldAutoCommit = $FS::UID::AutoCommit;
2221   local $FS::UID::AutoCommit = 0;
2222   my $dbh = dbh;
2223
2224   foreach my $cust_svc ( $self->cust_svc ) {
2225     #false laziness w/svc_Common::insert
2226     my $svc_x = $cust_svc->svc_x;
2227     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2228       my $error = $part_export->export_insert($svc_x);
2229       if ( $error ) {
2230         $dbh->rollback if $oldAutoCommit;
2231         return $error;
2232       }
2233     }
2234   }
2235
2236   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2237   '';
2238
2239 }
2240
2241 =item insert_reason
2242
2243 Associates this package with a (suspension or cancellation) reason (see
2244 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2245 L<FS::reason>).
2246
2247 Available options are:
2248
2249 =over 4
2250
2251 =item reason
2252
2253 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.
2254
2255 =item reason_otaker
2256
2257 the access_user (see L<FS::access_user>) providing the reason
2258
2259 =item date
2260
2261 a unix timestamp
2262
2263 =item action
2264
2265 the action (cancel, susp, adjourn, expire) associated with the reason
2266
2267 =back
2268
2269 If there is an error, returns the error, otherwise returns false.
2270
2271 =cut
2272
2273 sub insert_reason {
2274   my ($self, %options) = @_;
2275
2276   my $otaker = $options{reason_otaker} ||
2277                $FS::CurrentUser::CurrentUser->username;
2278
2279   my $reasonnum;
2280   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2281
2282     $reasonnum = $1;
2283
2284   } elsif ( ref($options{'reason'}) ) {
2285
2286     return 'Enter a new reason (or select an existing one)'
2287       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2288
2289     my $reason = new FS::reason({
2290       'reason_type' => $options{'reason'}->{'typenum'},
2291       'reason'      => $options{'reason'}->{'reason'},
2292     });
2293     my $error = $reason->insert;
2294     return $error if $error;
2295
2296     $reasonnum = $reason->reasonnum;
2297
2298   } else {
2299     return "Unparsable reason: ". $options{'reason'};
2300   }
2301
2302   my $cust_pkg_reason =
2303     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2304                               'reasonnum' => $reasonnum,
2305                               'otaker'    => $otaker,
2306                               'action'    => substr(uc($options{'action'}),0,1),
2307                               'date'      => $options{'date'}
2308                                                ? $options{'date'}
2309                                                : time,
2310                             });
2311
2312   $cust_pkg_reason->insert;
2313 }
2314
2315 =item insert_discount
2316
2317 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2318 inserting a new discount on the fly (see L<FS::discount>).
2319
2320 Available options are:
2321
2322 =over 4
2323
2324 =item discountnum
2325
2326 =back
2327
2328 If there is an error, returns the error, otherwise returns false.
2329
2330 =cut
2331
2332 sub insert_discount {
2333   #my ($self, %options) = @_;
2334   my $self = shift;
2335
2336   my $cust_pkg_discount = new FS::cust_pkg_discount {
2337     'pkgnum'      => $self->pkgnum,
2338     'discountnum' => $self->discountnum,
2339     'months_used' => 0,
2340     'end_date'    => '', #XXX
2341     'otaker'      => $self->otaker,
2342     #for the create a new discount case
2343     '_type'       => $self->discountnum__type,
2344     'amount'      => $self->discountnum_amount,
2345     'percent'     => $self->discountnum_percent,
2346     'months'      => $self->discountnum_months,
2347     #'disabled'    => $self->discountnum_disabled,
2348   };
2349
2350   $cust_pkg_discount->insert;
2351 }
2352
2353 =item set_usage USAGE_VALUE_HASHREF
2354
2355 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2356 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2357 upbytes, downbytes, and totalbytes are appropriate keys.
2358
2359 All svc_accts which are part of this package have their values reset.
2360
2361 =cut
2362
2363 sub set_usage {
2364   my ($self, $valueref, %opt) = @_;
2365
2366   foreach my $cust_svc ($self->cust_svc){
2367     my $svc_x = $cust_svc->svc_x;
2368     $svc_x->set_usage($valueref, %opt)
2369       if $svc_x->can("set_usage");
2370   }
2371 }
2372
2373 =item recharge USAGE_VALUE_HASHREF
2374
2375 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2376 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2377 upbytes, downbytes, and totalbytes are appropriate keys.
2378
2379 All svc_accts which are part of this package have their values incremented.
2380
2381 =cut
2382
2383 sub recharge {
2384   my ($self, $valueref) = @_;
2385
2386   foreach my $cust_svc ($self->cust_svc){
2387     my $svc_x = $cust_svc->svc_x;
2388     $svc_x->recharge($valueref)
2389       if $svc_x->can("recharge");
2390   }
2391 }
2392
2393 =item cust_pkg_discount
2394
2395 =cut
2396
2397 sub cust_pkg_discount {
2398   my $self = shift;
2399   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2400 }
2401
2402 =item cust_pkg_discount_active
2403
2404 =cut
2405
2406 sub cust_pkg_discount_active {
2407   my $self = shift;
2408   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2409 }
2410
2411 =back
2412
2413 =head1 CLASS METHODS
2414
2415 =over 4
2416
2417 =item recurring_sql
2418
2419 Returns an SQL expression identifying recurring packages.
2420
2421 =cut
2422
2423 sub recurring_sql { "
2424   '0' != ( select freq from part_pkg
2425              where cust_pkg.pkgpart = part_pkg.pkgpart )
2426 "; }
2427
2428 =item onetime_sql
2429
2430 Returns an SQL expression identifying one-time packages.
2431
2432 =cut
2433
2434 sub onetime_sql { "
2435   '0' = ( select freq from part_pkg
2436             where cust_pkg.pkgpart = part_pkg.pkgpart )
2437 "; }
2438
2439 =item ordered_sql
2440
2441 Returns an SQL expression identifying ordered packages (recurring packages not
2442 yet billed).
2443
2444 =cut
2445
2446 sub ordered_sql {
2447    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2448 }
2449
2450 =item active_sql
2451
2452 Returns an SQL expression identifying active packages.
2453
2454 =cut
2455
2456 sub active_sql {
2457   $_[0]->recurring_sql. "
2458   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2459   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2460   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2461 "; }
2462
2463 =item not_yet_billed_sql
2464
2465 Returns an SQL expression identifying packages which have not yet been billed.
2466
2467 =cut
2468
2469 sub not_yet_billed_sql { "
2470       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2471   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2472   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2473 "; }
2474
2475 =item inactive_sql
2476
2477 Returns an SQL expression identifying inactive packages (one-time packages
2478 that are otherwise unsuspended/uncancelled).
2479
2480 =cut
2481
2482 sub inactive_sql { "
2483   ". $_[0]->onetime_sql(). "
2484   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2485   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2486   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2487 "; }
2488
2489 =item susp_sql
2490 =item suspended_sql
2491
2492 Returns an SQL expression identifying suspended packages.
2493
2494 =cut
2495
2496 sub suspended_sql { susp_sql(@_); }
2497 sub susp_sql {
2498   #$_[0]->recurring_sql(). ' AND '.
2499   "
2500         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2501     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2502   ";
2503 }
2504
2505 =item cancel_sql
2506 =item cancelled_sql
2507
2508 Returns an SQL exprression identifying cancelled packages.
2509
2510 =cut
2511
2512 sub cancelled_sql { cancel_sql(@_); }
2513 sub cancel_sql {
2514   #$_[0]->recurring_sql(). ' AND '.
2515   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2516 }
2517
2518 =item search HASHREF
2519
2520 (Class method)
2521
2522 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2523 Valid parameters are
2524
2525 =over 4
2526
2527 =item agentnum
2528
2529 =item magic
2530
2531 active, inactive, suspended, cancel (or cancelled)
2532
2533 =item status
2534
2535 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2536
2537 =item custom
2538
2539  boolean selects custom packages
2540
2541 =item classnum
2542
2543 =item pkgpart
2544
2545 pkgpart or arrayref or hashref of pkgparts
2546
2547 =item setup
2548
2549 arrayref of beginning and ending epoch date
2550
2551 =item last_bill
2552
2553 arrayref of beginning and ending epoch date
2554
2555 =item bill
2556
2557 arrayref of beginning and ending epoch date
2558
2559 =item adjourn
2560
2561 arrayref of beginning and ending epoch date
2562
2563 =item susp
2564
2565 arrayref of beginning and ending epoch date
2566
2567 =item expire
2568
2569 arrayref of beginning and ending epoch date
2570
2571 =item cancel
2572
2573 arrayref of beginning and ending epoch date
2574
2575 =item query
2576
2577 pkgnum or APKG_pkgnum
2578
2579 =item cust_fields
2580
2581 a value suited to passing to FS::UI::Web::cust_header
2582
2583 =item CurrentUser
2584
2585 specifies the user for agent virtualization
2586
2587 =item fcc_line
2588
2589  boolean selects packages containing fcc form 477 telco lines
2590
2591 =back
2592
2593 =cut
2594
2595 sub search {
2596   my ($class, $params) = @_;
2597   my @where = ();
2598
2599   ##
2600   # parse agent
2601   ##
2602
2603   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2604     push @where,
2605       "cust_main.agentnum = $1";
2606   }
2607
2608   ##
2609   # parse custnum
2610   ##
2611
2612   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2613     push @where,
2614       "cust_pkg.custnum = $1";
2615   }
2616
2617   ##
2618   # parse status
2619   ##
2620
2621   if (    $params->{'magic'}  eq 'active'
2622        || $params->{'status'} eq 'active' ) {
2623
2624     push @where, FS::cust_pkg->active_sql();
2625
2626   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2627             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2628
2629     push @where, FS::cust_pkg->not_yet_billed_sql();
2630
2631   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2632             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2633
2634     push @where, FS::cust_pkg->inactive_sql();
2635
2636   } elsif (    $params->{'magic'}  eq 'suspended'
2637             || $params->{'status'} eq 'suspended'  ) {
2638
2639     push @where, FS::cust_pkg->suspended_sql();
2640
2641   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2642             || $params->{'status'} =~ /^cancell?ed$/ ) {
2643
2644     push @where, FS::cust_pkg->cancelled_sql();
2645
2646   }
2647
2648   ###
2649   # parse package class
2650   ###
2651
2652   #false lazinessish w/graph/cust_bill_pkg.cgi
2653   my $classnum = 0;
2654   my @pkg_class = ();
2655   if ( exists($params->{'classnum'})
2656        && $params->{'classnum'} =~ /^(\d*)$/
2657      )
2658   {
2659     $classnum = $1;
2660     if ( $classnum ) { #a specific class
2661       push @where, "part_pkg.classnum = $classnum";
2662
2663       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2664       #die "classnum $classnum not found!" unless $pkg_class[0];
2665       #$title .= $pkg_class[0]->classname.' ';
2666
2667     } elsif ( $classnum eq '' ) { #the empty class
2668
2669       push @where, "part_pkg.classnum IS NULL";
2670       #$title .= 'Empty class ';
2671       #@pkg_class = ( '(empty class)' );
2672     } elsif ( $classnum eq '0' ) {
2673       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2674       #push @pkg_class, '(empty class)';
2675     } else {
2676       die "illegal classnum";
2677     }
2678   }
2679   #eslaf
2680
2681   ###
2682   # parse package report options
2683   ###
2684
2685   my @report_option = ();
2686   if ( exists($params->{'report_option'})
2687        && $params->{'report_option'} =~ /^([,\d]*)$/
2688      )
2689   {
2690     @report_option = split(',', $1);
2691   }
2692
2693   if (@report_option) {
2694     # this will result in the empty set for the dangling comma case as it should
2695     push @where,
2696       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2697                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2698                     AND optionname = 'report_option_$_'
2699                     AND optionvalue = '1' )"
2700          } @report_option;
2701   }
2702
2703   #eslaf
2704
2705   ###
2706   # parse custom
2707   ###
2708
2709   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2710
2711   ###
2712   # parse fcc_line
2713   ###
2714
2715   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2716
2717   ###
2718   # parse censustract
2719   ###
2720
2721   if ( exists($params->{'censustract'}) ) {
2722     $params->{'censustract'} =~ /^([.\d]*)$/;
2723     my $censustract = "cust_main.censustract = '$1'";
2724     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2725     push @where,  "( $censustract )";
2726   }
2727
2728   ###
2729   # parse part_pkg
2730   ###
2731
2732   if ( ref($params->{'pkgpart'}) ) {
2733
2734     my @pkgpart = ();
2735     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2736       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2737     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2738       @pkgpart = @{ $params->{'pkgpart'} };
2739     } else {
2740       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2741     }
2742
2743     @pkgpart = grep /^(\d+)$/, @pkgpart;
2744
2745     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2746
2747   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2748     push @where, "pkgpart = $1";
2749   }
2750
2751   ###
2752   # parse dates
2753   ###
2754
2755   my $orderby = '';
2756
2757   #false laziness w/report_cust_pkg.html
2758   my %disable = (
2759     'all'             => {},
2760     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2761     'active'          => { 'susp'=>1, 'cancel'=>1 },
2762     'suspended'       => { 'cancel' => 1 },
2763     'cancelled'       => {},
2764     ''                => {},
2765   );
2766
2767   if( exists($params->{'active'} ) ) {
2768     # This overrides all the other date-related fields
2769     my($beginning, $ending) = @{$params->{'active'}};
2770     push @where,
2771       "cust_pkg.setup IS NOT NULL",
2772       "cust_pkg.setup <= $ending",
2773       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2774       "NOT (".FS::cust_pkg->onetime_sql . ")";
2775   }
2776   else {
2777     foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2778
2779       next unless exists($params->{$field});
2780
2781       my($beginning, $ending) = @{$params->{$field}};
2782
2783       next if $beginning == 0 && $ending == 4294967295;
2784
2785       push @where,
2786         "cust_pkg.$field IS NOT NULL",
2787         "cust_pkg.$field >= $beginning",
2788         "cust_pkg.$field <= $ending";
2789
2790       $orderby ||= "ORDER BY cust_pkg.$field";
2791
2792     }
2793   }
2794
2795   $orderby ||= 'ORDER BY bill';
2796
2797   ###
2798   # parse magic, legacy, etc.
2799   ###
2800
2801   if ( $params->{'magic'} &&
2802        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2803   ) {
2804
2805     $orderby = 'ORDER BY pkgnum';
2806
2807     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2808       push @where, "pkgpart = $1";
2809     }
2810
2811   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2812
2813     $orderby = 'ORDER BY pkgnum';
2814
2815   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2816
2817     $orderby = 'ORDER BY pkgnum';
2818
2819     push @where, '0 < (
2820       SELECT count(*) FROM pkg_svc
2821        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2822          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2823                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2824                                      AND cust_svc.svcpart = pkg_svc.svcpart
2825                                 )
2826     )';
2827
2828   }
2829
2830   ##
2831   # setup queries, links, subs, etc. for the search
2832   ##
2833
2834   # here is the agent virtualization
2835   if ($params->{CurrentUser}) {
2836     my $access_user =
2837       qsearchs('access_user', { username => $params->{CurrentUser} });
2838
2839     if ($access_user) {
2840       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2841     } else {
2842       push @where, "1=0";
2843     }
2844   } else {
2845     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2846   }
2847
2848   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2849
2850   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2851                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2852                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2853
2854   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2855
2856   my $sql_query = {
2857     'table'       => 'cust_pkg',
2858     'hashref'     => {},
2859     'select'      => join(', ',
2860                                 'cust_pkg.*',
2861                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2862                                 'pkg_class.classname',
2863                                 'cust_main.custnum AS cust_main_custnum',
2864                                 FS::UI::Web::cust_sql_fields(
2865                                   $params->{'cust_fields'}
2866                                 ),
2867                      ),
2868     'extra_sql'   => "$extra_sql $orderby",
2869     'addl_from'   => $addl_from,
2870     'count_query' => $count_query,
2871   };
2872
2873 }
2874
2875 =item fcc_477_count
2876
2877 Returns a list of two package counts.  The first is a count of packages
2878 based on the supplied criteria and the second is the count of residential
2879 packages with those same criteria.  Criteria are specified as in the search
2880 method.
2881
2882 =cut
2883
2884 sub fcc_477_count {
2885   my ($class, $params) = @_;
2886
2887   my $sql_query = $class->search( $params );
2888
2889   my $count_sql = delete($sql_query->{'count_query'});
2890   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2891     or die "couldn't parse count_sql";
2892
2893   my $count_sth = dbh->prepare($count_sql)
2894     or die "Error preparing $count_sql: ". dbh->errstr;
2895   $count_sth->execute
2896     or die "Error executing $count_sql: ". $count_sth->errstr;
2897   my $count_arrayref = $count_sth->fetchrow_arrayref;
2898
2899   return ( @$count_arrayref );
2900
2901 }
2902
2903
2904 =item location_sql
2905
2906 Returns a list: the first item is an SQL fragment identifying matching
2907 packages/customers via location (taking into account shipping and package
2908 address taxation, if enabled), and subsequent items are the parameters to
2909 substitute for the placeholders in that fragment.
2910
2911 =cut
2912
2913 sub location_sql {
2914   my($class, %opt) = @_;
2915   my $ornull = $opt{'ornull'};
2916
2917   my $conf = new FS::Conf;
2918
2919   # '?' placeholders in _location_sql_where
2920   my $x = $ornull ? 3 : 2;
2921   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2922
2923   my $main_where;
2924   my @main_param;
2925   if ( $conf->exists('tax-ship_address') ) {
2926
2927     $main_where = "(
2928          (     ( ship_last IS NULL     OR  ship_last  = '' )
2929            AND ". _location_sql_where('cust_main', '', $ornull ). "
2930          )
2931       OR (       ship_last IS NOT NULL AND ship_last != ''
2932            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2933          )
2934     )";
2935     #    AND payby != 'COMP'
2936
2937     @main_param = ( @bill_param, @bill_param );
2938
2939   } else {
2940
2941     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2942     @main_param = @bill_param;
2943
2944   }
2945
2946   my $where;
2947   my @param;
2948   if ( $conf->exists('tax-pkg_address') ) {
2949
2950     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2951
2952     $where = " (
2953                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2954                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2955                )
2956              ";
2957     @param = ( @main_param, @bill_param );
2958
2959   } else {
2960
2961     $where = $main_where;
2962     @param = @main_param;
2963
2964   }
2965
2966   ( $where, @param );
2967
2968 }
2969
2970 #subroutine, helper for location_sql
2971 sub _location_sql_where {
2972   my $table  = shift;
2973   my $prefix = @_ ? shift : '';
2974   my $ornull = @_ ? shift : '';
2975
2976 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
2977
2978   $ornull = $ornull ? ' OR ? IS NULL ' : '';
2979
2980   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
2981   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
2982   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
2983
2984 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
2985   "
2986         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
2987     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
2988     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
2989     AND   $table.${prefix}country = ?
2990   ";
2991 }
2992
2993 =head1 SUBROUTINES
2994
2995 =over 4
2996
2997 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
2998
2999 CUSTNUM is a customer (see L<FS::cust_main>)
3000
3001 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3002 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3003 permitted.
3004
3005 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3006 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3007 new billing items.  An error is returned if this is not possible (see
3008 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3009 parameter.
3010
3011 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3012 newly-created cust_pkg objects.
3013
3014 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3015 and inserted.  Multiple FS::pkg_referral records can be created by
3016 setting I<refnum> to an array reference of refnums or a hash reference with
3017 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3018 record will be created corresponding to cust_main.refnum.
3019
3020 =cut
3021
3022 sub order {
3023   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3024
3025   my $conf = new FS::Conf;
3026
3027   # Transactionize this whole mess
3028   local $SIG{HUP} = 'IGNORE';
3029   local $SIG{INT} = 'IGNORE';
3030   local $SIG{QUIT} = 'IGNORE';
3031   local $SIG{TERM} = 'IGNORE';
3032   local $SIG{TSTP} = 'IGNORE';
3033   local $SIG{PIPE} = 'IGNORE';
3034
3035   my $oldAutoCommit = $FS::UID::AutoCommit;
3036   local $FS::UID::AutoCommit = 0;
3037   my $dbh = dbh;
3038
3039   my $error;
3040 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3041 #  return "Customer not found: $custnum" unless $cust_main;
3042
3043   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3044     if $DEBUG;
3045
3046   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3047                          @$remove_pkgnum;
3048
3049   my $change = scalar(@old_cust_pkg) != 0;
3050
3051   my %hash = ();
3052   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3053
3054     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3055          " to pkgpart ". $pkgparts->[0]. "\n"
3056       if $DEBUG;
3057
3058     my $err_or_cust_pkg =
3059       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3060                                 'refnum'  => $refnum,
3061                               );
3062
3063     unless (ref($err_or_cust_pkg)) {
3064       $dbh->rollback if $oldAutoCommit;
3065       return $err_or_cust_pkg;
3066     }
3067
3068     push @$return_cust_pkg, $err_or_cust_pkg;
3069     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3070     return '';
3071
3072   }
3073
3074   # Create the new packages.
3075   foreach my $pkgpart (@$pkgparts) {
3076
3077     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3078
3079     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3080                                       pkgpart => $pkgpart,
3081                                       refnum  => $refnum,
3082                                       %hash,
3083                                     };
3084     $error = $cust_pkg->insert( 'change' => $change );
3085     if ($error) {
3086       $dbh->rollback if $oldAutoCommit;
3087       return $error;
3088     }
3089     push @$return_cust_pkg, $cust_pkg;
3090   }
3091   # $return_cust_pkg now contains refs to all of the newly
3092   # created packages.
3093
3094   # Transfer services and cancel old packages.
3095   foreach my $old_pkg (@old_cust_pkg) {
3096
3097     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3098       if $DEBUG;
3099
3100     foreach my $new_pkg (@$return_cust_pkg) {
3101       $error = $old_pkg->transfer($new_pkg);
3102       if ($error and $error == 0) {
3103         # $old_pkg->transfer failed.
3104         $dbh->rollback if $oldAutoCommit;
3105         return $error;
3106       }
3107     }
3108
3109     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3110       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3111       foreach my $new_pkg (@$return_cust_pkg) {
3112         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3113         if ($error and $error == 0) {
3114           # $old_pkg->transfer failed.
3115         $dbh->rollback if $oldAutoCommit;
3116         return $error;
3117         }
3118       }
3119     }
3120
3121     if ($error > 0) {
3122       # Transfers were successful, but we went through all of the
3123       # new packages and still had services left on the old package.
3124       # We can't cancel the package under the circumstances, so abort.
3125       $dbh->rollback if $oldAutoCommit;
3126       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3127     }
3128     $error = $old_pkg->cancel( quiet=>1 );
3129     if ($error) {
3130       $dbh->rollback;
3131       return $error;
3132     }
3133   }
3134   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3135   '';
3136 }
3137
3138 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3139
3140 A bulk change method to change packages for multiple customers.
3141
3142 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3143 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3144 permitted.
3145
3146 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3147 replace.  The services (see L<FS::cust_svc>) are moved to the
3148 new billing items.  An error is returned if this is not possible (see
3149 L<FS::pkg_svc>).
3150
3151 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3152 newly-created cust_pkg objects.
3153
3154 =cut
3155
3156 sub bulk_change {
3157   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3158
3159   # Transactionize this whole mess
3160   local $SIG{HUP} = 'IGNORE';
3161   local $SIG{INT} = 'IGNORE';
3162   local $SIG{QUIT} = 'IGNORE';
3163   local $SIG{TERM} = 'IGNORE';
3164   local $SIG{TSTP} = 'IGNORE';
3165   local $SIG{PIPE} = 'IGNORE';
3166
3167   my $oldAutoCommit = $FS::UID::AutoCommit;
3168   local $FS::UID::AutoCommit = 0;
3169   my $dbh = dbh;
3170
3171   my @errors;
3172   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3173                          @$remove_pkgnum;
3174
3175   while(scalar(@old_cust_pkg)) {
3176     my @return = ();
3177     my $custnum = $old_cust_pkg[0]->custnum;
3178     my (@remove) = map { $_->pkgnum }
3179                    grep { $_->custnum == $custnum } @old_cust_pkg;
3180     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3181
3182     my $error = order $custnum, $pkgparts, \@remove, \@return;
3183
3184     push @errors, $error
3185       if $error;
3186     push @$return_cust_pkg, @return;
3187   }
3188
3189   if (scalar(@errors)) {
3190     $dbh->rollback if $oldAutoCommit;
3191     return join(' / ', @errors);
3192   }
3193
3194   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3195   '';
3196 }
3197
3198 # Used by FS::Upgrade to migrate to a new database.
3199 sub _upgrade_data {  # class method
3200   my ($class, %opts) = @_;
3201   $class->_upgrade_otaker(%opts);
3202 }
3203
3204 =back
3205
3206 =head1 BUGS
3207
3208 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3209
3210 In sub order, the @pkgparts array (passed by reference) is clobbered.
3211
3212 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3213 method to pass dates to the recur_prog expression, it should do so.
3214
3215 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3216 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3217 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3218 configuration values.  Probably need a subroutine which decides what to do
3219 based on whether or not we've fetched the user yet, rather than a hash.  See
3220 FS::UID and the TODO.
3221
3222 Now that things are transactional should the check in the insert method be
3223 moved to check ?
3224
3225 =head1 SEE ALSO
3226
3227 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3228 L<FS::pkg_svc>, schema.html from the base documentation
3229
3230 =cut
3231
3232 1;
3233