X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=d9a6385e23e86038212e01115415ec3bee95d101;hp=cbf4ae50d38be016d2ff1f2ff54dfe184c019d18;hb=2d82b5b713c7c11d2d54a018d121b80fd6485c60;hpb=a984fa561b6493ae41215c3d26013767f9ce79cb diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index cbf4ae50d..d9a6385e2 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,25 +1,53 @@ package FS::cust_pkg; use strict; -use vars qw(@ISA); +use vars qw(@ISA $disable_agentcheck); use FS::UID qw( getotaker dbh ); use FS::Record qw( qsearch qsearchs ); +use FS::Misc qw( send_email ); use FS::cust_svc; use FS::part_pkg; use FS::cust_main; use FS::type_pkgs; use FS::pkg_svc; +use FS::cust_bill_pkg; # need to 'use' these instead of 'require' in sub { cancel, suspend, unsuspend, # setup } # because they load configuraion by setting FS::UID::callback (see TODO) use FS::svc_acct; -use FS::svc_acct_sm; use FS::svc_domain; use FS::svc_www; +use FS::svc_forward; + +# for sending cancel emails in sub cancel +use FS::Conf; @ISA = qw( FS::Record ); +$disable_agentcheck = 0; + +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + #if ( $hashref->{'pkgpart'} ) { + if ( $hashref->{'pkg'} ) { + # #@{ $self->{'_pkgnum'} } = (); + # my $subcache = $cache->subcache('pkgpart', 'part_pkg'); + # $self->{'_pkgpart'} = $subcache; + # #push @{ $self->{'_pkgnum'} }, + # FS::part_pkg->new_or_cached($hashref, $subcache); + $self->{'_pkgpart'} = FS::part_pkg->new($hashref); + } + if ( exists $hashref->{'svcnum'} ) { + #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum}); + $self->{'_svcnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum}; + } +} + =head1 NAME FS::cust_pkg - Object methods for cust_pkg objects @@ -49,6 +77,8 @@ FS::cust_pkg - Object methods for cust_pkg objects @labels = $record->labels; + $seconds = $record->seconds_since($timestamp); + $error = FS::cust_pkg::order( $custnum, \@pkgparts ); $error = FS::cust_pkg::order( $custnum, \@pkgparts, \@remove_pkgnums ] ); @@ -67,7 +97,9 @@ inherits from FS::Record. The following fields are currently supported: =item setup - date -=item bill - date +=item bill - date (next bill date) + +=item last_bill - last bill date =item susp - date @@ -78,7 +110,7 @@ inherits from FS::Record. The following fields are currently supported: =item otaker - order taker (assigned automatically if null, see L) =item manual_flag - If this field is set to 1, disables the automatic -unsuspensiond of this package when using the B config file. +unsuspension of this package when using the B config file. =back @@ -115,7 +147,16 @@ sub insert { my $error = $self->ut_number('custnum'); return $error if $error; - return "Unknown customer ". $self->custnum unless $self->cust_main; + my $cust_main = $self->cust_main; + return "Unknown customer ". $self->custnum unless $cust_main; + + unless ( $disable_agentcheck ) { + my $agent = qsearchs( 'agent', { 'agentnum' => $cust_main->agentnum } ); + my $pkgpart_href = $agent->pkgpart_hashref; + return "agent ". $agent->agentnum. + " can't purchase pkgpart ". $self->pkgpart + unless $pkgpart_href->{ $self->pkgpart }; + } $self->SUPER::insert; @@ -123,15 +164,16 @@ sub insert { =item delete -Currently unimplemented. You don't want to delete billing items, because there -would then be no record the customer ever purchased the item. Instead, see -the cancel method. +This method now works but you probably shouldn't use it. + +You don't want to delete billing items, because there would then be no record +the customer ever purchased the item. Instead, see the cancel method. =cut -sub delete { - return "Can't delete cust_pkg records!"; -} +#sub delete { +# return "Can't delete cust_pkg records!"; +#} =item replace OLD_RECORD @@ -157,9 +199,12 @@ sub replace { #return "Can't (yet?) change pkgpart!" if $old->pkgpart != $new->pkgpart; return "Can't change otaker!" if $old->otaker ne $new->otaker; - return "Can't change setup once it exists!" - if $old->getfield('setup') && - $old->getfield('setup') != $new->getfield('setup'); + + #allow this *sigh* + #return "Can't change setup once it exists!" + # if $old->getfield('setup') && + # $old->getfield('setup') != $new->getfield('setup'); + #some logic for bill, susp, cancel? $new->SUPER::replace($old); @@ -191,33 +236,39 @@ sub check { return "Unknown customer ". $self->custnum unless $self->cust_main; } - return "Unknown pkgpart" + return "Unknown pkgpart: ". $self->pkgpart unless qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); $self->otaker(getotaker) unless $self->otaker; - $self->otaker =~ /^(\w{0,16})$/ or return "Illegal otaker"; + $self->otaker =~ /^([\w\.\-]{0,16})$/ or return "Illegal otaker"; $self->otaker($1); if ( $self->dbdef_table->column('manual_flag') ) { - $self->manual_flag =~ /^([01]?)$/ or return "Illegal manual_flag"; + $self->manual_flag('') if $self->manual_flag eq ' '; + $self->manual_flag =~ /^([01]?)$/ + or return "Illegal manual_flag ". $self->manual_flag; $self->manual_flag($1); } - ''; #no error + $self->SUPER::check; } -=item cancel +=item cancel [ OPTION => VALUE ... ] Cancels and removes all services (see L and L) in this package, then cancels the package itself (sets the cancel field to now). +Available options are: I + +I can be set true to supress email cancellation notices. + If there is an error, returns the error, otherwise returns false. =cut sub cancel { - my $self = shift; + my( $self, %options ) = @_; my $error; local $SIG{HUP} = 'IGNORE'; @@ -234,33 +285,11 @@ sub cancel { foreach my $cust_svc ( qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $cust_svc->svcpart } ); + my $error = $cust_svc->cancel; - $part_svc->svcdb =~ /^([\w\-]+)$/ or do { - $dbh->rollback if $oldAutoCommit; - return "Illegal svcdb value in part_svc!"; - }; - my $svcdb = $1; - require "FS/$svcdb.pm"; - - my $svc = qsearchs( $svcdb, { 'svcnum' => $cust_svc->svcnum } ); - if ($svc) { - $error = $svc->cancel; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error cancelling service: $error" - } - $error = $svc->delete; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error deleting service: $error"; - } - } - - $error = $cust_svc->delete; if ( $error ) { $dbh->rollback if $oldAutoCommit; - return "Error deleting cust_svc: $error"; + return "Error cancelling cust_svc: $error"; } } @@ -278,7 +307,21 @@ sub cancel { $dbh->commit or die $dbh->errstr if $oldAutoCommit; + my $conf = new FS::Conf; + my @invoicing_list = grep { $_ ne 'POST' } $self->cust_main->invoicing_list; + if ( !$options{'quiet'} && $conf->exists('emailcancel') && @invoicing_list ) { + my $conf = new FS::Conf; + my $error = send_email( + 'from' => $conf->config('invoice_from'), + 'to' => \@invoicing_list, + 'subject' => $conf->config('cancelsubject'), + 'body' => [ map "$_\n", $conf->config('cancelmessage') ], + ); + #should this do something on errors? + } + ''; #no errors + } =item suspend @@ -407,6 +450,24 @@ sub unsuspend { ''; #no errors } +=item last_bill + +Returns the last bill date, or if there is no last bill date, the setup date. +Useful for billing metered services. + +=cut + +sub last_bill { + my $self = shift; + if ( $self->dbdef_table->column('last_bill') ) { + return $self->setfield('last_bill', $_[0]) if @_; + return $self->getfield('last_bill') if $self->getfield('last_bill'); + } + my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum, + 'edate' => $self->bill, } ); + $cust_bill_pkg ? $cust_bill_pkg->sdate : $self->setup || 0; +} + =item part_pkg Returns the definition for this billing item, as an FS::part_pkg object (see @@ -416,7 +477,26 @@ L). sub part_pkg { my $self = shift; - qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); + #exists( $self->{'_pkgpart'} ) + $self->{'_pkgpart'} + ? $self->{'_pkgpart'} + : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item cust_svc + +Returns the services for this package, as FS::cust_svc objects (see +L) + +=cut + +sub cust_svc { + my $self = shift; + if ( $self->{'_svcnum'} ) { + values %{ $self->{'_svcnum'}->cache }; + } else { + qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + } } =item labels @@ -428,7 +508,7 @@ Returns a list of lists, calling the label method for all services sub labels { my $self = shift; - map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + map { [ $_->label ] } $self->cust_svc; } =item cust_main @@ -442,6 +522,184 @@ sub cust_main { qsearchs( 'cust_main', { 'custnum' => $self->custnum } ); } +=item seconds_since TIMESTAMP + +Returns the number of seconds all accounts (see L) in this +package have been online since TIMESTAMP, according to the session monitor. + +TIMESTAMP is specified as a UNIX timestamp; see L. Also see +L and L for conversion functions. + +=cut + +sub seconds_since { + my($self, $since) = @_; + my $seconds = 0; + + foreach my $cust_svc ( + grep { $_->part_svc->svcdb eq 'svc_acct' } $self->cust_svc + ) { + $seconds += $cust_svc->seconds_since($since); + } + + $seconds; + +} + +=item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END + +Returns the numbers of seconds all accounts (see L) in this +package have been online between TIMESTAMP_START (inclusive) and TIMESTAMP_END +(exclusive). + +TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see +L. Also see L and L for conversion +functions. + + +=cut + +sub seconds_since_sqlradacct { + my($self, $start, $end) = @_; + + my $seconds = 0; + + foreach my $cust_svc ( + grep { + my $part_svc = $_->part_svc; + $part_svc->svcdb eq 'svc_acct' + && scalar($part_svc->part_export('sqlradius')); + } $self->cust_svc + ) { + $seconds += $cust_svc->seconds_since_sqlradacct($start, $end); + } + + $seconds; + +} + +=item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE + +Returns the sum of the given attribute for all accounts (see L) +in this package for sessions ending between TIMESTAMP_START (inclusive) and +TIMESTAMP_END +(exclusive). + +TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see +L. Also see L and L for conversion +functions. + +=cut + +sub attribute_since_sqlradacct { + my($self, $start, $end, $attrib) = @_; + + my $sum = 0; + + foreach my $cust_svc ( + grep { + my $part_svc = $_->part_svc; + $part_svc->svcdb eq 'svc_acct' + && scalar($part_svc->part_export('sqlradius')); + } $self->cust_svc + ) { + $sum += $cust_svc->attribute_since_sqlradacct($start, $end, $attrib); + } + + $sum; + +} + +=item transfer DEST_PKGNUM + +Transfers as many services as possible from this package to another package. +The destination package must already exist. Services are moved only if +the destination allows services with the correct I (not svcdb). +Any services that can't be moved remain in the original package. + +Returns an error, if there is one; otherwise, returns the number of services +that couldn't be moved. + +=cut + +sub transfer { + my ($self, $dest_pkgnum) = @_; + + my $remaining = 0; + my $dest; + my %target; + my $pkg_svc; + + if (ref ($dest_pkgnum) eq 'FS::cust_pkg') { + $dest = $dest_pkgnum; + $dest_pkgnum = $dest->pkgnum; + } else { + $dest = qsearchs('cust_pkg', { pkgnum => $dest_pkgnum }); + } + + return ('Package does not exist: '.$dest_pkgnum) unless $dest; + + foreach $pkg_svc (qsearch('pkg_svc', { pkgpart => $dest->pkgpart })) { + $target{$pkg_svc->svcpart} = $pkg_svc->quantity; + } + + my $cust_svc; + + foreach $cust_svc ($dest->cust_svc) { + $target{$cust_svc->svcpart}--; + } + + foreach $cust_svc ($self->cust_svc) { + if($target{$cust_svc->svcpart} > 0) { + $target{$cust_svc->svcpart}--; + my $new = new FS::cust_svc { + svcnum => $cust_svc->svcnum, + svcpart => $cust_svc->svcpart, + pkgnum => $dest_pkgnum }; + my $error = $new->replace($cust_svc); + return $error if $error; + } else { + $remaining++ + } + } + return $remaining; +} + +=item reexport + +=cut + +sub reexport { + my $self = shift; + + local $SIG{HUP} = 'IGNORE'; + local $SIG{INT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; + local $SIG{TERM} = 'IGNORE'; + local $SIG{TSTP} = 'IGNORE'; + local $SIG{PIPE} = 'IGNORE'; + + my $oldAutoCommit = $FS::UID::AutoCommit; + local $FS::UID::AutoCommit = 0; + my $dbh = dbh; + + foreach my $cust_svc ( $self->cust_svc ) { + #false laziness w/svc_Common::insert + my $svc_x = $cust_svc->svc_x; + foreach my $part_export ( $cust_svc->part_svc->part_export ) { + my $error = $part_export->export_insert($svc_x); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return $error; + } + } + } + + $dbh->commit or die $dbh->errstr if $oldAutoCommit; + ''; + +} + =back =head1 SUBROUTINES @@ -468,125 +726,66 @@ newly-created cust_pkg objects. =cut sub order { - my($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_; - $remove_pkgnums = [] unless defined($remove_pkgnums); + # Rewritten to make use of the transfer() method, and in general + # to not suck so badly. + + my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; + + # Transactionize this whole mess my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; - # generate %part_pkg - # $part_pkg{$pkgpart} is true iff $custnum may purchase $pkgpart - # - my($cust_main)=qsearchs('cust_main',{'custnum'=>$custnum}); - my($agent)=qsearchs('agent',{'agentnum'=> $cust_main->agentnum }); - my %part_pkg = %{ $agent->pkgpart_hashref }; - - my(%svcnum); - # generate %svcnum - # for those packages being removed: - #@{ $svcnum{$svcpart} } goes from a svcpart to a list of FS::Record - # objects (table eq 'cust_svc') - my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($cust_svc); - foreach $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) { - push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc; - } - } - - my(@cust_svc); - #generate @cust_svc - # for those packages the customer is purchasing: - # @{$pkgparts} is a list of said packages, by pkgpart - # @cust_svc is a corresponding list of lists of FS::Record objects - my($pkgpart); - foreach $pkgpart ( @{$pkgparts} ) { - unless ( $part_pkg{$pkgpart} ) { + my $error; + my $cust_main = qsearchs('cust_main', { custnum => $custnum }); + return "Customer not found: $custnum" unless $cust_main; + + # Create the new packages. + my $cust_pkg; + foreach (@$pkgparts) { + $cust_pkg = new FS::cust_pkg { custnum => $custnum, + pkgpart => $_ }; + $error = $cust_pkg->insert; + if ($error) { $dbh->rollback if $oldAutoCommit; - return "Customer not permitted to purchase pkgpart $pkgpart!"; + return $error; } - push @cust_svc, [ - map { - ( $svcnum{$_} && @{ $svcnum{$_} } ) ? shift @{ $svcnum{$_} } : (); - } map { $_->svcpart } qsearch('pkg_svc', { 'pkgpart' => $pkgpart }) - ]; + push @$return_cust_pkg, $cust_pkg; } - - #check for leftover services - foreach (keys %svcnum) { - next unless @{ $svcnum{$_} }; - $dbh->rollback if $oldAutoCommit; - return "Leftover services, svcpart $_: svcnum ". - join(', ', map { $_->svcnum } @{ $svcnum{$_} } ); - } - - #no leftover services, let's make changes. - - local $SIG{HUP} = 'IGNORE'; - local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; - local $SIG{TERM} = 'IGNORE'; - local $SIG{TSTP} = 'IGNORE'; - local $SIG{PIPE} = 'IGNORE'; - - #first cancel old packages -# my($pkgnum); - foreach $pkgnum ( @{$remove_pkgnums} ) { - my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum}); - unless ( $old ) { - $dbh->rollback if $oldAutoCommit; - return "Package $pkgnum not found to remove!"; - } - my(%hash) = $old->hash; - $hash{'cancel'}=time; - my($new) = new FS::cust_pkg ( \%hash ); - my($error)=$new->replace($old); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't update package $pkgnum: $error"; + # $return_cust_pkg now contains refs to all of the newly + # created packages. + + # Transfer services and cancel old packages. + foreach my $old_pkgnum (@$remove_pkgnum) { + my $old_pkg = qsearchs ('cust_pkg', { pkgnum => $old_pkgnum }); + foreach my $new_pkg (@$return_cust_pkg) { + $error = $old_pkg->transfer($new_pkg); + if ($error and $error == 0) { + # $old_pkg->transfer failed. + $dbh->rollback if $oldAutoCommit; + return $error; + } } - } - - #now add new packages, changing cust_svc records if necessary -# my($pkgpart); - while ($pkgpart=shift @{$pkgparts} ) { - - my $new = new FS::cust_pkg { - 'custnum' => $custnum, - 'pkgpart' => $pkgpart, - }; - my $error = $new->insert; - if ( $error ) { + if ($error > 0) { + # Transfers were successful, but we went through all of the + # new packages and still had services left on the old package. + # We can't cancel the package under the circumstances, so abort. $dbh->rollback if $oldAutoCommit; - return "Couldn't insert new cust_pkg record: $error"; + return "Unable to transfer all services from package ".$old_pkg->pkgnum; } - push @{$return_cust_pkg}, $new if $return_cust_pkg; - my $pkgnum = $new->pkgnum; - - foreach my $cust_svc ( @{ shift @cust_svc } ) { - my(%hash) = $cust_svc->hash; - $hash{'pkgnum'}=$pkgnum; - my($new) = new FS::cust_svc ( \%hash ); - my($error)=$new->replace($cust_svc); - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Couldn't link old service to new package: $error"; - } + $error = $old_pkg->cancel; + if ($error) { + $dbh->rollback; + return $error; } - } - + } $dbh->commit or die $dbh->errstr if $oldAutoCommit; - - ''; #no errors + ''; } =back -=head1 VERSION - -$Id: cust_pkg.pm,v 1.10 2001-10-15 12:16:42 ivan Exp $ - =head1 BUGS sub order is not OO. Perhaps it should be moved to FS::cust_main and made so? @@ -596,11 +795,12 @@ In sub order, the @pkgparts array (passed by reference) is clobbered. Also in sub order, no money is adjusted. Once FS::part_pkg defines a standard method to pass dates to the recur_prog expression, it should do so. -FS::svc_acct, FS::svc_acct_sm, and FS::svc_domain are loaded via 'use' at -compile time, rather than via 'require' in sub { setup, suspend, unsuspend, -cancel } because they use %FS::UID::callback to load configuration values. -Probably need a subroutine which decides what to do based on whether or not -we've fetched the user yet, rather than a hash. See FS::UID and the TODO. +FS::svc_acct, FS::svc_domain, FS::svc_www, FS::svc_ip and FS::svc_forward are +loaded via 'use' at compile time, rather than via 'require' in sub { setup, +suspend, unsuspend, cancel } because they use %FS::UID::callback to load +configuration values. Probably need a subroutine which decides what to do +based on whether or not we've fetched the user yet, rather than a hash. See +FS::UID and the TODO. Now that things are transactional should the check in the insert method be moved to check ?