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