site_perl/cust_pkg.pm

   1 package FS::cust_pkg;
   2
   3 use strict;
   4 use vars qw(@ISA);
   5 use FS::UID qw( getotaker );
   6 use FS::Record qw( qsearch qsearchs );
   7 use FS::cust_svc;
   8 use FS::part_pkg;
   9 use FS::cust_main;
  10
  11 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
  12 # setup }
  13 # because they load configuraion by setting FS::UID::callback (see TODO)
  14 use FS::svc_acct;
  15 use FS::svc_acct_sm;
  16 use FS::svc_domain;
  17
  18 @ISA = qw( FS::Record );
  19
  20 =head1 NAME
  21
  22 FS::cust_pkg - Object methods for cust_pkg objects
  23
  24 =head1 SYNOPSIS
  25
  26   use FS::cust_pkg;
  27
  28   $record = new FS::cust_pkg \%hash;
  29   $record = new FS::cust_pkg { 'column' => 'value' };
  30
  31   $error = $record->insert;
  32
  33   $error = $new_record->replace($old_record);
  34
  35   $error = $record->delete;
  36
  37   $error = $record->check;
  38
  39   $error = $record->cancel;
  40
  41   $error = $record->suspend;
  42
  43   $error = $record->unsuspend;
  44
  45   $part_pkg = $record->part_pkg;
  46
  47   $error = FS::cust_pkg::order( $custnum, \@pkgparts );
  48   $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
  49
  50 =head1 DESCRIPTION
  51
  52 An FS::cust_pkg object represents a customer billing item.  FS::cust_pkg
  53 inherits from FS::Record.  The following fields are currently supported:
  54
  55 =over 4
  56
  57 =item pkgnum - primary key (assigned automatically for new billing items)
  58
  59 =item custnum - Customer (see L<FS::cust_main>)
  60
  61 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
  62
  63 =item setup - date
  64
  65 =item bill - date
  66
  67 =item susp - date
  68
  69 =item expire - date
  70
  71 =item cancel - date
  72
  73 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
  74
  75 =back
  76
  77 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
  78 see L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for
  79 conversion functions.
  80
  81 =head1 METHODS
  82
  83 =over 4
  84
  85 =item new HASHREF
  86
  87 Create a new billing item.  To add the item to the database, see L<"insert">.
  88
  89 =cut
  90
  91 sub table { 'cust_pkg'; }
  92
  93 =item insert
  94
  95 Adds this billing item to the database ("Orders" the item).  If there is an
  96 error, returns the error, otherwise returns false.
  97
  98 =item delete
  99
 100 Currently unimplemented.  You don't want to delete billing items, because there
 101 would then be no record the customer ever purchased the item.  Instead, see
 102 the cancel method.
 103
 104 =cut
 105
 106 sub delete {
 107   return "Can't delete cust_pkg records!";
 108 }
 109
 110 =item replace OLD_RECORD
 111
 112 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 113 returns the error, otherwise returns false.
 114
 115 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
 116
 117 Changing pkgpart may have disasterous effects.  See the order subroutine.
 118
 119 setup and bill are normally updated by calling the bill method of a customer
 120 object (see L<FS::cust_main>).
 121
 122 suspend is normally updated by the suspend and unsuspend methods.
 123
 124 cancel is normally updated by the cancel method (and also the order subroutine
 125 in some cases).
 126
 127 =cut
 128
 129 sub replace {
 130   my( $new, $old ) = ( shift, shift );
 131
 132   #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
 133   return "Can't change otaker!" if $old->otaker ne $new->otaker;
 134   return "Can't change setup once it exists!"
 135     if $old->getfield('setup') &&
 136        $old->getfield('setup') != $new->getfield('setup');
 137   #some logic for bill, susp, cancel?
 138
 139   $new->SUPER::replace($old);
 140 }
 141
 142 =item check
 143
 144 Checks all fields to make sure this is a valid billing item.  If there is an
 145 error, returns the error, otherwise returns false.  Called by the insert and
 146 replace methods.
 147
 148 =cut
 149
 150 sub check {
 151   my $self = shift;
 152
 153   my $error =
 154     $self->ut_numbern('pkgnum')
 155     || $self->ut_number('custnum')
 156     || $self->ut_number('pkgpart')
 157     || $self->ut_numbern('setup')
 158     || $self->ut_numbern('bill')
 159     || $self->ut_numbern('susp')
 160     || $self->ut_numbern('cancel')
 161   ;
 162   return $error if $error;
 163
 164   return "Unknown customer"
 165     unless qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
 166
 167   return "Unknown pkgpart"
 168     unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 169
 170   $self->otaker(getotaker) unless $self->otaker;
 171   $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker";
 172   $self->otaker($1);
 173
 174   ''; #no error
 175 }
 176
 177 =item cancel
 178
 179 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
 180 in this package, then cancels the package itself (sets the cancel field to
 181 now).
 182
 183 If there is an error, returns the error, otherwise returns false.
 184
 185 =cut
 186
 187 sub cancel {
 188   my $self = shift;
 189   my $error;
 190
 191   local $SIG{HUP} = 'IGNORE';
 192   local $SIG{INT} = 'IGNORE';
 193   local $SIG{QUIT} = 'IGNORE';
 194   local $SIG{TERM} = 'IGNORE';
 195   local $SIG{TSTP} = 'IGNORE';
 196   local $SIG{PIPE} = 'IGNORE';
 197
 198   foreach my $cust_svc (
 199     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 200   ) {
 201     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 202
 203     $part_svc->svcdb =~ /^([\w\-]+)$/
 204       or return "Illegal svcdb value in part_svc!";
 205     my $svcdb = $1;
 206     require "FS/$svcdb.pm";
 207
 208     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 209     if ($svc) {
 210       $error = $svc->cancel;
 211       return "Error cancelling service: $error" if $error;
 212       $error = $svc->delete;
 213       return "Error deleting service: $error" if $error;
 214     }
 215
 216     $error = $cust_svc->delete;
 217     return "Error deleting cust_svc: $error" if $error;
 218
 219   }
 220
 221   unless ( $self->getfield('cancel') ) {
 222     my %hash = $self->hash;
 223     $hash{'cancel'} = time;
 224     my $new = new FS::cust_pkg ( \%hash );
 225     $error = $new->replace($self);
 226     return $error if $error;
 227   }
 228
 229   ''; #no errors
 230 }
 231
 232 =item suspend
 233
 234 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 235 package, then suspends the package itself (sets the susp field to now).
 236
 237 If there is an error, returns the error, otherwise returns false.
 238
 239 =cut
 240
 241 sub suspend {
 242   my $self = shift;
 243   my $error ;
 244
 245   local $SIG{HUP} = 'IGNORE';
 246   local $SIG{INT} = 'IGNORE';
 247   local $SIG{QUIT} = 'IGNORE';
 248   local $SIG{TERM} = 'IGNORE';
 249   local $SIG{TSTP} = 'IGNORE';
 250   local $SIG{PIPE} = 'IGNORE';
 251
 252   foreach my $cust_svc (
 253     qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
 254   ) {
 255     my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
 256
 257     $part_svc->svcdb =~ /^([\w\-]+)$/
 258       or return "Illegal svcdb value in part_svc!";
 259     my $svcdb = $1;
 260     require "FS/$svcdb.pm";
 261
 262     my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
 263     if ($svc) {
 264       $error = $svc->suspend;
 265       return $error if $error;
 266     }
 267
 268   }
 269
 270   unless ( $self->getfield('susp') ) {
 271     my %hash = $self->hash;
 272     $hash{'susp'} = time;
 273     my $new = new FS::cust_pkg ( \%hash );
 274     $error = $new->replace($self);
 275     return $error if $error;
 276   }
 277
 278   ''; #no errors
 279 }
 280
 281 =item unsuspend
 282
 283 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
 284 package, then unsuspends the package itself (clears the susp field).
 285
 286 If there is an error, returns the error, otherwise returns false.
 287
 288 =cut
 289
 290 sub unsuspend {
 291   my $self = shift;
 292   my($error);
 293
 294   local $SIG{HUP} = 'IGNORE';
 295   local $SIG{INT} = 'IGNORE';
 296   local $SIG{QUIT} = 'IGNORE';
 297   local $SIG{TERM} = 'IGNORE';
 298   local $SIG{TSTP} = 'IGNORE';
 299   local $SIG{PIPE} = 'IGNORE';
 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\-]+)$/
 307       or return "Illegal svcdb value in part_svc!";
 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->unsuspend;
 314       return $error if $error;
 315     }
 316
 317   }
 318
 319   unless ( ! $self->getfield('susp') ) {
 320     my %hash = $self->hash;
 321     $hash{'susp'} = '';
 322     my $new = new FS::cust_pkg ( \%hash );
 323     $error = $new->replace($self);
 324     return $error if $error;
 325   }
 326
 327   ''; #no errors
 328 }
 329
 330 =item part_pkg
 331
 332 Returns the definition for this billing item, as an FS::part_pkg object (see
 333 L<FS::part_pkg).
 334
 335 =cut
 336
 337 sub part_pkg {
 338   my $self = shift;
 339   qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
 340 }
 341
 342 =back
 343
 344 =head1 SUBROUTINES
 345
 346 =over 4
 347
 348 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF ]
 349
 350 CUSTNUM is a customer (see L<FS::cust_main>)
 351
 352 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
 353 L<FS::part_pkg>) to order for this customer.  Duplicates are of course
 354 permitted.
 355
 356 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
 357 remove for this customer.  The services (see L<FS::cust_svc>) are moved to the
 358 new billing items.  An error is returned if this is not possible (see
 359 L<FS::pkg_svc>).
 360
 361 =cut
 362
 363 sub order {
 364   my($custnum,$pkgparts,$remove_pkgnums)=@_;
 365
 366   my(%part_pkg);
 367   # generate %part_pkg
 368   # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
 369     my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
 370     my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
 371
 372     my($type_pkgs);
 373     foreach $type_pkgs ( qsearch('type_pkgs',{'typenum'=> $agent->typenum }) ) {
 374       my($pkgpart)=$type_pkgs->pkgpart;
 375       $part_pkg{$pkgpart}++;
 376     }
 377   #
 378
 379   my(%svcnum);
 380   # generate %svcnum
 381   # for those packages being removed:
 382   #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record
 383   # objects (table eq 'cust_svc')
 384   my($pkgnum);
 385   foreach $pkgnum ( @{$remove_pkgnums} ) {
 386     my($cust_svc);
 387     foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
 388       push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
 389     }
 390   }
 391
 392   my(@cust_svc);
 393   #generate @cust_svc
 394   # for those packages the customer is purchasing:
 395   # @{$pkgparts} is a list of said packages, by pkgpart
 396   # @cust_svc is a corresponding list of lists of FS::Record objects
 397   my($pkgpart);
 398   foreach $pkgpart ( @{$pkgparts} ) {
 399     return "Customer not permitted to purchase pkgpart $pkgpart!"
 400       unless $part_pkg{$pkgpart};
 401     push @cust_svc, [
 402       map {
 403         ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
 404       } (split(/,/,
 405        qsearchs('part_pkg',{'pkgpart'=>$pkgpart})->getfield('services')
 406       ))
 407     ];
 408   }
 409
 410   #check for leftover services
 411   foreach (keys %svcnum) {
 412     next unless @{ $svcnum{$_} };
 413     return "Leftover services!";
 414   }
 415
 416   #no leftover services, let's make changes.
 417
 418   local $SIG{HUP} = 'IGNORE';
 419   local $SIG{INT} = 'IGNORE';
 420   local $SIG{QUIT} = 'IGNORE';
 421   local $SIG{TERM} = 'IGNORE';
 422   local $SIG{TSTP} = 'IGNORE';
 423   local $SIG{PIPE} = 'IGNORE';
 424
 425   #first cancel old packages
 426 #  my($pkgnum);
 427   foreach $pkgnum ( @{$remove_pkgnums} ) {
 428     my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
 429     die "Package $pkgnum not found to remove!" unless $old;
 430     my(%hash) = $old->hash;
 431     $hash{'cancel'}=time;
 432     my($new) = new FS::cust_pkg ( \%hash );
 433     my($error)=$new->replace($old);
 434     die "Couldn't update package $pkgnum: $error" if $error;
 435   }
 436
 437   #now add new packages, changing cust_svc records if necessary
 438 #  my($pkgpart);
 439   while ($pkgpart=shift @{$pkgparts} ) {
 440
 441     my($new) = new FS::cust_pkg ( {
 442                                        'custnum' => $custnum,
 443                                        'pkgpart' => $pkgpart,
 444                                     } );
 445     my($error) = $new->insert;
 446     die "Couldn't insert new cust_pkg record: $error" if $error;
 447     my($pkgnum)=$new->getfield('pkgnum');
 448
 449     my($cust_svc);
 450     foreach $cust_svc ( @{ shift @cust_svc } ) {
 451       my(%hash) = $cust_svc->hash;
 452       $hash{'pkgnum'}=$pkgnum;
 453       my($new) = new FS::cust_svc ( \%hash );
 454       my($error)=$new->replace($cust_svc);
 455       die "Couldn't link old service to new package: $error" if $error;
 456     }
 457   }
 458
 459   ''; #no errors
 460 }
 461
 462 =back
 463
 464 =head1 VERSION
 465
 466 $Id: cust_pkg.pm,v 1.6 1999-01-25 12:26:12 ivan Exp $
 467
 468 =head1 BUGS
 469
 470 sub order is not OO.  Perhaps it should be moved to FS::cust_main and made so?
 471
 472 In sub order, the @pkgparts array (passed by reference) is clobbered.
 473
 474 Also in sub order, no money is adjusted.  Once FS::part_pkg defines a standard
 475 method to pass dates to the recur_prog expression, it should do so.
 476
 477 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
 478 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
 479 cancel } because they use %FS::UID::callback to load configuration values.
 480 Probably need a subroutine which decides what to do based on whether or not
 481 we've fetched the user yet, rather than a hash.  See FS::UID and the TODO.
 482
 483 =head1 SEE ALSO
 484
 485 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>
 486 , L<FS::pkg_svc>, schema.html from the base documentation
 487
 488 =head1 HISTORY
 489
 490 ivan@voicenet.com 97-jul-1 - 21
 491
 492 fixed for new agent->agent_type->type_pkgs in &order ivan@sisd.com 98-mar-7
 493
 494 pod ivan@sisd.com 98-sep-21
 495
 496 $Log: cust_pkg.pm,v $
 497 Revision 1.6  1999-01-25 12:26:12  ivan
 498 yet more mod_perl stuff
 499
 500 Revision 1.5  1999/01/18 21:58:07  ivan
 501 esthetic: eq and ne were used in a few places instead of == and !=
 502
 503 Revision 1.4  1998/12/29 11:59:45  ivan
 504 mostly properly OO, some work still to be done with svc_ stuff
 505
 506 Revision 1.3  1998/11/15 13:01:35  ivan
 507 allow pkgpart changing (for per-customer custom pricing).  warn about it in doc
 508
 509 Revision 1.2  1998/11/12 03:42:45  ivan
 510 added label method
 511
 512
 513 =cut
 514
 515 1;
 516