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 base_recur
1375
1376 Calls the I<base_recur> of the FS::part_pkg object associated with this billing
1377 item.
1378
1379 =cut
1380
1381 sub base_recur {
1382   my $self = shift;
1383   $self->part_pkg->base_recur($self, @_);
1384 }
1385
1386 =item calc_remain
1387
1388 Calls the I<calc_remain> of the FS::part_pkg object associated with this
1389 billing item.
1390
1391 =cut
1392
1393 sub calc_remain {
1394   my $self = shift;
1395   $self->part_pkg->calc_remain($self, @_);
1396 }
1397
1398 =item calc_cancel
1399
1400 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
1401 billing item.
1402
1403 =cut
1404
1405 sub calc_cancel {
1406   my $self = shift;
1407   $self->part_pkg->calc_cancel($self, @_);
1408 }
1409
1410 =item cust_bill_pkg
1411
1412 Returns any invoice line items for this package (see L<FS::cust_bill_pkg>).
1413
1414 =cut
1415
1416 sub cust_bill_pkg {
1417   my $self = shift;
1418   qsearch( 'cust_bill_pkg', { 'pkgnum' => $self->pkgnum } );
1419 }
1420
1421 =item cust_pkg_detail [ DETAILTYPE ]
1422
1423 Returns any customer package details for this package (see
1424 L<FS::cust_pkg_detail>).
1425
1426 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1427
1428 =cut
1429
1430 sub cust_pkg_detail {
1431   my $self = shift;
1432   my %hash = ( 'pkgnum' => $self->pkgnum );
1433   $hash{detailtype} = shift if @_;
1434   qsearch({
1435     'table'    => 'cust_pkg_detail',
1436     'hashref'  => \%hash,
1437     'order_by' => 'ORDER BY weight, pkgdetailnum',
1438   });
1439 }
1440
1441 =item set_cust_pkg_detail DETAILTYPE [ DETAIL, DETAIL, ... ]
1442
1443 Sets customer package details for this package (see L<FS::cust_pkg_detail>).
1444
1445 DETAILTYPE can be set to "I" for invoice details or "C" for comments.
1446
1447 If there is an error, returns the error, otherwise returns false.
1448
1449 =cut
1450
1451 sub set_cust_pkg_detail {
1452   my( $self, $detailtype, @details ) = @_;
1453
1454   local $SIG{HUP} = 'IGNORE';
1455   local $SIG{INT} = 'IGNORE';
1456   local $SIG{QUIT} = 'IGNORE';
1457   local $SIG{TERM} = 'IGNORE';
1458   local $SIG{TSTP} = 'IGNORE';
1459   local $SIG{PIPE} = 'IGNORE';
1460
1461   my $oldAutoCommit = $FS::UID::AutoCommit;
1462   local $FS::UID::AutoCommit = 0;
1463   my $dbh = dbh;
1464
1465   foreach my $current ( $self->cust_pkg_detail($detailtype) ) {
1466     my $error = $current->delete;
1467     if ( $error ) {
1468       $dbh->rollback if $oldAutoCommit;
1469       return "error removing old detail: $error";
1470     }
1471   }
1472
1473   foreach my $detail ( @details ) {
1474     my $cust_pkg_detail = new FS::cust_pkg_detail {
1475       'pkgnum'     => $self->pkgnum,
1476       'detailtype' => $detailtype,
1477       'detail'     => $detail,
1478     };
1479     my $error = $cust_pkg_detail->insert;
1480     if ( $error ) {
1481       $dbh->rollback if $oldAutoCommit;
1482       return "error adding new detail: $error";
1483     }
1484
1485   }
1486
1487   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1488   '';
1489
1490 }
1491
1492 =item cust_event
1493
1494 Returns the new-style customer billing events (see L<FS::cust_event>) for this invoice.
1495
1496 =cut
1497
1498 #false laziness w/cust_bill.pm
1499 sub cust_event {
1500   my $self = shift;
1501   qsearch({
1502     'table'     => 'cust_event',
1503     'addl_from' => 'JOIN part_event USING ( eventpart )',
1504     'hashref'   => { 'tablenum' => $self->pkgnum },
1505     'extra_sql' => " AND eventtable = 'cust_pkg' ",
1506   });
1507 }
1508
1509 =item num_cust_event
1510
1511 Returns the number of new-style customer billing events (see L<FS::cust_event>) for this invoice.
1512
1513 =cut
1514
1515 #false laziness w/cust_bill.pm
1516 sub num_cust_event {
1517   my $self = shift;
1518   my $sql =
1519     "SELECT COUNT(*) FROM cust_event JOIN part_event USING ( eventpart ) ".
1520     "  WHERE tablenum = ? AND eventtable = 'cust_pkg'";
1521   my $sth = dbh->prepare($sql) or die  dbh->errstr. " preparing $sql";
1522   $sth->execute($self->pkgnum) or die $sth->errstr. " executing $sql";
1523   $sth->fetchrow_arrayref->[0];
1524 }
1525
1526 =item cust_svc [ SVCPART ]
1527
1528 Returns the services for this package, as FS::cust_svc objects (see
1529 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
1530 services.
1531
1532 =cut
1533
1534 sub cust_svc {
1535   my $self = shift;
1536
1537   return () unless $self->num_cust_svc(@_);
1538
1539   if ( @_ ) {
1540     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
1541                                   'svcpart' => shift,          } );
1542   }
1543
1544   cluck "cust_pkg->cust_svc called" if $DEBUG > 2;
1545
1546   #if ( $self->{'_svcnum'} ) {
1547   #  values %{ $self->{'_svcnum'}->cache };
1548   #} else {
1549     $self->_sort_cust_svc(
1550       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
1551     );
1552   #}
1553
1554 }
1555
1556 =item overlimit [ SVCPART ]
1557
1558 Returns the services for this package which have exceeded their
1559 usage limit as FS::cust_svc objects (see L<FS::cust_svc>).  If a svcpart
1560 is specified, return only the matching services.
1561
1562 =cut
1563
1564 sub overlimit {
1565   my $self = shift;
1566   return () unless $self->num_cust_svc(@_);
1567   grep { $_->overlimit } $self->cust_svc(@_);
1568 }
1569
1570 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
1571
1572 Returns historical services for this package created before END TIMESTAMP and
1573 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
1574 (see L<FS::h_cust_svc>).
1575
1576 =cut
1577
1578 sub h_cust_svc {
1579   my $self = shift;
1580
1581   $self->_sort_cust_svc(
1582     [ qsearch( 'h_cust_svc',
1583                { 'pkgnum' => $self->pkgnum, },
1584                FS::h_cust_svc->sql_h_search(@_),
1585              )
1586     ]
1587   );
1588 }
1589
1590 sub _sort_cust_svc {
1591   my( $self, $arrayref ) = @_;
1592
1593   my $sort =
1594     sub ($$) { my ($a, $b) = @_; $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] };
1595
1596   map  { $_->[0] }
1597   sort $sort
1598   map {
1599         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
1600                                              'svcpart' => $_->svcpart     } );
1601         [ $_,
1602           $pkg_svc ? $pkg_svc->primary_svc : '',
1603           $pkg_svc ? $pkg_svc->quantity : 0,
1604         ];
1605       }
1606   @$arrayref;
1607
1608 }
1609
1610 =item num_cust_svc [ SVCPART ]
1611
1612 Returns the number of provisioned services for this package.  If a svcpart is
1613 specified, counts only the matching services.
1614
1615 =cut
1616
1617 sub num_cust_svc {
1618   my $self = shift;
1619
1620   return $self->{'_num_cust_svc'}
1621     if !scalar(@_)
1622        && exists($self->{'_num_cust_svc'})
1623        && $self->{'_num_cust_svc'} =~ /\d/;
1624
1625   cluck "cust_pkg->num_cust_svc called, _num_cust_svc:".$self->{'_num_cust_svc'}
1626     if $DEBUG > 2;
1627
1628   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
1629   $sql .= ' AND svcpart = ?' if @_;
1630
1631   my $sth = dbh->prepare($sql)     or die  dbh->errstr;
1632   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
1633   $sth->fetchrow_arrayref->[0];
1634 }
1635
1636 =item available_part_svc
1637
1638 Returns a list of FS::part_svc objects representing services included in this
1639 package but not yet provisioned.  Each FS::part_svc object also has an extra
1640 field, I<num_avail>, which specifies the number of available services.
1641
1642 =cut
1643
1644 sub available_part_svc {
1645   my $self = shift;
1646   grep { $_->num_avail > 0 }
1647     map {
1648           my $part_svc = $_->part_svc;
1649           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
1650             $_->quantity - $self->num_cust_svc($_->svcpart);
1651           $part_svc;
1652         }
1653       $self->part_pkg->pkg_svc;
1654 }
1655
1656 =item part_svc
1657
1658 Returns a list of FS::part_svc objects representing provisioned and available
1659 services included in this package.  Each FS::part_svc object also has the
1660 following extra fields:
1661
1662 =over 4
1663
1664 =item num_cust_svc  (count)
1665
1666 =item num_avail     (quantity - count)
1667
1668 =item cust_pkg_svc (services) - array reference containing the provisioned services, as cust_svc objects
1669
1670 svcnum
1671 label -> ($cust_svc->label)[1]
1672
1673 =back
1674
1675 =cut
1676
1677 sub part_svc {
1678   my $self = shift;
1679
1680   #XXX some sort of sort order besides numeric by svcpart...
1681   my @part_svc = sort { $a->svcpart <=> $b->svcpart } map {
1682     my $pkg_svc = $_;
1683     my $part_svc = $pkg_svc->part_svc;
1684     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1685     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #more evil
1686     $part_svc->{'Hash'}{'num_avail'}    =
1687       max( 0, $pkg_svc->quantity - $num_cust_svc );
1688     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1689       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1690     $part_svc;
1691   } $self->part_pkg->pkg_svc;
1692
1693   #extras
1694   push @part_svc, map {
1695     my $part_svc = $_;
1696     my $num_cust_svc = $self->num_cust_svc($part_svc->svcpart);
1697     $part_svc->{'Hash'}{'num_cust_svc'} = $num_cust_svc; #speak no evail
1698     $part_svc->{'Hash'}{'num_avail'}    = 0; #0-$num_cust_svc ?
1699     $part_svc->{'Hash'}{'cust_pkg_svc'} =
1700       $num_cust_svc ? [ $self->cust_svc($part_svc->svcpart) ] : [];
1701     $part_svc;
1702   } $self->extra_part_svc;
1703
1704   @part_svc;
1705
1706 }
1707
1708 =item extra_part_svc
1709
1710 Returns a list of FS::part_svc objects corresponding to services in this
1711 package which are still provisioned but not (any longer) available in the
1712 package definition.
1713
1714 =cut
1715
1716 sub extra_part_svc {
1717   my $self = shift;
1718
1719   my $pkgnum  = $self->pkgnum;
1720   my $pkgpart = $self->pkgpart;
1721
1722 #  qsearch( {
1723 #    'table'     => 'part_svc',
1724 #    'hashref'   => {},
1725 #    'extra_sql' =>
1726 #      "WHERE 0 = ( SELECT COUNT(*) FROM pkg_svc
1727 #                     WHERE pkg_svc.svcpart = part_svc.svcpart
1728 #                       AND pkg_svc.pkgpart = ?
1729 #                       AND quantity > 0
1730 #                 )
1731 #        AND 0 < ( SELECT COUNT(*) FROM cust_svc
1732 #                       LEFT JOIN cust_pkg USING ( pkgnum )
1733 #                     WHERE cust_svc.svcpart = part_svc.svcpart
1734 #                       AND pkgnum = ?
1735 #                 )",
1736 #    'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1737 #  } );
1738
1739 #seems to benchmark slightly faster...
1740   qsearch( {
1741     #'select'      => 'DISTINCT ON (svcpart) part_svc.*',
1742     #MySQL doesn't grok DISINCT ON
1743     'select'      => 'DISTINCT part_svc.*',
1744     'table'       => 'part_svc',
1745     'addl_from'   =>
1746       'LEFT JOIN pkg_svc  ON (     pkg_svc.svcpart   = part_svc.svcpart
1747                                AND pkg_svc.pkgpart   = ?
1748                                AND quantity > 0
1749                              )
1750        LEFT JOIN cust_svc ON (     cust_svc.svcpart = part_svc.svcpart )
1751        LEFT JOIN cust_pkg USING ( pkgnum )
1752       ',
1753     'hashref'     => {},
1754     'extra_sql'   => "WHERE pkgsvcnum IS NULL AND cust_pkg.pkgnum = ? ",
1755     'extra_param' => [ [$self->pkgpart=>'int'], [$self->pkgnum=>'int'] ],
1756   } );
1757 }
1758
1759 =item status
1760
1761 Returns a short status string for this package, currently:
1762
1763 =over 4
1764
1765 =item not yet billed
1766
1767 =item one-time charge
1768
1769 =item active
1770
1771 =item suspended
1772
1773 =item cancelled
1774
1775 =back
1776
1777 =cut
1778
1779 sub status {
1780   my $self = shift;
1781
1782   my $freq = length($self->freq) ? $self->freq : $self->part_pkg->freq;
1783
1784   return 'cancelled' if $self->get('cancel');
1785   return 'suspended' if $self->susp;
1786   return 'not yet billed' unless $self->setup;
1787   return 'one-time charge' if $freq =~ /^(0|$)/;
1788   return 'active';
1789 }
1790
1791 =item ucfirst_status
1792
1793 Returns the status with the first character capitalized.
1794
1795 =cut
1796
1797 sub ucfirst_status {
1798   ucfirst(shift->status);
1799 }
1800
1801 =item statuses
1802
1803 Class method that returns the list of possible status strings for packages
1804 (see L<the status method|/status>).  For example:
1805
1806   @statuses = FS::cust_pkg->statuses();
1807
1808 =cut
1809
1810 tie my %statuscolor, 'Tie::IxHash',
1811   'not yet billed'  => '000000',
1812   'one-time charge' => '000000',
1813   'active'          => '00CC00',
1814   'suspended'       => 'FF9900',
1815   'cancelled'       => 'FF0000',
1816 ;
1817
1818 sub statuses {
1819   my $self = shift; #could be class...
1820   #grep { $_ !~ /^(not yet billed)$/ } #this is a dumb status anyway
1821   #                                    # mayble split btw one-time vs. recur
1822     keys %statuscolor;
1823 }
1824
1825 =item statuscolor
1826
1827 Returns a hex triplet color string for this package's status.
1828
1829 =cut
1830
1831 sub statuscolor {
1832   my $self = shift;
1833   $statuscolor{$self->status};
1834 }
1835
1836 =item pkg_label
1837
1838 Returns a label for this package.  (Currently "pkgnum: pkg - comment" or
1839 "pkg-comment" depending on user preference).
1840
1841 =cut
1842
1843 sub pkg_label {
1844   my $self = shift;
1845   my $label = $self->part_pkg->pkg_comment( 'nopkgpart' => 1 );
1846   $label = $self->pkgnum. ": $label"
1847     if $FS::CurrentUser::CurrentUser->option('show_pkgnum');
1848   $label;
1849 }
1850
1851 =item pkg_label_long
1852
1853 Returns a long label for this package, adding the primary service's label to
1854 pkg_label.
1855
1856 =cut
1857
1858 sub pkg_label_long {
1859   my $self = shift;
1860   my $label = $self->pkg_label;
1861   my $cust_svc = $self->primary_cust_svc;
1862   $label .= ' ('. ($cust_svc->label)[1]. ')' if $cust_svc;
1863   $label;
1864 }
1865
1866 =item primary_cust_svc
1867
1868 Returns a primary service (as FS::cust_svc object) if one can be identified.
1869
1870 =cut
1871
1872 #for labeling purposes - might not 100% match up with part_pkg->svcpart's idea
1873
1874 sub primary_cust_svc {
1875   my $self = shift;
1876
1877   my @cust_svc = $self->cust_svc;
1878
1879   return '' unless @cust_svc; #no serivces - irrelevant then
1880
1881   return $cust_svc[0] if scalar(@cust_svc) == 1; #always return a single service
1882
1883   # primary service as specified in the package definition
1884   # or exactly one service definition with quantity one
1885   my $svcpart = $self->part_pkg->svcpart;
1886   @cust_svc = grep { $_->svcpart == $svcpart } @cust_svc;
1887   return $cust_svc[0] if scalar(@cust_svc) == 1;
1888
1889   #couldn't identify one thing..
1890   return '';
1891 }
1892
1893 =item labels
1894
1895 Returns a list of lists, calling the label method for all services
1896 (see L<FS::cust_svc>) of this billing item.
1897
1898 =cut
1899
1900 sub labels {
1901   my $self = shift;
1902   map { [ $_->label ] } $self->cust_svc;
1903 }
1904
1905 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
1906
1907 Like the labels method, but returns historical information on services that
1908 were active as of END_TIMESTAMP and (optionally) not cancelled before
1909 START_TIMESTAMP.
1910
1911 Returns a list of lists, calling the label method for all (historical) services
1912 (see L<FS::h_cust_svc>) of this billing item.
1913
1914 =cut
1915
1916 sub h_labels {
1917   my $self = shift;
1918   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
1919 }
1920
1921 =item labels_short
1922
1923 Like labels, except returns a simple flat list, and shortens long
1924 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1925 identical services to one line that lists the service label and the number of
1926 individual services rather than individual items.
1927
1928 =cut
1929
1930 sub labels_short {
1931   shift->_labels_short( 'labels', @_ );
1932 }
1933
1934 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
1935
1936 Like h_labels, except returns a simple flat list, and shortens long
1937 (currently >5 or the cust_bill-max_same_services configuration value) lists of
1938 identical services to one line that lists the service label and the number of
1939 individual services rather than individual items.
1940
1941 =cut
1942
1943 sub h_labels_short {
1944   shift->_labels_short( 'h_labels', @_ );
1945 }
1946
1947 sub _labels_short {
1948   my( $self, $method ) = ( shift, shift );
1949
1950   my $conf = new FS::Conf;
1951   my $max_same_services = $conf->config('cust_bill-max_same_services') || 5;
1952
1953   my %labels;
1954   #tie %labels, 'Tie::IxHash';
1955   push @{ $labels{$_->[0]} }, $_->[1]
1956     foreach $self->$method(@_);
1957   my @labels;
1958   foreach my $label ( keys %labels ) {
1959     my %seen = ();
1960     my @values = grep { ! $seen{$_}++ } @{ $labels{$label} };
1961     my $num = scalar(@values);
1962     if ( $num > $max_same_services ) {
1963       push @labels, "$label ($num)";
1964     } else {
1965       if ( $conf->exists('cust_bill-consolidate_services') ) {
1966         # push @labels, "$label: ". join(', ', @values);
1967         while ( @values ) {
1968           my $detail = "$label: ";
1969           $detail .= shift(@values). ', '
1970             while @values && length($detail.$values[0]) < 78;
1971           $detail =~ s/, $//;
1972           push @labels, $detail;
1973         }
1974       } else {
1975         push @labels, map { "$label: $_" } @values;
1976       }
1977     }
1978   }
1979
1980  @labels;
1981
1982 }
1983
1984 =item cust_main
1985
1986 Returns the parent customer object (see L<FS::cust_main>).
1987
1988 =cut
1989
1990 sub cust_main {
1991   my $self = shift;
1992   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
1993 }
1994
1995 #these subs are in location_Mixin.pm now... unfortunately the POD doesn't mixin
1996
1997 =item cust_location
1998
1999 Returns the location object, if any (see L<FS::cust_location>).
2000
2001 =item cust_location_or_main
2002
2003 If this package is associated with a location, returns the locaiton (see
2004 L<FS::cust_location>), otherwise returns the customer (see L<FS::cust_main>).
2005
2006 =item location_label [ OPTION => VALUE ... ]
2007
2008 Returns the label of the location object (see L<FS::cust_location>).
2009
2010 =cut
2011
2012 #end of subs in location_Mixin.pm now... unfortunately the POD doesn't mixin
2013
2014 =item seconds_since TIMESTAMP
2015
2016 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
2017 package have been online since TIMESTAMP, according to the session monitor.
2018
2019 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2020 L<Time::Local> and L<Date::Parse> for conversion functions.
2021
2022 =cut
2023
2024 sub seconds_since {
2025   my($self, $since) = @_;
2026   my $seconds = 0;
2027
2028   foreach my $cust_svc (
2029     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
2030   ) {
2031     $seconds += $cust_svc->seconds_since($since);
2032   }
2033
2034   $seconds;
2035
2036 }
2037
2038 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2039
2040 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
2041 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
2042 (exclusive).
2043
2044 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2045 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2046 functions.
2047
2048
2049 =cut
2050
2051 sub seconds_since_sqlradacct {
2052   my($self, $start, $end) = @_;
2053
2054   my $seconds = 0;
2055
2056   foreach my $cust_svc (
2057     grep {
2058       my $part_svc = $_->part_svc;
2059       $part_svc->svcdb eq 'svc_acct'
2060         && scalar($part_svc->part_export('sqlradius'));
2061     } $self->cust_svc
2062   ) {
2063     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
2064   }
2065
2066   $seconds;
2067
2068 }
2069
2070 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2071
2072 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2073 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2074 TIMESTAMP_END
2075 (exclusive).
2076
2077 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2078 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2079 functions.
2080
2081 =cut
2082
2083 sub attribute_since_sqlradacct {
2084   my($self, $start, $end, $attrib) = @_;
2085
2086   my $sum = 0;
2087
2088   foreach my $cust_svc (
2089     grep {
2090       my $part_svc = $_->part_svc;
2091       $part_svc->svcdb eq 'svc_acct'
2092         && scalar($part_svc->part_export('sqlradius'));
2093     } $self->cust_svc
2094   ) {
2095     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
2096   }
2097
2098   $sum;
2099
2100 }
2101
2102 =item quantity
2103
2104 =cut
2105
2106 sub quantity {
2107   my( $self, $value ) = @_;
2108   if ( defined($value) ) {
2109     $self->setfield('quantity', $value);
2110   }
2111   $self->getfield('quantity') || 1;
2112 }
2113
2114 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
2115
2116 Transfers as many services as possible from this package to another package.
2117
2118 The destination package can be specified by pkgnum by passing an FS::cust_pkg
2119 object.  The destination package must already exist.
2120
2121 Services are moved only if the destination allows services with the correct
2122 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
2123 this option with caution!  No provision is made for export differences
2124 between the old and new service definitions.  Probably only should be used
2125 when your exports for all service definitions of a given svcdb are identical.
2126 (attempt a transfer without it first, to move all possible svcpart-matching
2127 services)
2128
2129 Any services that can't be moved remain in the original package.
2130
2131 Returns an error, if there is one; otherwise, returns the number of services
2132 that couldn't be moved.
2133
2134 =cut
2135
2136 sub transfer {
2137   my ($self, $dest_pkgnum, %opt) = @_;
2138
2139   my $remaining = 0;
2140   my $dest;
2141   my %target;
2142
2143   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
2144     $dest = $dest_pkgnum;
2145     $dest_pkgnum = $dest->pkgnum;
2146   } else {
2147     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
2148   }
2149
2150   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
2151
2152   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
2153     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
2154   }
2155
2156   foreach my $cust_svc ($dest->cust_svc) {
2157     $target{$cust_svc->svcpart}--;
2158   }
2159
2160   my %svcpart2svcparts = ();
2161   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2162     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
2163     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
2164       next if exists $svcpart2svcparts{$svcpart};
2165       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
2166       $svcpart2svcparts{$svcpart} = [
2167         map  { $_->[0] }
2168         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
2169         map {
2170               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
2171                                                    'svcpart' => $_          } );
2172               [ $_,
2173                 $pkg_svc ? $pkg_svc->primary_svc : '',
2174                 $pkg_svc ? $pkg_svc->quantity : 0,
2175               ];
2176             }
2177
2178         grep { $_ != $svcpart }
2179         map  { $_->svcpart }
2180         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
2181       ];
2182       warn "alternates for svcpart $svcpart: ".
2183            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
2184         if $DEBUG;
2185     }
2186   }
2187
2188   foreach my $cust_svc ($self->cust_svc) {
2189     if($target{$cust_svc->svcpart} > 0) {
2190       $target{$cust_svc->svcpart}--;
2191       my $new = new FS::cust_svc { $cust_svc->hash };
2192       $new->pkgnum($dest_pkgnum);
2193       my $error = $new->replace($cust_svc);
2194       return $error if $error;
2195     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
2196       if ( $DEBUG ) {
2197         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
2198         warn "alternates to consider: ".
2199              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
2200       }
2201       my @alternate = grep {
2202                              warn "considering alternate svcpart $_: ".
2203                                   "$target{$_} available in new package\n"
2204                                if $DEBUG;
2205                              $target{$_} > 0;
2206                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
2207       if ( @alternate ) {
2208         warn "alternate(s) found\n" if $DEBUG;
2209         my $change_svcpart = $alternate[0];
2210         $target{$change_svcpart}--;
2211         my $new = new FS::cust_svc { $cust_svc->hash };
2212         $new->svcpart($change_svcpart);
2213         $new->pkgnum($dest_pkgnum);
2214         my $error = $new->replace($cust_svc);
2215         return $error if $error;
2216       } else {
2217         $remaining++;
2218       }
2219     } else {
2220       $remaining++
2221     }
2222   }
2223   return $remaining;
2224 }
2225
2226 =item reexport
2227
2228 This method is deprecated.  See the I<depend_jobnum> option to the insert and
2229 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
2230
2231 =cut
2232
2233 sub reexport {
2234   my $self = shift;
2235
2236   local $SIG{HUP} = 'IGNORE';
2237   local $SIG{INT} = 'IGNORE';
2238   local $SIG{QUIT} = 'IGNORE';
2239   local $SIG{TERM} = 'IGNORE';
2240   local $SIG{TSTP} = 'IGNORE';
2241   local $SIG{PIPE} = 'IGNORE';
2242
2243   my $oldAutoCommit = $FS::UID::AutoCommit;
2244   local $FS::UID::AutoCommit = 0;
2245   my $dbh = dbh;
2246
2247   foreach my $cust_svc ( $self->cust_svc ) {
2248     #false laziness w/svc_Common::insert
2249     my $svc_x = $cust_svc->svc_x;
2250     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
2251       my $error = $part_export->export_insert($svc_x);
2252       if ( $error ) {
2253         $dbh->rollback if $oldAutoCommit;
2254         return $error;
2255       }
2256     }
2257   }
2258
2259   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2260   '';
2261
2262 }
2263
2264 =item insert_reason
2265
2266 Associates this package with a (suspension or cancellation) reason (see
2267 L<FS::cust_pkg_reason>, possibly inserting a new reason on the fly (see
2268 L<FS::reason>).
2269
2270 Available options are:
2271
2272 =over 4
2273
2274 =item reason
2275
2276 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.
2277
2278 =item reason_otaker
2279
2280 the access_user (see L<FS::access_user>) providing the reason
2281
2282 =item date
2283
2284 a unix timestamp
2285
2286 =item action
2287
2288 the action (cancel, susp, adjourn, expire) associated with the reason
2289
2290 =back
2291
2292 If there is an error, returns the error, otherwise returns false.
2293
2294 =cut
2295
2296 sub insert_reason {
2297   my ($self, %options) = @_;
2298
2299   my $otaker = $options{reason_otaker} ||
2300                $FS::CurrentUser::CurrentUser->username;
2301
2302   my $reasonnum;
2303   if ( $options{'reason'} =~ /^(\d+)$/ ) {
2304
2305     $reasonnum = $1;
2306
2307   } elsif ( ref($options{'reason'}) ) {
2308
2309     return 'Enter a new reason (or select an existing one)'
2310       unless $options{'reason'}->{'reason'} !~ /^\s*$/;
2311
2312     my $reason = new FS::reason({
2313       'reason_type' => $options{'reason'}->{'typenum'},
2314       'reason'      => $options{'reason'}->{'reason'},
2315     });
2316     my $error = $reason->insert;
2317     return $error if $error;
2318
2319     $reasonnum = $reason->reasonnum;
2320
2321   } else {
2322     return "Unparsable reason: ". $options{'reason'};
2323   }
2324
2325   my $cust_pkg_reason =
2326     new FS::cust_pkg_reason({ 'pkgnum'    => $self->pkgnum,
2327                               'reasonnum' => $reasonnum,
2328                               'otaker'    => $otaker,
2329                               'action'    => substr(uc($options{'action'}),0,1),
2330                               'date'      => $options{'date'}
2331                                                ? $options{'date'}
2332                                                : time,
2333                             });
2334
2335   $cust_pkg_reason->insert;
2336 }
2337
2338 =item insert_discount
2339
2340 Associates this package with a discount (see L<FS::cust_pkg_discount>, possibly
2341 inserting a new discount on the fly (see L<FS::discount>).
2342
2343 Available options are:
2344
2345 =over 4
2346
2347 =item discountnum
2348
2349 =back
2350
2351 If there is an error, returns the error, otherwise returns false.
2352
2353 =cut
2354
2355 sub insert_discount {
2356   #my ($self, %options) = @_;
2357   my $self = shift;
2358
2359   my $cust_pkg_discount = new FS::cust_pkg_discount {
2360     'pkgnum'      => $self->pkgnum,
2361     'discountnum' => $self->discountnum,
2362     'months_used' => 0,
2363     'end_date'    => '', #XXX
2364     'otaker'      => $self->otaker,
2365     #for the create a new discount case
2366     '_type'       => $self->discountnum__type,
2367     'amount'      => $self->discountnum_amount,
2368     'percent'     => $self->discountnum_percent,
2369     'months'      => $self->discountnum_months,
2370     #'disabled'    => $self->discountnum_disabled,
2371   };
2372
2373   $cust_pkg_discount->insert;
2374 }
2375
2376 =item set_usage USAGE_VALUE_HASHREF
2377
2378 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2379 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2380 upbytes, downbytes, and totalbytes are appropriate keys.
2381
2382 All svc_accts which are part of this package have their values reset.
2383
2384 =cut
2385
2386 sub set_usage {
2387   my ($self, $valueref, %opt) = @_;
2388
2389   foreach my $cust_svc ($self->cust_svc){
2390     my $svc_x = $cust_svc->svc_x;
2391     $svc_x->set_usage($valueref, %opt)
2392       if $svc_x->can("set_usage");
2393   }
2394 }
2395
2396 =item recharge USAGE_VALUE_HASHREF
2397
2398 USAGE_VALUE_HASHREF is a hashref of svc_acct usage columns and the amounts
2399 to which they should be set (see L<FS::svc_acct>).  Currently seconds,
2400 upbytes, downbytes, and totalbytes are appropriate keys.
2401
2402 All svc_accts which are part of this package have their values incremented.
2403
2404 =cut
2405
2406 sub recharge {
2407   my ($self, $valueref) = @_;
2408
2409   foreach my $cust_svc ($self->cust_svc){
2410     my $svc_x = $cust_svc->svc_x;
2411     $svc_x->recharge($valueref)
2412       if $svc_x->can("recharge");
2413   }
2414 }
2415
2416 =item cust_pkg_discount
2417
2418 =cut
2419
2420 sub cust_pkg_discount {
2421   my $self = shift;
2422   qsearch('cust_pkg_discount', { 'pkgnum' => $self->pkgnum } );
2423 }
2424
2425 =item cust_pkg_discount_active
2426
2427 =cut
2428
2429 sub cust_pkg_discount_active {
2430   my $self = shift;
2431   grep { $_->status eq 'active' } $self->cust_pkg_discount;
2432 }
2433
2434 =back
2435
2436 =head1 CLASS METHODS
2437
2438 =over 4
2439
2440 =item recurring_sql
2441
2442 Returns an SQL expression identifying recurring packages.
2443
2444 =cut
2445
2446 sub recurring_sql { "
2447   '0' != ( select freq from part_pkg
2448              where cust_pkg.pkgpart = part_pkg.pkgpart )
2449 "; }
2450
2451 =item onetime_sql
2452
2453 Returns an SQL expression identifying one-time packages.
2454
2455 =cut
2456
2457 sub onetime_sql { "
2458   '0' = ( select freq from part_pkg
2459             where cust_pkg.pkgpart = part_pkg.pkgpart )
2460 "; }
2461
2462 =item ordered_sql
2463
2464 Returns an SQL expression identifying ordered packages (recurring packages not
2465 yet billed).
2466
2467 =cut
2468
2469 sub ordered_sql {
2470    $_[0]->recurring_sql. " AND ". $_[0]->not_yet_billed_sql;
2471 }
2472
2473 =item active_sql
2474
2475 Returns an SQL expression identifying active packages.
2476
2477 =cut
2478
2479 sub active_sql {
2480   $_[0]->recurring_sql. "
2481   AND cust_pkg.setup IS NOT NULL AND 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 not_yet_billed_sql
2487
2488 Returns an SQL expression identifying packages which have not yet been billed.
2489
2490 =cut
2491
2492 sub not_yet_billed_sql { "
2493       ( cust_pkg.setup  IS NULL OR cust_pkg.setup  = 0 )
2494   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2495   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2496 "; }
2497
2498 =item inactive_sql
2499
2500 Returns an SQL expression identifying inactive packages (one-time packages
2501 that are otherwise unsuspended/uncancelled).
2502
2503 =cut
2504
2505 sub inactive_sql { "
2506   ". $_[0]->onetime_sql(). "
2507   AND cust_pkg.setup IS NOT NULL AND cust_pkg.setup != 0
2508   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
2509   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
2510 "; }
2511
2512 =item susp_sql
2513 =item suspended_sql
2514
2515 Returns an SQL expression identifying suspended packages.
2516
2517 =cut
2518
2519 sub suspended_sql { susp_sql(@_); }
2520 sub susp_sql {
2521   #$_[0]->recurring_sql(). ' AND '.
2522   "
2523         ( cust_pkg.cancel IS     NULL  OR cust_pkg.cancel = 0 )
2524     AND   cust_pkg.susp   IS NOT NULL AND cust_pkg.susp  != 0
2525   ";
2526 }
2527
2528 =item cancel_sql
2529 =item cancelled_sql
2530
2531 Returns an SQL exprression identifying cancelled packages.
2532
2533 =cut
2534
2535 sub cancelled_sql { cancel_sql(@_); }
2536 sub cancel_sql {
2537   #$_[0]->recurring_sql(). ' AND '.
2538   "cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0";
2539 }
2540
2541 =item search HASHREF
2542
2543 (Class method)
2544
2545 Returns a qsearch hash expression to search for parameters specified in HASHREF.
2546 Valid parameters are
2547
2548 =over 4
2549
2550 =item agentnum
2551
2552 =item magic
2553
2554 active, inactive, suspended, cancel (or cancelled)
2555
2556 =item status
2557
2558 active, inactive, suspended, one-time charge, inactive, cancel (or cancelled)
2559
2560 =item custom
2561
2562  boolean selects custom packages
2563
2564 =item classnum
2565
2566 =item pkgpart
2567
2568 pkgpart or arrayref or hashref of pkgparts
2569
2570 =item setup
2571
2572 arrayref of beginning and ending epoch date
2573
2574 =item last_bill
2575
2576 arrayref of beginning and ending epoch date
2577
2578 =item bill
2579
2580 arrayref of beginning and ending epoch date
2581
2582 =item adjourn
2583
2584 arrayref of beginning and ending epoch date
2585
2586 =item susp
2587
2588 arrayref of beginning and ending epoch date
2589
2590 =item expire
2591
2592 arrayref of beginning and ending epoch date
2593
2594 =item cancel
2595
2596 arrayref of beginning and ending epoch date
2597
2598 =item query
2599
2600 pkgnum or APKG_pkgnum
2601
2602 =item cust_fields
2603
2604 a value suited to passing to FS::UI::Web::cust_header
2605
2606 =item CurrentUser
2607
2608 specifies the user for agent virtualization
2609
2610 =item fcc_line
2611
2612  boolean selects packages containing fcc form 477 telco lines
2613
2614 =back
2615
2616 =cut
2617
2618 sub search {
2619   my ($class, $params) = @_;
2620   my @where = ();
2621
2622   ##
2623   # parse agent
2624   ##
2625
2626   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2627     push @where,
2628       "cust_main.agentnum = $1";
2629   }
2630
2631   ##
2632   # parse custnum
2633   ##
2634
2635   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2636     push @where,
2637       "cust_pkg.custnum = $1";
2638   }
2639
2640   ##
2641   # custbatch
2642   ##
2643
2644   if ( $params->{'pkgbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
2645     push @where,
2646       "cust_pkg.pkgbatch = '$1'";
2647   }
2648
2649   ##
2650   # parse status
2651   ##
2652
2653   if (    $params->{'magic'}  eq 'active'
2654        || $params->{'status'} eq 'active' ) {
2655
2656     push @where, FS::cust_pkg->active_sql();
2657
2658   } elsif (    $params->{'magic'}  =~ /^not[ _]yet[ _]billed$/
2659             || $params->{'status'} =~ /^not[ _]yet[ _]billed$/ ) {
2660
2661     push @where, FS::cust_pkg->not_yet_billed_sql();
2662
2663   } elsif (    $params->{'magic'}  =~ /^(one-time charge|inactive)/
2664             || $params->{'status'} =~ /^(one-time charge|inactive)/ ) {
2665
2666     push @where, FS::cust_pkg->inactive_sql();
2667
2668   } elsif (    $params->{'magic'}  eq 'suspended'
2669             || $params->{'status'} eq 'suspended'  ) {
2670
2671     push @where, FS::cust_pkg->suspended_sql();
2672
2673   } elsif (    $params->{'magic'}  =~ /^cancell?ed$/
2674             || $params->{'status'} =~ /^cancell?ed$/ ) {
2675
2676     push @where, FS::cust_pkg->cancelled_sql();
2677
2678   }
2679
2680   ###
2681   # parse package class
2682   ###
2683
2684   #false lazinessish w/graph/cust_bill_pkg.cgi
2685   my $classnum = 0;
2686   my @pkg_class = ();
2687   if ( exists($params->{'classnum'})
2688        && $params->{'classnum'} =~ /^(\d*)$/
2689      )
2690   {
2691     $classnum = $1;
2692     if ( $classnum ) { #a specific class
2693       push @where, "part_pkg.classnum = $classnum";
2694
2695       #@pkg_class = ( qsearchs('pkg_class', { 'classnum' => $classnum } ) );
2696       #die "classnum $classnum not found!" unless $pkg_class[0];
2697       #$title .= $pkg_class[0]->classname.' ';
2698
2699     } elsif ( $classnum eq '' ) { #the empty class
2700
2701       push @where, "part_pkg.classnum IS NULL";
2702       #$title .= 'Empty class ';
2703       #@pkg_class = ( '(empty class)' );
2704     } elsif ( $classnum eq '0' ) {
2705       #@pkg_class = qsearch('pkg_class', {} ); # { 'disabled' => '' } );
2706       #push @pkg_class, '(empty class)';
2707     } else {
2708       die "illegal classnum";
2709     }
2710   }
2711   #eslaf
2712
2713   ###
2714   # parse package report options
2715   ###
2716
2717   my @report_option = ();
2718   if ( exists($params->{'report_option'})
2719        && $params->{'report_option'} =~ /^([,\d]*)$/
2720      )
2721   {
2722     @report_option = split(',', $1);
2723   }
2724
2725   if (@report_option) {
2726     # this will result in the empty set for the dangling comma case as it should
2727     push @where,
2728       map{ "0 < ( SELECT count(*) FROM part_pkg_option
2729                     WHERE part_pkg_option.pkgpart = part_pkg.pkgpart
2730                     AND optionname = 'report_option_$_'
2731                     AND optionvalue = '1' )"
2732          } @report_option;
2733   }
2734
2735   #eslaf
2736
2737   ###
2738   # parse custom
2739   ###
2740
2741   push @where,  "part_pkg.custom = 'Y'" if $params->{custom};
2742
2743   ###
2744   # parse fcc_line
2745   ###
2746
2747   push @where,  "part_pkg.fcc_ds0s > 0" if $params->{fcc_line};
2748
2749   ###
2750   # parse censustract
2751   ###
2752
2753   if ( exists($params->{'censustract'}) ) {
2754     $params->{'censustract'} =~ /^([.\d]*)$/;
2755     my $censustract = "cust_main.censustract = '$1'";
2756     $censustract .= ' OR cust_main.censustract is NULL' unless $1;
2757     push @where,  "( $censustract )";
2758   }
2759
2760   ###
2761   # parse part_pkg
2762   ###
2763
2764   if ( ref($params->{'pkgpart'}) ) {
2765
2766     my @pkgpart = ();
2767     if ( ref($params->{'pkgpart'}) eq 'HASH' ) {
2768       @pkgpart = grep $params->{'pkgpart'}{$_}, keys %{ $params->{'pkgpart'} };
2769     } elsif ( ref($params->{'pkgpart'}) eq 'ARRAY' ) {
2770       @pkgpart = @{ $params->{'pkgpart'} };
2771     } else {
2772       die 'unhandled pkgpart ref '. $params->{'pkgpart'};
2773     }
2774
2775     @pkgpart = grep /^(\d+)$/, @pkgpart;
2776
2777     push @where, 'pkgpart IN ('. join(',', @pkgpart). ')' if scalar(@pkgpart);
2778
2779   } elsif ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2780     push @where, "pkgpart = $1";
2781   }
2782
2783   ###
2784   # parse dates
2785   ###
2786
2787   my $orderby = '';
2788
2789   #false laziness w/report_cust_pkg.html
2790   my %disable = (
2791     'all'             => {},
2792     'one-time charge' => { 'last_bill'=>1, 'bill'=>1, 'adjourn'=>1, 'susp'=>1, 'expire'=>1, 'cancel'=>1, },
2793     'active'          => { 'susp'=>1, 'cancel'=>1 },
2794     'suspended'       => { 'cancel' => 1 },
2795     'cancelled'       => {},
2796     ''                => {},
2797   );
2798
2799   if( exists($params->{'active'} ) ) {
2800     # This overrides all the other date-related fields
2801     my($beginning, $ending) = @{$params->{'active'}};
2802     push @where,
2803       "cust_pkg.setup IS NOT NULL",
2804       "cust_pkg.setup <= $ending",
2805       "(cust_pkg.cancel IS NULL OR cust_pkg.cancel >= $beginning )",
2806       "NOT (".FS::cust_pkg->onetime_sql . ")";
2807   }
2808   else {
2809     foreach my $field (qw( setup last_bill bill adjourn susp expire cancel )) {
2810
2811       next unless exists($params->{$field});
2812
2813       my($beginning, $ending) = @{$params->{$field}};
2814
2815       next if $beginning == 0 && $ending == 4294967295;
2816
2817       push @where,
2818         "cust_pkg.$field IS NOT NULL",
2819         "cust_pkg.$field >= $beginning",
2820         "cust_pkg.$field <= $ending";
2821
2822       $orderby ||= "ORDER BY cust_pkg.$field";
2823
2824     }
2825   }
2826
2827   $orderby ||= 'ORDER BY bill';
2828
2829   ###
2830   # parse magic, legacy, etc.
2831   ###
2832
2833   if ( $params->{'magic'} &&
2834        $params->{'magic'} =~ /^(active|inactive|suspended|cancell?ed)$/
2835   ) {
2836
2837     $orderby = 'ORDER BY pkgnum';
2838
2839     if ( $params->{'pkgpart'} =~ /^(\d+)$/ ) {
2840       push @where, "pkgpart = $1";
2841     }
2842
2843   } elsif ( $params->{'query'} eq 'pkgnum' ) {
2844
2845     $orderby = 'ORDER BY pkgnum';
2846
2847   } elsif ( $params->{'query'} eq 'APKG_pkgnum' ) {
2848
2849     $orderby = 'ORDER BY pkgnum';
2850
2851     push @where, '0 < (
2852       SELECT count(*) FROM pkg_svc
2853        WHERE pkg_svc.pkgpart =  cust_pkg.pkgpart
2854          AND pkg_svc.quantity > ( SELECT count(*) FROM cust_svc
2855                                    WHERE cust_svc.pkgnum  = cust_pkg.pkgnum
2856                                      AND cust_svc.svcpart = pkg_svc.svcpart
2857                                 )
2858     )';
2859
2860   }
2861
2862   ##
2863   # setup queries, links, subs, etc. for the search
2864   ##
2865
2866   # here is the agent virtualization
2867   if ($params->{CurrentUser}) {
2868     my $access_user =
2869       qsearchs('access_user', { username => $params->{CurrentUser} });
2870
2871     if ($access_user) {
2872       push @where, $access_user->agentnums_sql('table'=>'cust_main');
2873     } else {
2874       push @where, "1=0";
2875     }
2876   } else {
2877     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql('table'=>'cust_main');
2878   }
2879
2880   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2881
2882   my $addl_from = 'LEFT JOIN cust_main USING ( custnum  ) '.
2883                   'LEFT JOIN part_pkg  USING ( pkgpart  ) '.
2884                   'LEFT JOIN pkg_class ON ( part_pkg.classnum = pkg_class.classnum ) ';
2885
2886   my $count_query = "SELECT COUNT(*) FROM cust_pkg $addl_from $extra_sql";
2887
2888   my $sql_query = {
2889     'table'       => 'cust_pkg',
2890     'hashref'     => {},
2891     'select'      => join(', ',
2892                                 'cust_pkg.*',
2893                                 ( map "part_pkg.$_", qw( pkg freq ) ),
2894                                 'pkg_class.classname',
2895                                 'cust_main.custnum AS cust_main_custnum',
2896                                 FS::UI::Web::cust_sql_fields(
2897                                   $params->{'cust_fields'}
2898                                 ),
2899                      ),
2900     'extra_sql'   => "$extra_sql $orderby",
2901     'addl_from'   => $addl_from,
2902     'count_query' => $count_query,
2903   };
2904
2905 }
2906
2907 =item fcc_477_count
2908
2909 Returns a list of two package counts.  The first is a count of packages
2910 based on the supplied criteria and the second is the count of residential
2911 packages with those same criteria.  Criteria are specified as in the search
2912 method.
2913
2914 =cut
2915
2916 sub fcc_477_count {
2917   my ($class, $params) = @_;
2918
2919   my $sql_query = $class->search( $params );
2920
2921   my $count_sql = delete($sql_query->{'count_query'});
2922   $count_sql =~ s/ FROM/,count(CASE WHEN cust_main.company IS NULL OR cust_main.company = '' THEN 1 END) FROM/
2923     or die "couldn't parse count_sql";
2924
2925   my $count_sth = dbh->prepare($count_sql)
2926     or die "Error preparing $count_sql: ". dbh->errstr;
2927   $count_sth->execute
2928     or die "Error executing $count_sql: ". $count_sth->errstr;
2929   my $count_arrayref = $count_sth->fetchrow_arrayref;
2930
2931   return ( @$count_arrayref );
2932
2933 }
2934
2935
2936 =item location_sql
2937
2938 Returns a list: the first item is an SQL fragment identifying matching
2939 packages/customers via location (taking into account shipping and package
2940 address taxation, if enabled), and subsequent items are the parameters to
2941 substitute for the placeholders in that fragment.
2942
2943 =cut
2944
2945 sub location_sql {
2946   my($class, %opt) = @_;
2947   my $ornull = $opt{'ornull'};
2948
2949   my $conf = new FS::Conf;
2950
2951   # '?' placeholders in _location_sql_where
2952   my $x = $ornull ? 3 : 2;
2953   my @bill_param = ( ('city')x3, ('county')x$x, ('state')x$x, 'country' );
2954
2955   my $main_where;
2956   my @main_param;
2957   if ( $conf->exists('tax-ship_address') ) {
2958
2959     $main_where = "(
2960          (     ( ship_last IS NULL     OR  ship_last  = '' )
2961            AND ". _location_sql_where('cust_main', '', $ornull ). "
2962          )
2963       OR (       ship_last IS NOT NULL AND ship_last != ''
2964            AND ". _location_sql_where('cust_main', 'ship_', $ornull ). "
2965          )
2966     )";
2967     #    AND payby != 'COMP'
2968
2969     @main_param = ( @bill_param, @bill_param );
2970
2971   } else {
2972
2973     $main_where = _location_sql_where('cust_main'); # AND payby != 'COMP'
2974     @main_param = @bill_param;
2975
2976   }
2977
2978   my $where;
2979   my @param;
2980   if ( $conf->exists('tax-pkg_address') ) {
2981
2982     my $loc_where = _location_sql_where( 'cust_location', '', $ornull );
2983
2984     $where = " (
2985                     ( cust_pkg.locationnum IS     NULL AND $main_where )
2986                  OR ( cust_pkg.locationnum IS NOT NULL AND $loc_where  )
2987                )
2988              ";
2989     @param = ( @main_param, @bill_param );
2990
2991   } else {
2992
2993     $where = $main_where;
2994     @param = @main_param;
2995
2996   }
2997
2998   ( $where, @param );
2999
3000 }
3001
3002 #subroutine, helper for location_sql
3003 sub _location_sql_where {
3004   my $table  = shift;
3005   my $prefix = @_ ? shift : '';
3006   my $ornull = @_ ? shift : '';
3007
3008 #  $ornull             = $ornull          ? " OR ( ? IS NULL AND $table.${prefix}county IS NULL ) " : '';
3009
3010   $ornull = $ornull ? ' OR ? IS NULL ' : '';
3011
3012   my $or_empty_city   = " OR ( ? = '' AND $table.${prefix}city   IS NULL ) ";
3013   my $or_empty_county = " OR ( ? = '' AND $table.${prefix}county IS NULL ) ";
3014   my $or_empty_state =  " OR ( ? = '' AND $table.${prefix}state  IS NULL ) ";
3015
3016 #        ( $table.${prefix}city    = ? $or_empty_city   $ornull )
3017   "
3018         ( $table.${prefix}city    = ? OR ? = '' OR CAST(? AS text) IS NULL )
3019     AND ( $table.${prefix}county  = ? $or_empty_county $ornull )
3020     AND ( $table.${prefix}state   = ? $or_empty_state  $ornull )
3021     AND   $table.${prefix}country = ?
3022   ";
3023 }
3024
3025 =head1 SUBROUTINES
3026
3027 =over 4
3028
3029 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF [ REFNUM ] ] ]
3030
3031 CUSTNUM is a customer (see L<FS::cust_main>)
3032
3033 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3034 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
3035 permitted.
3036
3037 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
3038 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
3039 new billing items.  An error is returned if this is not possible (see
3040 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
3041 parameter.
3042
3043 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3044 newly-created cust_pkg objects.
3045
3046 REFNUM, if specified, will specify the FS::pkg_referral record to be created
3047 and inserted.  Multiple FS::pkg_referral records can be created by
3048 setting I<refnum> to an array reference of refnums or a hash reference with
3049 refnums as keys.  If no I<refnum> is defined, a default FS::pkg_referral
3050 record will be created corresponding to cust_main.refnum.
3051
3052 =cut
3053
3054 sub order {
3055   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg, $refnum) = @_;
3056
3057   my $conf = new FS::Conf;
3058
3059   # Transactionize this whole mess
3060   local $SIG{HUP} = 'IGNORE';
3061   local $SIG{INT} = 'IGNORE';
3062   local $SIG{QUIT} = 'IGNORE';
3063   local $SIG{TERM} = 'IGNORE';
3064   local $SIG{TSTP} = 'IGNORE';
3065   local $SIG{PIPE} = 'IGNORE';
3066
3067   my $oldAutoCommit = $FS::UID::AutoCommit;
3068   local $FS::UID::AutoCommit = 0;
3069   my $dbh = dbh;
3070
3071   my $error;
3072 #  my $cust_main = qsearchs('cust_main', { custnum => $custnum });
3073 #  return "Customer not found: $custnum" unless $cust_main;
3074
3075   warn "$me order: pkgnums to remove: ". join(',', @$remove_pkgnum). "\n"
3076     if $DEBUG;
3077
3078   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3079                          @$remove_pkgnum;
3080
3081   my $change = scalar(@old_cust_pkg) != 0;
3082
3083   my %hash = ();
3084   if ( scalar(@old_cust_pkg) == 1 && scalar(@$pkgparts) == 1 ) {
3085
3086     warn "$me order: changing pkgnum ". $old_cust_pkg[0]->pkgnum.
3087          " to pkgpart ". $pkgparts->[0]. "\n"
3088       if $DEBUG;
3089
3090     my $err_or_cust_pkg =
3091       $old_cust_pkg[0]->change( 'pkgpart' => $pkgparts->[0],
3092                                 'refnum'  => $refnum,
3093                               );
3094
3095     unless (ref($err_or_cust_pkg)) {
3096       $dbh->rollback if $oldAutoCommit;
3097       return $err_or_cust_pkg;
3098     }
3099
3100     push @$return_cust_pkg, $err_or_cust_pkg;
3101     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3102     return '';
3103
3104   }
3105
3106   # Create the new packages.
3107   foreach my $pkgpart (@$pkgparts) {
3108
3109     warn "$me order: inserting pkgpart $pkgpart\n" if $DEBUG;
3110
3111     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
3112                                       pkgpart => $pkgpart,
3113                                       refnum  => $refnum,
3114                                       %hash,
3115                                     };
3116     $error = $cust_pkg->insert( 'change' => $change );
3117     if ($error) {
3118       $dbh->rollback if $oldAutoCommit;
3119       return $error;
3120     }
3121     push @$return_cust_pkg, $cust_pkg;
3122   }
3123   # $return_cust_pkg now contains refs to all of the newly
3124   # created packages.
3125
3126   # Transfer services and cancel old packages.
3127   foreach my $old_pkg (@old_cust_pkg) {
3128
3129     warn "$me order: transferring services from pkgnum ". $old_pkg->pkgnum. "\n"
3130       if $DEBUG;
3131
3132     foreach my $new_pkg (@$return_cust_pkg) {
3133       $error = $old_pkg->transfer($new_pkg);
3134       if ($error and $error == 0) {
3135         # $old_pkg->transfer failed.
3136         $dbh->rollback if $oldAutoCommit;
3137         return $error;
3138       }
3139     }
3140
3141     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
3142       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
3143       foreach my $new_pkg (@$return_cust_pkg) {
3144         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
3145         if ($error and $error == 0) {
3146           # $old_pkg->transfer failed.
3147         $dbh->rollback if $oldAutoCommit;
3148         return $error;
3149         }
3150       }
3151     }
3152
3153     if ($error > 0) {
3154       # Transfers were successful, but we went through all of the
3155       # new packages and still had services left on the old package.
3156       # We can't cancel the package under the circumstances, so abort.
3157       $dbh->rollback if $oldAutoCommit;
3158       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
3159     }
3160     $error = $old_pkg->cancel( quiet=>1 );
3161     if ($error) {
3162       $dbh->rollback;
3163       return $error;
3164     }
3165   }
3166   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3167   '';
3168 }
3169
3170 =item bulk_change PKGPARTS_ARYREF, REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ]
3171
3172 A bulk change method to change packages for multiple customers.
3173
3174 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
3175 L<FS::part_pkg>) to order for each customer.  Duplicates are of course
3176 permitted.
3177
3178 REMOVE_PKGNUMS is an list of pkgnums specifying the billing items to
3179 replace.  The services (see L<FS::cust_svc>) are moved to the
3180 new billing items.  An error is returned if this is not possible (see
3181 L<FS::pkg_svc>).
3182
3183 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
3184 newly-created cust_pkg objects.
3185
3186 =cut
3187
3188 sub bulk_change {
3189   my ($pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
3190
3191   # Transactionize this whole mess
3192   local $SIG{HUP} = 'IGNORE';
3193   local $SIG{INT} = 'IGNORE';
3194   local $SIG{QUIT} = 'IGNORE';
3195   local $SIG{TERM} = 'IGNORE';
3196   local $SIG{TSTP} = 'IGNORE';
3197   local $SIG{PIPE} = 'IGNORE';
3198
3199   my $oldAutoCommit = $FS::UID::AutoCommit;
3200   local $FS::UID::AutoCommit = 0;
3201   my $dbh = dbh;
3202
3203   my @errors;
3204   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
3205                          @$remove_pkgnum;
3206
3207   while(scalar(@old_cust_pkg)) {
3208     my @return = ();
3209     my $custnum = $old_cust_pkg[0]->custnum;
3210     my (@remove) = map { $_->pkgnum }
3211                    grep { $_->custnum == $custnum } @old_cust_pkg;
3212     @old_cust_pkg = grep { $_->custnum != $custnum } @old_cust_pkg;
3213
3214     my $error = order $custnum, $pkgparts, \@remove, \@return;
3215
3216     push @errors, $error
3217       if $error;
3218     push @$return_cust_pkg, @return;
3219   }
3220
3221   if (scalar(@errors)) {
3222     $dbh->rollback if $oldAutoCommit;
3223     return join(' / ', @errors);
3224   }
3225
3226   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3227   '';
3228 }
3229
3230 # Used by FS::Upgrade to migrate to a new database.
3231 sub _upgrade_data {  # class method
3232   my ($class, %opts) = @_;
3233   $class->_upgrade_otaker(%opts);
3234 }
3235
3236 =back
3237
3238 =head1 BUGS
3239
3240 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
3241
3242 In sub order, the @pkgparts array (passed by reference) is clobbered.
3243
3244 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
3245 method to pass dates to the recur_prog expression, it should do so.
3246
3247 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
3248 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
3249 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
3250 configuration values.  Probably need a subroutine which decides what to do
3251 based on whether or not we've fetched the user yet, rather than a hash.  See
3252 FS::UID and the TODO.
3253
3254 Now that things are transactional should the check in the insert method be
3255 moved to check ?
3256
3257 =head1 SEE ALSO
3258
3259 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
3260 L<FS::pkg_svc>, schema.html from the base documentation
3261
3262 =cut
3263
3264 1;
3265