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 ]
 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>).
 443
 444 =cut
 445
 446 sub order {
 447   my($custnum,$pkgparts,$remove_pkgnums)=@_;
 448
 449   my $oldAutoCommit = $FS::UID::AutoCommit;
 450   local $FS::UID::AutoCommit = 0;
 451   my $dbh = dbh;
 452
 453   # generate %part_pkg
 454   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 455   #
 456   my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 457   my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 458   my %part_pkg = %{ $agent->pkgpart_hashref };
 459
 460   my(%svcnum);
 461   # generate %svcnum
 462   # for those packages being removed:
 463   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record
 464   # objects (table eq 'cust_svc')
 465   my($pkgnum);
 466   foreach $pkgnum ( @{$remove_pkgnums} ) {
 467     my($cust_svc);
 468     foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 469       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 470     }
 471   }
 472
 473   my(@cust_svc);
 474   #generate @cust_svc
 475   # for those packages the customer is purchasing:
 476   # @{$pkgparts} is a list of said packages, by pkgpart
 477   # @cust_svc is a corresponding list of lists of FS::Record objects
 478   my($pkgpart);
 479   foreach $pkgpart ( @{$pkgparts} ) {
 480     unless ( $part_pkg{$pkgpart} ) {
 481       $dbh->rollback if $oldAutoCommit;
 482       return "Customer not permitted to purchase pkgpart $pkgpart!";
 483     }
 484     push @cust_svc, [
 485       map {
 486         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 487       } map { $_->svcpart } qsearch('pkg_svc', { 'pkgpart' => $pkgpart })
 488     ];
 489   }
 490
 491   #check for leftover services
 492   foreach (keys %svcnum) {
 493     next unless @{ $svcnum{$_} };
 494     $dbh->rollback if $oldAutoCommit;
 495     return "Leftover services, svcpart $_: svcnum ".
 496            join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
 497   }
 498
 499   #no leftover services, let's make changes.
 500
 501   local $SIG{HUP} = 'IGNORE';
 502   local $SIG{INT} = 'IGNORE';
 503   local $SIG{QUIT} = 'IGNORE';
 504   local $SIG{TERM} = 'IGNORE';
 505   local $SIG{TSTP} = 'IGNORE';
 506   local $SIG{PIPE} = 'IGNORE';
 507
 508   #first cancel old packages
 509 #  my($pkgnum);
 510   foreach $pkgnum ( @{$remove_pkgnums} ) {
 511     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 512     unless ( $old ) {
 513       $dbh->rollback if $oldAutoCommit;
 514       die "Package $pkgnum not found to remove!";
 515     }
 516     my(%hash) = $old->hash;
 517     $hash{'cancel'}=time;
 518     my($new) = new FS::cust_pkg ( \%hash );
 519     my($error)=$new->replace($old);
 520     if ( $error ) {
 521       $dbh->rollback if $oldAutoCommit;
 522       die "Couldn't update package $pkgnum: $error";
 523     }
 524   }
 525
 526   #now add new packages, changing cust_svc records if necessary
 527 #  my($pkgpart);
 528   while ($pkgpart=shift @{$pkgparts} ) {
 529
 530     my($new) = new FS::cust_pkg ( {
 531                                        'custnum' => $custnum,
 532                                        'pkgpart' => $pkgpart,
 533                                     } );
 534     my($error) = $new->insert;
 535    if ( $error ) {
 536       $dbh->rollback if $oldAutoCommit;
 537       die "Couldn't insert new cust_pkg record: $error";
 538     }
 539     my($pkgnum)=$new->getfield('pkgnum');
 540
 541     my($cust_svc);
 542     foreach $cust_svc ( @{ shift @cust_svc } ) {
 543       my(%hash) = $cust_svc->hash;
 544       $hash{'pkgnum'}=$pkgnum;
 545       my($new) = new FS::cust_svc ( \%hash );
 546       my($error)=$new->replace($cust_svc);
 547      if ( $error ) {
 548         $dbh->rollback if $oldAutoCommit;
 549         die "Couldn't link old service to new package: $error";
 550       }
 551     }
 552   }
 553
 554   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 555
 556   ''; #no errors
 557 }
 558
 559 =back
 560
 561 =head1 VERSION
 562
 563 $Id: cust_pkg.pm,v 1.5 2001-04-09 23:05:15 ivan Exp $
 564
 565 =head1 BUGS
 566
 567 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 568
 569 In sub order, the @pkgparts array (passed by reference) is clobbered.
 570
 571 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 572 method to pass dates to the recur_prog expression, it should do so.
 573
 574 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 575 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 576 cancel } because they use %FS::UID::callback to load configuration values.
 577 Probably need a subroutine which decides what to do based on whether or not
 578 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 579
 580 =head1 SEE ALSO
 581
 582 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>
 583 , L<FS::pkg_svc>, schema.html from the base documentation
 584
 585 =cut
 586
 587 1;
 588