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