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