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