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