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