require 5.006;
use strict;
-use base qw( FS::cust_main::Billing FS::cust_main::Billing_Realtime
+ #FS::cust_main:_Marketgear when they're ready to move to 2.1
+use base qw( FS::cust_main::Packages
+ FS::cust_main::Billing FS::cust_main::Billing_Realtime
FS::otaker_Mixin FS::payinfo_Mixin FS::cust_main_Mixin
FS::Record
);
$skip_fuzzyfiles @fuzzyfields
@paytypes
);
-use vars qw( $realtime_bop_decline_quiet ); #ugh
use Carp;
use Scalar::Util qw( blessed );
-use List::Util qw( min );
use Time::Local qw(timelocal);
use Storable qw(thaw);
use MIME::Base64;
use FS::prepay_credit;
use FS::queue;
use FS::part_pkg;
-use FS::part_event;
-use FS::part_event_condition;
use FS::part_export;
#use FS::cust_event;
use FS::type_pkgs;
use FS::banned_pay;
use FS::TicketSystem;
-$realtime_bop_decline_quiet = 0; #move to Billing_Realtime
-
# 1 is mostly method/subroutine entry and options
# 2 traces progress of some operations
# 3 is even more information including possibly sensitive data
}
}
- if ( $conf->config('cust_main-skeleton_tables')
- && $conf->config('cust_main-skeleton_custnum') ) {
-
- warn " inserting skeleton records\n"
- if $DEBUG > 1;
-
+ if ( $self->can('start_copy_skel') ) {
my $error = $self->start_copy_skel;
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error;
}
-
}
warn " ordering packages\n"
}
-sub start_copy_skel {
- my $self = shift;
-
- #'mg_user_preference' => {},
- #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
- #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
- #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
- #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
- my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
- die $@ if $@;
-
- _copy_skel( 'cust_main', #tablename
- $conf->config('cust_main-skeleton_custnum'), #sourceid
- $self->custnum, #destid
- @tables, #child tables
- );
-}
-
-#recursive subroutine, not a method
-sub _copy_skel {
- my( $table, $sourceid, $destid, %child_tables ) = @_;
-
- my $primary_key;
- if ( $table =~ /^(\w+)\.(\w+)$/ ) {
- ( $table, $primary_key ) = ( $1, $2 );
- } else {
- my $dbdef_table = dbdef->table($table);
- $primary_key = $dbdef_table->primary_key
- or return "$table has no primary key".
- " (or do you need to run dbdef-create?)";
- }
-
- warn " _copy_skel: $table.$primary_key $sourceid to $destid for ".
- join (', ', keys %child_tables). "\n"
- if $DEBUG > 2;
-
- foreach my $child_table_def ( keys %child_tables ) {
-
- my $child_table;
- my $child_pkey = '';
- if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
- ( $child_table, $child_pkey ) = ( $1, $2 );
- } else {
- $child_table = $child_table_def;
-
- $child_pkey = dbdef->table($child_table)->primary_key;
- # or return "$table has no primary key".
- # " (or do you need to run dbdef-create?)\n";
- }
-
- my $sequence = '';
- if ( keys %{ $child_tables{$child_table_def} } ) {
-
- return "$child_table has no primary key".
- " (run dbdef-create or try specifying it?)\n"
- unless $child_pkey;
-
- #false laziness w/Record::insert and only works on Pg
- #refactor the proper last-inserted-id stuff out of Record::insert if this
- # ever gets use for anything besides a quick kludge for one customer
- my $default = dbdef->table($child_table)->column($child_pkey)->default;
- $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
- or return "can't parse $child_table.$child_pkey default value ".
- " for sequence name: $default";
- $sequence = $1;
-
- }
-
- my @sel_columns = grep { $_ ne $primary_key }
- dbdef->table($child_table)->columns;
- my $sel_columns = join(', ', @sel_columns );
-
- my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
- my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
- my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
-
- my $sel_st = "SELECT $sel_columns FROM $child_table".
- " WHERE $primary_key = $sourceid";
- warn " $sel_st\n"
- if $DEBUG > 2;
- my $sel_sth = dbh->prepare( $sel_st )
- or return dbh->errstr;
-
- $sel_sth->execute or return $sel_sth->errstr;
-
- while ( my $row = $sel_sth->fetchrow_hashref ) {
-
- warn " selected row: ".
- join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
- if $DEBUG > 2;
-
- my $statement =
- "INSERT INTO $child_table $ins_columns VALUES $placeholders";
- my $ins_sth =dbh->prepare($statement)
- or return dbh->errstr;
- my @param = ( $destid, map $row->{$_}, @ins_columns );
- warn " $statement: [ ". join(', ', @param). " ]\n"
- if $DEBUG > 2;
- $ins_sth->execute( @param )
- or return $ins_sth->errstr;
-
- #next unless keys %{ $child_tables{$child_table} };
- next unless $sequence;
-
- #another section of that laziness
- my $seq_sql = "SELECT currval('$sequence')";
- my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
- $seq_sth->execute or return $seq_sth->errstr;
- my $insertid = $seq_sth->fetchrow_arrayref->[0];
-
- # don't drink soap! recurse! recurse! okay!
- my $error =
- _copy_skel( $child_table_def,
- $row->{$child_pkey}, #sourceid
- $insertid, #destid
- %{ $child_tables{$child_table_def} },
- );
- return $error if $error;
-
- }
-
- }
-
- return '';
-
-}
-
-=item order_pkg HASHREF | OPTION => VALUE ...
-
-Orders a single package.
-
-Options may be passed as a list of key/value pairs or as a hash reference.
-Options are:
-
-=over 4
-
-=item cust_pkg
-
-FS::cust_pkg object
-
-=item cust_location
-
-Optional FS::cust_location object
-
-=item svcs
-
-Optional arryaref of FS::svc_* service objects.
-
-=item depend_jobnum
-
-If this option is set to a job queue jobnum (see L<FS::queue>), all provisioning
-jobs will have a dependancy on the supplied job (they will not run until the
-specific job completes). This can be used to defer provisioning until some
-action completes (such as running the customer's credit card successfully).
-
-=item ticket_subject
-
-Optional subject for a ticket created and attached to this customer
-
-=item ticket_subject
-
-Optional queue name for ticket additions
-
-=back
-
-=cut
-
-sub order_pkg {
- my $self = shift;
- my $opt = ref($_[0]) ? shift : { @_ };
-
- warn "$me order_pkg called with options ".
- join(', ', map { "$_: $opt->{$_}" } keys %$opt ). "\n"
- if $DEBUG;
-
- my $cust_pkg = $opt->{'cust_pkg'};
- my $svcs = $opt->{'svcs'} || [];
-
- my %svc_options = ();
- $svc_options{'depend_jobnum'} = $opt->{'depend_jobnum'}
- if exists($opt->{'depend_jobnum'}) && $opt->{'depend_jobnum'};
-
- my %insert_params = map { $opt->{$_} ? ( $_ => $opt->{$_} ) : () }
- qw( ticket_subject ticket_queue );
-
- 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;
-
- if ( $opt->{'cust_location'} &&
- ( ! $cust_pkg->locationnum || $cust_pkg->locationnum == -1 ) ) {
- my $error = $opt->{'cust_location'}->insert;
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return "inserting cust_location (transaction rolled back): $error";
- }
- $cust_pkg->locationnum($opt->{'cust_location'}->locationnum);
- }
-
- $cust_pkg->custnum( $self->custnum );
-
- my $error = $cust_pkg->insert( %insert_params );
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return "inserting cust_pkg (transaction rolled back): $error";
- }
-
- foreach my $svc_something ( @{ $opt->{'svcs'} } ) {
- if ( $svc_something->svcnum ) {
- my $old_cust_svc = $svc_something->cust_svc;
- my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
- $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
- $error = $new_cust_svc->replace($old_cust_svc);
- } else {
- $svc_something->pkgnum( $cust_pkg->pkgnum );
- if ( $svc_something->isa('FS::svc_acct') ) {
- foreach ( grep { $opt->{$_.'_ref'} && ${ $opt->{$_.'_ref'} } }
- qw( seconds upbytes downbytes totalbytes ) ) {
- $svc_something->$_( $svc_something->$_() + ${ $opt->{$_.'_ref'} } );
- ${ $opt->{$_.'_ref'} } = 0;
- }
- }
- $error = $svc_something->insert(%svc_options);
- }
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return "inserting svc_ (transaction rolled back): $error";
- }
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
- ''; #no error
-
-}
-
-#deprecated #=item order_pkgs HASHREF [ , SECONDSREF ] [ , OPTION => VALUE ... ]
-=item order_pkgs HASHREF [ , OPTION => VALUE ... ]
-
-Like the insert method on an existing record, this method orders multiple
-packages and included services atomicaly. Pass a Tie::RefHash data structure
-to this method containing FS::cust_pkg and FS::svc_I<tablename> objects.
-There should be a better explanation of this, but until then, here's an
-example:
-
- use Tie::RefHash;
- tie %hash, 'Tie::RefHash'; #this part is important
- %hash = (
- $cust_pkg => [ $svc_acct ],
- ...
- );
- $cust_main->order_pkgs( \%hash, 'noexport'=>1 );
-
-Services can be new, in which case they are inserted, or existing unaudited
-services, in which case they are linked to the newly-created package.
-
-Currently available options are: I<depend_jobnum>, I<noexport>, I<seconds_ref>,
-I<upbytes_ref>, I<downbytes_ref>, and I<totalbytes_ref>.
-
-If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
-on the supplied jobnum (they will not run until the specific job completes).
-This can be used to defer provisioning until some action completes (such
-as running the customer's credit card successfully).
-
-The I<noexport> option is deprecated. If I<noexport> is set true, no
-provisioning jobs (exports) are scheduled. (You can schedule them later with
-the B<reexport> method for each cust_pkg object. Using the B<reexport> method
-on the cust_main object is not recommended, as existing services will also be
-reexported.)
-
-If I<seconds_ref>, I<upbytes_ref>, I<downbytes_ref>, or I<totalbytes_ref> is
-provided, the scalars (provided by references) will be incremented by the
-values of the prepaid card.`
-
-=cut
-
-sub order_pkgs {
- my $self = shift;
- my $cust_pkgs = shift;
- my $seconds_ref = ref($_[0]) ? shift : ''; #deprecated
- my %options = @_;
- $seconds_ref ||= $options{'seconds_ref'};
-
- warn "$me order_pkgs called with options ".
- join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
- if $DEBUG;
-
- 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;
-
- local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
-
- foreach my $cust_pkg ( keys %$cust_pkgs ) {
-
- my $error = $self->order_pkg(
- 'cust_pkg' => $cust_pkg,
- 'svcs' => $cust_pkgs->{$cust_pkg},
- 'seconds_ref' => $seconds_ref,
- map { $_ => $options{$_} } qw( upbytes_ref downbytes_ref totalbytes_ref
- depend_jobnum
- )
- );
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return $error;
- }
+=item PACKAGE METHODS
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
- ''; #no error
-}
+Documentation on customer package methods has been moved to
+L<FS::cust_main::Packages>.
=item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ]
|| $self->ut_textn('invoice_terms')
|| $self->ut_alphan('geocode')
|| $self->ut_floatn('cdr_termination_percentage')
+ || $self->ut_floatn('credit_limit')
;
#barf. need message catalogs. i18n. etc.
#fields that cust_location has
}
-=item all_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
-
-Returns all packages (see L<FS::cust_pkg>) for this customer.
-
-=cut
-
-sub all_pkgs {
- my $self = shift;
- my $extra_qsearch = ref($_[0]) ? shift : {};
-
- return $self->num_pkgs unless wantarray || keys(%$extra_qsearch);
-
- my @cust_pkg = ();
- if ( $self->{'_pkgnum'} ) {
- @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
- } else {
- @cust_pkg = $self->_cust_pkg($extra_qsearch);
- }
-
- sort sort_packages @cust_pkg;
-}
-
-=item cust_pkg
-
-Synonym for B<all_pkgs>.
-
-=cut
-
-sub cust_pkg {
- shift->all_pkgs(@_);
-}
-
=item cust_location
Returns all locations (see L<FS::cust_location>) for this customer.
$line;
}
-=item ncancelled_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
-
-Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
-
-=cut
-
-sub ncancelled_pkgs {
- my $self = shift;
- my $extra_qsearch = ref($_[0]) ? shift : {};
-
- return $self->num_ncancelled_pkgs unless wantarray;
-
- my @cust_pkg = ();
- if ( $self->{'_pkgnum'} ) {
-
- warn "$me ncancelled_pkgs: returning cached objects"
- if $DEBUG > 1;
-
- @cust_pkg = grep { ! $_->getfield('cancel') }
- values %{ $self->{'_pkgnum'}->cache };
-
- } else {
-
- warn "$me ncancelled_pkgs: searching for packages with custnum ".
- $self->custnum. "\n"
- if $DEBUG > 1;
-
- $extra_qsearch->{'extra_sql'} .= ' AND ( cancel IS NULL OR cancel = 0 ) ';
-
- @cust_pkg = $self->_cust_pkg($extra_qsearch);
-
- }
-
- sort sort_packages @cust_pkg;
-
-}
-
-sub _cust_pkg {
- my $self = shift;
- my $extra_qsearch = ref($_[0]) ? shift : {};
-
- $extra_qsearch->{'select'} ||= '*';
- $extra_qsearch->{'select'} .=
- ',( SELECT COUNT(*) FROM cust_svc WHERE cust_pkg.pkgnum = cust_svc.pkgnum )
- AS _num_cust_svc';
-
- map {
- $_->{'_num_cust_svc'} = $_->get('_num_cust_svc');
- $_;
- }
- qsearch({
- %$extra_qsearch,
- 'table' => 'cust_pkg',
- 'hashref' => { 'custnum' => $self->custnum },
- });
-
-}
-
-# This should be generalized to use config options to determine order.
-sub sort_packages {
-
- my $locationsort = ( $a->locationnum || 0 ) <=> ( $b->locationnum || 0 );
- return $locationsort if $locationsort;
-
- if ( $a->get('cancel') xor $b->get('cancel') ) {
- return -1 if $b->get('cancel');
- return 1 if $a->get('cancel');
- #shouldn't get here...
- return 0;
- } else {
- my $a_num_cust_svc = $a->num_cust_svc;
- my $b_num_cust_svc = $b->num_cust_svc;
- return 0 if !$a_num_cust_svc && !$b_num_cust_svc;
- return -1 if $a_num_cust_svc && !$b_num_cust_svc;
- return 1 if !$a_num_cust_svc && $b_num_cust_svc;
- my @a_cust_svc = $a->cust_svc;
- my @b_cust_svc = $b->cust_svc;
- return 0 if !scalar(@a_cust_svc) && !scalar(@b_cust_svc);
- return -1 if scalar(@a_cust_svc) && !scalar(@b_cust_svc);
- return 1 if !scalar(@a_cust_svc) && scalar(@b_cust_svc);
- $a_cust_svc[0]->svc_x->label cmp $b_cust_svc[0]->svc_x->label;
- }
-
-}
-
-=item suspended_pkgs
-
-Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
-
-=cut
-
-sub suspended_pkgs {
- my $self = shift;
- grep { $_->susp } $self->ncancelled_pkgs;
-}
-
-=item unflagged_suspended_pkgs
-
-Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
-customer (thouse packages without the `manual_flag' set).
-
-=cut
-
-sub unflagged_suspended_pkgs {
- my $self = shift;
- return $self->suspended_pkgs
- unless dbdef->table('cust_pkg')->column('manual_flag');
- grep { ! $_->manual_flag } $self->suspended_pkgs;
-}
-
-=item unsuspended_pkgs
-
-Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
-this customer.
-
-=cut
-
-sub unsuspended_pkgs {
- my $self = shift;
- grep { ! $_->susp } $self->ncancelled_pkgs;
-}
-
-=item next_bill_date
-
-Returns the next date this customer will be billed, as a UNIX timestamp, or
-undef if no active package has a next bill date.
-
-=cut
-
-sub next_bill_date {
- my $self = shift;
- min( map $_->get('bill'), grep $_->get('bill'), $self->unsuspended_pkgs );
-}
-
-=item num_cancelled_pkgs
-
-Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
-customer.
-
-=cut
-
-sub num_cancelled_pkgs {
- shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
-}
-
-sub num_ncancelled_pkgs {
- shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
-}
-
-sub num_pkgs {
- my( $self ) = shift;
- my $sql = scalar(@_) ? shift : '';
- $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
- my $sth = dbh->prepare(
- "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
- ) or die dbh->errstr;
- $sth->execute($self->custnum) or die $sth->errstr;
- $sth->fetchrow_arrayref->[0];
-}
-
=item unsuspend
Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
Documentation on billing methods has been moved to
L<FS::cust_main::Billing>.
-=item do_cust_event [ HASHREF | OPTION => VALUE ... ]
-
-Runs billing events; see L<FS::part_event> and the billing events web
-interface.
-
-If there is an error, returns the error, otherwise returns false.
-
-Options are passed as name-value pairs.
-
-Currently available options are:
-
-=over 4
-
-=item time
-
-Use this time when deciding when to print invoices and late notices on those invoices. The default is now. It is specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion functions.
-
-=item check_freq
-
-"1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
-
-=item stage
-
-"collect" (the default) or "pre-bill"
-
-=item quiet
-
-set true to surpress email card/ACH decline notices.
-
-=item debug
-
-Debugging level. Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
-
-=cut
-
-# =item payby
-#
-# allows for one time override of normal customer billing method
-
-# =item retry
-#
-# Retry card/echeck/LEC transactions even when not scheduled by invoice events.
-
-sub do_cust_event {
- my( $self, %options ) = @_;
- my $time = $options{'time'} || time;
-
- #put below somehow?
- 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;
-
- $self->select_for_update; #mutex
-
- if ( $DEBUG ) {
- my $balance = $self->balance;
- warn "$me do_cust_event customer ". $self->custnum. ": balance $balance\n"
- }
-
-# if ( exists($options{'retry_card'}) ) {
-# carp 'retry_card option passed to collect is deprecated; use retry';
-# $options{'retry'} ||= $options{'retry_card'};
-# }
-# if ( exists($options{'retry'}) && $options{'retry'} ) {
-# my $error = $self->retry_realtime;
-# if ( $error ) {
-# $dbh->rollback if $oldAutoCommit;
-# return $error;
-# }
-# }
-
- # false laziness w/pay_batch::import_results
-
- my $due_cust_event = $self->due_cust_event(
- 'debug' => ( $options{'debug'} || 0 ),
- 'time' => $time,
- 'check_freq' => $options{'check_freq'},
- 'stage' => ( $options{'stage'} || 'collect' ),
- );
- unless( ref($due_cust_event) ) {
- $dbh->rollback if $oldAutoCommit;
- return $due_cust_event;
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
- #never want to roll back an event just because it or a different one
- # returned an error
- local $FS::UID::AutoCommit = 1; #$oldAutoCommit;
-
- foreach my $cust_event ( @$due_cust_event ) {
-
- #XXX lock event
-
- #re-eval event conditions (a previous event could have changed things)
- unless ( $cust_event->test_conditions( 'time' => $time ) ) {
- #don't leave stray "new/locked" records around
- my $error = $cust_event->delete;
- return $error if $error;
- next;
- }
-
- {
- local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
- warn " running cust_event ". $cust_event->eventnum. "\n"
- if $DEBUG > 1;
-
- #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
- if ( my $error = $cust_event->do_event() ) {
- #XXX wtf is this? figure out a proper dealio with return value
- #from do_event
- return $error;
- }
- }
-
- }
-
- '';
-
-}
-
-=item due_cust_event [ HASHREF | OPTION => VALUE ... ]
-
-Inserts database records for and returns an ordered listref of new events due
-for this customer, as FS::cust_event objects (see L<FS::cust_event>). If no
-events are due, an empty listref is returned. If there is an error, returns a
-scalar error message.
-
-To actually run the events, call each event's test_condition method, and if
-still true, call the event's do_event method.
-
-Options are passed as a hashref or as a list of name-value pairs. Available
-options are:
-
-=over 4
-
-=item check_freq
-
-Search only for events of this check frequency (how often events of this type are checked); currently "1d" (daily, the default) and "1m" (monthly) are recognized.
-
-=item stage
-
-"collect" (the default) or "pre-bill"
-
-=item time
-
-"Current time" for the events.
-
-=item debug
-
-Debugging level. Default is 0 (no debugging), or can be set to 1 (passed-in options), 2 (traces progress), 3 (more information), or 4 (include full search queries)
-
-=item eventtable
-
-Only return events for the specified eventtable (by default, events of all eventtables are returned)
-
-=item objects
-
-Explicitly pass the objects to be tested (typically used with eventtable).
-
-=item testonly
-
-Set to true to return the objects, but not actually insert them into the
-database.
-
-=back
-
-=cut
-
-sub due_cust_event {
- my $self = shift;
- my %opt = ref($_[0]) ? %{ $_[0] } : @_;
-
- #???
- #my $DEBUG = $opt{'debug'}
- local($DEBUG) = $opt{'debug'}
- if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
-
- warn "$me due_cust_event called with options ".
- join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
- if $DEBUG;
-
- $opt{'time'} ||= time;
-
- 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;
-
- $self->select_for_update #mutex
- unless $opt{testonly};
-
- ###
- # find possible events (initial search)
- ###
-
- my @cust_event = ();
-
- my @eventtable = $opt{'eventtable'}
- ? ( $opt{'eventtable'} )
- : FS::part_event->eventtables_runorder;
-
- foreach my $eventtable ( @eventtable ) {
-
- my @objects;
- if ( $opt{'objects'} ) {
-
- @objects = @{ $opt{'objects'} };
-
- } else {
-
- #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
- @objects = ( $eventtable eq 'cust_main' )
- ? ( $self )
- : ( $self->$eventtable() );
-
- }
-
- my @e_cust_event = ();
-
- my $cross = "CROSS JOIN $eventtable";
- $cross .= ' LEFT JOIN cust_main USING ( custnum )'
- unless $eventtable eq 'cust_main';
-
- foreach my $object ( @objects ) {
-
- #this first search uses the condition_sql magic for optimization.
- #the more possible events we can eliminate in this step the better
-
- my $cross_where = '';
- my $pkey = $object->primary_key;
- $cross_where = "$eventtable.$pkey = ". $object->$pkey();
-
- my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
- my $extra_sql =
- FS::part_event_condition->where_conditions_sql( $eventtable,
- 'time'=>$opt{'time'}
- );
- my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
-
- $extra_sql = "AND $extra_sql" if $extra_sql;
-
- #here is the agent virtualization
- $extra_sql .= " AND ( part_event.agentnum IS NULL
- OR part_event.agentnum = ". $self->agentnum. ' )';
-
- $extra_sql .= " $order";
-
- warn "searching for events for $eventtable ". $object->$pkey. "\n"
- if $opt{'debug'} > 2;
- my @part_event = qsearch( {
- 'debug' => ( $opt{'debug'} > 3 ? 1 : 0 ),
- 'select' => 'part_event.*',
- 'table' => 'part_event',
- 'addl_from' => "$cross $join",
- 'hashref' => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
- 'eventtable' => $eventtable,
- 'disabled' => '',
- },
- 'extra_sql' => "AND $cross_where $extra_sql",
- } );
-
- if ( $DEBUG > 2 ) {
- my $pkey = $object->primary_key;
- warn " ". scalar(@part_event).
- " possible events found for $eventtable ". $object->$pkey(). "\n";
- }
-
- push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
-
- }
-
- warn " ". scalar(@e_cust_event).
- " subtotal possible cust events found for $eventtable\n"
- if $DEBUG > 1;
-
- push @cust_event, @e_cust_event;
-
- }
-
- warn " ". scalar(@cust_event).
- " total possible cust events found in initial search\n"
- if $DEBUG; # > 1;
-
-
- ##
- # test stage
- ##
-
- $opt{stage} ||= 'collect';
- @cust_event =
- grep { my $stage = $_->part_event->event_stage;
- $opt{stage} eq $stage or ( ! $stage && $opt{stage} eq 'collect' )
- }
- @cust_event;
-
- ##
- # test conditions
- ##
-
- my %unsat = ();
-
- @cust_event = grep $_->test_conditions( 'time' => $opt{'time'},
- 'stats_hashref' => \%unsat ),
- @cust_event;
-
- warn " ". scalar(@cust_event). " cust events left satisfying conditions\n"
- if $DEBUG; # > 1;
-
- warn " invalid conditions not eliminated with condition_sql:\n".
- join('', map " $_: ".$unsat{$_}."\n", keys %unsat )
- if keys %unsat && $DEBUG; # > 1;
-
- ##
- # insert
- ##
-
- unless( $opt{testonly} ) {
- foreach my $cust_event ( @cust_event ) {
-
- my $error = $cust_event->insert();
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return $error;
- }
-
- }
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
-
- ##
- # return
- ##
-
- warn " returning events: ". Dumper(@cust_event). "\n"
- if $DEBUG > 2;
-
- \@cust_event;
-
-}
-
-=item retry_realtime
-
-Schedules realtime / batch credit card / electronic check / LEC billing
-events for for retry. Useful if card information has changed or manual
-retry is desired. The 'collect' method must be called to actually retry
-the transaction.
-
-Implementation details: For either this customer, or for each of this
-customer's open invoices, changes the status of the first "done" (with
-statustext error) realtime processing event to "failed".
-
-=cut
-
-sub retry_realtime {
- 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;
-
- #a little false laziness w/due_cust_event (not too bad, really)
-
- my $join = FS::part_event_condition->join_conditions_sql;
- my $order = FS::part_event_condition->order_conditions_sql;
- my $mine =
- '( '
- . join ( ' OR ' , map {
- "( part_event.eventtable = " . dbh->quote($_)
- . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
- } FS::part_event->eventtables)
- . ') ';
-
- #here is the agent virtualization
- my $agent_virt = " ( part_event.agentnum IS NULL
- OR part_event.agentnum = ". $self->agentnum. ' )';
-
- #XXX this shouldn't be hardcoded, actions should declare it...
- my @realtime_events = qw(
- cust_bill_realtime_card
- cust_bill_realtime_check
- cust_bill_realtime_lec
- cust_bill_batch
- );
-
- my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
- @realtime_events
- ).
- ' ) ';
-
- my @cust_event = qsearchs({
- 'table' => 'cust_event',
- 'select' => 'cust_event.*',
- 'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
- 'hashref' => { 'status' => 'done' },
- 'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
- " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
- });
-
- my %seen_invnum = ();
- foreach my $cust_event (@cust_event) {
-
- #max one for the customer, one for each open invoice
- my $cust_X = $cust_event->cust_X;
- next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
- ? $cust_X->invnum
- : 0
- }++
- or $cust_event->part_event->eventtable eq 'cust_bill'
- && ! $cust_X->owed;
-
- my $error = $cust_event->retry;
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return "error scheduling event for retry: $error";
- }
-
- }
-
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;
- '';
-
-}
-
-
-=cut
-
=item REALTIME BILLING METHODS
Documentation on realtime billing methods has been moved to
return '' unless $amount > 0;
my $invnum = delete $options{invnum};
- my $payby = $options{invnum} || $self->payby; #dubious
+ my $payby = $options{payby} || $self->payby; #still dubious
if ($options{'realtime'}) {
return $self->realtime_bop( FS::payby->payby2bop($self->payby),
$error ? $error : $cust_pkg;
}
-=item cust_bill
+=item cust_bill [ OPTION => VALUE... | EXTRA_QSEARCH_PARAMS_HASHREF ]
Returns all the invoices (see L<FS::cust_bill>) for this customer.
+Optionally, a list or hashref of additional arguments to the qsearch call can
+be passed.
+
=cut
sub cust_bill {
my $self = shift;
- map { $_ } #return $self->num_cust_bill unless wantarray;
- sort { $a->_date <=> $b->_date }
- qsearch('cust_bill', { 'custnum' => $self->custnum, } )
+ my $opt = ref($_[0]) ? shift : { @_ };
+
+ #return $self->num_cust_bill unless wantarray || keys %$opt;
+
+ $opt->{'table'} = 'cust_bill';
+ $opt->{'hashref'} ||= {}; #i guess it would autovivify anyway...
+ $opt->{'hashref'}{'custnum'} = $self->custnum;
+ $opt->{'order_by'} ||= 'ORDER BY _date ASC';
+
+ map { $_ } #behavior of sort undefined in scalar context
+ sort { $a->_date <=> $b->_date }
+ qsearch($opt);
}
=item open_cust_bill
sub open_cust_bill {
my $self = shift;
- qsearch({
- 'table' => 'cust_bill',
- 'hashref' => { 'custnum' => $self->custnum, },
+ $self->cust_bill(
'extra_sql' => ' AND '. FS::cust_bill->owed_sql. ' > 0',
- 'order_by' => 'ORDER BY _date ASC',
- });
+ #@_
+ );
}
-=item cust_statements
+=item cust_statement [ OPTION => VALUE... | EXTRA_QSEARCH_PARAMS_HASHREF ]
Returns all the statements (see L<FS::cust_statement>) for this customer.
+Optionally, a list or hashref of additional arguments to the qsearch call can
+be passed.
+
=cut
sub cust_statement {
my $self = shift;
- map { $_ } #return $self->num_cust_statement unless wantarray;
- sort { $a->_date <=> $b->_date }
- qsearch('cust_statement', { 'custnum' => $self->custnum, } )
+ my $opt = ref($_[0]) ? shift : { @_ };
+
+ #return $self->num_cust_statement unless wantarray || keys %$opt;
+
+ $opt->{'table'} = 'cust_statement';
+ $opt->{'hashref'} ||= {}; #i guess it would autovivify anyway...
+ $opt->{'hashref'}{'custnum'} = $self->custnum;
+ $opt->{'order_by'} ||= 'ORDER BY _date ASC';
+
+ map { $_ } #behavior of sort undefined in scalar context
+ sort { $a->_date <=> $b->_date }
+ qsearch($opt);
}
=item cust_credit
qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
}
-=item cust_pay_batch
+=item cust_pay_batch [ OPTION => VALUE... | EXTRA_QSEARCH_PARAMS_HASHREF ]
Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
+Optionally, a list or hashref of additional arguments to the qsearch call can
+be passed.
+
=cut
sub cust_pay_batch {
my $self = shift;
- map { $_ } #return $self->num_cust_pay_batch unless wantarray;
- sort { $a->paybatchnum <=> $b->paybatchnum }
- qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
+ my $opt = ref($_[0]) ? shift : { @_ };
+
+ #return $self->num_cust_statement unless wantarray || keys %$opt;
+
+ $opt->{'table'} = 'cust_pay_batch';
+ $opt->{'hashref'} ||= {}; #i guess it would autovivify anyway...
+ $opt->{'hashref'}{'custnum'} = $self->custnum;
+ $opt->{'order_by'} ||= 'ORDER BY paybatchnum ASC';
+
+ map { $_ } #behavior of sort undefined in scalar context
+ sort { $a->paybatchnum <=> $b->paybatchnum }
+ qsearch($opt);
}
=item cust_pay_pending
local($ignore_expired_card) = 1;
local($ignore_illegal_zip) = 1;
- local($ignore_illegal_zip) = 1;
local($ignore_banned_card) = 1;
+ local($skip_fuzzyfiles) = 1;
$class->_upgrade_otaker(%opts);
}