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