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