5 use FS::UID qw( getotaker dbh );
6 use FS::Record qw( qsearch qsearchs );
13 # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend,
15 # because they load configuraion by setting FS::UID::callback (see TODO)
22 @ISA = qw( FS::Record );
26 my ( $hashref, $cache ) = @_;
27 #if ( $hashref->{'pkgpart'} ) {
28 if ( $hashref->{'pkg'} ) {
29 # #@{ $self->{'_pkgnum'} } = ();
30 # my $subcache = $cache->subcache('pkgpart', 'part_pkg');
31 # $self->{'_pkgpart'} = $subcache;
32 # #push @{ $self->{'_pkgnum'} },
33 # FS::part_pkg->new_or_cached($hashref, $subcache);
34 $self->{'_pkgpart'} = FS::part_pkg->new($hashref);
36 if ( exists $hashref->{'svcnum'} ) {
37 #@{ $self->{'_pkgnum'} } = ();
38 my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum});
39 $self->{'_svcnum'} = $subcache;
40 #push @{ $self->{'_pkgnum'} },
41 FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum};
47 FS::cust_pkg - Object methods for cust_pkg objects
53 $record = new FS::cust_pkg \%hash;
54 $record = new FS::cust_pkg { 'column' => 'value' };
56 $error = $record->insert;
58 $error = $new_record->replace($old_record);
60 $error = $record->delete;
62 $error = $record->check;
64 $error = $record->cancel;
66 $error = $record->suspend;
68 $error = $record->unsuspend;
70 $part_pkg = $record->part_pkg;
72 @labels = $record->labels;
74 $seconds = $record->seconds_since($timestamp);
76 $error = FS::cust_pkg::order( $custnum, \@pkgparts );
77 $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] );
81 An FS::cust_pkg object represents a customer billing item. FS::cust_pkg
82 inherits from FS::Record. The following fields are currently supported:
86 =item pkgnum - primary key (assigned automatically for new billing items)
88 =item custnum - Customer (see L<FS::cust_main>)
90 =item pkgpart - Billing item definition (see L<FS::part_pkg>)
102 =item otaker - order taker (assigned automatically if null, see L<FS::UID>)
104 =item manual_flag - If this field is set to 1, disables the automatic
105 unsuspension of this package when using the B<unsuspendauto> config file.
109 Note: setup, bill, susp, expire and cancel are specified as UNIX timestamps;
110 see L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for
111 conversion functions.
119 Create a new billing item. To add the item to the database, see L<"insert">.
123 sub table { 'cust_pkg'; }
127 Adds this billing item to the database ("Orders" the item). If there is an
128 error, returns the error, otherwise returns false.
135 # custnum might not have have been defined in sub check (for one-shot new
136 # customers), so check it here instead
137 # (is this still necessary with transactions?)
139 my $error = $self->ut_number('custnum');
140 return $error if $error;
142 return "Unknown customer ". $self->custnum unless $self->cust_main;
144 $self->SUPER::insert;
150 This method now works but you probably shouldn't use it.
152 You don't want to delete billing items, because there would then be no record
153 the customer ever purchased the item. Instead, see the cancel method.
158 # return "Can't delete cust_pkg records!";
161 =item replace OLD_RECORD
163 Replaces the OLD_RECORD with this one in the database. If there is an error,
164 returns the error, otherwise returns false.
166 Currently, custnum, setup, bill, susp, expire, and cancel may be changed.
168 Changing pkgpart may have disasterous effects. See the order subroutine.
170 setup and bill are normally updated by calling the bill method of a customer
171 object (see L<FS::cust_main>).
173 suspend is normally updated by the suspend and unsuspend methods.
175 cancel is normally updated by the cancel method (and also the order subroutine
181 my( $new, $old ) = ( shift, shift );
183 #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart;
184 return "Can't change otaker!" if $old->otaker ne $new->otaker;
187 #return "Can't change setup once it exists!"
188 # if $old->getfield('setup') &&
189 # $old->getfield('setup') != $new->getfield('setup');
191 #some logic for bill, susp, cancel?
193 $new->SUPER::replace($old);
198 Checks all fields to make sure this is a valid billing item. If there is an
199 error, returns the error, otherwise returns false. Called by the insert and
208 $self->ut_numbern('pkgnum')
209 || $self->ut_numbern('custnum')
210 || $self->ut_number('pkgpart')
211 || $self->ut_numbern('setup')
212 || $self->ut_numbern('bill')
213 || $self->ut_numbern('susp')
214 || $self->ut_numbern('cancel')
216 return $error if $error;
218 if ( $self->custnum ) {
219 return "Unknown customer ". $self->custnum unless $self->cust_main;
222 return "Unknown pkgpart"
223 unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
225 $self->otaker(getotaker) unless $self->otaker;
226 $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker";
229 if ( $self->dbdef_table->column('manual_flag') ) {
230 $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag";
231 $self->manual_flag($1);
239 Cancels and removes all services (see L<FS::cust_svc> and L<FS::part_svc>)
240 in this package, then cancels the package itself (sets the cancel field to
243 If there is an error, returns the error, otherwise returns false.
251 local $SIG{HUP} = 'IGNORE';
252 local $SIG{INT} = 'IGNORE';
253 local $SIG{QUIT} = 'IGNORE';
254 local $SIG{TERM} = 'IGNORE';
255 local $SIG{TSTP} = 'IGNORE';
256 local $SIG{PIPE} = 'IGNORE';
258 my $oldAutoCommit = $FS::UID::AutoCommit;
259 local $FS::UID::AutoCommit = 0;
262 foreach my $cust_svc (
263 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
265 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
267 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
268 $dbh->rollback if $oldAutoCommit;
269 return "Illegal svcdb value in part_svc!";
272 require "FS/$svcdb.pm";
274 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
276 $error = $svc->cancel;
278 $dbh->rollback if $oldAutoCommit;
279 return "Error cancelling service: $error"
281 $error = $svc->delete;
283 $dbh->rollback if $oldAutoCommit;
284 return "Error deleting service: $error";
288 $error = $cust_svc->delete;
290 $dbh->rollback if $oldAutoCommit;
291 return "Error deleting cust_svc: $error";
296 unless ( $self->getfield('cancel') ) {
297 my %hash = $self->hash;
298 $hash{'cancel'} = time;
299 my $new = new FS::cust_pkg ( \%hash );
300 $error = $new->replace($self);
302 $dbh->rollback if $oldAutoCommit;
307 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
314 Suspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
315 package, then suspends the package itself (sets the susp field to now).
317 If there is an error, returns the error, otherwise returns false.
325 local $SIG{HUP} = 'IGNORE';
326 local $SIG{INT} = 'IGNORE';
327 local $SIG{QUIT} = 'IGNORE';
328 local $SIG{TERM} = 'IGNORE';
329 local $SIG{TSTP} = 'IGNORE';
330 local $SIG{PIPE} = 'IGNORE';
332 my $oldAutoCommit = $FS::UID::AutoCommit;
333 local $FS::UID::AutoCommit = 0;
336 foreach my $cust_svc (
337 qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } )
339 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
341 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
342 $dbh->rollback if $oldAutoCommit;
343 return "Illegal svcdb value in part_svc!";
346 require "FS/$svcdb.pm";
348 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
350 $error = $svc->suspend;
352 $dbh->rollback if $oldAutoCommit;
359 unless ( $self->getfield('susp') ) {
360 my %hash = $self->hash;
361 $hash{'susp'} = time;
362 my $new = new FS::cust_pkg ( \%hash );
363 $error = $new->replace($self);
365 $dbh->rollback if $oldAutoCommit;
370 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
377 Unsuspends all services (see L<FS::cust_svc> and L<FS::part_svc>) in this
378 package, then unsuspends the package itself (clears the susp field).
380 If there is an error, returns the error, otherwise returns false.
388 local $SIG{HUP} = 'IGNORE';
389 local $SIG{INT} = 'IGNORE';
390 local $SIG{QUIT} = 'IGNORE';
391 local $SIG{TERM} = 'IGNORE';
392 local $SIG{TSTP} = 'IGNORE';
393 local $SIG{PIPE} = 'IGNORE';
395 my $oldAutoCommit = $FS::UID::AutoCommit;
396 local $FS::UID::AutoCommit = 0;
399 foreach my $cust_svc (
400 qsearch('cust_svc',{'pkgnum'=> $self->pkgnum } )
402 my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } );
404 $part_svc->svcdb =~ /^([\w\-]+)$/ or do {
405 $dbh->rollback if $oldAutoCommit;
406 return "Illegal svcdb value in part_svc!";
409 require "FS/$svcdb.pm";
411 my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } );
413 $error = $svc->unsuspend;
415 $dbh->rollback if $oldAutoCommit;
422 unless ( ! $self->getfield('susp') ) {
423 my %hash = $self->hash;
425 my $new = new FS::cust_pkg ( \%hash );
426 $error = $new->replace($self);
428 $dbh->rollback if $oldAutoCommit;
433 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
440 Returns the definition for this billing item, as an FS::part_pkg object (see
447 #exists( $self->{'_pkgpart'} )
449 ? $self->{'_pkgpart'}
450 : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } );
455 Returns the services for this package, as FS::cust_svc objects (see
462 if ( $self->{'_svcnum'} ) {
463 values %{ $self->{'_svcnum'}->cache };
465 qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
471 Returns a list of lists, calling the label method for all services
472 (see L<FS::cust_svc>) of this billing item.
478 map { [ $_->label ] } $self->cust_svc;
483 Returns the parent customer object (see L<FS::cust_main>).
489 qsearchs( 'cust_main', { 'custnum' => $self->custnum } );
492 =item seconds_since TIMESTAMP
494 Returns the number of seconds all accounts (see L<FS::svc_acct>) in this
495 package have been online since TIMESTAMP.
497 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
498 L<Time::Local> and L<Date::Parse> for conversion functions.
503 my($self, $since) = @_;
506 foreach my $cust_svc (
507 grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc
509 $seconds += $cust_svc->seconds_since($since);
522 =item order CUSTNUM, PKGPARTS_ARYREF, [ REMOVE_PKGNUMS_ARYREF [ RETURN_CUST_PKG_ARRAYREF ] ]
524 CUSTNUM is a customer (see L<FS::cust_main>)
526 PKGPARTS is a list of pkgparts specifying the the billing item definitions (see
527 L<FS::part_pkg>) to order for this customer. Duplicates are of course
530 REMOVE_PKGNUMS is an optional list of pkgnums specifying the billing items to
531 remove for this customer. The services (see L<FS::cust_svc>) are moved to the
532 new billing items. An error is returned if this is not possible (see
533 L<FS::pkg_svc>). An empty arrayref is equivalent to not specifying this
536 RETURN_CUST_PKG_ARRAYREF, if specified, will be filled in with the
537 newly-created cust_pkg objects.
542 my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_;
543 $remove_pkgnums = [] unless defined($remove_pkgnums);
545 my $oldAutoCommit = $FS::UID::AutoCommit;
546 local $FS::UID::AutoCommit = 0;
550 # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart
552 my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum});
553 my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum });
554 my %part_pkg = %{ $agent->pkgpart_hashref };
558 # for those packages being removed:
559 #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::cust_svc objects
561 foreach $pkgnum ( @{$remove_pkgnums} ) {
562 foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) {
563 push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc;
569 # for those packages the customer is purchasing:
570 # @{$pkgparts} is a list of said packages, by pkgpart
571 # @cust_svc is a corresponding list of lists of FS::Record objects
572 foreach my $pkgpart ( @{$pkgparts} ) {
573 unless ( $part_pkg{$pkgpart} ) {
574 $dbh->rollback if $oldAutoCommit;
575 return "Customer not permitted to purchase pkgpart $pkgpart!";
579 ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : ();
580 } map { $_->svcpart }
581 qsearch('pkg_svc', { pkgpart => $pkgpart,
582 quantity => { op=>'>', value=>'0', } } )
586 #special-case until this can be handled better
587 # move services to new svcparts - even if the svcparts don't match (svcdb
589 # looks like they're moved in no particular order, ewwwwwwww
590 # and looks like just one of each svcpart can be moved... o well
592 #start with still-leftover services
593 #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) {
594 foreach my $svcpart ( keys %svcnum ) {
595 next unless @{ $svcnum{$svcpart} };
597 my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb;
599 #find an empty place to put one
601 foreach my $pkgpart ( @{$pkgparts} ) {
603 qsearch('pkg_svc', { pkgpart => $pkgpart,
604 quantity => { op=>'>', value=>'0', } } );
606 # grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } );
607 if ( ! @{$cust_svc[$i]} #find an empty place to put them with
608 && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb
612 ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart;
613 my $cust_svc = shift @{$svcnum{$svcpart}};
614 $cust_svc->svcpart($new_svcpart);
615 #warn "changing from $svcpart to $new_svcpart!!!\n";
616 $cust_svc[$i] = [ $cust_svc ];
623 #check for leftover services
624 foreach (keys %svcnum) {
625 next unless @{ $svcnum{$_} };
626 $dbh->rollback if $oldAutoCommit;
627 return "Leftover services, svcpart $_: svcnum ".
628 join(', ', map { $_->svcnum } @{ $svcnum{$_} } );
631 #no leftover services, let's make changes.
633 local $SIG{HUP} = 'IGNORE';
634 local $SIG{INT} = 'IGNORE';
635 local $SIG{QUIT} = 'IGNORE';
636 local $SIG{TERM} = 'IGNORE';
637 local $SIG{TSTP} = 'IGNORE';
638 local $SIG{PIPE} = 'IGNORE';
640 #first cancel old packages
641 foreach my $pkgnum ( @{$remove_pkgnums} ) {
642 my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum});
644 $dbh->rollback if $oldAutoCommit;
645 return "Package $pkgnum not found to remove!";
647 my(%hash) = $old->hash;
648 $hash{'cancel'}=time;
649 my($new) = new FS::cust_pkg ( \%hash );
650 my($error)=$new->replace($old);
652 $dbh->rollback if $oldAutoCommit;
653 return "Couldn't update package $pkgnum: $error";
657 #now add new packages, changing cust_svc records if necessary
659 while ($pkgpart=shift @{$pkgparts} ) {
661 my $new = new FS::cust_pkg {
662 'custnum' => $custnum,
663 'pkgpart' => $pkgpart,
665 my $error = $new->insert;
667 $dbh->rollback if $oldAutoCommit;
668 return "Couldn't insert new cust_pkg record: $error";
670 push @{$return_cust_pkg}, $new if $return_cust_pkg;
671 my $pkgnum = $new->pkgnum;
673 foreach my $cust_svc ( @{ shift @cust_svc } ) {
674 my(%hash) = $cust_svc->hash;
675 $hash{'pkgnum'}=$pkgnum;
676 my $new = new FS::cust_svc ( \%hash );
678 #avoid Record diffing missing changed svcpart field from above.
679 my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } );
681 my $error = $new->replace($old);
683 $dbh->rollback if $oldAutoCommit;
684 return "Couldn't link old service to new package: $error";
689 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
698 $Id: cust_pkg.pm,v 1.18 2002-04-20 02:06:38 ivan Exp $
702 sub order is not OO. Perhaps it should be moved to FS::cust_main and made so?
704 In sub order, the @pkgparts array (passed by reference) is clobbered.
706 Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard
707 method to pass dates to the recur_prog expression, it should do so.
709 FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at
710 compile time, rather than via 'require' in sub { setup, suspend, unsuspend,
711 cancel } because they use %FS::UID::callback to load configuration values.
712 Probably need a subroutine which decides what to do based on whether or not
713 we've fetched the user yet, rather than a hash. See FS::UID and the TODO.
715 Now that things are transactional should the check in the insert method be
720 L<FS::Record>, L<FS::cust_main>, L<FS::part_pkg>, L<FS::cust_svc>,
721 L<FS::pkg_svc>, schema.html from the base documentation