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