FS/FS/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA);
   5 use FS::UID qw( getotaker dbh );
   6 use FS::Record qw( qsearch qsearchs );
   7 use FS::cust_svc;
   8 use FS::part_pkg;
   9 use FS::cust_main;
  10 use FS::type_pkgs;
  11 use FS::pkg_svc;
  12
  13 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  14 # setup }
  15 # because they load configuraion by setting FS::UID::callback (see TODO)
  16 use FS::svc_acct;
  17 use FS::svc_acct_sm;
  18 use FS::svc_domain;
  19 use FS::svc_www;
  20 use FS::svc_forward;
  21
  22 @ISA = qw( FS::Record );
  23
  24 sub _cache {
  25   my $self = shift;
  26   my ( $hashref, $cache ) = @_;
  27   #if ( $hashref->{'pkgpart'} ) {
  28   if ( $hashref->{'pkg'} ) {
  29     # #@{ $self->{'_pkgnum'} } = ();
  30     # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
  31     # $self->{'_pkgpart'} = $subcache;
  32     # #push @{ $self->{'_pkgnum'} },
  33     #   FS::part_pkg->new_or_cached($hashref, $subcache);
  34     $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
  35   }
  36   if ( exists $hashref->{'svcnum'} ) {
  37     #@{ $self->{'_pkgnum'} } = ();
  38     my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
  39     $self->{'_svcnum'} = $subcache;
  40     #push @{ $self->{'_pkgnum'} },
  41     FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
  42   }
  43 }
  44
  45 =head1 NAME
  46
  47 FS::cust_pkg - Object methods for cust_pkg objects
  48
  49 =head1 SYNOPSIS
  50
  51   use FS::cust_pkg;
  52
  53   $record = new FS::cust_pkg \%hash;
  54   $record = new FS::cust_pkg { 'column' => 'value' };
  55
  56   $error = $record->insert;
  57
  58   $error = $new_record->replace($old_record);
  59
  60   $error = $record->delete;
  61
  62   $error = $record->check;
  63
  64   $error = $record->cancel;
  65
  66   $error = $record->suspend;
  67
  68   $error = $record->unsuspend;
  69
  70   $part_pkg = $record->part_pkg;
  71
  72   @labels = $record->labels;
  73
  74   $seconds = $record->seconds_since($timestamp);
  75
  76   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  77   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  78
  79 =head1 DESCRIPTION
  80
  81 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  82 inherits from FS::Record.  The following fields are currently supported:
  83
  84 =over 4
  85
  86 =item pkgnum - primary key (assigned automatically for new billing items)
  87
  88 =item custnum - Customer (see L<FS::cust_main>)
  89
  90 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
  91
  92 =item setup - date
  93
  94 =item bill - date
  95
  96 =item susp - date
  97
  98 =item expire - date
  99
 100 =item cancel - date
 101
 102 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
 103
 104 =item manual_flag - If this field is set to 1, disables the automatic
 105 unsuspension of this package when using the B<unsuspendauto> config file.
 106
 107 =back
 108
 109 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
 110 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
 111 conversion functions.
 112
 113 =head1 METHODS
 114
 115 =over 4
 116
 117 =item new HASHREF
 118
 119 Create a new billing item.  To add the item to the database, see L<"insert">.
 120
 121 =cut
 122
 123 sub table { 'cust_pkg'; }
 124
 125 =item insert
 126
 127 Adds this billing item to the database ("Orders" the item).  If there is an
 128 error, returns the error, otherwise returns false.
 129
 130 =cut
 131
 132 sub insert {
 133   my $self = shift;
 134
 135   # custnum might not have have been defined in sub check (for one-shot new
 136   # customers), so check it here instead
 137   # (is this still necessary with transactions?)
 138
 139   my $error = $self->ut_number('custnum');
 140   return $error if $error;
 141
 142   return "Unknown customer ". $self->custnum unless $self->cust_main;
 143
 144   $self->SUPER::insert;
 145
 146 }
 147
 148 =item delete
 149
 150 This method now works but you probably shouldn't use it.
 151
 152 You don't want to delete billing items, because there would then be no record
 153 the customer ever purchased the item.  Instead, see the cancel method.
 154
 155 =cut
 156
 157 #sub delete {
 158 #  return "Can't delete cust_pkg records!";
 159 #}
 160
 161 =item replace OLD_RECORD
 162
 163 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 164 returns the error, otherwise returns false.
 165
 166 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 167
 168 Changing pkgpart may have disasterous effects.  See the order subroutine.
 169
 170 setup and bill are normally updated by calling the bill method of a customer
 171 object (see L<FS::cust_main>).
 172
 173 suspend is normally updated by the suspend and unsuspend methods.
 174
 175 cancel is normally updated by the cancel method (and also the order subroutine
 176 in some cases).
 177
 178 =cut
 179
 180 sub replace {
 181   my( $new, $old ) = ( shift, shift );
 182
 183   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 184   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 185
 186   #allow this *sigh*
 187   #return "Can't change setup once it exists!"
 188   #  if $old->getfield('setup') &&
 189   #     $old->getfield('setup') != $new->getfield('setup');
 190
 191   #some logic for bill, susp, cancel?
 192
 193   $new->SUPER::replace($old);
 194 }
 195
 196 =item check
 197
 198 Checks all fields to make sure this is a valid billing item.  If there is an
 199 error, returns the error, otherwise returns false.  Called by the insert and
 200 replace methods.
 201
 202 =cut
 203
 204 sub check {
 205   my $self = shift;
 206
 207   my $error =
 208     $self->ut_numbern('pkgnum')
 209     || $self->ut_numbern('custnum')
 210     || $self->ut_number('pkgpart')
 211     || $self->ut_numbern('setup')
 212     || $self->ut_numbern('bill')
 213     || $self->ut_numbern('susp')
 214     || $self->ut_numbern('cancel')
 215   ;
 216   return $error if $error;
 217
 218   if ( $self->custnum ) {
 219     return "Unknown customer ". $self->custnum unless $self->cust_main;
 220   }
 221
 222   return "Unknown pkgpart"
 223     unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 224
 225   $self->otaker(getotaker) unless $self->otaker;
 226   $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker";
 227   $self->otaker($1);
 228
 229   if ( $self->dbdef_table->column('manual_flag') ) {
 230     $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag";
 231     $self->manual_flag($1);
 232   }
 233
 234   ''; #no error
 235 }
 236
 237 =item cancel
 238
 239 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 240 in this package, then cancels the package itself (sets the cancel field to
 241 now).
 242
 243 If there is an error, returns the error, otherwise returns false.
 244
 245 =cut
 246
 247 sub cancel {
 248   my $self = shift;
 249   my $error;
 250
 251   local $SIG{HUP} = 'IGNORE';
 252   local $SIG{INT} = 'IGNORE';
 253   local $SIG{QUIT} = 'IGNORE';
 254   local $SIG{TERM} = 'IGNORE';
 255   local $SIG{TSTP} = 'IGNORE';
 256   local $SIG{PIPE} = 'IGNORE';
 257
 258   my $oldAutoCommit = $FS::UID::AutoCommit;
 259   local $FS::UID::AutoCommit = 0;
 260   my $dbh = dbh;
 261
 262   foreach my $cust_svc (
 263     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 264   ) {
 265     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 266
 267     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 268       $dbh->rollback if $oldAutoCommit;
 269       return "Illegal svcdb value in part_svc!";
 270     };
 271     my $svcdb = $1;
 272     require "FS/$svcdb.pm";
 273
 274     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 275     if ($svc) {
 276       $error = $svc->cancel;
 277       if ( $error ) {
 278         $dbh->rollback if $oldAutoCommit;
 279         return "Error cancelling service: $error"
 280       }
 281       $error = $svc->delete;
 282       if ( $error ) {
 283         $dbh->rollback if $oldAutoCommit;
 284         return "Error deleting service: $error";
 285       }
 286     }
 287
 288     $error = $cust_svc->delete;
 289     if ( $error ) {
 290       $dbh->rollback if $oldAutoCommit;
 291       return "Error deleting cust_svc: $error";
 292     }
 293
 294   }
 295
 296   unless ( $self->getfield('cancel') ) {
 297     my %hash = $self->hash;
 298     $hash{'cancel'} = time;
 299     my $new = new FS::cust_pkg ( \%hash );
 300     $error = $new->replace($self);
 301     if ( $error ) {
 302       $dbh->rollback if $oldAutoCommit;
 303       return $error;
 304     }
 305   }
 306
 307   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 308
 309   ''; #no errors
 310 }
 311
 312 =item suspend
 313
 314 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 315 package, then suspends the package itself (sets the susp field to now).
 316
 317 If there is an error, returns the error, otherwise returns false.
 318
 319 =cut
 320
 321 sub suspend {
 322   my $self = shift;
 323   my $error ;
 324
 325   local $SIG{HUP} = 'IGNORE';
 326   local $SIG{INT} = 'IGNORE';
 327   local $SIG{QUIT} = 'IGNORE';
 328   local $SIG{TERM} = 'IGNORE';
 329   local $SIG{TSTP} = 'IGNORE';
 330   local $SIG{PIPE} = 'IGNORE';
 331
 332   my $oldAutoCommit = $FS::UID::AutoCommit;
 333   local $FS::UID::AutoCommit = 0;
 334   my $dbh = dbh;
 335
 336   foreach my $cust_svc (
 337     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 338   ) {
 339     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 340
 341     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 342       $dbh->rollback if $oldAutoCommit;
 343       return "Illegal svcdb value in part_svc!";
 344     };
 345     my $svcdb = $1;
 346     require "FS/$svcdb.pm";
 347
 348     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 349     if ($svc) {
 350       $error = $svc->suspend;
 351       if ( $error ) {
 352         $dbh->rollback if $oldAutoCommit;
 353         return $error;
 354       }
 355     }
 356
 357   }
 358
 359   unless ( $self->getfield('susp') ) {
 360     my %hash = $self->hash;
 361     $hash{'susp'} = time;
 362     my $new = new FS::cust_pkg ( \%hash );
 363     $error = $new->replace($self);
 364     if ( $error ) {
 365       $dbh->rollback if $oldAutoCommit;
 366       return $error;
 367     }
 368   }
 369
 370   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 371
 372   ''; #no errors
 373 }
 374
 375 =item unsuspend
 376
 377 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 378 package, then unsuspends the package itself (clears the susp field).
 379
 380 If there is an error, returns the error, otherwise returns false.
 381
 382 =cut
 383
 384 sub unsuspend {
 385   my $self = shift;
 386   my($error);
 387
 388   local $SIG{HUP} = 'IGNORE';
 389   local $SIG{INT} = 'IGNORE';
 390   local $SIG{QUIT} = 'IGNORE';
 391   local $SIG{TERM} = 'IGNORE';
 392   local $SIG{TSTP} = 'IGNORE';
 393   local $SIG{PIPE} = 'IGNORE';
 394
 395   my $oldAutoCommit = $FS::UID::AutoCommit;
 396   local $FS::UID::AutoCommit = 0;
 397   my $dbh = dbh;
 398
 399   foreach my $cust_svc (
 400     qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
 401   ) {
 402     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 403
 404     $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
 405       $dbh->rollback if $oldAutoCommit;
 406       return "Illegal svcdb value in part_svc!";
 407     };
 408     my $svcdb = $1;
 409     require "FS/$svcdb.pm";
 410
 411     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 412     if ($svc) {
 413       $error = $svc->unsuspend;
 414       if ( $error ) {
 415         $dbh->rollback if $oldAutoCommit;
 416         return $error;
 417       }
 418     }
 419
 420   }
 421
 422   unless ( ! $self->getfield('susp') ) {
 423     my %hash = $self->hash;
 424     $hash{'susp'} = '';
 425     my $new = new FS::cust_pkg ( \%hash );
 426     $error = $new->replace($self);
 427     if ( $error ) {
 428       $dbh->rollback if $oldAutoCommit;
 429       return $error;
 430     }
 431   }
 432
 433   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 434
 435   ''; #no errors
 436 }
 437
 438 =item part_pkg
 439
 440 Returns the definition for this billing item, as an FS::part_pkg object (see
 441 L<FS::part_pkg>).
 442
 443 =cut
 444
 445 sub part_pkg {
 446   my $self = shift;
 447   #exists( $self->{'_pkgpart'} )
 448   $self->{'_pkgpart'}
 449     ? $self->{'_pkgpart'}
 450     : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 451 }
 452
 453 =item cust_svc
 454
 455 Returns the services for this package, as FS::cust_svc objects (see
 456 L<FS::cust_svc>)
 457
 458 =cut
 459
 460 sub cust_svc {
 461   my $self = shift;
 462   if ( $self->{'_svcnum'} ) {
 463     values %{ $self->{'_svcnum'}->cache };
 464   } else {
 465     qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
 466   }
 467 }
 468
 469 =item labels
 470
 471 Returns a list of lists, calling the label method for all services
 472 (see L<FS::cust_svc>) of this billing item.
 473
 474 =cut
 475
 476 sub labels {
 477   my $self = shift;
 478   map { [ $_->label ] } $self->cust_svc;
 479 }
 480
 481 =item cust_main
 482
 483 Returns the parent customer object (see L<FS::cust_main>).
 484
 485 =cut
 486
 487 sub cust_main {
 488   my $self = shift;
 489   qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 490 }
 491
 492 =item seconds_since TIMESTAMP
 493
 494 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
 495 package have been online since TIMESTAMP.
 496
 497 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
 498 L<Time::Local> and L<Date::Parse> for conversion functions.
 499
 500 =cut
 501
 502 sub seconds_since {
 503   my($self, $since) = @_;
 504   my $seconds = 0;
 505
 506   foreach my $cust_svc (
 507     grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
 508   ) {
 509     $seconds += $cust_svc->seconds_since($since);
 510   }
 511
 512   $seconds;
 513
 514 }
 515
 516 =back
 517
 518 =head1 SUBROUTINES
 519
 520 =over 4
 521
 522 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
 523
 524 CUSTNUM is a customer (see L<FS::cust_main>)
 525
 526 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 527 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 528 permitted.
 529
 530 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 531 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 532 new billing items.  An error is returned if this is not possible (see
 533 L<FS::pkg_svc>).  An empty arrayref is equivalent to not specifying this
 534 parameter.
 535
 536 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
 537 newly-created cust_pkg objects.
 538
 539 =cut
 540
 541 sub order {
 542   my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
 543   $remove_pkgnums = [] unless defined($remove_pkgnums);
 544
 545   my $oldAutoCommit = $FS::UID::AutoCommit;
 546   local $FS::UID::AutoCommit = 0;
 547   my $dbh = dbh;
 548
 549   # generate %part_pkg
 550   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 551   #
 552   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 553   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 554   my %part_pkg = %{ $agent->pkgpart_hashref };
 555
 556   my(%svcnum);
 557   # generate %svcnum
 558   # for those packages being removed:
 559   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record
 560   # objects (table eq 'cust_svc')
 561   my($pkgnum);
 562   foreach $pkgnum ( @{$remove_pkgnums} ) {
 563     my($cust_svc);
 564     foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 565       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 566     }
 567   }
 568
 569   my(@cust_svc);
 570   #generate @cust_svc
 571   # for those packages the customer is purchasing:
 572   # @{$pkgparts} is a list of said packages, by pkgpart
 573   # @cust_svc is a corresponding list of lists of FS::Record objects
 574   my($pkgpart);
 575   foreach $pkgpart ( @{$pkgparts} ) {
 576     unless ( $part_pkg{$pkgpart} ) {
 577       $dbh->rollback if $oldAutoCommit;
 578       return "Customer not permitted to purchase pkgpart $pkgpart!";
 579     }
 580     push @cust_svc, [
 581       map {
 582         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 583       } map { $_->svcpart } qsearch('pkg_svc', { 'pkgpart' => $pkgpart })
 584     ];
 585   }
 586
 587   #check for leftover services
 588   foreach (keys %svcnum) {
 589     next unless @{ $svcnum{$_} };
 590     $dbh->rollback if $oldAutoCommit;
 591     return "Leftover services, svcpart $_: svcnum ".
 592            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 593   }
 594
 595   #no leftover services, let's make changes.
 596
 597   local $SIG{HUP} = 'IGNORE';
 598   local $SIG{INT} = 'IGNORE';
 599   local $SIG{QUIT} = 'IGNORE';
 600   local $SIG{TERM} = 'IGNORE';
 601   local $SIG{TSTP} = 'IGNORE';
 602   local $SIG{PIPE} = 'IGNORE';
 603
 604   #first cancel old packages
 605 #  my($pkgnum);
 606   foreach $pkgnum ( @{$remove_pkgnums} ) {
 607     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 608     unless ( $old ) {
 609       $dbh->rollback if $oldAutoCommit;
 610       return "Package $pkgnum not found to remove!";
 611     }
 612     my(%hash) = $old->hash;
 613     $hash{'cancel'}=time;
 614     my($new) = new FS::cust_pkg ( \%hash );
 615     my($error)=$new->replace($old);
 616     if ( $error ) {
 617       $dbh->rollback if $oldAutoCommit;
 618       return "Couldn't update package $pkgnum: $error";
 619     }
 620   }
 621
 622   #now add new packages, changing cust_svc records if necessary
 623 #  my($pkgpart);
 624   while ($pkgpart=shift @{$pkgparts} ) {
 625
 626     my $new = new FS::cust_pkg {
 627                                  'custnum' => $custnum,
 628                                  'pkgpart' => $pkgpart,
 629                                };
 630     my $error = $new->insert;
 631     if ( $error ) {
 632       $dbh->rollback if $oldAutoCommit;
 633       return "Couldn't insert new cust_pkg record: $error";
 634     }
 635     push @{$return_cust_pkg}, $new if $return_cust_pkg;
 636     my $pkgnum = $new->pkgnum;
 637
 638     foreach my $cust_svc ( @{ shift @cust_svc } ) {
 639       my(%hash) = $cust_svc->hash;
 640       $hash{'pkgnum'}=$pkgnum;
 641       my($new) = new FS::cust_svc ( \%hash );
 642       my($error)=$new->replace($cust_svc);
 643       if ( $error ) {
 644         $dbh->rollback if $oldAutoCommit;
 645         return "Couldn't link old service to new package: $error";
 646       }
 647     }
 648   }
 649
 650   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 651
 652   ''; #no errors
 653 }
 654
 655 =back
 656
 657 =head1 VERSION
 658
 659 $Id: cust_pkg.pm,v 1.16 2002-01-29 16:33:15 ivan Exp $
 660
 661 =head1 BUGS
 662
 663 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 664
 665 In sub order, the @pkgparts array (passed by reference) is clobbered.
 666
 667 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 668 method to pass dates to the recur_prog expression, it should do so.
 669
 670 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 671 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 672 cancel } because they use %FS::UID::callback to load configuration values.
 673 Probably need a subroutine which decides what to do based on whether or not
 674 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 675
 676 Now that things are transactional should the check in the insert method be
 677 moved to check ?
 678
 679 =head1 SEE ALSO
 680
 681 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
 682 L<FS::pkg_svc>, schema.html from the base documentation
 683
 684 =cut
 685
 686 1;
 687