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