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;
# 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 );
=item bill - date (next bill date)
-=item last_bill - last bill date
-
=item susp - date
=item expire - date
$self->manual_flag($1);
}
- $self->SUPER::check;
+ ''; #no error
}
=item cancel [ OPTION => VALUE ... ]
$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
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 ) {
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,
Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
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<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
}
-=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<svcpart> (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
This method is deprecated. See the I<depend_jobnum> option to the insert and
=cut
sub order {
- my ($custnum, $pkgparts, $remove_pkgnum, $return_cust_pkg) = @_;
-
- # 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";
+ }
+ }
+
+ #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 ( $DEBUG ) {
+ foreach my $svcpart ( keys %svcnum ) {
+ warn "after special-case move svcpart $svcpart: existing svcnums ".
+ join(', ', map { $_->svcnum } @{$svcnum{$svcpart}} ). "\n";
}
- 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.
+ }
+
+
+ #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
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 ?
projects / freeside.git / blobdiff