X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2Fcust_pkg.pm;h=a3297ab4739d20ed1df2e18765af95466fa01aa2;hb=05430ec3d4d7d2303c0d8012d195923ec86fc289;hp=db0f7d423d0ae5148a900bf6795ae4e9e690a050;hpb=65615896de6e2474953722ea25122174b151d289;p=freeside.git diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index db0f7d423..a3297ab47 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -1,10 +1,9 @@ package FS::cust_pkg; use strict; -use vars qw(@ISA $disable_agentcheck @SVCDB_CANCEL_SEQ $DEBUG); +use vars qw(@ISA $disable_agentcheck $DEBUG); 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; @@ -16,12 +15,17 @@ use FS::cust_bill_pkg; # 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 +# need all this for sending cancel emails in sub cancel + use FS::Conf; +use Date::Format; +use Mail::Internet 1.44; +use Mail::Header; @ISA = qw( FS::Record ); @@ -29,14 +33,6 @@ $DEBUG = 0; $disable_agentcheck = 0; -# The order in which to unprovision services. -@SVCDB_CANCEL_SEQ = qw( svc_external - svc_www - svc_forward - svc_acct - svc_domain - svc_broadband ); - sub _cache { my $self = shift; my ( $hashref, $cache ) = @_; @@ -109,8 +105,6 @@ inherits from FS::Record. The following fields are currently supported: =item bill - date (next bill date) -=item last_bill - last bill date - =item susp - date =item expire - date @@ -260,7 +254,7 @@ sub check { $self->manual_flag($1); } - $self->SUPER::check; + ''; #no error } =item cancel [ OPTION => VALUE ... ] @@ -292,22 +286,16 @@ sub cancel { local $FS::UID::AutoCommit = 0; my $dbh = dbh; - my %svc; foreach my $cust_svc ( - qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) + qsearch( 'cust_svc', { 'pkgnum' => $self->pkgnum } ) ) { - push @{ $svc{$cust_svc->part_svc->svcdb} }, $cust_svc; - } - - foreach my $svcdb (@SVCDB_CANCEL_SEQ) { - foreach my $cust_svc (@{ $svc{$svcdb} }) { - my $error = $cust_svc->cancel; + my $error = $cust_svc->cancel; - if ( $error ) { - $dbh->rollback if $oldAutoCommit; - return "Error cancelling cust_svc: $error"; - } + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Error cancelling cust_svc: $error"; } + } unless ( $self->getfield('cancel') ) { @@ -324,16 +312,38 @@ 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? + + if ( !$options{'quiet'} && $conf->exists('emailcancel') + && grep { $_ ne 'POST' } $self->cust_main->invoicing_list) { + + my @invoicing_list = $self->cust_main->invoicing_list; + + my $invoice_from = $conf->config('invoice_from'); + my @print_text = map "$_\n", $conf->config('cancelmessage'); + my $subject = $conf->config('cancelsubject'); + my $smtpmachine = $conf->config('smtpmachine'); + + if ( grep { $_ ne 'POST' } @invoicing_list ) { #email invoice + #false laziness w/FS::cust_pay::delete & fs_signup_server && ::realtime_card + #$ENV{SMTPHOSTS} = $smtpmachine; + $ENV{MAILADDRESS} = $invoice_from; + my $header = new Mail::Header ( [ + "From: $invoice_from", + "To: ". join(', ', grep { $_ ne 'POST' } @invoicing_list ), + "Sender: $invoice_from", + "Reply-To: $invoice_from", + "Date: ". time2str("%a, %d %b %Y %X %z", time), + "Subject: $subject", + ] ); + my $message = new Mail::Internet ( + 'Header' => $header, + 'Body' => [ @print_text ], + ); + $!=0; + $message->smtpsend( Host => $smtpmachine ) + or $message->smtpsend( Host => $smtpmachine, Debug => 1 ); + #should this return an error? + } } ''; #no errors @@ -452,7 +462,10 @@ sub unsuspend { unless ( ! $self->getfield('susp') ) { my %hash = $self->hash; + my $inactive = time - $hash{'susp'}; $hash{'susp'} = ''; + $hash{'bill'} = ( $hash{'bill'} || $hash{'setup'} ) + $inactive + if $inactive > 0 && ( $hash{'bill'} || $hash{'setup'} ); my $new = new FS::cust_pkg ( \%hash ); $error = $new->replace($self); if ( $error ) { @@ -476,7 +489,7 @@ Useful for billing metered services. sub last_bill { my $self = shift; if ( $self->dbdef_table->column('last_bill') ) { - return $self->setfield('last_bill', $_[0]) if @_; + return $self->setfield('last_bill', $_[1]) if @_; return $self->getfield('last_bill') if $self->getfield('last_bill'); } my $cust_bill_pkg = qsearchs('cust_bill_pkg', { 'pkgnum' => $self->pkgnum, @@ -508,21 +521,11 @@ L) sub cust_svc { my $self = shift; - #if ( $self->{'_svcnum'} ) { - # values %{ $self->{'_svcnum'}->cache }; - #} else { - map { $_->[0] } - sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] } - map { - my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $self->pkgpart, - 'svcpart' => $_->svcpart } ); - [ $_, - $pkg_svc ? $pkg_svc->primary_svc : '', - $pkg_svc ? $pkg_svc->quantity : 0, - ]; - } + if ( $self->{'_svcnum'} ) { + values %{ $self->{'_svcnum'}->cache }; + } else { qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); - #} + } } =item labels @@ -608,8 +611,7 @@ sub seconds_since_sqlradacct { 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_END (exclusive). TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see L. Also see L and L for conversion @@ -636,123 +638,6 @@ sub attribute_since_sqlradacct { } -=item transfer DEST_PKGNUM | DEST_CUST_PKG, [ OPTION => VALUE ... ] - -Transfers as many services as possible from this package to another package. - -The destination package can be specified by pkgnum by passing an FS::cust_pkg -object. The destination package must already exist. - -Services are moved only if the destination allows services with the correct -I (not svcdb), unless the B option is set true. Use -this option with caution! No provision is made for export differences -between the old and new service definitions. Probably only should be used -when your exports for all service definitions of a given svcdb are identical. -(attempt a transfer without it first, to move all possible svcpart-matching -services) - -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, %opt) = @_; - - my $remaining = 0; - my $dest; - my %target; - - 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 my $pkg_svc ( $dest->part_pkg->pkg_svc ) { - $target{$pkg_svc->svcpart} = $pkg_svc->quantity; - } - - foreach my $cust_svc ($dest->cust_svc) { - $target{$cust_svc->svcpart}--; - } - - my %svcpart2svcparts = (); - if ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) { - warn "change_svcpart option received, creating alternates list\n" if $DEBUG; - foreach my $svcpart ( map { $_->svcpart } $self->cust_svc ) { - next if exists $svcpart2svcparts{$svcpart}; - my $part_svc = qsearchs('part_svc', { 'svcpart' => $svcpart } ); - $svcpart2svcparts{$svcpart} = [ - map { $_->[0] } - sort { $b->[1] cmp $a->[1] or $a->[2] <=> $b->[2] } - map { - my $pkg_svc = qsearchs( 'pkg_svc', { 'pkgpart' => $dest->pkgpart, - 'svcpart' => $_ } ); - [ $_, - $pkg_svc ? $pkg_svc->primary_svc : '', - $pkg_svc ? $pkg_svc->quantity : 0, - ]; - } - - grep { $_ != $svcpart } - map { $_->svcpart } - qsearch('part_svc', { 'svcdb' => $part_svc->svcdb } ) - ]; - warn "alternates for svcpart $svcpart: ". - join(', ', @{$svcpart2svcparts{$svcpart}}). "\n" - if $DEBUG; - } - } - - foreach my $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; - } elsif ( exists $opt{'change_svcpart'} && $opt{'change_svcpart'} ) { - if ( $DEBUG ) { - warn "looking for alternates for svcpart ". $cust_svc->svcpart. "\n"; - warn "alternates to consider: ". - join(', ', @{$svcpart2svcparts{$cust_svc->svcpart}}). "\n"; - } - my @alternate = grep { - warn "considering alternate svcpart $_: ". - "$target{$_} available in new package\n" - if $DEBUG; - $target{$_} > 0; - } @{$svcpart2svcparts{$cust_svc->svcpart}}; - if ( @alternate ) { - warn "alternate(s) found\n" if $DEBUG; - my $change_svcpart = $alternate[0]; - $target{$change_svcpart}--; - my $new = new FS::cust_svc { - svcnum => $cust_svc->svcnum, - svcpart => $change_svcpart, - pkgnum => $dest_pkgnum, - }; - my $error = $new->replace($cust_svc); - return $error if $error; - } else { - $remaining++; - } - } else { - $remaining++ - } - } - return $remaining; -} - =item reexport This method is deprecated. See the I option to the insert and @@ -817,81 +702,186 @@ newly-created cust_pkg objects. =cut sub order { - my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_; - - my $conf = new FS::Conf; - - # Transactionize this whole mess - 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($custnum, $pkgparts, $remove_pkgnums, $return_cust_pkg) = @_; + $remove_pkgnums = [] unless defined($remove_pkgnums); my $oldAutoCommit = $FS::UID::AutoCommit; local $FS::UID::AutoCommit = 0; my $dbh = dbh; - 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) { + # 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::cust_svc objects + my($pkgnum); + foreach $pkgnum ( @{$remove_pkgnums} ) { + foreach my $cust_svc (qsearch('cust_svc',{'pkgnum'=>$pkgnum})) { + push @{ $svcnum{$cust_svc->getfield('svcpart')} }, $cust_svc; + } + } + if ( $DEBUG ) { + foreach my $svcpart ( keys %svcnum ) { + warn "initial svcpart $svcpart: existing svcnums ". + join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n"; + } + } + + 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 + foreach my $pkgpart ( @{$pkgparts} ) { + unless ( $part_pkg{$pkgpart} ) { $dbh->rollback if $oldAutoCommit; - return $error; + return "Customer not permitted to purchase pkgpart $pkgpart!"; } - push @$return_cust_pkg, $cust_pkg; + push @cust_svc, [ + map { + my $svcnum = $svcnum{$_->{svcpart}}; + if ( $svcnum && @$svcnum ) { + my $num = ( $_->{quantity} < scalar(@$svcnum) ) + ? $_->{quantity} + : scalar(@$svcnum); + splice @$svcnum, 0, $num; + } else { + (); + } + } map { { 'svcpart' => $_->svcpart, + 'quantity' => $_->quantity } } + qsearch('pkg_svc', { pkgpart => $pkgpart, + quantity => { op=>'>', value=>'0', } } ) + ]; } - # $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; - } + + if ( $DEBUG ) { + foreach my $svcpart ( keys %svcnum ) { + warn "after regular move svcpart $svcpart: existing svcnums ". + join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n"; } + } - if ( $error > 0 && $conf->exists('cust_pkg-change_svcpart') ) { - warn "trying transfer again with change_svcpart option\n" if $DEBUG; - foreach my $new_pkg (@$return_cust_pkg) { - $error = $old_pkg->transfer($new_pkg, 'change_svcpart'=>1 ); - if ($error and $error == 0) { - # $old_pkg->transfer failed. - $dbh->rollback if $oldAutoCommit; - return $error; - } + #special-case until this can be handled better + # move services to new svcparts - even if the svcparts don't match (svcdb + # needs to...) + # looks like they're moved in no particular order, ewwwwwwww + # and looks like just one of each svcpart can be moved... o well + + #start with still-leftover services + #foreach my $svcpart ( grep { scalar(@{ $svcnum{$_} }) } keys %svcnum ) { + foreach my $svcpart ( keys %svcnum ) { + next unless @{ $svcnum{$svcpart} }; + + my $svcdb = $svcnum{$svcpart}->[0]->part_svc->svcdb; + + #find an empty place to put one + my $i = 0; + foreach my $pkgpart ( @{$pkgparts} ) { + my @pkg_svc = + qsearch('pkg_svc', { pkgpart => $pkgpart, + quantity => { op=>'>', value=>'0', } } ); + #my @pkg_svc = + # grep { $_->quantity > 0 } qsearch('pkg_svc', { pkgpart=>$pkgpart } ); + if ( ! @{$cust_svc[$i]} #find an empty place to put them with + && grep { $svcdb eq $_->part_svc->svcdb } #with appropriate svcdb + @pkg_svc + ) { + my $new_svcpart = + ( grep { $svcdb eq $_->part_svc->svcdb } @pkg_svc )[0]->svcpart; + my $cust_svc = shift @{$svcnum{$svcpart}}; + $cust_svc->svcpart($new_svcpart); + #warn "changing from $svcpart to $new_svcpart!!!\n"; + $cust_svc[$i] = [ $cust_svc ]; } + $i++; } - 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. + } + + if ( $DEBUG ) { + foreach my $svcpart ( keys %svcnum ) { + warn "after special-case move svcpart $svcpart: existing svcnums ". + join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n"; + } + } + + + #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 + foreach my $pkgnum ( @{$remove_pkgnums} ) { + my($old) = qsearchs('cust_pkg',{'pkgnum'=>$pkgnum}); + unless ( $old ) { $dbh->rollback if $oldAutoCommit; - return "Unable to transfer all services from package ".$old_pkg->pkgnum; + return "Package $pkgnum not found to remove!"; } - $error = $old_pkg->cancel; - if ($error) { - $dbh->rollback; - return $error; + 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"; } } + + #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 ) { + $dbh->rollback if $oldAutoCommit; + return "Couldn't insert new cust_pkg record: $error"; + } + 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 ); + + #avoid Record diffing missing changed svcpart field from above. + my $old = qsearchs('cust_svc', { 'svcnum' => $cust_svc->svcnum } ); + + my $error = $new->replace($old); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "Couldn't link old service to new package: $error"; + } + } + } + $dbh->commit or die $dbh->errstr if $oldAutoCommit; - ''; + + ''; #no errors } =back @@ -905,12 +895,11 @@ 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_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. +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. Now that things are transactional should the check in the insert method be moved to check ?