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 configuration 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 Calls
 268
 269 =cut
 270
 271 sub replace {
 272   my( $new, $old ) = ( shift, shift );
 273
 274   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 275   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 276
 277   #allow this *sigh*
 278   #return "Can't change setup once it exists!"
 279   #  if $old->getfield('setup') &&
 280   #     $old->getfield('setup') != $new->getfield('setup');
 281
 282   #some logic for bill, susp, cancel?
 283
 284   local($disable_agentcheck) = 1 if $old->pkgpart == $new->pkgpart;
 285
 286   local $SIG{HUP} = 'IGNORE';
 287   local $SIG{INT} = 'IGNORE';
 288   local $SIG{QUIT} = 'IGNORE';
 289   local $SIG{TERM} = 'IGNORE';
 290   local $SIG{TSTP} = 'IGNORE';
 291   local $SIG{PIPE} = 'IGNORE';
 292
 293   my $oldAutoCommit = $FS::UID::AutoCommit;
 294   local $FS::UID::AutoCommit = 0;
 295   my $dbh = dbh;
 296
 297   #save off and freeze RADIUS attributes for any associated svc_acct records
 298   my @svc_acct = ();
 299   if ( $old->part_pkg->is_prepaid || $new->part_pkg->is_prepaid ) {
 300
 301                 #also check for specific exports?
 302                 # to avoid spurious modify export events
 303     @svc_acct = map  { $_->svc_x }
 304                 grep { $_->part_svc->svcdb eq 'svc_acct' }
 305                      $old->cust_svc;
 306
 307     $_->snapshot foreach @svc_acct;
 308
 309   }
 310
 311   my $error = $new->SUPER::replace($old);
 312   if ( $error ) {
 313     $dbh->rollback if $oldAutoCommit;
 314     return $error;
 315   }
 316
 317   #for prepaid packages,
 318   #trigger export of new RADIUS Expiration attribute when cust_pkg.bill changes
 319   foreach my $old_svc_acct ( @svc_acct ) {
 320     my $new_svc_acct = new FS::svc_acct { $old_svc_acct->hash };
 321     my $s_error = $new_svc_acct->replace($old_svc_acct);
 322     if ( $s_error ) {
 323       $dbh->rollback if $oldAutoCommit;
 324       return $s_error;
 325     }
 326   }
 327
 328   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 329   '';
 330
 331 }
 332
 333 =item check
 334
 335 Checks all fields to make sure this is a valid billing item.  If there is an
 336 error, returns the error, otherwise returns false.  Called by the insert and
 337 replace methods.
 338
 339 =cut
 340
 341 sub check {
 342   my $self = shift;
 343
 344   my $error =
 345     $self->ut_numbern('pkgnum')
 346     || $self->ut_foreign_key('custnum', 'cust_main', 'custnum')
 347     || $self->ut_numbern('pkgpart')
 348     || $self->ut_numbern('setup')
 349     || $self->ut_numbern('bill')
 350     || $self->ut_numbern('susp')
 351     || $self->ut_numbern('cancel')
 352   ;
 353   return $error if $error;
 354
 355   if ( $self->reg_code ) {
 356
 357     unless ( grep { $self->pkgpart == $_->pkgpart }
 358              map  { $_->reg_code_pkg }
 359              qsearchs( 'reg_code', { 'code'     => $self->reg_code,
 360                                      'agentnum' => $self->cust_main->agentnum })
 361            ) {
 362       return "Unknown registration code";
 363     }
 364
 365   } elsif ( $self->promo_code ) {
 366
 367     my $promo_part_pkg =
 368       qsearchs('part_pkg', {
 369         'pkgpart'    => $self->pkgpart,
 370         'promo_code' => { op=>'ILIKE', value=>$self->promo_code },
 371       } );
 372     return 'Unknown promotional code' unless $promo_part_pkg;
 373
 374   } else {
 375
 376     unless ( $disable_agentcheck ) {
 377       my $agent =
 378         qsearchs( 'agent', { 'agentnum' => $self->cust_main->agentnum } );
 379       my $pkgpart_href = $agent->pkgpart_hashref;
 380       return "agent ". $agent->agentnum.
 381              " can't purchase pkgpart ". $self->pkgpart
 382         unless $pkgpart_href->{ $self->pkgpart };
 383     }
 384
 385     $error = $self->ut_foreign_key('pkgpart', 'part_pkg', 'pkgpart' );
 386     return $error if $error;
 387
 388   }
 389
 390   $self->otaker(getotaker) unless $self->otaker;
 391   $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker";
 392   $self->otaker($1);
 393
 394   if ( $self->dbdef_table->column('manual_flag') ) {
 395     $self->manual_flag('') if $self->manual_flag eq ' ';
 396     $self->manual_flag =~ /^([01]?)$/
 397       or return "Illegal manual_flag ". $self->manual_flag;
 398     $self->manual_flag($1);
 399   }
 400
 401   $self->SUPER::check;
 402 }
 403
 404 =item cancel [ OPTION => VALUE ... ]
 405
 406 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 407 in this package, then cancels the package itself (sets the cancel field to
 408 now).
 409
 410 Available options are: I<quiet>
 411
 412 I<quiet> can be set true to supress email cancellation notices.
 413
 414 If there is an error, returns the error, otherwise returns false.
 415
 416 =cut
 417
 418 sub cancel {
 419   my( $self, %options ) = @_;
 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   my %svc;
 434   foreach my $cust_svc (
 435       qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 436   ) {
 437     push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc;
 438   }
 439
 440   foreach my $svcdb (@SVCDB_CANCEL_SEQ) {
 441     foreach my $cust_svc (@{ $svc{$svcdb} }) {
 442       my $error = $cust_svc->cancel;
 443
 444       if ( $error ) {
 445         $dbh->rollback if $oldAutoCommit;
 446         return "Error cancelling cust_svc: $error";
 447       }
 448     }
 449   }
 450
 451   # Add a credit for remaining service
 452   my $remaining_value = $self->calc_remain();
 453   if ( $remaining_value > 0 ) {
 454     my $error = $self->cust_main->credit(
 455       $remaining_value,
 456       'Credit for unused time on '. $self->part_pkg->pkg,
 457     );
 458     if ($error) {
 459       $dbh->rollback if $oldAutoCommit;
 460       return "Error crediting customer \$$remaining_value for unused time on".
 461              $self->part_pkg->pkg. ": $error";
 462     }
 463   }
 464
 465   unless ( $self->getfield('cancel') ) {
 466     my %hash = $self->hash;
 467     $hash{'cancel'} = time;
 468     my $new = new FS::cust_pkg ( \%hash );
 469     $error = $new->replace($self);
 470     if ( $error ) {
 471       $dbh->rollback if $oldAutoCommit;
 472       return $error;
 473     }
 474   }
 475
 476   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 477
 478   my $conf = new FS::Conf;
 479   my @invoicing_list = grep { $_ !~ /^(POST|FAX)$/ } $self->cust_main->invoicing_list;
 480   if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) {
 481     my $conf = new FS::Conf;
 482     my $error = send_email(
 483       'from'    => $conf->config('invoice_from'),
 484       'to'      => \@invoicing_list,
 485       'subject' => $conf->config('cancelsubject'),
 486       'body'    => [ map "$_\n", $conf->config('cancelmessage') ],
 487     );
 488     #should this do something on errors?
 489   }
 490
 491   ''; #no errors
 492
 493 }
 494
 495 =item suspend
 496
 497 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 498 package, then suspends the package itself (sets the susp field to now).
 499
 500 If there is an error, returns the error, otherwise returns false.
 501
 502 =cut
 503
 504 sub suspend {
 505   my $self = shift;
 506   my $error ;
 507
 508   local $SIG{HUP} = 'IGNORE';
 509   local $SIG{INT} = 'IGNORE';
 510   local $SIG{QUIT} = 'IGNORE';
 511   local $SIG{TERM} = 'IGNORE';
 512   local $SIG{TSTP} = 'IGNORE';
 513   local $SIG{PIPE} = 'IGNORE';
 514
 515   my $oldAutoCommit = $FS::UID::AutoCommit;
 516   local $FS::UID::AutoCommit = 0;
 517   my $dbh = dbh;
 518
 519   foreach my $cust_svc (
 520     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 521   ) {
 522     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 523
 524     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 525       $dbh->rollback if $oldAutoCommit;
 526       return "Illegal svcdb value in part_svc!";
 527     };
 528     my $svcdb = $1;
 529     require "FS/$svcdb.pm";
 530
 531     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 532     if ($svc) {
 533       $error = $svc->suspend;
 534       if ( $error ) {
 535         $dbh->rollback if $oldAutoCommit;
 536         return $error;
 537       }
 538     }
 539
 540   }
 541
 542   unless ( $self->getfield('susp') ) {
 543     my %hash = $self->hash;
 544     $hash{'susp'} = time;
 545     my $new = new FS::cust_pkg ( \%hash );
 546     $error = $new->replace($self);
 547     if ( $error ) {
 548       $dbh->rollback if $oldAutoCommit;
 549       return $error;
 550     }
 551   }
 552
 553   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 554
 555   ''; #no errors
 556 }
 557
 558 =item unsuspend
 559
 560 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 561 package, then unsuspends the package itself (clears the susp field).
 562
 563 If there is an error, returns the error, otherwise returns false.
 564
 565 =cut
 566
 567 sub unsuspend {
 568   my $self = shift;
 569   my($error);
 570
 571   local $SIG{HUP} = 'IGNORE';
 572   local $SIG{INT} = 'IGNORE';
 573   local $SIG{QUIT} = 'IGNORE';
 574   local $SIG{TERM} = 'IGNORE';
 575   local $SIG{TSTP} = 'IGNORE';
 576   local $SIG{PIPE} = 'IGNORE';
 577
 578   my $oldAutoCommit = $FS::UID::AutoCommit;
 579   local $FS::UID::AutoCommit = 0;
 580   my $dbh = dbh;
 581
 582   foreach my $cust_svc (
 583     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 584   ) {
 585     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 586
 587     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 588       $dbh->rollback if $oldAutoCommit;
 589       return "Illegal svcdb value in part_svc!";
 590     };
 591     my $svcdb = $1;
 592     require "FS/$svcdb.pm";
 593
 594     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 595     if ($svc) {
 596       $error = $svc->unsuspend;
 597       if ( $error ) {
 598         $dbh->rollback if $oldAutoCommit;
 599         return $error;
 600       }
 601     }
 602
 603   }
 604
 605   unless ( ! $self->getfield('susp') ) {
 606     my %hash = $self->hash;
 607     my $inactive = time - $hash{'susp'};
 608     $hash{'susp'} = '';
 609     $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive
 610       if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} );
 611     my $new = new FS::cust_pkg ( \%hash );
 612     $error = $new->replace($self);
 613     if ( $error ) {
 614       $dbh->rollback if $oldAutoCommit;
 615       return $error;
 616     }
 617   }
 618
 619   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 620
 621   ''; #no errors
 622 }
 623
 624 =item last_bill
 625
 626 Returns the last bill date, or if there is no last bill date, the setup date.
 627 Useful for billing metered services.
 628
 629 =cut
 630
 631 sub last_bill {
 632   my $self = shift;
 633   if ( $self->dbdef_table->column('last_bill') ) {
 634     return $self->setfield('last_bill', $_[0]) if @_;
 635     return $self->getfield('last_bill') if $self->getfield('last_bill');
 636   }
 637   my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum,
 638                                                   'edate'  => $self->bill,  } );
 639   $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0;
 640 }
 641
 642 =item part_pkg
 643
 644 Returns the definition for this billing item, as an FS::part_pkg object (see
 645 L<FS::part_pkg>).
 646
 647 =cut
 648
 649 sub part_pkg {
 650   my $self = shift;
 651   #exists( $self->{'_pkgpart'} )
 652   $self->{'_pkgpart'}
 653     ? $self->{'_pkgpart'}
 654     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 655 }
 656
 657 =item calc_setup
 658
 659 Calls the I<calc_setup> of the FS::part_pkg object associated with this billing
 660 item.
 661
 662 =cut
 663
 664 sub calc_setup {
 665   my $self = shift;
 666   $self->part_pkg->calc_setup($self, @_);
 667 }
 668
 669 =item calc_recur
 670
 671 Calls the I<calc_recur> of the FS::part_pkg object associated with this billing
 672 item.
 673
 674 =cut
 675
 676 sub calc_recur {
 677   my $self = shift;
 678   $self->part_pkg->calc_recur($self, @_);
 679 }
 680
 681 =item calc_remain
 682
 683 Calls the I<calc_remain> of the FS::part_pkg object associated with this
 684 billing item.
 685
 686 =cut
 687
 688 sub calc_remain {
 689   my $self = shift;
 690   $self->part_pkg->calc_remain($self, @_);
 691 }
 692
 693 =item calc_cancel
 694
 695 Calls the I<calc_cancel> of the FS::part_pkg object associated with this
 696 billing item.
 697
 698 =cut
 699
 700 sub calc_cancel {
 701   my $self = shift;
 702   $self->part_pkg->calc_cancel($self, @_);
 703 }
 704
 705 =item cust_svc [ SVCPART ]
 706
 707 Returns the services for this package, as FS::cust_svc objects (see
 708 L<FS::cust_svc>).  If a svcpart is specified, return only the matching
 709 services.
 710
 711 =cut
 712
 713 sub cust_svc {
 714   my $self = shift;
 715
 716   if ( @_ ) {
 717     return qsearch( 'cust_svc', { 'pkgnum'  => $self->pkgnum,
 718                                   'svcpart' => shift,          } );
 719   }
 720
 721   #if ( $self->{'_svcnum'} ) {
 722   #  values %{ $self->{'_svcnum'}->cache };
 723   #} else {
 724     $self->_sort_cust_svc(
 725       [ qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ]
 726     );
 727   #}
 728
 729 }
 730
 731 =item h_cust_svc END_TIMESTAMP [ START_TIMESTAMP ]
 732
 733 Returns historical services for this package created before END TIMESTAMP and
 734 (optionally) not cancelled before START_TIMESTAMP, as FS::h_cust_svc objects
 735 (see L<FS::h_cust_svc>).
 736
 737 =cut
 738
 739 sub h_cust_svc {
 740   my $self = shift;
 741
 742   $self->_sort_cust_svc(
 743     [ qsearch( 'h_cust_svc',
 744                { 'pkgnum' => $self->pkgnum, },
 745                FS::h_cust_svc->sql_h_search(@_),
 746              )
 747     ]
 748   );
 749 }
 750
 751 sub _sort_cust_svc {
 752   my( $self, $arrayref ) = @_;
 753
 754   map  { $_->[0] }
 755   sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
 756   map {
 757         my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart,
 758                                              'svcpart' => $_->svcpart     } );
 759         [ $_,
 760           $pkg_svc ? $pkg_svc->primary_svc : '',
 761           $pkg_svc ? $pkg_svc->quantity : 0,
 762         ];
 763       }
 764   @$arrayref;
 765
 766 }
 767
 768 =item num_cust_svc [ SVCPART ]
 769
 770 Returns the number of provisioned services for this package.  If a svcpart is
 771 specified, counts only the matching services.
 772
 773 =cut
 774
 775 sub num_cust_svc {
 776   my $self = shift;
 777   my $sql = 'SELECT COUNT(*) FROM cust_svc WHERE pkgnum = ?';
 778   $sql .= ' AND svcpart = ?' if @_;
 779   my $sth = dbh->prepare($sql) or die dbh->errstr;
 780   $sth->execute($self->pkgnum, @_) or die $sth->errstr;
 781   $sth->fetchrow_arrayref->[0];
 782 }
 783
 784 =item available_part_svc
 785
 786 Returns a list FS::part_svc objects representing services included in this
 787 package but not yet provisioned.  Each FS::part_svc object also has an extra
 788 field, I<num_avail>, which specifies the number of available services.
 789
 790 =cut
 791
 792 sub available_part_svc {
 793   my $self = shift;
 794   grep { $_->num_avail > 0 }
 795     map {
 796           my $part_svc = $_->part_svc;
 797           $part_svc->{'Hash'}{'num_avail'} = #evil encapsulation-breaking
 798             $_->quantity - $self->num_cust_svc($_->svcpart);
 799           $part_svc;
 800         }
 801       $self->part_pkg->pkg_svc;
 802 }
 803
 804 =item status
 805
 806 Returns a short status string for this package, currently:
 807
 808 =over 4
 809
 810 =item not yet billed
 811
 812 =item one-time charge
 813
 814 =item active
 815
 816 =item suspended
 817
 818 =item cancelled
 819
 820 =back
 821
 822 =cut
 823
 824 sub status {
 825   my $self = shift;
 826
 827   return 'cancelled' if $self->get('cancel');
 828   return 'suspended' if $self->susp;
 829   return 'not yet billed' unless $self->setup;
 830   return 'one-time charge' if $self->part_pkg->freq =~ /^(0|$)/;
 831   return 'active';
 832 }
 833
 834 =item statuscolor
 835
 836 Returns a hex triplet color string for this package's status.
 837
 838 =cut
 839
 840 my %statuscolor = (
 841   'not yet billed'  => '000000',
 842   'one-time charge' => '000000',
 843   'active'          => '00CC00',
 844   'suspended'       => 'FF9900',
 845   'cancelled'       => 'FF0000',
 846 );
 847 sub statuscolor {
 848   my $self = shift;
 849   $statuscolor{$self->status};
 850 }
 851
 852 =item labels
 853
 854 Returns a list of lists, calling the label method for all services
 855 (see L<FS::cust_svc>) of this billing item.
 856
 857 =cut
 858
 859 sub labels {
 860   my $self = shift;
 861   map { [ $_->label ] } $self->cust_svc;
 862 }
 863
 864 =item h_labels END_TIMESTAMP [ START_TIMESTAMP ]
 865
 866 Like the labels method, but returns historical information on services that
 867 were active as of END_TIMESTAMP and (optionally) not cancelled before
 868 START_TIMESTAMP.
 869
 870 Returns a list of lists, calling the label method for all (historical) services
 871 (see L<FS::h_cust_svc>) of this billing item.
 872
 873 =cut
 874
 875 sub h_labels {
 876   my $self = shift;
 877   map { [ $_->label(@_) ] } $self->h_cust_svc(@_);
 878 }
 879
 880 =item h_labels_short END_TIMESTAMP [ START_TIMESTAMP ]
 881
 882 Like h_labels, except returns a simple flat list, and shortens long
 883 (currently >5) lists of identical services to one line that lists the service
 884 label and the number of individual services rather than individual items.
 885
 886 =cut
 887
 888 sub h_labels_short {
 889   my $self = shift;
 890
 891   my %labels;
 892   #tie %labels, 'Tie::IxHash';
 893   push @{ $labels{$_->[0]} }, $_->[1]
 894     foreach $self->h_labels(@_);
 895   my @labels;
 896   foreach my $label ( keys %labels ) {
 897     my @values = @{ $labels{$label} };
 898     my $num = scalar(@values);
 899     if ( $num > 5 ) {
 900       push @labels, "$label ($num)";
 901     } else {
 902       push @labels, map { "$label: $_" } @values;
 903     }
 904   }
 905
 906  @labels;
 907
 908 }
 909
 910 =item cust_main
 911
 912 Returns the parent customer object (see L<FS::cust_main>).
 913
 914 =cut
 915
 916 sub cust_main {
 917   my $self = shift;
 918   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 919 }
 920
 921 =item seconds_since TIMESTAMP
 922
 923 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 924 package have been online since TIMESTAMP, according to the session monitor.
 925
 926 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 927 L<Time::Local> and L<Date::Parse> for conversion functions.
 928
 929 =cut
 930
 931 sub seconds_since {
 932   my($self, $since) = @_;
 933   my $seconds = 0;
 934
 935   foreach my $cust_svc (
 936     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 937   ) {
 938     $seconds += $cust_svc->seconds_since($since);
 939   }
 940
 941   $seconds;
 942
 943 }
 944
 945 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
 946
 947 Returns the numbers of seconds all accounts (see L<FS::svc_acct>) in this
 948 package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END
 949 (exclusive).
 950
 951 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 952 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 953 functions.
 954
 955
 956 =cut
 957
 958 sub seconds_since_sqlradacct {
 959   my($self, $start, $end) = @_;
 960
 961   my $seconds = 0;
 962
 963   foreach my $cust_svc (
 964     grep {
 965       my $part_svc = $_->part_svc;
 966       $part_svc->svcdb eq 'svc_acct'
 967         && scalar($part_svc->part_export('sqlradius'));
 968     } $self->cust_svc
 969   ) {
 970     $seconds += $cust_svc->seconds_since_sqlradacct($start, $end);
 971   }
 972
 973   $seconds;
 974
 975 }
 976
 977 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
 978
 979 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
 980 in this package for sessions ending between TIMESTAMP_START (inclusive) and
 981 TIMESTAMP_END
 982 (exclusive).
 983
 984 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
 985 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
 986 functions.
 987
 988 =cut
 989
 990 sub attribute_since_sqlradacct {
 991   my($self, $start, $end, $attrib) = @_;
 992
 993   my $sum = 0;
 994
 995   foreach my $cust_svc (
 996     grep {
 997       my $part_svc = $_->part_svc;
 998       $part_svc->svcdb eq 'svc_acct'
 999         && scalar($part_svc->part_export('sqlradius'));
1000     } $self->cust_svc
1001   ) {
1002     $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib);
1003   }
1004
1005   $sum;
1006
1007 }
1008
1009 =item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ]
1010
1011 Transfers as many services as possible from this package to another package.
1012
1013 The destination package can be specified by pkgnum by passing an FS::cust_pkg
1014 object.  The destination package must already exist.
1015
1016 Services are moved only if the destination allows services with the correct
1017 I<svcpart> (not svcdb), unless the B<change_svcpart> option is set true.  Use
1018 this option with caution!  No provision is made for export differences
1019 between the old and new service definitions.  Probably only should be used
1020 when your exports for all service definitions of a given svcdb are identical.
1021 (attempt a transfer without it first, to move all possible svcpart-matching
1022 services)
1023
1024 Any services that can't be moved remain in the original package.
1025
1026 Returns an error, if there is one; otherwise, returns the number of services
1027 that couldn't be moved.
1028
1029 =cut
1030
1031 sub transfer {
1032   my ($self, $dest_pkgnum, %opt) = @_;
1033
1034   my $remaining = 0;
1035   my $dest;
1036   my %target;
1037
1038   if (ref ($dest_pkgnum) eq 'FS::cust_pkg') {
1039     $dest = $dest_pkgnum;
1040     $dest_pkgnum = $dest->pkgnum;
1041   } else {
1042     $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum });
1043   }
1044
1045   return ('Package does not exist: '.$dest_pkgnum) unless $dest;
1046
1047   foreach my $pkg_svc ( $dest->part_pkg->pkg_svc ) {
1048     $target{$pkg_svc->svcpart} = $pkg_svc->quantity;
1049   }
1050
1051   foreach my $cust_svc ($dest->cust_svc) {
1052     $target{$cust_svc->svcpart}--;
1053   }
1054
1055   my %svcpart2svcparts = ();
1056   if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1057     warn "change_svcpart option received, creating alternates list\n" if $DEBUG;
1058     foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) {
1059       next if exists $svcpart2svcparts{$svcpart};
1060       my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } );
1061       $svcpart2svcparts{$svcpart} = [
1062         map  { $_->[0] }
1063         sort { $b->[1] cmp $a->[1]  or  $a->[2] <=> $b->[2] }
1064         map {
1065               my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart,
1066                                                    'svcpart' => $_          } );
1067               [ $_,
1068                 $pkg_svc ? $pkg_svc->primary_svc : '',
1069                 $pkg_svc ? $pkg_svc->quantity : 0,
1070               ];
1071             }
1072
1073         grep { $_ != $svcpart }
1074         map  { $_->svcpart }
1075         qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } )
1076       ];
1077       warn "alternates for svcpart $svcpart: ".
1078            join(', ', @{$svcpart2svcparts{$svcpart}}). "\n"
1079         if $DEBUG;
1080     }
1081   }
1082
1083   foreach my $cust_svc ($self->cust_svc) {
1084     if($target{$cust_svc->svcpart} > 0) {
1085       $target{$cust_svc->svcpart}--;
1086       my $new = new FS::cust_svc {
1087         svcnum  => $cust_svc->svcnum,
1088         svcpart => $cust_svc->svcpart,
1089         pkgnum  => $dest_pkgnum,
1090       };
1091       my $error = $new->replace($cust_svc);
1092       return $error if $error;
1093     } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) {
1094       if ( $DEBUG ) {
1095         warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n";
1096         warn "alternates to consider: ".
1097              join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n";
1098       }
1099       my @alternate = grep {
1100                              warn "considering alternate svcpart $_: ".
1101                                   "$target{$_} available in new package\n"
1102                                if $DEBUG;
1103                              $target{$_} > 0;
1104                            } @{$svcpart2svcparts{$cust_svc->svcpart}};
1105       if ( @alternate ) {
1106         warn "alternate(s) found\n" if $DEBUG;
1107         my $change_svcpart = $alternate[0];
1108         $target{$change_svcpart}--;
1109         my $new = new FS::cust_svc {
1110           svcnum  => $cust_svc->svcnum,
1111           svcpart => $change_svcpart,
1112           pkgnum  => $dest_pkgnum,
1113         };
1114         my $error = $new->replace($cust_svc);
1115         return $error if $error;
1116       } else {
1117         $remaining++;
1118       }
1119     } else {
1120       $remaining++
1121     }
1122   }
1123   return $remaining;
1124 }
1125
1126 =item reexport
1127
1128 This method is deprecated.  See the I<depend_jobnum> option to the insert and
1129 order_pkgs methods in FS::cust_main for a better way to defer provisioning.
1130
1131 =cut
1132
1133 sub reexport {
1134   my $self = shift;
1135
1136   local $SIG{HUP} = 'IGNORE';
1137   local $SIG{INT} = 'IGNORE';
1138   local $SIG{QUIT} = 'IGNORE';
1139   local $SIG{TERM} = 'IGNORE';
1140   local $SIG{TSTP} = 'IGNORE';
1141   local $SIG{PIPE} = 'IGNORE';
1142
1143   my $oldAutoCommit = $FS::UID::AutoCommit;
1144   local $FS::UID::AutoCommit = 0;
1145   my $dbh = dbh;
1146
1147   foreach my $cust_svc ( $self->cust_svc ) {
1148     #false laziness w/svc_Common::insert
1149     my $svc_x = $cust_svc->svc_x;
1150     foreach my $part_export ( $cust_svc->part_svc->part_export ) {
1151       my $error = $part_export->export_insert($svc_x);
1152       if ( $error ) {
1153         $dbh->rollback if $oldAutoCommit;
1154         return $error;
1155       }
1156     }
1157   }
1158
1159   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1160   '';
1161
1162 }
1163
1164 =back
1165
1166 =head1 CLASS METHOD
1167
1168 =over 4
1169
1170 =item recurring_sql
1171
1172 Returns an SQL expression identifying recurring packages.
1173
1174 =cut
1175
1176 sub recurring_sql { "
1177   '0' != ( select freq from part_pkg
1178              where cust_pkg.pkgpart = part_pkg.pkgpart )
1179 "; }
1180
1181 =item active_sql
1182
1183 Returns an SQL expression identifying active packages.
1184
1185 =cut
1186
1187 sub active_sql { "
1188   ". $_[0]->recurring_sql(). "
1189   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1190   AND ( cust_pkg.susp   IS NULL OR cust_pkg.susp   = 0 )
1191 "; }
1192
1193 =item susp_sql
1194 =item suspended_sql
1195
1196 Returns an SQL expression identifying suspended packages.
1197
1198 =cut
1199
1200 sub suspended_sql { susp_sql(@_); }
1201 sub susp_sql { "
1202   ". $_[0]->recurring_sql(). "
1203   AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
1204   AND cust_pkg.susp IS NOT NULL AND cust_pkg.susp != 0
1205 "; }
1206
1207 =item cancel_sql
1208 =item cancelled_sql
1209
1210 Returns an SQL exprression identifying cancelled packages.
1211
1212 =cut
1213
1214 sub cancelled_sql { cancel_sql(@_); }
1215 sub cancel_sql { "
1216   ". $_[0]->recurring_sql(). "
1217   AND cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0
1218 "; }
1219
1220 =head1 SUBROUTINES
1221
1222 =over 4
1223
1224 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
1225
1226 CUSTNUM is a customer (see L<FS::cust_main>)
1227
1228 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
1229 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
1230 permitted.
1231
1232 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
1233 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
1234 new billing items.  An error is returned if this is not possible (see
1235 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
1236 parameter.
1237
1238 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
1239 newly-created cust_pkg objects.
1240
1241 =cut
1242
1243 sub order {
1244   my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
1245
1246   my $conf = new FS::Conf;
1247
1248   # Transactionize this whole mess
1249   local $SIG{HUP} = 'IGNORE';
1250   local $SIG{INT} = 'IGNORE';
1251   local $SIG{QUIT} = 'IGNORE';
1252   local $SIG{TERM} = 'IGNORE';
1253   local $SIG{TSTP} = 'IGNORE';
1254   local $SIG{PIPE} = 'IGNORE';
1255
1256   my $oldAutoCommit = $FS::UID::AutoCommit;
1257   local $FS::UID::AutoCommit = 0;
1258   my $dbh = dbh;
1259
1260   my $error;
1261   my $cust_main = qsearchs('cust_main', { custnum => $custnum });
1262   return "Customer not found: $custnum" unless $cust_main;
1263
1264   my @old_cust_pkg = map { qsearchs('cust_pkg', { pkgnum => $_ }) }
1265                          @$remove_pkgnum;
1266
1267   my $change = scalar(@old_cust_pkg) != 0;
1268
1269   my %hash = ();
1270   if ( scalar(@old_cust_pkg) == 1 ) {
1271     #$hash{$_} = $old_cust_pkg[0]->$_() foreach qw( last_bill bill );
1272     $hash{'setup'} = time;
1273   }
1274
1275   # Create the new packages.
1276   foreach my $pkgpart (@$pkgparts) {
1277     my $cust_pkg = new FS::cust_pkg { custnum => $custnum,
1278                                       pkgpart => $pkgpart,
1279                                       %hash,
1280                                     };
1281     $error = $cust_pkg->insert( 'change' => $change );
1282     if ($error) {
1283       $dbh->rollback if $oldAutoCommit;
1284       return $error;
1285     }
1286     push @$return_cust_pkg, $cust_pkg;
1287   }
1288   # $return_cust_pkg now contains refs to all of the newly
1289   # created packages.
1290
1291   # Transfer services and cancel old packages.
1292   foreach my $old_pkg (@old_cust_pkg) {
1293
1294     foreach my $new_pkg (@$return_cust_pkg) {
1295       $error = $old_pkg->transfer($new_pkg);
1296       if ($error and $error == 0) {
1297         # $old_pkg->transfer failed.
1298         $dbh->rollback if $oldAutoCommit;
1299         return $error;
1300       }
1301     }
1302
1303     if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) {
1304       warn "trying transfer again with change_svcpart option\n" if $DEBUG;
1305       foreach my $new_pkg (@$return_cust_pkg) {
1306         $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 );
1307         if ($error and $error == 0) {
1308           # $old_pkg->transfer failed.
1309         $dbh->rollback if $oldAutoCommit;
1310         return $error;
1311         }
1312       }
1313     }
1314
1315     if ($error > 0) {
1316       # Transfers were successful, but we went through all of the
1317       # new packages and still had services left on the old package.
1318       # We can't cancel the package under the circumstances, so abort.
1319       $dbh->rollback if $oldAutoCommit;
1320       return "Unable to transfer all services from package ".$old_pkg->pkgnum;
1321     }
1322     $error = $old_pkg->cancel;
1323     if ($error) {
1324       $dbh->rollback;
1325       return $error;
1326     }
1327   }
1328   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1329   '';
1330 }
1331
1332 =back
1333
1334 =head1 BUGS
1335
1336 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
1337
1338 In sub order, the @pkgparts array (passed by reference) is clobbered.
1339
1340 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
1341 method to pass dates to the recur_prog expression, it should do so.
1342
1343 FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are
1344 loaded via 'use' at compile time, rather than via 'require' in sub { setup,
1345 suspend, unsuspend, cancel } because they use %FS::UID::callback to load
1346 configuration values.  Probably need a subroutine which decides what to do
1347 based on whether or not we've fetched the user yet, rather than a hash.  See
1348 FS::UID and the TODO.
1349
1350 Now that things are transactional should the check in the insert method be
1351 moved to check ?
1352
1353 =head1 SEE ALSO
1354
1355 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
1356 L<FS::pkg_svc>, schema.html from the base documentation
1357
1358 =cut
1359
1360 1;
1361