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