FS/FS/cust_pkg.pm

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