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