FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG);
   5 use FS::UID qw( getotaker dbh );
   6 use FS::Record qw( qsearch qsearchs );
   7 use FS::Misc qw( send_email );
   8 use FS::cust_svc;
   9 use FS::part_pkg;
  10 use FS::cust_main;
  11 use FS::type_pkgs;
  12 use FS::pkg_svc;
  13 use FS::cust_bill_pkg;
  14 use FS::h_cust_svc;
  15
  16 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  17 # setup }
  18 # because they load configuraion by setting FS::UID::callback (see TODO)
  19 use FS::svc_acct;
  20 use FS::svc_domain;
  21 use FS::svc_www;
  22 use FS::svc_forward;
  23
  24 # for sending cancel emails in sub cancel
  25 use FS::Conf;
  26
  27 @ISA = qw( FS::Record );
  28
  29 $DEBUG = 0;
  30
  31 $disable_agentcheck = 0;
  32
  33 # The order in which to unprovision services.
  34 @SVCDB_CANCEL_SEQ = qw( svc_external
  35                         svc_www
  36                         svc_forward
  37                         svc_acct
  38                         svc_domain
  39                         svc_broadband );
  40
  41 sub _cache {
  42   my $self = shift;
  43   my ( $hashref, $cache ) = @_;
  44   #if ( $hashref->{'pkgpart'} ) {
  45   if ( $hashref->{'pkg'} ) {
  46     # #@{ $self->{'_pkgnum'} } = ();
  47     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  48     # $self->{'_pkgpart'} = $subcache;
  49     # #push @{ $self->{'_pkgnum'} },
  50     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  51     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  52   }
  53   if ( exists $hashref->{'svcnum'} ) {
  54     #@{ $self->{'_pkgnum'} } = ();
  55     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  56     $self->{'_svcnum'} = $subcache;
  57     #push @{ $self->{'_pkgnum'} },
  58     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  59   }
  60 }
  61
  62 =head1 NAME
  63
  64 FS::cust_pkg - Object methods for cust_pkg objects
  65
  66 =head1 SYNOPSIS
  67
  68   use FS::cust_pkg;
  69
  70   $record = new FS::cust_pkg \%hash;
  71   $record = new FS::cust_pkg { 'column' => 'value' };
  72
  73   $error = $record->insert;
  74
  75   $error = $new_record->replace($old_record);
  76
  77   $error = $record->delete;
  78
  79   $error = $record->check;
  80
  81   $error = $record->cancel;
  82
  83   $error = $record->suspend;
  84
  85   $error = $record->unsuspend;
  86
  87   $part_pkg = $record->part_pkg;
  88
  89   @labels = $record->labels;
  90
  91   $seconds = $record->seconds_since($timestamp);
  92
  93   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  94   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  95
  96 =head1 DESCRIPTION
  97
  98 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  99 inherits from FS::Record.  The following fields are currently supported:
 100
 101 =over 4
 102
 103 =item pkgnum - primary key (assigned automatically for new billing items)
 104
 105 =item custnum - Customer (see L<FS::cust_main>)
 106
 107 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
 108
 109 =item setup - date
 110
 111 =item bill - date (next bill date)
 112
 113 =item last_bill - last bill date
 114
 115 =item susp - date
 116
 117 =item expire - date
 118
 119 =item cancel - date
 120
 121 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 122
 123 =item manual_flag - If this field is set to 1, disables the automatic
 124 unsuspension of this package when using the B<unsuspendauto> config file.
 125
 126 =back
 127
 128 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
 129 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 130 conversion functions.
 131
 132 =head1 METHODS
 133
 134 =over 4
 135
 136 =item new HASHREF
 137
 138 Create a new billing item.  To add the item to the database, see L<"insert">.
 139
 140 =cut
 141
 142 sub table { 'cust_pkg'; }
 143
 144 =item insert [ OPTION => VALUE ... ]
 145
 146 Adds this billing item to the database ("Orders" the item).  If there is an
 147 error, returns the error, otherwise returns false.
 148
 149 If the additional field I<promo_code> is defined instead of I<pkgpart>, it
 150 will be used to look up the package definition and agent restrictions will be
 151 ignored.
 152
 153 The following options are available: I<change>
 154
 155 I<change>, if set true, supresses any referral credit to a referring customer.
 156
 157 =cut
 158
 159 sub insert {
 160   my( $self, %options ) = @_;
 161
 162   local $SIG{HUP} = 'IGNORE';
 163   local $SIG{INT} = 'IGNORE';
 164   local $SIG{QUIT} = 'IGNORE';
 165   local $SIG{TERM} = 'IGNORE';
 166   local $SIG{TSTP} = 'IGNORE';
 167   local $SIG{PIPE} = 'IGNORE';
 168
 169   my $oldAutoCommit = $FS::UID::AutoCommit;
 170   local $FS::UID::AutoCommit = 0;
 171   my $dbh = dbh;
 172
 173   my $error = $self->SUPER::insert;
 174   if ( $error ) {
 175     $dbh->rollback if $oldAutoCommit;
 176     return $error;
 177   }
 178
 179   my $conf = new FS::Conf;
 180   my $cust_main = $self->cust_main;
 181   my $part_pkg = $self->part_pkg;
 182   if ( $conf->exists('referral_credit')
 183        && $cust_main->referral_custnum
 184        && ! $options{'change'}
 185        && $part_pkg->freq !~ /^0\D?$/
 186      )
 187   {
 188     my $referring_cust_main = $cust_main->referring_cust_main;
 189     if ( $referring_cust_main->status ne 'cancelled' ) {
 190       my $error;
 191       if ( $part_pkg->freq !~ /^\d+$/ ) {
 192         warn 'WARNING: Not crediting customer '. $cust_main->referral_custnum.
 193              ' for package '. $self->pkgnum.
 194              ' ( customer '. $self->custnum. ')'.
 195              ' - One-time referral credits not (yet) available for '.
 196              ' packages with '. $part_pkg->freq_pretty. ' frequency';
 197       } else {
 198
 199         my $amount = sprintf( "%.2f", $part_pkg->base_recur / $part_pkg->freq );
 200         my $error =
 201           $referring_cust_main->credit( $amount,
 202                                         'Referral credit for '. $cust_main->name
 203                                       );
 204         if ( $error ) {
 205           $dbh->rollback if $oldAutoCommit;
 206           return "Error crediting customer ". $cust_main->referral_custnum.
 207                " for referral: $error";
 208         }
 209
 210       }
 211
 212     }
 213   }
 214
 215   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 216   '';
 217
 218 }
 219
 220 =item delete
 221
 222 This method now works but you probably shouldn't use it.
 223
 224 You don't want to delete billing items, because there would then be no record
 225 the customer ever purchased the item.  Instead, see the cancel method.
 226
 227 =cut
 228
 229 #sub delete {
 230 #  return "Can't delete cust_pkg records!";
 231 #}
 232
 233 =item replace OLD_RECORD
 234
 235 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 236 returns the error, otherwise returns false.
 237
 238 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 239
 240 Changing pkgpart may have disasterous effects.  See the order subroutine.
 241
 242 setup and bill are normally updated by calling the bill method of a customer
 243 object (see L<FS::cust_main>).
 244
 245 suspend is normally updated by the suspend and unsuspend methods.
 246
 247 cancel is normally updated by the cancel method (and also the order subroutine
 248 in some cases).
 249
 250 =cut
 251
 252 sub replace {
 253   my( $new, $old ) = ( shift, shift );
 254
 255   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 256   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 257
 258   #allow this *sigh*
 259   #return "Can't change setup once it exists!"
 260   #  if $old->getfield('setup') &&
 261   #     $old->getfield('setup') != $new->getfield('setup');
 262
 263   #some logic for bill, susp, cancel?
 264
 265   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 266
 267   $new->SUPER::replace($old);
 268 }
 269
 270 =item check
 271
 272 Checks all fields to make sure this is a valid billing item.  If there is an
 273 error, returns the error, otherwise returns false.  Called by the insert and
 274 replace methods.
 275
 276 =cut
 277
 278 sub check {
 279   my $self = shift;
 280
 281   my $error =
 282     $self->ut_numbern('pkgnum')
 283     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 284     || $self->ut_numbern('pkgpart')
 285     || $self->ut_numbern('setup')
 286     || $self->ut_numbern('bill')
 287     || $self->ut_numbern('susp')
 288     || $self->ut_numbern('cancel')
 289   ;
 290   return $error if $error;
 291
 292   if ( $self->promo_code ) {
 293
 294     my $promo_part_pkg =
 295       qsearchs('part_pkg', {
 296         'pkgpart'    => $self->pkgpart,
 297         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 298       } );
 299     return 'Unknown promotional code' unless $promo_part_pkg;
 300     $self->pkgpart($promo_part_pkg->pkgpart);
 301
 302   } else {
 303
 304     unless ( $disable_agentcheck ) {
 305       my $agent =
 306         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 307       my $pkgpart_href = $agent->pkgpart_hashref;
 308       return "agent ". $agent->agentnum.
 309              " can't purchase pkgpart ". $self->pkgpart
 310         unless $pkgpart_href->{ $self->pkgpart };
 311     }
 312
 313     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 314     return $error if $error;
 315
 316   }
 317
 318   $self->otaker(getotaker) unless $self->otaker;
 319   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
 320   $self->otaker($1);
 321
 322   if ( $self->dbdef_table->column('manual_flag') ) {
 323     $self->manual_flag('') if $self->manual_flag eq ' ';
 324     $self->manual_flag =~ /^([01]?)$/
 325       or return "Illegal manual_flag ". $self->manual_flag;
 326     $self->manual_flag($1);
 327   }
 328
 329   $self->SUPER::check;
 330 }
 331
 332 =item cancel [ OPTION => VALUE ... ]
 333
 334 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 335 in this package, then cancels the package itself (sets the cancel field to
 336 now).
 337
 338 Available options are: I<quiet>
 339
 340 I<quiet> can be set true to supress email cancellation notices.
 341
 342 If there is an error, returns the error, otherwise returns false.
 343
 344 =cut
 345
 346 sub cancel {
 347   my( $self, %options ) = @_;
 348   my $error;
 349
 350   local $SIG{HUP} = 'IGNORE';
 351   local $SIG{INT} = 'IGNORE';
 352   local $SIG{QUIT} = 'IGNORE';
 353   local $SIG{TERM} = 'IGNORE';
 354   local $SIG{TSTP} = 'IGNORE';
 355   local $SIG{PIPE} = 'IGNORE';
 356
 357   my $oldAutoCommit = $FS::UID::AutoCommit;
 358   local $FS::UID::AutoCommit = 0;
 359   my $dbh = dbh;
 360
 361   my %svc;
 362   foreach my $cust_svc (
 363       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 364   ) {
 365     push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
 366   }
 367
 368   foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
 369     foreach my $cust_svc (@{ $svc{$svcdb} }) {
 370       my $error = $cust_svc->cancel;
 371
 372       if ( $error ) {
 373         $dbh->rollback if $oldAutoCommit;
 374         return "Error cancelling cust_svc: $error";
 375       }
 376     }
 377   }
 378
 379   # Add a credit for remaining service
 380   my $remaining_value= $self->calc_remain();
 381   if ($remaining_value > 0) {
 382     my $error = $self->credit($remaining_value, 'Credit for service remaining');
 383     if ($error) {
 384       $dbh->rollback if $oldAutoCommit;
 385       return "Error crediting customer for service remaining: $error";
 386     }
 387   }
 388
 389   unless ( $self->getfield('cancel') ) {
 390     my %hash = $self->hash;
 391     $hash{'cancel'} = time;
 392     my $new = new FS::cust_pkg ( \%hash );
 393     $error = $new->replace($self);
 394     if ( $error ) {
 395       $dbh->rollback if $oldAutoCommit;
 396       return $error;
 397     }
 398   }
 399
 400   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 401
 402   my $conf = new FS::Conf;
 403   my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list;
 404   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 405     my $conf = new FS::Conf;
 406     my $error = send_email(
 407       'from'    => $conf->config('invoice_from'),
 408       'to'      => \@invoicing_list,
 409       'subject' => $conf->config('cancelsubject'),
 410       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 411     );
 412     #should this do something on errors?
 413   }
 414
 415   ''; #no errors
 416
 417 }
 418
 419 =item suspend
 420
 421 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 422 package, then suspends the package itself (sets the susp field to now).
 423
 424 If there is an error, returns the error, otherwise returns false.
 425
 426 =cut
 427
 428 sub suspend {
 429   my $self = shift;
 430   my $error ;
 431
 432   local $SIG{HUP} = 'IGNORE';
 433   local $SIG{INT} = 'IGNORE';
 434   local $SIG{QUIT} = 'IGNORE';
 435   local $SIG{TERM} = 'IGNORE';
 436   local $SIG{TSTP} = 'IGNORE';
 437   local $SIG{PIPE} = 'IGNORE';
 438
 439   my $oldAutoCommit = $FS::UID::AutoCommit;
 440   local $FS::UID::AutoCommit = 0;
 441   my $dbh = dbh;
 442
 443   foreach my $cust_svc (
 444     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 445   ) {
 446     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 447
 448     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 449       $dbh->rollback if $oldAutoCommit;
 450       return "Illegal svcdb value in part_svc!";
 451     };
 452     my $svcdb = $1;
 453     require "FS/$svcdb.pm";
 454
 455     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 456     if ($svc) {
 457       $error = $svc->suspend;
 458       if ( $error ) {
 459         $dbh->rollback if $oldAutoCommit;
 460         return $error;
 461       }
 462     }
 463
 464   }
 465
 466   unless ( $self->getfield('susp') ) {
 467     my %hash = $self->hash;
 468     $hash{'susp'} = time;
 469     my $new = new FS::cust_pkg ( \%hash );
 470     $error = $new->replace($self);
 471     if ( $error ) {
 472       $dbh->rollback if $oldAutoCommit;
 473       return $error;
 474     }
 475   }
 476
 477   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 478
 479   ''; #no errors
 480 }
 481
 482 =item unsuspend
 483
 484 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 485 package, then unsuspends the package itself (clears the susp field).
 486
 487 If there is an error, returns the error, otherwise returns false.
 488
 489 =cut
 490
 491 sub unsuspend {
 492   my $self = shift;
 493   my($error);
 494
 495   local $SIG{HUP} = 'IGNORE';
 496   local $SIG{INT} = 'IGNORE';
 497   local $SIG{QUIT} = 'IGNORE';
 498   local $SIG{TERM} = 'IGNORE';
 499   local $SIG{TSTP} = 'IGNORE';
 500   local $SIG{PIPE} = 'IGNORE';
 501
 502   my $oldAutoCommit = $FS::UID::AutoCommit;
 503   local $FS::UID::AutoCommit = 0;
 504   my $dbh = dbh;
 505
 506   foreach my $cust_svc (
 507     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 508   ) {
 509     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 510
 511     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 512       $dbh->rollback if $oldAutoCommit;
 513       return "Illegal svcdb value in part_svc!";
 514     };
 515     my $svcdb = $1;
 516     require "FS/$svcdb.pm";
 517
 518     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 519     if ($svc) {
 520       $error = $svc->unsuspend;
 521       if ( $error ) {
 522         $dbh->rollback if $oldAutoCommit;
 523         return $error;
 524       }
 525     }
 526
 527   }
 528
 529   unless ( ! $self->getfield('susp') ) {
 530     my %hash = $self->hash;
 531     my $inactive = time - $hash{'susp'};
 532     $hash{'susp'} = '';
 533     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 534       if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 535     my $new = new FS::cust_pkg ( \%hash );
 536     $error = $new->replace($self);
 537     if ( $error ) {
 538       $dbh->rollback if $oldAutoCommit;
 539       return $error;
 540     }
 541   }
 542
 543   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 544
 545   ''; #no errors
 546 }
 547
 548 =item last_bill
 549
 550 Returns the last bill date, or if there is no last bill date, the setup date.
 551 Useful for billing metered services.
 552
 553 =cut
 554
 555 sub last_bill {
 556   my $self = shift;
 557   if ( $self->dbdef_table->column('last_bill') ) {
 558     return $self->setfield('last_bill', $_[0]) if @_;
 559     return $self->getfield('last_bill') if $self->getfield('last_bill');
 560   }
 561   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 562                                                   'edate'  => $self->bill,  } );
 563   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 564 }
 565
 566 =item part_pkg
 567
 568 Returns the definition for this billing item, as an FS::part_pkg object (see
 569 L<FS::part_pkg>).
 570
 571 =cut
 572
 573 sub part_pkg {
 574   my $self = shift;
 575   #exists( $self->{'_pkgpart'} )
 576   $self->{'_pkgpart'}
 577     ? $self->{'_pkgpart'}
 578     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 579 }
 580
 581 =item calc_setup
 582
 583 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 584 item.
 585
 586 =cut
 587
 588 sub calc_setup {
 589   my $self = shift;
 590   $self->part_pkg->calc_setup($self, @_);
 591 }
 592
 593 =item calc_recur
 594
 595 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 596 item.
 597
 598 =cut
 599
 600 sub calc_recur {
 601   my $self = shift;
 602   $self->part_pkg->calc_recur($self, @_);
 603 }
 604
 605 =item calc_remain
 606
 607 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 608 billing item.
 609
 610 =cut
 611
 612 sub calc_recur {
 613   my $self = shift;
 614   $self->part_pkg->calc_remain($self, @_);
 615 }
 616
 617 =item calc_cancel
 618
 619 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 620 billing item.
 621
 622 =cut
 623
 624 sub calc_cancel {
 625   my $self = shift;
 626   $self->part_pkg->calc_cancel($self, @_);
 627 }
 628
 629 =item cust_svc [ SVCPART ]
 630
 631 Returns the services for this package, as FS::cust_svc objects (see
 632 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 633 services.
 634
 635 =cut
 636
 637 sub cust_svc {
 638   my $self = shift;
 639
 640   if ( @_ ) {
 641     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 642                                   'svcpart' => shift,          } );
 643   }
 644
 645   #if ( $self->{'_svcnum'} ) {
 646   #  values %{ $self->{'_svcnum'}->cache };
 647   #} else {
 648     $self->_sort_cust_svc(
 649       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 650     );
 651   #}
 652
 653 }
 654
 655 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 656
 657 Returns historical services for this package created before END TIMESTAMP and
 658 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 659 (see L<FS::h_cust_svc>).
 660
 661 =cut
 662
 663 sub h_cust_svc {
 664   my $self = shift;
 665
 666   $self->_sort_cust_svc(
 667     [ qsearch( 'h_cust_svc',
 668                { 'pkgnum' => $self->pkgnum, },
 669                FS::h_cust_svc->sql_h_search(@_),
 670              )
 671     ]
 672   );
 673 }
 674
 675 sub _sort_cust_svc {
 676   my( $self, $arrayref ) = @_;
 677
 678   map  { $_->[0] }
 679   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 680   map {
 681         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 682                                              'svcpart' => $_->svcpart     } );
 683         [ $_,
 684           $pkg_svc ? $pkg_svc->primary_svc : '',
 685           $pkg_svc ? $pkg_svc->quantity : 0,
 686         ];
 687       }
 688   @$arrayref;
 689
 690 }
 691
 692 =item num_cust_svc [ SVCPART ]
 693
 694 Returns the number of provisioned services for this package.  If a svcpart is
 695 specified, counts only the matching services.
 696
 697 =cut
 698
 699 sub num_cust_svc {
 700   my $self = shift;
 701   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 702   $sql .= ' AND svcpart = ?' if @_;
 703   my $sth = dbh->prepare($sql) or die dbh->errstr;
 704   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 705   $sth->fetchrow_arrayref->[0];
 706 }
 707
 708 =item available_part_svc
 709
 710 Returns a list FS::part_svc objects representing services included in this
 711 package but not yet provisioned.  Each FS::part_svc object also has an extra
 712 field, I<num_avail>, which specifies the number of available services.
 713
 714 =cut
 715
 716 sub available_part_svc {
 717   my $self = shift;
 718   grep { $_->num_avail > 0 }
 719     map {
 720           my $part_svc = $_->part_svc;
 721           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 722             $_->quantity - $self->num_cust_svc($_->svcpart);
 723           $part_svc;
 724         }
 725       $self->part_pkg->pkg_svc;
 726 }
 727
 728 =item labels
 729
 730 Returns a list of lists, calling the label method for all services
 731 (see L<FS::cust_svc>) of this billing item.
 732
 733 =cut
 734
 735 sub labels {
 736   my $self = shift;
 737   map { [ $_->label ] } $self->cust_svc;
 738 }
 739
 740 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
 741
 742 Like the labels method, but returns historical information on services that
 743 were active as of END_TIMESTAMP and (optionally) not cancelled before
 744 START_TIMESTAMP.
 745
 746 Returns a list of lists, calling the label method for all (historical) services
 747 (see L<FS::h_cust_svc>) of this billing item.
 748
 749 =cut
 750
 751 sub h_labels {
 752   my $self = shift;
 753   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
 754 }
 755
 756 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
 757
 758 Like h_labels, except returns a simple flat list, and shortens long
 759 (currently >5) lists of identical services to one line that lists the service
 760 label and the number of individual services rather than individual items.
 761
 762 =cut
 763
 764 sub h_labels_short {
 765   my $self = shift;
 766
 767   my %labels;
 768   #tie %labels, 'Tie::IxHash';
 769   push @{ $labels{$_->[0]} }, $_->[1]
 770     foreach $self->h_labels(@_);
 771   my @labels;
 772   foreach my $label ( keys %labels ) {
 773     my @values = @{ $labels{$label} };
 774     my $num = scalar(@values);
 775     if ( $num > 5 ) {
 776       push @labels, "$label ($num)";
 777     } else {
 778       push @labels, map { "$label: $_" } @values;
 779     }
 780   }
 781
 782  @labels;
 783
 784 }
 785
 786 =item cust_main
 787
 788 Returns the parent customer object (see L<FS::cust_main>).
 789
 790 =cut
 791
 792 sub cust_main {
 793   my $self = shift;
 794   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 795 }
 796
 797 =item seconds_since TIMESTAMP
 798
 799 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 800 package have been online since TIMESTAMP, according to the session monitor.
 801
 802 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 803 L<Time::Local> and L<Date::Parse> for conversion functions.
 804
 805 =cut
 806
 807 sub seconds_since {
 808   my($self, $since) = @_;
 809   my $seconds = 0;
 810
 811   foreach my $cust_svc (
 812     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 813   ) {
 814     $seconds += $cust_svc->seconds_since($since);
 815   }
 816
 817   $seconds;
 818
 819 }
 820
 821 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 822
 823 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 824 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 825 (exclusive).
 826
 827 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 828 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 829 functions.
 830
 831
 832 =cut
 833
 834 sub seconds_since_sqlradacct {
 835   my($self, $start, $end) = @_;
 836
 837   my $seconds = 0;
 838
 839   foreach my $cust_svc (
 840     grep {
 841       my $part_svc = $_->part_svc;
 842       $part_svc->svcdb eq 'svc_acct'
 843         && scalar($part_svc->part_export('sqlradius'));
 844     } $self->cust_svc
 845   ) {
 846     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 847   }
 848
 849   $seconds;
 850
 851 }
 852
 853 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 854
 855 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 856 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 857 TIMESTAMP_END
 858 (exclusive).
 859
 860 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 861 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 862 functions.
 863
 864 =cut
 865
 866 sub attribute_since_sqlradacct {
 867   my($self, $start, $end, $attrib) = @_;
 868
 869   my $sum = 0;
 870
 871   foreach my $cust_svc (
 872     grep {
 873       my $part_svc = $_->part_svc;
 874       $part_svc->svcdb eq 'svc_acct'
 875         && scalar($part_svc->part_export('sqlradius'));
 876     } $self->cust_svc
 877   ) {
 878     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 879   }
 880
 881   $sum;
 882
 883 }
 884
 885 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
 886
 887 Transfers as many services as possible from this package to another package.
 888
 889 The destination package can be specified by pkgnum by passing an FS::cust_pkg
 890 object.  The destination package must already exist.
 891
 892 Services are moved only if the destination allows services with the correct
 893 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
 894 this option with caution!  No provision is made for export differences
 895 between the old and new service definitions.  Probably only should be used
 896 when your exports for all service definitions of a given svcdb are identical.
 897 (attempt a transfer without it first, to move all possible svcpart-matching
 898 services)
 899
 900 Any services that can't be moved remain in the original package.
 901
 902 Returns an error, if there is one; otherwise, returns the number of services
 903 that couldn't be moved.
 904
 905 =cut
 906
 907 sub transfer {
 908   my ($self, $dest_pkgnum, %opt) = @_;
 909
 910   my $remaining = 0;
 911   my $dest;
 912   my %target;
 913
 914   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
 915     $dest = $dest_pkgnum;
 916     $dest_pkgnum = $dest->pkgnum;
 917   } else {
 918     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
 919   }
 920
 921   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 922
 923   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
 924     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
 925   }
 926
 927   foreach my $cust_svc ($dest->cust_svc) {
 928     $target{$cust_svc->svcpart}--;
 929   }
 930
 931   my %svcpart2svcparts = ();
 932   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 933     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
 934     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
 935       next if exists $svcpart2svcparts{$svcpart};
 936       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
 937       $svcpart2svcparts{$svcpart} = [
 938         map  { $_->[0] }
 939         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 940         map {
 941               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
 942                                                    'svcpart' => $_          } );
 943               [ $_,
 944                 $pkg_svc ? $pkg_svc->primary_svc : '',
 945                 $pkg_svc ? $pkg_svc->quantity : 0,
 946               ];
 947             }
 948
 949         grep { $_ != $svcpart }
 950         map  { $_->svcpart }
 951         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
 952       ];
 953       warn "alternates for svcpart $svcpart: ".
 954            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
 955         if $DEBUG;
 956     }
 957   }
 958
 959   foreach my $cust_svc ($self->cust_svc) {
 960     if($target{$cust_svc->svcpart} > 0) {
 961       $target{$cust_svc->svcpart}--;
 962       my $new = new FS::cust_svc {
 963         svcnum  => $cust_svc->svcnum,
 964         svcpart => $cust_svc->svcpart,
 965         pkgnum  => $dest_pkgnum,
 966       };
 967       my $error = $new->replace($cust_svc);
 968       return $error if $error;
 969     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 970       if ( $DEBUG ) {
 971         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
 972         warn "alternates to consider: ".
 973              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
 974       }
 975       my @alternate = grep {
 976                              warn "considering alternate svcpart $_: ".
 977                                   "$target{$_} available in new package\n"
 978                                if $DEBUG;
 979                              $target{$_} > 0;
 980                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
 981       if ( @alternate ) {
 982         warn "alternate(s) found\n" if $DEBUG;
 983         my $change_svcpart = $alternate[0];
 984         $target{$change_svcpart}--;
 985         my $new = new FS::cust_svc {
 986           svcnum  => $cust_svc->svcnum,
 987           svcpart => $change_svcpart,
 988           pkgnum  => $dest_pkgnum,
 989         };
 990         my $error = $new->replace($cust_svc);
 991         return $error if $error;
 992       } else {
 993         $remaining++;
 994       }
 995     } else {
 996       $remaining++
 997     }
 998   }
 999   return $remaining;
1000 }
1001
1002 =item reexport
1003
1004 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1005 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1006
1007 =cut
1008
1009 sub reexport {
1010   my $self = shift;
1011
1012   local $SIG{HUP} = 'IGNORE';
1013   local $SIG{INT} = 'IGNORE';
1014   local $SIG{QUIT} = 'IGNORE';
1015   local $SIG{TERM} = 'IGNORE';
1016   local $SIG{TSTP} = 'IGNORE';
1017   local $SIG{PIPE} = 'IGNORE';
1018
1019   my $oldAutoCommit = $FS::UID::AutoCommit;
1020   local $FS::UID::AutoCommit = 0;
1021   my $dbh = dbh;
1022
1023   foreach my $cust_svc ( $self->cust_svc ) {
1024     #false laziness w/svc_Common::insert
1025     my $svc_x = $cust_svc->svc_x;
1026     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1027       my $error = $part_export->export_insert($svc_x);
1028       if ( $error ) {
1029         $dbh->rollback if $oldAutoCommit;
1030         return $error;
1031       }
1032     }
1033   }
1034
1035   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1036   '';
1037
1038 }
1039
1040 =back
1041
1042 =head1 SUBROUTINES
1043
1044 =over 4
1045
1046 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1047
1048 CUSTNUM is a customer (see L<FS::cust_main>)
1049
1050 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1051 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1052 permitted.
1053
1054 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1055 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1056 new billing items.  An error is returned if this is not possible (see
1057 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1058 parameter.
1059
1060 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1061 newly-created cust_pkg objects.
1062
1063 =cut
1064
1065 sub order {
1066   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1067
1068   my $conf = new FS::Conf;
1069
1070   # Transactionize this whole mess
1071   local $SIG{HUP} = 'IGNORE';
1072   local $SIG{INT} = 'IGNORE';
1073   local $SIG{QUIT} = 'IGNORE';
1074   local $SIG{TERM} = 'IGNORE';
1075   local $SIG{TSTP} = 'IGNORE';
1076   local $SIG{PIPE} = 'IGNORE';
1077
1078   my $oldAutoCommit = $FS::UID::AutoCommit;
1079   local $FS::UID::AutoCommit = 0;
1080   my $dbh = dbh;
1081
1082   my $error;
1083   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1084   return "Customer not found: $custnum" unless $cust_main;
1085
1086   my $change = scalar(@$remove_pkgnum) != 0;
1087
1088   # Create the new packages.
1089   foreach my $pkgpart (@$pkgparts) {
1090     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1091                                       pkgpart => $pkgpart };
1092     $error = $cust_pkg->insert( 'change' => $change );
1093     if ($error) {
1094       $dbh->rollback if $oldAutoCommit;
1095       return $error;
1096     }
1097     push @$return_cust_pkg, $cust_pkg;
1098   }
1099   # $return_cust_pkg now contains refs to all of the newly
1100   # created packages.
1101
1102   # Transfer services and cancel old packages.
1103   foreach my $old_pkgnum (@$remove_pkgnum) {
1104     my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
1105
1106     foreach my $new_pkg (@$return_cust_pkg) {
1107       $error = $old_pkg->transfer($new_pkg);
1108       if ($error and $error == 0) {
1109         # $old_pkg->transfer failed.
1110         $dbh->rollback if $oldAutoCommit;
1111         return $error;
1112       }
1113     }
1114
1115     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1116       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1117       foreach my $new_pkg (@$return_cust_pkg) {
1118         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1119         if ($error and $error == 0) {
1120           # $old_pkg->transfer failed.
1121         $dbh->rollback if $oldAutoCommit;
1122         return $error;
1123         }
1124       }
1125     }
1126
1127     if ($error > 0) {
1128       # Transfers were successful, but we went through all of the
1129       # new packages and still had services left on the old package.
1130       # We can't cancel the package under the circumstances, so abort.
1131       $dbh->rollback if $oldAutoCommit;
1132       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1133     }
1134     $error = $old_pkg->cancel;
1135     if ($error) {
1136       $dbh->rollback;
1137       return $error;
1138     }
1139   }
1140   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1141   '';
1142 }
1143
1144 =back
1145
1146 =head1 BUGS
1147
1148 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1149
1150 In sub order, the @pkgparts array (passed by reference) is clobbered.
1151
1152 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1153 method to pass dates to the recur_prog expression, it should do so.
1154
1155 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1156 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1157 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1158 configuration values.  Probably need a subroutine which decides what to do
1159 based on whether or not we've fetched the user yet, rather than a hash.  See
1160 FS::UID and the TODO.
1161
1162 Now that things are transactional should the check in the insert method be
1163 moved to check ?
1164
1165 =head1 SEE ALSO
1166
1167 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1168 L<FS::pkg_svc>, schema.html from the base documentation
1169
1170 =cut
1171
1172 1;
1173