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