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