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