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->credit($remaining_value, 'Credit for service remaining');
 402     if ($error) {
 403       $dbh->rollback if $oldAutoCommit;
 404       return "Error crediting customer for service remaining: $error";
 405     }
 406   }
 407
 408   unless ( $self->getfield('cancel') ) {
 409     my %hash = $self->hash;
 410     $hash{'cancel'} = time;
 411     my $new = new FS::cust_pkg ( \%hash );
 412     $error = $new->replace($self);
 413     if ( $error ) {
 414       $dbh->rollback if $oldAutoCommit;
 415       return $error;
 416     }
 417   }
 418
 419   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 420
 421   my $conf = new FS::Conf;
 422   my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list;
 423   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 424     my $conf = new FS::Conf;
 425     my $error = send_email(
 426       'from'    => $conf->config('invoice_from'),
 427       'to'      => \@invoicing_list,
 428       'subject' => $conf->config('cancelsubject'),
 429       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 430     );
 431     #should this do something on errors?
 432   }
 433
 434   ''; #no errors
 435
 436 }
 437
 438 =item suspend
 439
 440 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 441 package, then suspends the package itself (sets the susp field to now).
 442
 443 If there is an error, returns the error, otherwise returns false.
 444
 445 =cut
 446
 447 sub suspend {
 448   my $self = shift;
 449   my $error ;
 450
 451   local $SIG{HUP} = 'IGNORE';
 452   local $SIG{INT} = 'IGNORE';
 453   local $SIG{QUIT} = 'IGNORE';
 454   local $SIG{TERM} = 'IGNORE';
 455   local $SIG{TSTP} = 'IGNORE';
 456   local $SIG{PIPE} = 'IGNORE';
 457
 458   my $oldAutoCommit = $FS::UID::AutoCommit;
 459   local $FS::UID::AutoCommit = 0;
 460   my $dbh = dbh;
 461
 462   foreach my $cust_svc (
 463     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 464   ) {
 465     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 466
 467     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 468       $dbh->rollback if $oldAutoCommit;
 469       return "Illegal svcdb value in part_svc!";
 470     };
 471     my $svcdb = $1;
 472     require "FS/$svcdb.pm";
 473
 474     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 475     if ($svc) {
 476       $error = $svc->suspend;
 477       if ( $error ) {
 478         $dbh->rollback if $oldAutoCommit;
 479         return $error;
 480       }
 481     }
 482
 483   }
 484
 485   unless ( $self->getfield('susp') ) {
 486     my %hash = $self->hash;
 487     $hash{'susp'} = time;
 488     my $new = new FS::cust_pkg ( \%hash );
 489     $error = $new->replace($self);
 490     if ( $error ) {
 491       $dbh->rollback if $oldAutoCommit;
 492       return $error;
 493     }
 494   }
 495
 496   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 497
 498   ''; #no errors
 499 }
 500
 501 =item unsuspend
 502
 503 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 504 package, then unsuspends the package itself (clears the susp field).
 505
 506 If there is an error, returns the error, otherwise returns false.
 507
 508 =cut
 509
 510 sub unsuspend {
 511   my $self = shift;
 512   my($error);
 513
 514   local $SIG{HUP} = 'IGNORE';
 515   local $SIG{INT} = 'IGNORE';
 516   local $SIG{QUIT} = 'IGNORE';
 517   local $SIG{TERM} = 'IGNORE';
 518   local $SIG{TSTP} = 'IGNORE';
 519   local $SIG{PIPE} = 'IGNORE';
 520
 521   my $oldAutoCommit = $FS::UID::AutoCommit;
 522   local $FS::UID::AutoCommit = 0;
 523   my $dbh = dbh;
 524
 525   foreach my $cust_svc (
 526     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 527   ) {
 528     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 529
 530     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 531       $dbh->rollback if $oldAutoCommit;
 532       return "Illegal svcdb value in part_svc!";
 533     };
 534     my $svcdb = $1;
 535     require "FS/$svcdb.pm";
 536
 537     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 538     if ($svc) {
 539       $error = $svc->unsuspend;
 540       if ( $error ) {
 541         $dbh->rollback if $oldAutoCommit;
 542         return $error;
 543       }
 544     }
 545
 546   }
 547
 548   unless ( ! $self->getfield('susp') ) {
 549     my %hash = $self->hash;
 550     my $inactive = time - $hash{'susp'};
 551     $hash{'susp'} = '';
 552     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 553       if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 554     my $new = new FS::cust_pkg ( \%hash );
 555     $error = $new->replace($self);
 556     if ( $error ) {
 557       $dbh->rollback if $oldAutoCommit;
 558       return $error;
 559     }
 560   }
 561
 562   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 563
 564   ''; #no errors
 565 }
 566
 567 =item last_bill
 568
 569 Returns the last bill date, or if there is no last bill date, the setup date.
 570 Useful for billing metered services.
 571
 572 =cut
 573
 574 sub last_bill {
 575   my $self = shift;
 576   if ( $self->dbdef_table->column('last_bill') ) {
 577     return $self->setfield('last_bill', $_[0]) if @_;
 578     return $self->getfield('last_bill') if $self->getfield('last_bill');
 579   }
 580   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 581                                                   'edate'  => $self->bill,  } );
 582   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 583 }
 584
 585 =item part_pkg
 586
 587 Returns the definition for this billing item, as an FS::part_pkg object (see
 588 L<FS::part_pkg>).
 589
 590 =cut
 591
 592 sub part_pkg {
 593   my $self = shift;
 594   #exists( $self->{'_pkgpart'} )
 595   $self->{'_pkgpart'}
 596     ? $self->{'_pkgpart'}
 597     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 598 }
 599
 600 =item calc_setup
 601
 602 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 603 item.
 604
 605 =cut
 606
 607 sub calc_setup {
 608   my $self = shift;
 609   $self->part_pkg->calc_setup($self, @_);
 610 }
 611
 612 =item calc_recur
 613
 614 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 615 item.
 616
 617 =cut
 618
 619 sub calc_recur {
 620   my $self = shift;
 621   $self->part_pkg->calc_recur($self, @_);
 622 }
 623
 624 =item calc_remain
 625
 626 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 627 billing item.
 628
 629 =cut
 630
 631 sub calc_remain {
 632   my $self = shift;
 633   $self->part_pkg->calc_remain($self, @_);
 634 }
 635
 636 =item calc_cancel
 637
 638 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 639 billing item.
 640
 641 =cut
 642
 643 sub calc_cancel {
 644   my $self = shift;
 645   $self->part_pkg->calc_cancel($self, @_);
 646 }
 647
 648 =item cust_svc [ SVCPART ]
 649
 650 Returns the services for this package, as FS::cust_svc objects (see
 651 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 652 services.
 653
 654 =cut
 655
 656 sub cust_svc {
 657   my $self = shift;
 658
 659   if ( @_ ) {
 660     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 661                                   'svcpart' => shift,          } );
 662   }
 663
 664   #if ( $self->{'_svcnum'} ) {
 665   #  values %{ $self->{'_svcnum'}->cache };
 666   #} else {
 667     $self->_sort_cust_svc(
 668       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 669     );
 670   #}
 671
 672 }
 673
 674 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 675
 676 Returns historical services for this package created before END TIMESTAMP and
 677 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 678 (see L<FS::h_cust_svc>).
 679
 680 =cut
 681
 682 sub h_cust_svc {
 683   my $self = shift;
 684
 685   $self->_sort_cust_svc(
 686     [ qsearch( 'h_cust_svc',
 687                { 'pkgnum' => $self->pkgnum, },
 688                FS::h_cust_svc->sql_h_search(@_),
 689              )
 690     ]
 691   );
 692 }
 693
 694 sub _sort_cust_svc {
 695   my( $self, $arrayref ) = @_;
 696
 697   map  { $_->[0] }
 698   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 699   map {
 700         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 701                                              'svcpart' => $_->svcpart     } );
 702         [ $_,
 703           $pkg_svc ? $pkg_svc->primary_svc : '',
 704           $pkg_svc ? $pkg_svc->quantity : 0,
 705         ];
 706       }
 707   @$arrayref;
 708
 709 }
 710
 711 =item num_cust_svc [ SVCPART ]
 712
 713 Returns the number of provisioned services for this package.  If a svcpart is
 714 specified, counts only the matching services.
 715
 716 =cut
 717
 718 sub num_cust_svc {
 719   my $self = shift;
 720   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 721   $sql .= ' AND svcpart = ?' if @_;
 722   my $sth = dbh->prepare($sql) or die dbh->errstr;
 723   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 724   $sth->fetchrow_arrayref->[0];
 725 }
 726
 727 =item available_part_svc
 728
 729 Returns a list FS::part_svc objects representing services included in this
 730 package but not yet provisioned.  Each FS::part_svc object also has an extra
 731 field, I<num_avail>, which specifies the number of available services.
 732
 733 =cut
 734
 735 sub available_part_svc {
 736   my $self = shift;
 737   grep { $_->num_avail > 0 }
 738     map {
 739           my $part_svc = $_->part_svc;
 740           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 741             $_->quantity - $self->num_cust_svc($_->svcpart);
 742           $part_svc;
 743         }
 744       $self->part_pkg->pkg_svc;
 745 }
 746
 747 =item labels
 748
 749 Returns a list of lists, calling the label method for all services
 750 (see L<FS::cust_svc>) of this billing item.
 751
 752 =cut
 753
 754 sub labels {
 755   my $self = shift;
 756   map { [ $_->label ] } $self->cust_svc;
 757 }
 758
 759 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
 760
 761 Like the labels method, but returns historical information on services that
 762 were active as of END_TIMESTAMP and (optionally) not cancelled before
 763 START_TIMESTAMP.
 764
 765 Returns a list of lists, calling the label method for all (historical) services
 766 (see L<FS::h_cust_svc>) of this billing item.
 767
 768 =cut
 769
 770 sub h_labels {
 771   my $self = shift;
 772   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
 773 }
 774
 775 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
 776
 777 Like h_labels, except returns a simple flat list, and shortens long
 778 (currently >5) lists of identical services to one line that lists the service
 779 label and the number of individual services rather than individual items.
 780
 781 =cut
 782
 783 sub h_labels_short {
 784   my $self = shift;
 785
 786   my %labels;
 787   #tie %labels, 'Tie::IxHash';
 788   push @{ $labels{$_->[0]} }, $_->[1]
 789     foreach $self->h_labels(@_);
 790   my @labels;
 791   foreach my $label ( keys %labels ) {
 792     my @values = @{ $labels{$label} };
 793     my $num = scalar(@values);
 794     if ( $num > 5 ) {
 795       push @labels, "$label ($num)";
 796     } else {
 797       push @labels, map { "$label: $_" } @values;
 798     }
 799   }
 800
 801  @labels;
 802
 803 }
 804
 805 =item cust_main
 806
 807 Returns the parent customer object (see L<FS::cust_main>).
 808
 809 =cut
 810
 811 sub cust_main {
 812   my $self = shift;
 813   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 814 }
 815
 816 =item seconds_since TIMESTAMP
 817
 818 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 819 package have been online since TIMESTAMP, according to the session monitor.
 820
 821 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 822 L<Time::Local> and L<Date::Parse> for conversion functions.
 823
 824 =cut
 825
 826 sub seconds_since {
 827   my($self, $since) = @_;
 828   my $seconds = 0;
 829
 830   foreach my $cust_svc (
 831     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 832   ) {
 833     $seconds += $cust_svc->seconds_since($since);
 834   }
 835
 836   $seconds;
 837
 838 }
 839
 840 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 841
 842 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 843 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 844 (exclusive).
 845
 846 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 847 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 848 functions.
 849
 850
 851 =cut
 852
 853 sub seconds_since_sqlradacct {
 854   my($self, $start, $end) = @_;
 855
 856   my $seconds = 0;
 857
 858   foreach my $cust_svc (
 859     grep {
 860       my $part_svc = $_->part_svc;
 861       $part_svc->svcdb eq 'svc_acct'
 862         && scalar($part_svc->part_export('sqlradius'));
 863     } $self->cust_svc
 864   ) {
 865     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 866   }
 867
 868   $seconds;
 869
 870 }
 871
 872 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 873
 874 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 875 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 876 TIMESTAMP_END
 877 (exclusive).
 878
 879 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 880 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 881 functions.
 882
 883 =cut
 884
 885 sub attribute_since_sqlradacct {
 886   my($self, $start, $end, $attrib) = @_;
 887
 888   my $sum = 0;
 889
 890   foreach my $cust_svc (
 891     grep {
 892       my $part_svc = $_->part_svc;
 893       $part_svc->svcdb eq 'svc_acct'
 894         && scalar($part_svc->part_export('sqlradius'));
 895     } $self->cust_svc
 896   ) {
 897     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
 898   }
 899
 900   $sum;
 901
 902 }
 903
 904 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
 905
 906 Transfers as many services as possible from this package to another package.
 907
 908 The destination package can be specified by pkgnum by passing an FS::cust_pkg
 909 object.  The destination package must already exist.
 910
 911 Services are moved only if the destination allows services with the correct
 912 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
 913 this option with caution!  No provision is made for export differences
 914 between the old and new service definitions.  Probably only should be used
 915 when your exports for all service definitions of a given svcdb are identical.
 916 (attempt a transfer without it first, to move all possible svcpart-matching
 917 services)
 918
 919 Any services that can't be moved remain in the original package.
 920
 921 Returns an error, if there is one; otherwise, returns the number of services
 922 that couldn't be moved.
 923
 924 =cut
 925
 926 sub transfer {
 927   my ($self, $dest_pkgnum, %opt) = @_;
 928
 929   my $remaining = 0;
 930   my $dest;
 931   my %target;
 932
 933   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
 934     $dest = $dest_pkgnum;
 935     $dest_pkgnum = $dest->pkgnum;
 936   } else {
 937     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
 938   }
 939
 940   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
 941
 942   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
 943     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
 944   }
 945
 946   foreach my $cust_svc ($dest->cust_svc) {
 947     $target{$cust_svc->svcpart}--;
 948   }
 949
 950   my %svcpart2svcparts = ();
 951   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 952     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
 953     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
 954       next if exists $svcpart2svcparts{$svcpart};
 955       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
 956       $svcpart2svcparts{$svcpart} = [
 957         map  { $_->[0] }
 958         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 959         map {
 960               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
 961                                                    'svcpart' => $_          } );
 962               [ $_,
 963                 $pkg_svc ? $pkg_svc->primary_svc : '',
 964                 $pkg_svc ? $pkg_svc->quantity : 0,
 965               ];
 966             }
 967
 968         grep { $_ != $svcpart }
 969         map  { $_->svcpart }
 970         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
 971       ];
 972       warn "alternates for svcpart $svcpart: ".
 973            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
 974         if $DEBUG;
 975     }
 976   }
 977
 978   foreach my $cust_svc ($self->cust_svc) {
 979     if($target{$cust_svc->svcpart} > 0) {
 980       $target{$cust_svc->svcpart}--;
 981       my $new = new FS::cust_svc {
 982         svcnum  => $cust_svc->svcnum,
 983         svcpart => $cust_svc->svcpart,
 984         pkgnum  => $dest_pkgnum,
 985       };
 986       my $error = $new->replace($cust_svc);
 987       return $error if $error;
 988     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
 989       if ( $DEBUG ) {
 990         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
 991         warn "alternates to consider: ".
 992              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
 993       }
 994       my @alternate = grep {
 995                              warn "considering alternate svcpart $_: ".
 996                                   "$target{$_} available in new package\n"
 997                                if $DEBUG;
 998                              $target{$_} > 0;
 999                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1000       if ( @alternate ) {
1001         warn "alternate(s) found\n" if $DEBUG;
1002         my $change_svcpart = $alternate[0];
1003         $target{$change_svcpart}--;
1004         my $new = new FS::cust_svc {
1005           svcnum  => $cust_svc->svcnum,
1006           svcpart => $change_svcpart,
1007           pkgnum  => $dest_pkgnum,
1008         };
1009         my $error = $new->replace($cust_svc);
1010         return $error if $error;
1011       } else {
1012         $remaining++;
1013       }
1014     } else {
1015       $remaining++
1016     }
1017   }
1018   return $remaining;
1019 }
1020
1021 =item reexport
1022
1023 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1024 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1025
1026 =cut
1027
1028 sub reexport {
1029   my $self = shift;
1030
1031   local $SIG{HUP} = 'IGNORE';
1032   local $SIG{INT} = 'IGNORE';
1033   local $SIG{QUIT} = 'IGNORE';
1034   local $SIG{TERM} = 'IGNORE';
1035   local $SIG{TSTP} = 'IGNORE';
1036   local $SIG{PIPE} = 'IGNORE';
1037
1038   my $oldAutoCommit = $FS::UID::AutoCommit;
1039   local $FS::UID::AutoCommit = 0;
1040   my $dbh = dbh;
1041
1042   foreach my $cust_svc ( $self->cust_svc ) {
1043     #false laziness w/svc_Common::insert
1044     my $svc_x = $cust_svc->svc_x;
1045     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1046       my $error = $part_export->export_insert($svc_x);
1047       if ( $error ) {
1048         $dbh->rollback if $oldAutoCommit;
1049         return $error;
1050       }
1051     }
1052   }
1053
1054   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1055   '';
1056
1057 }
1058
1059 =back
1060
1061 =head1 SUBROUTINES
1062
1063 =over 4
1064
1065 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1066
1067 CUSTNUM is a customer (see L<FS::cust_main>)
1068
1069 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1070 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1071 permitted.
1072
1073 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1074 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1075 new billing items.  An error is returned if this is not possible (see
1076 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1077 parameter.
1078
1079 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1080 newly-created cust_pkg objects.
1081
1082 =cut
1083
1084 sub order {
1085   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1086
1087   my $conf = new FS::Conf;
1088
1089   # Transactionize this whole mess
1090   local $SIG{HUP} = 'IGNORE';
1091   local $SIG{INT} = 'IGNORE';
1092   local $SIG{QUIT} = 'IGNORE';
1093   local $SIG{TERM} = 'IGNORE';
1094   local $SIG{TSTP} = 'IGNORE';
1095   local $SIG{PIPE} = 'IGNORE';
1096
1097   my $oldAutoCommit = $FS::UID::AutoCommit;
1098   local $FS::UID::AutoCommit = 0;
1099   my $dbh = dbh;
1100
1101   my $error;
1102   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1103   return "Customer not found: $custnum" unless $cust_main;
1104
1105   my $change = scalar(@$remove_pkgnum) != 0;
1106
1107   # Create the new packages.
1108   foreach my $pkgpart (@$pkgparts) {
1109     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1110                                       pkgpart => $pkgpart };
1111     $error = $cust_pkg->insert( 'change' => $change );
1112     if ($error) {
1113       $dbh->rollback if $oldAutoCommit;
1114       return $error;
1115     }
1116     push @$return_cust_pkg, $cust_pkg;
1117   }
1118   # $return_cust_pkg now contains refs to all of the newly
1119   # created packages.
1120
1121   # Transfer services and cancel old packages.
1122   foreach my $old_pkgnum (@$remove_pkgnum) {
1123     my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum });
1124
1125     foreach my $new_pkg (@$return_cust_pkg) {
1126       $error = $old_pkg->transfer($new_pkg);
1127       if ($error and $error == 0) {
1128         # $old_pkg->transfer failed.
1129         $dbh->rollback if $oldAutoCommit;
1130         return $error;
1131       }
1132     }
1133
1134     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1135       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1136       foreach my $new_pkg (@$return_cust_pkg) {
1137         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1138         if ($error and $error == 0) {
1139           # $old_pkg->transfer failed.
1140         $dbh->rollback if $oldAutoCommit;
1141         return $error;
1142         }
1143       }
1144     }
1145
1146     if ($error > 0) {
1147       # Transfers were successful, but we went through all of the
1148       # new packages and still had services left on the old package.
1149       # We can't cancel the package under the circumstances, so abort.
1150       $dbh->rollback if $oldAutoCommit;
1151       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1152     }
1153     $error = $old_pkg->cancel;
1154     if ($error) {
1155       $dbh->rollback;
1156       return $error;
1157     }
1158   }
1159   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1160   '';
1161 }
1162
1163 =back
1164
1165 =head1 BUGS
1166
1167 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1168
1169 In sub order, the @pkgparts array (passed by reference) is clobbered.
1170
1171 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1172 method to pass dates to the recur_prog expression, it should do so.
1173
1174 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1175 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1176 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1177 configuration values.  Probably need a subroutine which decides what to do
1178 based on whether or not we've fetched the user yet, rather than a hash.  See
1179 FS::UID and the TODO.
1180
1181 Now that things are transactional should the check in the insert method be
1182 moved to check ?
1183
1184 =head1 SEE ALSO
1185
1186 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1187 L<FS::pkg_svc>, schema.html from the base documentation
1188
1189 =cut
1190
1191 1;
1192