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::cust_main::Billing_Discount
FS::otaker_Mixin FS::payinfo_Mixin FS::cust_main_Mixin
+ FS::geocode_Mixin
FS::Record
);
-use vars qw( @EXPORT_OK $DEBUG $me $conf
+use vars qw( $DEBUG $me $conf
@encrypted_fields
- $import $ignore_expired_card
+ $import
+ $ignore_expired_card $ignore_illegal_zip $ignore_banned_card
$skip_fuzzyfiles @fuzzyfields
@paytypes
);
-use vars qw( $realtime_bop_decline_quiet ); #ugh
use Carp;
-use Exporter;
use Scalar::Util qw( blessed );
-use List::Util qw( min );
use Time::Local qw(timelocal);
use Storable qw(thaw);
use MIME::Base64;
use Digest::MD5 qw(md5_base64);
use Date::Format;
#use Date::Manip;
-use File::Temp qw( tempfile );
-use String::Approx qw(amatch);
+use File::Temp; #qw( tempfile );
use Business::CreditCard 0.28;
use Locale::Country;
use FS::UID qw( getotaker dbh driver_name );
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;
-@EXPORT_OK = qw( smart_search );
-
-$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
$import = 0;
$ignore_expired_card = 0;
+$ignore_illegal_zip = 0;
+$ignore_banned_card = 0;
$skip_fuzzyfiles = 0;
@fuzzyfields = ( 'first', 'last', 'company', 'address1' );
}
}
- 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;
+=item PACKAGE METHODS
- 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;
- }
-
- }
-
- $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 ]
}
-=item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
+=item merge NEW_CUSTNUM [ , OPTION => VALUE ... ]
+This merges this customer into the provided new custnum, and then deletes the
+customer. If there is an error, returns the error, otherwise returns false.
-Replaces the OLD_RECORD with this one in the database. If there is an error,
-returns the error, otherwise returns false.
+The source customer's name, company name, phone numbers, agent,
+referring customer, customer class, advertising source, order taker, and
+billing information (except balance) are discarded.
-INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
-be set as the invoicing list (see L<"invoicing_list">). Errors return as
-expected and rollback the entire transaction; it is not necessary to call
-check_invoicing_list first. Here's an example:
+All packages are moved to the target customer. Packages with package locations
+are preserved. Packages without package locations are moved to a new package
+location with the source customer's service/shipping address.
- $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
+All invoices, statements, payments, credits and refunds are moved to the target
+customer. The source customer's balance is added to the target customer.
-Currently available options are: I<tax_exemption>.
+All notes, attachments, tickets and customer tags are moved to the target
+customer.
-The I<tax_exemption> option can be set to an arrayref of tax names.
-FS::cust_main_exemption records will be deleted and inserted as appropriate.
+Change history is not currently moved.
=cut
-sub replace {
- my $self = shift;
-
- my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
- ? shift
- : $self->replace_old;
-
- my @param = @_;
+sub merge {
+ my( $self, $new_custnum, %opt ) = @_;
- warn "$me replace called\n"
- if $DEBUG;
+ return "Can't merge a customer into self" if $self->custnum == $new_custnum;
- my $curuser = $FS::CurrentUser::CurrentUser;
- if ( $self->payby eq 'COMP'
- && $self->payby ne $old->payby
- && ! $curuser->access_right('Complimentary customer')
- )
- {
- return "You are not permitted to create complimentary accounts.";
+ unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
+ return "Invalid new customer number: $new_custnum";
}
- local($ignore_expired_card) = 1
- if $old->payby =~ /^(CARD|DCRD)$/
- && $self->payby =~ /^(CARD|DCRD)$/
- && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
-
local $SIG{HUP} = 'IGNORE';
local $SIG{INT} = 'IGNORE';
local $SIG{QUIT} = 'IGNORE';
local $FS::UID::AutoCommit = 0;
my $dbh = dbh;
- my $error = $self->SUPER::replace($old);
+ if ( qsearch('agent', { 'agent_custnum' => $self->custnum } ) ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Can't merge a master agent customer";
+ }
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- return $error;
+ #use FS::access_user
+ if ( qsearch('access_user', { 'user_custnum' => $self->custnum } ) ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Can't merge a master employee customer";
}
- if ( @param && ref($param[0]) eq 'ARRAY' ) { # INVOICING_LIST_ARYREF
- my $invoicing_list = shift @param;
- $error = $self->check_invoicing_list( $invoicing_list );
+ if ( qsearch('cust_pay_pending', { 'custnum' => $self->custnum,
+ 'status' => { op=>'!=', value=>'done' },
+ }
+ )
+ ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Can't merge a customer with pending payments";
+ }
+
+ tie my %financial_tables, 'Tie::IxHash',
+ 'cust_bill' => 'invoices',
+ 'cust_statement' => 'statements',
+ 'cust_credit' => 'credits',
+ 'cust_pay' => 'payments',
+ 'cust_pay_void' => 'voided payments',
+ 'cust_refund' => 'refunds',
+ ;
+
+ foreach my $table ( keys %financial_tables ) {
+
+ my @records = $self->$table();
+
+ foreach my $record ( @records ) {
+ $record->custnum($new_custnum);
+ my $error = $record->replace;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return "Error merging ". $financial_tables{$table}. ": $error\n";
+ }
+ }
+
+ }
+
+ my $name = $self->ship_name;
+
+ my $locationnum = '';
+ foreach my $cust_pkg ( $self->all_pkgs ) {
+ $cust_pkg->custnum($new_custnum);
+
+ unless ( $cust_pkg->locationnum ) {
+ unless ( $locationnum ) {
+ my $cust_location = new FS::cust_location {
+ $self->location_hash,
+ 'custnum' => $new_custnum,
+ };
+ my $error = $cust_location->insert;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ $locationnum = $cust_location->locationnum;
+ }
+ $cust_pkg->locationnum($locationnum);
+ }
+
+ my $error = $cust_pkg->replace;
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error;
}
- $self->invoicing_list( $invoicing_list );
- }
- if ( $self->exists('tagnum') ) { #so we don't delete these on edit by accident
-
- #this could be more efficient than deleting and re-inserting, if it matters
- foreach my $cust_tag (qsearch('cust_tag', {'custnum'=>$self->custnum} )) {
- my $error = $cust_tag->delete;
+ # add customer (ship) name to svc_phone.phone_name if blank
+ my @cust_svc = $cust_pkg->cust_svc;
+ foreach my $cust_svc (@cust_svc) {
+ my($label, $value, $svcdb) = $cust_svc->label;
+ next unless $svcdb eq 'svc_phone';
+ my $svc_phone = $cust_svc->svc_x;
+ next if $svc_phone->phone_name;
+ $svc_phone->phone_name($name);
+ my $error = $svc_phone->replace;
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error;
}
}
- foreach my $tagnum ( @{ $self->tagnum || [] } ) {
- my $cust_tag = new FS::cust_tag { 'tagnum' => $tagnum,
- 'custnum' => $self->custnum };
- my $error = $cust_tag->insert;
+
+ }
+
+ #not considered:
+ # cust_tax_exempt (texas tax exemptions)
+ # cust_recon (some sort of not-well understood thing for OnPac)
+
+ #these are moved over
+ foreach my $table (qw(
+ cust_tag cust_location contact cust_attachment cust_main_note
+ cust_tax_adjustment cust_pay_batch queue
+ )) {
+ foreach my $record ( qsearch( $table, { 'custnum' => $self->custnum } ) ) {
+ $record->custnum($new_custnum);
+ my $error = $record->replace;
if ( $error ) {
$dbh->rollback if $oldAutoCommit;
return $error;
}
}
-
}
- my %options = @param;
-
- my $tax_exemption = delete $options{'tax_exemption'};
+ #these aren't preserved
+ foreach my $table (qw(
+ cust_main_exemption cust_main_invoice
+ )) {
+ foreach my $record ( qsearch( $table, { 'custnum' => $self->custnum } ) ) {
+ my $error = $record->delete;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ }
+ }
+
+
+ my $sth = $dbh->prepare(
+ 'UPDATE cust_main SET referral_custnum = ? WHERE referral_custnum = ?'
+ ) or do {
+ my $errstr = $dbh->errstr;
+ $dbh->rollback if $oldAutoCommit;
+ return $errstr;
+ };
+ $sth->execute($new_custnum, $self->custnum) or do {
+ my $errstr = $sth->errstr;
+ $dbh->rollback if $oldAutoCommit;
+ return $errstr;
+ };
+
+ #tickets
+
+ my $ticket_dbh = '';
+ if ($conf->config('ticket_system') eq 'RT_Internal') {
+ $ticket_dbh = $dbh;
+ } elsif ($conf->config('ticket_system') eq 'RT_External') {
+ my ($datasrc, $user, $pass) = $conf->config('ticket_system-rt_external_datasrc');
+ $ticket_dbh = DBI->connect($datasrc, $user, $pass, { 'ChopBlanks' => 1 });
+ #or die "RT_External DBI->connect error: $DBI::errstr\n";
+ }
+
+ if ( $ticket_dbh ) {
+
+ my $ticket_sth = $ticket_dbh->prepare(
+ 'UPDATE Links SET Target = ? WHERE Target = ?'
+ ) or do {
+ my $errstr = $ticket_dbh->errstr;
+ $dbh->rollback if $oldAutoCommit;
+ return $errstr;
+ };
+ $ticket_sth->execute('freeside://freeside/cust_main/'.$new_custnum,
+ 'freeside://freeside/cust_main/'.$self->custnum)
+ or do {
+ my $errstr = $ticket_sth->errstr;
+ $dbh->rollback if $oldAutoCommit;
+ return $errstr;
+ };
+
+ }
+
+ #delete the customer record
+
+ my $error = $self->delete;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
+ '';
+
+}
+
+=item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
+
+
+Replaces the OLD_RECORD with this one in the database. If there is an error,
+returns the error, otherwise returns false.
+
+INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
+be set as the invoicing list (see L<"invoicing_list">). Errors return as
+expected and rollback the entire transaction; it is not necessary to call
+check_invoicing_list first. Here's an example:
+
+ $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
+
+Currently available options are: I<tax_exemption>.
+
+The I<tax_exemption> option can be set to an arrayref of tax names.
+FS::cust_main_exemption records will be deleted and inserted as appropriate.
+
+=cut
+
+sub replace {
+ my $self = shift;
+
+ my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
+ ? shift
+ : $self->replace_old;
+
+ my @param = @_;
+
+ warn "$me replace called\n"
+ if $DEBUG;
+
+ my $curuser = $FS::CurrentUser::CurrentUser;
+ if ( $self->payby eq 'COMP'
+ && $self->payby ne $old->payby
+ && ! $curuser->access_right('Complimentary customer')
+ )
+ {
+ return "You are not permitted to create complimentary accounts.";
+ }
+
+ if ( $old->get('geocode') && $old->get('geocode') eq $self->get('geocode')
+ && $conf->exists('enable_taxproducts')
+ )
+ {
+ my $pre = ($conf->exists('tax-ship_address') && $self->ship_zip)
+ ? 'ship_' : '';
+ $self->set('geocode', '')
+ if $old->get($pre.'zip') ne $self->get($pre.'zip')
+ && length($self->get($pre.'zip')) >= 10;
+ }
+
+ local($ignore_expired_card) = 1
+ if $old->payby =~ /^(CARD|DCRD)$/
+ && $self->payby =~ /^(CARD|DCRD)$/
+ && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
+
+ 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;
+
+ my $error = $self->SUPER::replace($old);
+
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+
+ if ( @param && ref($param[0]) eq 'ARRAY' ) { # INVOICING_LIST_ARYREF
+ my $invoicing_list = shift @param;
+ $error = $self->check_invoicing_list( $invoicing_list );
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ $self->invoicing_list( $invoicing_list );
+ }
+
+ if ( $self->exists('tagnum') ) { #so we don't delete these on edit by accident
+
+ #this could be more efficient than deleting and re-inserting, if it matters
+ foreach my $cust_tag (qsearch('cust_tag', {'custnum'=>$self->custnum} )) {
+ my $error = $cust_tag->delete;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ }
+ foreach my $tagnum ( @{ $self->tagnum || [] } ) {
+ my $cust_tag = new FS::cust_tag { 'tagnum' => $tagnum,
+ 'custnum' => $self->custnum };
+ my $error = $cust_tag->insert;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ return $error;
+ }
+ }
+
+ }
+
+ my %options = @param;
+
+ my $tax_exemption = delete $options{'tax_exemption'};
if ( $tax_exemption ) {
my %cust_main_exemption =
|| $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.
$self->ut_phonen('daytime', $self->country)
|| $self->ut_phonen('night', $self->country)
|| $self->ut_phonen('fax', $self->country)
- || $self->ut_zip('zip', $self->country)
;
return $error if $error;
+ unless ( $ignore_illegal_zip ) {
+ $error = $self->ut_zip('zip', $self->country);
+ return $error if $error;
+ }
+
if ( $conf->exists('cust_main-require_phone')
&& ! length($self->daytime) && ! length($self->night)
) {
$self->ut_phonen('ship_daytime', $self->ship_country)
|| $self->ut_phonen('ship_night', $self->ship_country)
|| $self->ut_phonen('ship_fax', $self->ship_country)
- || $self->ut_zip('ship_zip', $self->ship_country)
;
return $error if $error;
+ unless ( $ignore_illegal_zip ) {
+ $error = $self->ut_zip('ship_zip', $self->ship_country);
+ return $error if $error;
+ }
return "Unit # is required."
if $self->ship_address2 =~ /^\s*$/
&& $conf->exists('cust_main-require_address2');
if $self->payinfo !~ /^99\d{14}$/ #token
&& cardtype($self->payinfo) eq "Unknown";
- my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
- if ( $ban ) {
- return 'Banned credit card: banned on '.
- time2str('%a %h %o at %r', $ban->_date).
- ' by '. $ban->otaker.
- ' (ban# '. $ban->bannum. ')';
+ unless ( $ignore_banned_card ) {
+ my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
+ if ( $ban ) {
+ return 'Banned credit card: banned on '.
+ time2str('%a %h %o at %r', $ban->_date).
+ ' by '. $ban->otaker.
+ ' (ban# '. $ban->bannum. ')';
+ }
}
if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
$self->payinfo($payinfo);
$self->paycvv('');
- my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
- if ( $ban ) {
- return 'Banned ACH account: banned on '.
- time2str('%a %h %o at %r', $ban->_date).
- ' by '. $ban->otaker.
- ' (ban# '. $ban->bannum. ')';
+ unless ( $ignore_banned_card ) {
+ my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
+ if ( $ban ) {
+ return 'Banned ACH account: banned on '.
+ time2str('%a %h %o at %r', $ban->_date).
+ ' by '. $ban->otaker.
+ ' (ban# '. $ban->bannum. ')';
+ }
}
} elsif ( $self->payby eq 'LECB' ) {
} else {
return "Illegal expiration date: ". $self->paydate;
}
+ $m = sprintf('%02d',$m);
$self->paydate("$y-$m-01");
my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
return gettext('expired_card')
) {
$self->payname( $self->first. " ". $self->getfield('last') );
} else {
- $self->payname =~ /^([\w \,\.\-\'\&]+)$/
+ $self->payname =~ /^([µ_0123456789aAáÁàÀâÂåÅäÄãêæÆbBcCçÇdDðÐeEéÉèÈêÊëËfFgGhHiIíÍìÌîÎïÏjJkKlLmMnNñÑoOóÓòÒôÔöÖõÕøغpPqQrRsSßtTuUúÚùÙûÛüÜvVwWxXyYýÝÿzZþÞ \,\.\-\'\&]+)$/
or return gettext('illegal_name'). " payname: ". $self->payname;
$self->payname($1);
}
=item location_hash
Returns a list of key/value pairs, with the following keys: address1, adddress2,
-city, county, state, zip, country. The shipping address is used if present.
+city, county, state, zip, country, and geocode. The shipping address is used if present.
=cut
-#geocode? dependent on tax-ship_address config, not available in cust_location
-#mostly. not yet then.
-
-sub location_hash {
- my $self = shift;
- my $prefix = $self->has_ship_address ? 'ship_' : '';
-
- map { $_ => $self->get($prefix.$_) }
- qw( address1 address2 city county state zip country geocode );
- #fields that cust_location has
-}
-
-=item all_pkgs [ EXTRA_QSEARCH_PARAMS_HASHREF ]
+=item cust_location
-Returns all packages (see L<FS::cust_pkg>) for this customer.
+Returns all locations (see L<FS::cust_location>) for this customer.
=cut
-sub all_pkgs {
+sub cust_location {
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;
+ qsearch('cust_location', { 'custnum' => $self->custnum } );
}
-=item cust_pkg
+=item unsuspend
-Synonym for B<all_pkgs>.
+Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
+and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list
+on success or a list of errors.
=cut
-sub cust_pkg {
- shift->all_pkgs(@_);
+sub unsuspend {
+ my $self = shift;
+ grep { $_->unsuspend } $self->suspended_pkgs;
}
-=item cust_location
+=item suspend
-Returns all locations (see L<FS::cust_location>) for this customer.
+Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
+
+Returns a list: an empty list on success or a list of errors.
=cut
-sub cust_location {
+sub suspend {
my $self = shift;
- qsearch('cust_location', { 'custnum' => $self->custnum } );
+ grep { $_->suspend(@_) } $self->unsuspended_pkgs;
}
-=item location_label [ OPTION => VALUE ... ]
-
-Returns the label of the service location (see analog in L<FS::cust_location>) for this customer.
+=item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
-Options are
+Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
+PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead
+of a list of pkgparts; the hashref has the following keys:
=over 4
-=item join_string
+=item pkgparts - listref of pkgparts
-used to separate the address elements (defaults to ', ')
+=item (other options are passed to the suspend method)
-=item escape_function
+=back
-a callback used for escaping the text of the address elements
-=back
+Returns a list: an empty list on success or a list of errors.
=cut
-# false laziness with FS::cust_location::line
-
-sub location_label {
+sub suspend_if_pkgpart {
my $self = shift;
- my %opt = @_;
-
- my $separator = $opt{join_string} || ', ';
- my $escape = $opt{escape_function} || sub{ shift };
- my $line = '';
- my $cydefault = FS::conf->new->config('countrydefault') || 'US';
- my $prefix = length($self->ship_last) ? 'ship_' : '';
-
- my $notfirst = 0;
- foreach (qw ( address1 address2 ) ) {
- my $method = "$prefix$_";
- $line .= ($notfirst ? $separator : ''). &$escape($self->$method)
- if $self->$method;
- $notfirst++;
- }
- $notfirst = 0;
- foreach (qw ( city county state zip ) ) {
- my $method = "$prefix$_";
- if ( $self->$method ) {
- $line .= ' (' if $method eq 'county';
- $line .= ($notfirst ? ' ' : $separator). &$escape($self->$method);
- $line .= ' )' if $method eq 'county';
- $notfirst++;
- }
+ my (@pkgparts, %opt);
+ if (ref($_[0]) eq 'HASH'){
+ @pkgparts = @{$_[0]{pkgparts}};
+ %opt = %{$_[0]};
+ }else{
+ @pkgparts = @_;
}
- $line .= $separator. &$escape(code2country($self->country))
- if $self->country ne $cydefault;
-
- $line;
+ grep { $_->suspend(%opt) }
+ grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
+ $self->unsuspended_pkgs;
}
-=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 };
+=item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
- } else {
+Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
+given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref
+instead of a list of pkgparts; the hashref has the following keys:
- warn "$me ncancelled_pkgs: searching for packages with custnum ".
- $self->custnum. "\n"
- if $DEBUG > 1;
+=over 4
- $extra_qsearch->{'extra_sql'} .= ' AND ( cancel IS NULL OR cancel = 0 ) ';
+=item pkgparts - listref of pkgparts
- @cust_pkg = $self->_cust_pkg($extra_qsearch);
+=item (other options are passed to the suspend method)
- }
+=back
- sort sort_packages @cust_pkg;
+Returns a list: an empty list on success or a list of errors.
-}
+=cut
-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>
-and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list
-on success or a list of errors.
-
-=cut
-
-sub unsuspend {
- my $self = shift;
- grep { $_->unsuspend } $self->suspended_pkgs;
-}
-
-=item suspend
-
-Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
-
-Returns a list: an empty list on success or a list of errors.
-
-=cut
-
-sub suspend {
- my $self = shift;
- grep { $_->suspend(@_) } $self->unsuspended_pkgs;
-}
-
-=item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
-
-Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
-PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead
-of a list of pkgparts; the hashref has the following keys:
-
-=over 4
-
-=item pkgparts - listref of pkgparts
-
-=item (other options are passed to the suspend method)
-
-=back
-
-
-Returns a list: an empty list on success or a list of errors.
-
-=cut
-
-sub suspend_if_pkgpart {
- my $self = shift;
- my (@pkgparts, %opt);
- if (ref($_[0]) eq 'HASH'){
- @pkgparts = @{$_[0]{pkgparts}};
- %opt = %{$_[0]};
- }else{
- @pkgparts = @_;
- }
- grep { $_->suspend(%opt) }
- grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
- $self->unsuspended_pkgs;
-}
-
-=item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
-
-Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
-given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref
-instead of a list of pkgparts; the hashref has the following keys:
-
-=over 4
-
-=item pkgparts - listref of pkgparts
-
-=item (other options are passed to the suspend method)
-
-=back
-
-Returns a list: an empty list on success or a list of errors.
-
-=cut
-
-sub suspend_unless_pkgpart {
+sub suspend_unless_pkgpart {
my $self = shift;
my (@pkgparts, %opt);
if (ref($_[0]) eq 'HASH'){
=cut
sub notes {
- my $self = shift;
- #order by?
+ my($self,$orderby_classnum) = (shift,shift);
+ my $orderby = "_DATE DESC";
+ $orderby = "CLASSNUM ASC, $orderby" if $orderby_classnum;
qsearch( 'cust_main_note',
{ 'custnum' => $self->custnum },
'',
- 'ORDER BY _DATE DESC'
+ "ORDER BY $orderby",
);
}
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
+=item REALTIME BILLING METHODS
-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.
+Documentation on realtime billing methods has been moved to
+L<FS::cust_main::Billing_Realtime>.
-=item check_freq
+=item remove_cvv
-"1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
+Removes the I<paycvv> field from the database directly.
-=item stage
+If there is an error, returns the error, otherwise returns false.
-"collect" (the default) or "pre-bill"
+=cut
-=item quiet
-
-set true to surpress email card/ACH decline notices.
+sub remove_cvv {
+ my $self = shift;
+ my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
+ or return dbh->errstr;
+ $sth->execute($self->custnum)
+ or return $sth->errstr;
+ $self->paycvv('');
+ '';
+}
-=item debug
+=item batch_card OPTION => VALUE...
-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)
+Adds a payment for this invoice to the pending credit card batch (see
+L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
+runs the payment using a realtime gateway.
=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 batch_card {
+ my ($self, %options) = @_;
-sub do_cust_event {
- my( $self, %options ) = @_;
- my $time = $options{'time'} || time;
+ my $amount;
+ if (exists($options{amount})) {
+ $amount = $options{amount};
+ }else{
+ $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
+ }
+ return '' unless $amount > 0;
+
+ my $invnum = delete $options{invnum};
+ my $payby = $options{payby} || $self->payby; #still dubious
- #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';
+ if ($options{'realtime'}) {
+ return $self->realtime_bop( FS::payby->payby2bop($self->payby),
+ $amount,
+ %options,
+ );
+ }
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"
- }
+ #this needs to handle mysql as well as Pg, like svc_acct.pm
+ #(make it into a common function if folks need to do batching with mysql)
+ $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
+ or return "Cannot lock pay_batch: " . $dbh->errstr;
-# 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' ),
+ my %pay_batch = (
+ 'status' => 'O',
+ 'payby' => FS::payby->payby2payment($payby),
);
- 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 ) {
+ my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
- #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;
+ unless ( $pay_batch ) {
+ $pay_batch = new FS::pay_batch \%pay_batch;
+ my $error = $pay_batch->insert;
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ die "error creating new batch: $error\n";
}
+ }
- {
- 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;
- }
- }
+ my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
+ 'batchnum' => $pay_batch->batchnum,
+ 'custnum' => $self->custnum,
+ } );
+ foreach (qw( address1 address2 city state zip country payby payinfo paydate
+ payname )) {
+ $options{$_} = '' unless exists($options{$_});
}
- '';
+ my $cust_pay_batch = new FS::cust_pay_batch ( {
+ 'batchnum' => $pay_batch->batchnum,
+ 'invnum' => $invnum || 0, # is there a better value?
+ # this field should be
+ # removed...
+ # cust_bill_pay_batch now
+ 'custnum' => $self->custnum,
+ 'last' => $self->getfield('last'),
+ 'first' => $self->getfield('first'),
+ 'address1' => $options{address1} || $self->address1,
+ 'address2' => $options{address2} || $self->address2,
+ 'city' => $options{city} || $self->city,
+ 'state' => $options{state} || $self->state,
+ 'zip' => $options{zip} || $self->zip,
+ 'country' => $options{country} || $self->country,
+ 'payby' => $options{payby} || $self->payby,
+ 'payinfo' => $options{payinfo} || $self->payinfo,
+ 'exp' => $options{paydate} || $self->paydate,
+ 'payname' => $options{payname} || $self->payname,
+ 'amount' => $amount, # consolidating
+ } );
+
+ $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
+ if $old_cust_pay_batch;
-}
+ my $error;
+ if ($old_cust_pay_batch) {
+ $error = $cust_pay_batch->replace($old_cust_pay_batch)
+ } else {
+ $error = $cust_pay_batch->insert;
+ }
-=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
-L<FS::cust_main::Billing_Realtime>.
-
-=item remove_cvv
-
-Removes the I<paycvv> field from the database directly.
-
-If there is an error, returns the error, otherwise returns false.
-
-=cut
-
-sub remove_cvv {
- my $self = shift;
- my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
- or return dbh->errstr;
- $sth->execute($self->custnum)
- or return $sth->errstr;
- $self->paycvv('');
- '';
-}
-
-=item batch_card OPTION => VALUE...
-
-Adds a payment for this invoice to the pending credit card batch (see
-L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
-runs the payment using a realtime gateway.
-
-=cut
-
-sub batch_card {
- my ($self, %options) = @_;
-
- my $amount;
- if (exists($options{amount})) {
- $amount = $options{amount};
- }else{
- $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
- }
- return '' unless $amount > 0;
-
- my $invnum = delete $options{invnum};
- my $payby = $options{invnum} || $self->payby; #dubious
-
- if ($options{'realtime'}) {
- return $self->realtime_bop( FS::payby->payby2bop($self->payby),
- $amount,
- %options,
- );
- }
-
- my $oldAutoCommit = $FS::UID::AutoCommit;
- local $FS::UID::AutoCommit = 0;
- my $dbh = dbh;
-
- #this needs to handle mysql as well as Pg, like svc_acct.pm
- #(make it into a common function if folks need to do batching with mysql)
- $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
- or return "Cannot lock pay_batch: " . $dbh->errstr;
-
- my %pay_batch = (
- 'status' => 'O',
- 'payby' => FS::payby->payby2payment($payby),
- );
-
- my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
-
- unless ( $pay_batch ) {
- $pay_batch = new FS::pay_batch \%pay_batch;
- my $error = $pay_batch->insert;
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- die "error creating new batch: $error\n";
- }
- }
-
- my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
- 'batchnum' => $pay_batch->batchnum,
- 'custnum' => $self->custnum,
- } );
-
- foreach (qw( address1 address2 city state zip country payby payinfo paydate
- payname )) {
- $options{$_} = '' unless exists($options{$_});
- }
-
- my $cust_pay_batch = new FS::cust_pay_batch ( {
- 'batchnum' => $pay_batch->batchnum,
- 'invnum' => $invnum || 0, # is there a better value?
- # this field should be
- # removed...
- # cust_bill_pay_batch now
- 'custnum' => $self->custnum,
- 'last' => $self->getfield('last'),
- 'first' => $self->getfield('first'),
- 'address1' => $options{address1} || $self->address1,
- 'address2' => $options{address2} || $self->address2,
- 'city' => $options{city} || $self->city,
- 'state' => $options{state} || $self->state,
- 'zip' => $options{zip} || $self->zip,
- 'country' => $options{country} || $self->country,
- 'payby' => $options{payby} || $self->payby,
- 'payinfo' => $options{payinfo} || $self->payinfo,
- 'exp' => $options{paydate} || $self->paydate,
- 'payname' => $options{payname} || $self->payname,
- 'amount' => $amount, # consolidating
- } );
-
- $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
- if $old_cust_pay_batch;
-
- my $error;
- if ($old_cust_pay_batch) {
- $error = $cust_pay_batch->replace($old_cust_pay_batch)
- } else {
- $error = $cust_pay_batch->insert;
- }
-
- if ( $error ) {
- $dbh->rollback if $oldAutoCommit;
- die $error;
- }
+ if ( $error ) {
+ $dbh->rollback if $oldAutoCommit;
+ die $error;
+ }
my $unapplied = $self->total_unapplied_credits
+ $self->total_unapplied_payments
AND _date <= $time
";
- sprintf( "%.2f", $self->scalar_sql($sql) );
+ sprintf( "%.2f", $self->scalar_sql($sql) || 0 );
}
WHERE custnum = $custnum
";
- sprintf( "%.2f", $self->scalar_sql($sql) );
+ sprintf( "%.2f", $self->scalar_sql($sql) || 0 );
}
WHERE custnum = $custnum
";
- sprintf( "%.2f", $self->scalar_sql($sql) );
+ sprintf( "%.2f", $self->scalar_sql($sql) || 0 );
}
WHERE custnum = $custnum
";
- sprintf( "%.2f", $self->scalar_sql($sql) );
+ sprintf( "%.2f", $self->scalar_sql($sql) || 0 );
}
my $self = shift;
my $sql = 'SELECT SUM('. $self->balance_date_sql(@_).
') FROM cust_main WHERE custnum='. $self->custnum;
- sprintf( '%.2f', $self->scalar_sql($sql) );
+ sprintf( '%.2f', $self->scalar_sql($sql) || 0 );
}
=item balance_pkgnum PKGNUM
$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
=cut
-sub geocode {
- my ($self, $data_vendor) = (shift, shift); #always cch for now
-
- my $geocode = $self->get('geocode'); #XXX only one data_vendor for geocode
- return $geocode if $geocode;
-
- my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
- ? 'ship_'
- : '';
-
- my($zip,$plus4) = split /-/, $self->get("${prefix}zip")
- if $self->country eq 'US';
-
- $zip ||= '';
- $plus4 ||= '';
- #CCH specific location stuff
- my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
-
- my @cust_tax_location =
- qsearch( {
- 'table' => 'cust_tax_location',
- 'hashref' => { 'zip' => $zip, 'data_vendor' => $data_vendor },
- 'extra_sql' => $extra_sql,
- 'order_by' => 'ORDER BY plus4hi',#overlapping with distinct ends
- }
- );
- $geocode = $cust_tax_location[0]->geocode
- if scalar(@cust_tax_location);
-
- $geocode;
-}
-
=item cust_status
=item status
sub cust_status {
my $self = shift;
- # prospect ordered active inactive suspended cancelled
for my $status ( FS::cust_main->statuses() ) {
my $method = $status.'_sql';
my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
'prospect' => '7e0079', #'000000', #black? naw, purple
'active' => '00CC00', #green
'ordered' => '009999', #teal? cyan?
- 'inactive' => '0000CC', #blue
'suspended' => 'FF9900', #yellow
'cancelled' => 'FF0000', #red
+ 'inactive' => '0000CC', #blue
;
sub statuscolor { shift->cust_statuscolor(@_); }
scalar(@svc_X) ? ( $svc_X[0]->latitude, $svc_X[0]->longitude ) : ()
}
-=back
-
-=head1 CLASS METHODS
-
-=over 4
-
-=item statuses
-
-Class method that returns the list of possible status strings for customers
-(see L<the status method|/status>). For example:
-
- @statuses = FS::cust_main->statuses();
-
-=cut
-
-sub statuses {
- #my $self = shift; #could be class...
- keys %statuscolor;
-}
-
-=item prospect_sql
-
-Returns an SQL expression identifying prospective cust_main records (customers
-with no packages ever ordered)
-
-=cut
-
-use vars qw($select_count_pkgs);
-$select_count_pkgs =
- "SELECT COUNT(*) FROM cust_pkg
- WHERE cust_pkg.custnum = cust_main.custnum";
-
-sub select_count_pkgs_sql {
- $select_count_pkgs;
-}
-
-sub prospect_sql {
- " 0 = ( $select_count_pkgs ) ";
-}
-
-=item ordered_sql
-
-Returns an SQL expression identifying ordered cust_main records (customers with
-recurring packages not yet setup).
-
-=cut
-
-sub ordered_sql {
- FS::cust_main->none_active_sql.
- " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->ordered_sql. " ) ";
-}
-
-=item active_sql
-
-Returns an SQL expression identifying active cust_main records (customers with
-active recurring packages).
-
-=cut
-
-sub active_sql {
- " 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) ";
-}
-
-=item none_active_sql
-
-Returns an SQL expression identifying cust_main records with no active
-recurring packages. This includes customers of status prospect, ordered,
-inactive, and suspended.
-
-=cut
-
-sub none_active_sql {
- " 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) ";
-}
-
-=item inactive_sql
-
-Returns an SQL expression identifying inactive cust_main records (customers with
-no active recurring packages, but otherwise unsuspended/uncancelled).
-
-=cut
-
-sub inactive_sql {
- FS::cust_main->none_active_sql.
- " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " ) ";
-}
-
-=item susp_sql
-=item suspended_sql
-
-Returns an SQL expression identifying suspended cust_main records.
-
-=cut
-
-
-sub suspended_sql { susp_sql(@_); }
-sub susp_sql {
- FS::cust_main->none_active_sql.
- " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " ) ";
-}
-
-=item cancel_sql
-=item cancelled_sql
+=item masked FIELD
-Returns an SQL expression identifying cancelled cust_main records.
+Returns a masked version of the named field
=cut
-sub cancelled_sql { cancel_sql(@_); }
-sub cancel_sql {
+sub masked {
+my ($self,$field) = @_;
- my $recurring_sql = FS::cust_pkg->recurring_sql;
- my $cancelled_sql = FS::cust_pkg->cancelled_sql;
+# Show last four
- "
- 0 < ( $select_count_pkgs )
- AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql )
- AND 0 = ( $select_count_pkgs AND $recurring_sql
- AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
- )
- AND 0 = ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
- ";
+'x'x(length($self->getfield($field))-4).
+ substr($self->getfield($field), (length($self->getfield($field))-4));
}
-=item uncancel_sql
-=item uncancelled_sql
-
-Returns an SQL expression identifying un-cancelled cust_main records.
-
-=cut
-
-sub uncancelled_sql { uncancel_sql(@_); }
-sub uncancel_sql { "
- ( 0 < ( $select_count_pkgs
- AND ( cust_pkg.cancel IS NULL
- OR cust_pkg.cancel = 0
- )
- )
- OR 0 = ( $select_count_pkgs )
- )
-"; }
-
-=item balance_sql
-
-Returns an SQL fragment to retreive the balance.
-
-=cut
-
-sub balance_sql { "
- ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
- WHERE cust_bill.custnum = cust_main.custnum )
- - ( SELECT COALESCE( SUM(paid), 0 ) FROM cust_pay
- WHERE cust_pay.custnum = cust_main.custnum )
- - ( SELECT COALESCE( SUM(amount), 0 ) FROM cust_credit
- WHERE cust_credit.custnum = cust_main.custnum )
- + ( SELECT COALESCE( SUM(refund), 0 ) FROM cust_refund
- WHERE cust_refund.custnum = cust_main.custnum )
-"; }
-
-=item balance_date_sql [ START_TIME [ END_TIME [ OPTION => VALUE ... ] ] ]
-
-Returns an SQL fragment to retreive the balance for this customer, optionally
-considering invoices with date earlier than START_TIME, and not
-later than END_TIME (total_owed_date minus total_unapplied_credits minus
-total_unapplied_payments).
-
-Times are specified as SQL fragments or numeric
-UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
-L<Date::Parse> for conversion functions. The empty string can be passed
-to disable that time constraint completely.
-
-Available options are:
-
-=over 4
-
-=item unapplied_date
-
-set to true to disregard unapplied credits, payments and refunds outside the specified time period - by default the time period restriction only applies to invoices (useful for reporting, probably a bad idea for event triggering)
-
-=item total
-
-(unused. obsolete?)
-set to true to remove all customer comparison clauses, for totals
-
-=item where
-
-(unused. obsolete?)
-WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
-
-=item join
-
-(unused. obsolete?)
-JOIN clause (typically used with the total option)
-
-=item cutoff
-
-An absolute cutoff time. Payments, credits, and refunds I<applied> after this
-time will be ignored. Note that START_TIME and END_TIME only limit the date
-range for invoices and I<unapplied> payments, credits, and refunds.
-
=back
-=cut
-
-sub balance_date_sql {
- my( $class, $start, $end, %opt ) = @_;
-
- my $cutoff = $opt{'cutoff'};
-
- my $owed = FS::cust_bill->owed_sql($cutoff);
- my $unapp_refund = FS::cust_refund->unapplied_sql($cutoff);
- my $unapp_credit = FS::cust_credit->unapplied_sql($cutoff);
- my $unapp_pay = FS::cust_pay->unapplied_sql($cutoff);
-
- my $j = $opt{'join'} || '';
-
- my $owed_wh = $class->_money_table_where( 'cust_bill', $start,$end,%opt );
- my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
- my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
- my $pay_wh = $class->_money_table_where( 'cust_pay', $start,$end,%opt );
-
- " ( SELECT COALESCE(SUM($owed), 0) FROM cust_bill $j $owed_wh )
- + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
- - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
- - ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $j $pay_wh )
- ";
-
-}
-
-=item unapplied_payments_date_sql START_TIME [ END_TIME ]
-
-Returns an SQL fragment to retreive the total unapplied payments for this
-customer, only considering invoices with date earlier than START_TIME, and
-optionally not later than END_TIME.
-
-Times are specified as SQL fragments or numeric
-UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
-L<Date::Parse> for conversion functions. The empty string can be passed
-to disable that time constraint completely.
-
-Available options are:
-
-=cut
-
-sub unapplied_payments_date_sql {
- my( $class, $start, $end, %opt ) = @_;
-
- my $cutoff = $opt{'cutoff'};
-
- my $unapp_pay = FS::cust_pay->unapplied_sql($cutoff);
-
- my $pay_where = $class->_money_table_where( 'cust_pay', $start, $end,
- 'unapplied_date'=>1 );
-
- " ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $pay_where ) ";
-}
-
-=item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
-
-Helper method for balance_date_sql; name (and usage) subject to change
-(suggestions welcome).
-
-Returns a WHERE clause for the specified monetary TABLE (cust_bill,
-cust_refund, cust_credit or cust_pay).
-
-If TABLE is "cust_bill" or the unapplied_date option is true, only
-considers records with date earlier than START_TIME, and optionally not
-later than END_TIME .
-
-=cut
-
-sub _money_table_where {
- my( $class, $table, $start, $end, %opt ) = @_;
-
- my @where = ();
- push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
- if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
- push @where, "$table._date <= $start" if defined($start) && length($start);
- push @where, "$table._date > $end" if defined($end) && length($end);
- }
- push @where, @{$opt{'where'}} if $opt{'where'};
- my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
-
- $where;
-
-}
-
-=item search HASHREF
-
-(Class method)
-
-Returns a qsearch hash expression to search for parameters specified in
-HASHREF. Valid parameters are
+=head1 CLASS METHODS
=over 4
-=item agentnum
-
-=item status
-
-=item cancelled_pkgs
-
-bool
-
-=item signupdate
-
-listref of start date, end date
-
-=item payby
-
-listref
-
-=item paydate_year
-
-=item paydate_month
-
-=item current_balance
-
-listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
-
-=item cust_fields
-
-=item flattened_pkgs
-
-bool
-
-=back
-
-=cut
-
-sub search {
- my ($class, $params) = @_;
-
- my $dbh = dbh;
-
- my @where = ();
- my $orderby;
-
- ##
- # parse agent
- ##
-
- if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
- push @where,
- "cust_main.agentnum = $1";
- }
-
- ##
- # do the same for user
- ##
-
- if ( $params->{'usernum'} =~ /^(\d+)$/ and $1 ) {
- push @where,
- "cust_main.usernum = $1";
- }
-
- ##
- # parse status
- ##
-
- #prospect ordered active inactive suspended cancelled
- if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
- my $method = $params->{'status'}. '_sql';
- #push @where, $class->$method();
- push @where, FS::cust_main->$method();
- }
-
- ##
- # parse cancelled package checkbox
- ##
-
- my $pkgwhere = "";
-
- $pkgwhere .= "AND (cancel = 0 or cancel is null)"
- unless $params->{'cancelled_pkgs'};
-
- ##
- # parse without census tract checkbox
- ##
-
- push @where, "(censustract = '' or censustract is null)"
- if $params->{'no_censustract'};
-
- ##
- # dates
- ##
-
- foreach my $field (qw( signupdate )) {
-
- next unless exists($params->{$field});
-
- my($beginning, $ending, $hour) = @{$params->{$field}};
-
- push @where,
- "cust_main.$field IS NOT NULL",
- "cust_main.$field >= $beginning",
- "cust_main.$field <= $ending";
-
- # XXX: do this for mysql and/or pull it out of here
- if(defined $hour) {
- if ($dbh->{Driver}->{Name} eq 'Pg') {
- push @where, "extract(hour from to_timestamp(cust_main.$field)) = $hour";
- }
- else {
- warn "search by time of day not supported on ".$dbh->{Driver}->{Name}." databases";
- }
- }
-
- $orderby ||= "ORDER BY cust_main.$field";
-
- }
-
- ###
- # classnum
- ###
-
- if ( $params->{'classnum'} ) {
-
- my @classnum = ref( $params->{'classnum'} )
- ? @{ $params->{'classnum'} }
- : ( $params->{'classnum'} );
-
- @classnum = grep /^(\d*)$/, @classnum;
-
- if ( @classnum ) {
- push @where, '( '. join(' OR ', map {
- $_ ? "cust_main.classnum = $_"
- : "cust_main.classnum IS NULL"
- }
- @classnum
- ).
- ' )';
- }
-
- }
-
- ###
- # payby
- ###
-
- if ( $params->{'payby'} ) {
-
- my @payby = ref( $params->{'payby'} )
- ? @{ $params->{'payby'} }
- : ( $params->{'payby'} );
-
- @payby = grep /^([A-Z]{4})$/, @payby;
-
- push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )'
- if @payby;
-
- }
-
- ###
- # paydate_year / paydate_month
- ###
-
- if ( $params->{'paydate_year'} =~ /^(\d{4})$/ ) {
- my $year = $1;
- $params->{'paydate_month'} =~ /^(\d\d?)$/
- or die "paydate_year without paydate_month?";
- my $month = $1;
-
- push @where,
- 'paydate IS NOT NULL',
- "paydate != ''",
- "CAST(paydate AS timestamp) < CAST('$year-$month-01' AS timestamp )"
-;
- }
-
- ###
- # invoice terms
- ###
-
- if ( $params->{'invoice_terms'} =~ /^([\w ]+)$/ ) {
- my $terms = $1;
- if ( $1 eq 'NULL' ) {
- push @where,
- "( cust_main.invoice_terms IS NULL OR cust_main.invoice_terms = '' )";
- } else {
- push @where,
- "cust_main.invoice_terms IS NOT NULL",
- "cust_main.invoice_terms = '$1'";
- }
- }
-
- ##
- # amounts
- ##
-
- if ( $params->{'current_balance'} ) {
-
- #my $balance_sql = $class->balance_sql();
- my $balance_sql = FS::cust_main->balance_sql();
-
- my @current_balance =
- ref( $params->{'current_balance'} )
- ? @{ $params->{'current_balance'} }
- : ( $params->{'current_balance'} );
-
- push @where, map { s/current_balance/$balance_sql/; $_ }
- @current_balance;
-
- }
-
- ##
- # custbatch
- ##
-
- if ( $params->{'custbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
- push @where,
- "cust_main.custbatch = '$1'";
- }
-
- ##
- # setup queries, subs, etc. for the search
- ##
-
- $orderby ||= 'ORDER BY custnum';
-
- # here is the agent virtualization
- push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
-
- my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
-
- my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum ) ';
-
- my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
-
- my $select = join(', ',
- 'cust_main.custnum',
- FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
- );
-
- my(@extra_headers) = ();
- my(@extra_fields) = ();
-
- if ($params->{'flattened_pkgs'}) {
-
- if ($dbh->{Driver}->{Name} eq 'Pg') {
-
- $select .= ", array_to_string(array(select pkg from cust_pkg left join part_pkg using ( pkgpart ) where cust_main.custnum = cust_pkg.custnum $pkgwhere),'|') as magic";
-
- }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
- $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
- $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
- }else{
- warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
- "omitting packing information from report.";
- }
-
- my $header_query = "SELECT COUNT(cust_pkg.custnum = cust_main.custnum) AS count FROM cust_main $addl_from $extra_sql $pkgwhere group by cust_main.custnum order by count desc limit 1";
-
- my $sth = dbh->prepare($header_query) or die dbh->errstr;
- $sth->execute() or die $sth->errstr;
- my $headerrow = $sth->fetchrow_arrayref;
- my $headercount = $headerrow ? $headerrow->[0] : 0;
- while($headercount) {
- unshift @extra_headers, "Package ". $headercount;
- unshift @extra_fields, eval q!sub {my $c = shift;
- my @a = split '\|', $c->magic;
- my $p = $a[!.--$headercount. q!];
- $p;
- };!;
- }
-
- }
-
- my $sql_query = {
- 'table' => 'cust_main',
- 'select' => $select,
- 'hashref' => {},
- 'extra_sql' => $extra_sql,
- 'order_by' => $orderby,
- 'count_query' => $count_query,
- 'extra_headers' => \@extra_headers,
- 'extra_fields' => \@extra_fields,
- };
-
-}
-
-=item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
-
-Performs a fuzzy (approximate) search and returns the matching FS::cust_main
-records. Currently, I<first>, I<last>, I<company> and/or I<address1> may be
-specified (the appropriate ship_ field is also searched).
-
-Additional options are the same as FS::Record::qsearch
-
-=cut
-
-sub fuzzy_search {
- my( $self, $fuzzy, $hash, @opt) = @_;
- #$self
- $hash ||= {};
- my @cust_main = ();
-
- check_and_rebuild_fuzzyfiles();
- foreach my $field ( keys %$fuzzy ) {
-
- my $all = $self->all_X($field);
- next unless scalar(@$all);
-
- my %match = ();
- $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
-
- my @fcust = ();
- foreach ( keys %match ) {
- push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
- push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
- }
- my %fsaw = ();
- push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
- }
-
- # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
- my %saw = ();
- @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
-
- @cust_main;
-
-}
+=item statuses
-=item masked FIELD
+Class method that returns the list of possible status strings for customers
+(see L<the status method|/status>). For example:
-Returns a masked version of the named field
+ @statuses = FS::cust_main->statuses();
=cut
-sub masked {
-my ($self,$field) = @_;
-
-# Show last four
-
-'x'x(length($self->getfield($field))-4).
- substr($self->getfield($field), (length($self->getfield($field))-4));
-
+sub statuses {
+ #my $self = shift; #could be class...
+ keys %statuscolor;
}
-=back
+=item cust_status_sql
-=head1 SUBROUTINES
+Returns an SQL fragment to determine the status of a cust_main record, as a
+string.
-=over 4
+=cut
-=item smart_search OPTION => VALUE ...
+sub cust_status_sql {
+ my $sql = 'CASE';
+ for my $status ( FS::cust_main->statuses() ) {
+ my $method = $status.'_sql';
+ $sql .= ' WHEN ('.FS::cust_main->$method.") THEN '$status'";
+ }
+ $sql .= ' END';
+ return $sql;
+}
-Accepts the following options: I<search>, the string to search for. The string
-will be searched for as a customer number, phone number, name or company name,
-as an exact, or, in some cases, a substring or fuzzy match (see the source code
-for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
-skip fuzzy matching when an exact match is found.
-Any additional options are treated as an additional qualifier on the search
-(i.e. I<agentnum>).
+=item prospect_sql
-Returns a (possibly empty) array of FS::cust_main objects.
+Returns an SQL expression identifying prospective cust_main records (customers
+with no packages ever ordered)
=cut
-sub smart_search {
- my %options = @_;
-
- #here is the agent virtualization
- my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
+use vars qw($select_count_pkgs);
+$select_count_pkgs =
+ "SELECT COUNT(*) FROM cust_pkg
+ WHERE cust_pkg.custnum = cust_main.custnum";
- my @cust_main = ();
+sub select_count_pkgs_sql {
+ $select_count_pkgs;
+}
- my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
- my $search = delete $options{'search'};
- ( my $alphanum_search = $search ) =~ s/\W//g;
-
- if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
-
- #false laziness w/Record::ut_phone
- my $phonen = "$1-$2-$3";
- $phonen .= " x$4" if $4;
-
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { %options },
- 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
- ' ( '.
- join(' OR ', map "$_ = '$phonen'",
- qw( daytime night fax
- ship_daytime ship_night ship_fax )
- ).
- ' ) '.
- " AND $agentnums_sql", #agent virtualization
- } );
+sub prospect_sql {
+ " 0 = ( $select_count_pkgs ) ";
+}
- unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
- #try looking for matches with extensions unless one was specified
-
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { %options },
- 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
- ' ( '.
- join(' OR ', map "$_ LIKE '$phonen\%'",
- qw( daytime night
- ship_daytime ship_night )
- ).
- ' ) '.
- " AND $agentnums_sql", #agent virtualization
- } );
+=item ordered_sql
- }
+Returns an SQL expression identifying ordered cust_main records (customers with
+recurring packages not yet setup).
- # custnum search (also try agent_custid), with some tweaking options if your
- # legacy cust "numbers" have letters
- }
+=cut
- if ( $search =~ /^\s*(\d+)\s*$/
- || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
- && $search =~ /^\s*(\w\w?\d+)\s*$/
- )
- || ( $conf->exists('address1-search' )
- && $search =~ /^\s*(\d+\-?\w*)\s*$/ #i.e. 1234A or 9432-D
- )
- )
- {
+sub ordered_sql {
+ FS::cust_main->none_active_sql.
+ " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->ordered_sql. " ) ";
+}
- my $num = $1;
+=item active_sql
- if ( $num =~ /^(\d+)$/ && $num <= 2147483647 ) { #need a bigint custnum? wow
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { 'custnum' => $num, %options },
- 'extra_sql' => " AND $agentnums_sql", #agent virtualization
- } );
- }
+Returns an SQL expression identifying active cust_main records (customers with
+active recurring packages).
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { 'agent_custid' => $num, %options },
- 'extra_sql' => " AND $agentnums_sql", #agent virtualization
- } );
+=cut
- if ( $conf->exists('address1-search') ) {
- my $len = length($num);
- $num = lc($num);
- foreach my $prefix ( '', 'ship_' ) {
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { %options, },
- 'extra_sql' =>
- ( keys(%options) ? ' AND ' : ' WHERE ' ).
- " LOWER(SUBSTRING(${prefix}address1 FROM 1 FOR $len)) = '$num' ".
- " AND $agentnums_sql",
- } );
- }
- }
+sub active_sql {
+ " 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) ";
+}
- } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
-
- my($company, $last, $first) = ( $1, $2, $3 );
-
- # "Company (Last, First)"
- #this is probably something a browser remembered,
- #so just do an exact search (but case-insensitive, so USPS standardization
- #doesn't throw a wrench in the works)
-
- foreach my $prefix ( '', 'ship_' ) {
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { %options },
- 'extra_sql' =>
- ( keys(%options) ? ' AND ' : ' WHERE ' ).
- join(' AND ',
- " LOWER(${prefix}first) = ". dbh->quote(lc($first)),
- " LOWER(${prefix}last) = ". dbh->quote(lc($last)),
- " LOWER(${prefix}company) = ". dbh->quote(lc($company)),
- $agentnums_sql,
- ),
- } );
- }
+=item none_active_sql
- } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
- # try (ship_){last,company}
+Returns an SQL expression identifying cust_main records with no active
+recurring packages. This includes customers of status prospect, ordered,
+inactive, and suspended.
- my $value = lc($1);
+=cut
- # # remove "(Last, First)" in "Company (Last, First)", otherwise the
- # # full strings the browser remembers won't work
- # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
+sub none_active_sql {
+ " 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " ) ";
+}
- use Lingua::EN::NameParse;
- my $NameParse = new Lingua::EN::NameParse(
- auto_clean => 1,
- allow_reversed => 1,
- );
+=item inactive_sql
- my($last, $first) = ( '', '' );
- #maybe disable this too and just rely on NameParse?
- if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
-
- ($last, $first) = ( $1, $2 );
-
- #} elsif ( $value =~ /^(.+)\s+(.+)$/ ) {
- } elsif ( ! $NameParse->parse($value) ) {
+Returns an SQL expression identifying inactive cust_main records (customers with
+no active recurring packages, but otherwise unsuspended/uncancelled).
- my %name = $NameParse->components;
- $first = $name{'given_name_1'};
- $last = $name{'surname_1'};
+=cut
- }
+sub inactive_sql {
+ FS::cust_main->none_active_sql.
+ " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " ) ";
+}
- if ( $first && $last ) {
+=item susp_sql
+=item suspended_sql
- my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
+Returns an SQL expression identifying suspended cust_main records.
- #exact
- my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
- $sql .= "
- ( ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
- OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
- )";
+=cut
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => \%options,
- 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
- } );
- # or it just be something that was typed in... (try that in a sec)
+sub suspended_sql { susp_sql(@_); }
+sub susp_sql {
+ FS::cust_main->none_active_sql.
+ " AND 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " ) ";
+}
- }
+=item cancel_sql
+=item cancelled_sql
- my $q_value = dbh->quote($value);
-
- #exact
- my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
- $sql .= " ( LOWER(last) = $q_value
- OR LOWER(company) = $q_value
- OR LOWER(ship_last) = $q_value
- OR LOWER(ship_company) = $q_value
- ";
- $sql .= " OR LOWER(address1) = $q_value
- OR LOWER(ship_address1) = $q_value
- "
- if $conf->exists('address1-search');
- $sql .= " )";
-
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => \%options,
- 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
- } );
+Returns an SQL expression identifying cancelled cust_main records.
- #no exact match, trying substring/fuzzy
- #always do substring & fuzzy (unless they're explicity config'ed off)
- #getting complaints searches are not returning enough
- unless ( @cust_main && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
+=cut
- #still some false laziness w/search (was search/cust_main.cgi)
+sub cancelled_sql { cancel_sql(@_); }
+sub cancel_sql {
- #substring
+ my $recurring_sql = FS::cust_pkg->recurring_sql;
+ my $cancelled_sql = FS::cust_pkg->cancelled_sql;
- my @hashrefs = (
- { 'company' => { op=>'ILIKE', value=>"%$value%" }, },
- { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
- );
+ "
+ 0 < ( $select_count_pkgs )
+ AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql )
+ AND 0 = ( $select_count_pkgs AND $recurring_sql
+ AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
+ )
+ ";
+# AND 0 = ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
- if ( $first && $last ) {
+}
- push @hashrefs,
- { 'first' => { op=>'ILIKE', value=>"%$first%" },
- 'last' => { op=>'ILIKE', value=>"%$last%" },
- },
- { 'ship_first' => { op=>'ILIKE', value=>"%$first%" },
- 'ship_last' => { op=>'ILIKE', value=>"%$last%" },
- },
- ;
+=item uncancel_sql
+=item uncancelled_sql
- } else {
+Returns an SQL expression identifying un-cancelled cust_main records.
- push @hashrefs,
- { 'last' => { op=>'ILIKE', value=>"%$value%" }, },
- { 'ship_last' => { op=>'ILIKE', value=>"%$value%" }, },
- ;
- }
+=cut
- if ( $conf->exists('address1-search') ) {
- push @hashrefs,
- { 'address1' => { op=>'ILIKE', value=>"%$value%" }, },
- { 'ship_address1' => { op=>'ILIKE', value=>"%$value%" }, },
- ;
- }
+sub uncancelled_sql { uncancel_sql(@_); }
+sub uncancel_sql { "
+ ( 0 < ( $select_count_pkgs
+ AND ( cust_pkg.cancel IS NULL
+ OR cust_pkg.cancel = 0
+ )
+ )
+ OR 0 = ( $select_count_pkgs )
+ )
+"; }
- foreach my $hashref ( @hashrefs ) {
+=item balance_sql
- push @cust_main, qsearch( {
- 'table' => 'cust_main',
- 'hashref' => { %$hashref,
- %options,
- },
- 'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
- } );
+Returns an SQL fragment to retreive the balance.
- }
+=cut
- #fuzzy
- my @fuzopts = (
- \%options, #hashref
- '', #select
- " AND $agentnums_sql", #extra_sql #agent virtualization
- );
-
- if ( $first && $last ) {
- push @cust_main, FS::cust_main->fuzzy_search(
- { 'last' => $last, #fuzzy hashref
- 'first' => $first }, #
- @fuzopts
- );
- }
- foreach my $field ( 'last', 'company' ) {
- push @cust_main,
- FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
- }
- if ( $conf->exists('address1-search') ) {
- push @cust_main,
- FS::cust_main->fuzzy_search( { 'address1' => $value }, @fuzopts );
- }
+sub balance_sql { "
+ ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
+ WHERE cust_bill.custnum = cust_main.custnum )
+ - ( SELECT COALESCE( SUM(paid), 0 ) FROM cust_pay
+ WHERE cust_pay.custnum = cust_main.custnum )
+ - ( SELECT COALESCE( SUM(amount), 0 ) FROM cust_credit
+ WHERE cust_credit.custnum = cust_main.custnum )
+ + ( SELECT COALESCE( SUM(refund), 0 ) FROM cust_refund
+ WHERE cust_refund.custnum = cust_main.custnum )
+"; }
- }
+=item balance_date_sql [ START_TIME [ END_TIME [ OPTION => VALUE ... ] ] ]
- }
+Returns an SQL fragment to retreive the balance for this customer, optionally
+considering invoices with date earlier than START_TIME, and not
+later than END_TIME (total_owed_date minus total_unapplied_credits minus
+total_unapplied_payments).
- #eliminate duplicates
- my %saw = ();
- @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
+Times are specified as SQL fragments or numeric
+UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
+L<Date::Parse> for conversion functions. The empty string can be passed
+to disable that time constraint completely.
- @cust_main;
+Available options are:
-}
+=over 4
-=item email_search
+=item unapplied_date
-Accepts the following options: I<email>, the email address to search for. The
-email address will be searched for as an email invoice destination and as an
-svc_acct account.
+set to true to disregard unapplied credits, payments and refunds outside the specified time period - by default the time period restriction only applies to invoices (useful for reporting, probably a bad idea for event triggering)
-#Any additional options are treated as an additional qualifier on the search
-#(i.e. I<agentnum>).
+=item total
-Returns a (possibly empty) array of FS::cust_main objects (but usually just
-none or one).
+(unused. obsolete?)
+set to true to remove all customer comparison clauses, for totals
-=cut
+=item where
-sub email_search {
- my %options = @_;
+(unused. obsolete?)
+WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
- local($DEBUG) = 1;
+=item join
- my $email = delete $options{'email'};
+(unused. obsolete?)
+JOIN clause (typically used with the total option)
- #we're only being used by RT at the moment... no agent virtualization yet
- #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
+=item cutoff
- my @cust_main = ();
+An absolute cutoff time. Payments, credits, and refunds I<applied> after this
+time will be ignored. Note that START_TIME and END_TIME only limit the date
+range for invoices and I<unapplied> payments, credits, and refunds.
- if ( $email =~ /([^@]+)\@([^@]+)/ ) {
+=back
- my ( $user, $domain ) = ( $1, $2 );
+=cut
- warn "$me smart_search: searching for $user in domain $domain"
- if $DEBUG;
+sub balance_date_sql {
+ my( $class, $start, $end, %opt ) = @_;
- push @cust_main,
- map $_->cust_main,
- qsearch( {
- 'table' => 'cust_main_invoice',
- 'hashref' => { 'dest' => $email },
- }
- );
+ my $cutoff = $opt{'cutoff'};
- push @cust_main,
- map $_->cust_main,
- grep $_,
- map $_->cust_svc->cust_pkg,
- qsearch( {
- 'table' => 'svc_acct',
- 'hashref' => { 'username' => $user, },
- 'extra_sql' =>
- 'AND ( SELECT domain FROM svc_domain
- WHERE svc_acct.domsvc = svc_domain.svcnum
- ) = '. dbh->quote($domain),
- }
- );
- }
+ my $owed = FS::cust_bill->owed_sql($cutoff);
+ my $unapp_refund = FS::cust_refund->unapplied_sql($cutoff);
+ my $unapp_credit = FS::cust_credit->unapplied_sql($cutoff);
+ my $unapp_pay = FS::cust_pay->unapplied_sql($cutoff);
- my %saw = ();
- @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
+ my $j = $opt{'join'} || '';
- warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
- if $DEBUG;
+ my $owed_wh = $class->_money_table_where( 'cust_bill', $start,$end,%opt );
+ my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
+ my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
+ my $pay_wh = $class->_money_table_where( 'cust_pay', $start,$end,%opt );
- @cust_main;
+ " ( SELECT COALESCE(SUM($owed), 0) FROM cust_bill $j $owed_wh )
+ + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
+ - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
+ - ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $j $pay_wh )
+ ";
}
-=item check_and_rebuild_fuzzyfiles
+=item unapplied_payments_date_sql START_TIME [ END_TIME ]
-=cut
+Returns an SQL fragment to retreive the total unapplied payments for this
+customer, only considering invoices with date earlier than START_TIME, and
+optionally not later than END_TIME.
-sub check_and_rebuild_fuzzyfiles {
- my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
- rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
-}
+Times are specified as SQL fragments or numeric
+UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
+L<Date::Parse> for conversion functions. The empty string can be passed
+to disable that time constraint completely.
-=item rebuild_fuzzyfiles
+Available options are:
=cut
-sub rebuild_fuzzyfiles {
+sub unapplied_payments_date_sql {
+ my( $class, $start, $end, %opt ) = @_;
+
+ my $cutoff = $opt{'cutoff'};
- use Fcntl qw(:flock);
+ my $unapp_pay = FS::cust_pay->unapplied_sql($cutoff);
- my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
- mkdir $dir, 0700 unless -d $dir;
+ my $pay_where = $class->_money_table_where( 'cust_pay', $start, $end,
+ 'unapplied_date'=>1 );
- foreach my $fuzzy ( @fuzzyfields ) {
+ " ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $pay_where ) ";
+}
- open(LOCK,">>$dir/cust_main.$fuzzy")
- or die "can't open $dir/cust_main.$fuzzy: $!";
- flock(LOCK,LOCK_EX)
- or die "can't lock $dir/cust_main.$fuzzy: $!";
+=item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
- open (CACHE,">$dir/cust_main.$fuzzy.tmp")
- or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
+Helper method for balance_date_sql; name (and usage) subject to change
+(suggestions welcome).
- foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
- my $sth = dbh->prepare("SELECT $field FROM cust_main".
- " WHERE $field != '' AND $field IS NOT NULL");
- $sth->execute or die $sth->errstr;
+Returns a WHERE clause for the specified monetary TABLE (cust_bill,
+cust_refund, cust_credit or cust_pay).
- while ( my $row = $sth->fetchrow_arrayref ) {
- print CACHE $row->[0]. "\n";
- }
+If TABLE is "cust_bill" or the unapplied_date option is true, only
+considers records with date earlier than START_TIME, and optionally not
+later than END_TIME .
+
+=cut
- }
+sub _money_table_where {
+ my( $class, $table, $start, $end, %opt ) = @_;
- close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
-
- rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
- close LOCK;
+ my @where = ();
+ push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
+ if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
+ push @where, "$table._date <= $start" if defined($start) && length($start);
+ push @where, "$table._date > $end" if defined($end) && length($end);
}
+ push @where, @{$opt{'where'}} if $opt{'where'};
+ my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
+
+ $where;
}
-=item all_X
+#for dyanmic FS::$table->search in httemplate/misc/email_customers.html
+use FS::cust_main::Search;
+sub search {
+ my $class = shift;
+ FS::cust_main::Search->search(@_);
+}
-=cut
+=back
-sub all_X {
- my( $self, $field ) = @_;
- my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
- open(CACHE,"<$dir/cust_main.$field")
- or die "can't open $dir/cust_main.$field: $!";
- my @array = map { chomp; $_; } <CACHE>;
- close CACHE;
- \@array;
-}
+=head1 SUBROUTINES
+
+=over 4
=item append_fuzzyfiles FIRSTNAME LASTNAME COMPANY ADDRESS1
=cut
+use FS::cust_main::Search;
sub append_fuzzyfiles {
#my( $first, $last, $company ) = @_;
- &check_and_rebuild_fuzzyfiles;
+ FS::cust_main::Search::check_and_rebuild_fuzzyfiles();
use Fcntl qw(:flock);
sub _upgrade_data { #class method
my ($class, %opts) = @_;
- my $sql = 'UPDATE h_cust_main SET paycvv = NULL WHERE paycvv IS NOT NULL';
- my $sth = dbh->prepare($sql) or die dbh->errstr;
- $sth->execute or die $sth->errstr;
+ my @statements = (
+ 'UPDATE h_cust_main SET paycvv = NULL WHERE paycvv IS NOT NULL',
+ 'UPDATE cust_main SET signupdate = (SELECT signupdate FROM h_cust_main WHERE signupdate IS NOT NULL AND h_cust_main.custnum = cust_main.custnum ORDER BY historynum DESC LIMIT 1) WHERE signupdate IS NULL',
+ );
+ # fix yyyy-m-dd formatted paydates
+ if ( driver_name =~ /^mysql$/i ) {
+ push @statements,
+ "UPDATE cust_main SET paydate = CONCAT( SUBSTRING(paydate FROM 1 FOR 5), '0', SUBSTRING(paydate FROM 6) ) WHERE SUBSTRING(paydate FROM 7 FOR 1) = '-'";
+ }
+ else { # the SQL standard
+ push @statements,
+ "UPDATE cust_main SET paydate = SUBSTRING(paydate FROM 1 FOR 5) || '0' || SUBSTRING(paydate FROM 6) WHERE SUBSTRING(paydate FROM 7 FOR 1) = '-'";
+ }
+
+ foreach my $sql ( @statements ) {
+ my $sth = dbh->prepare($sql) or die dbh->errstr;
+ $sth->execute or die $sth->errstr;
+ }
local($ignore_expired_card) = 1;
+ local($ignore_illegal_zip) = 1;
+ local($ignore_banned_card) = 1;
local($skip_fuzzyfiles) = 1;
$class->_upgrade_otaker(%opts);
projects / freeside.git / blobdiff