5 use vars qw( @ISA @EXPORT_OK $DEBUG $me $conf @encrypted_fields
6 $import $skip_fuzzyfiles $ignore_expired_card @paytypes);
7 use vars qw( $realtime_bop_decline_quiet ); #ugh
11 use Scalar::Util qw( blessed );
12 use Time::Local qw(timelocal_nocheck);
15 use Digest::MD5 qw(md5_base64);
19 use String::Approx qw(amatch);
20 use Business::CreditCard 0.28;
22 use FS::UID qw( getotaker dbh driver_name );
23 use FS::Record qw( qsearchs qsearch dbdef );
24 use FS::Misc qw( generate_email send_email generate_ps do_print );
25 use FS::Msgcat qw(gettext);
29 use FS::cust_bill_pkg;
31 use FS::cust_pay_pending;
32 use FS::cust_pay_void;
33 use FS::cust_pay_batch;
36 use FS::part_referral;
37 use FS::cust_main_county;
39 use FS::cust_main_invoice;
40 use FS::cust_credit_bill;
41 use FS::cust_bill_pay;
42 use FS::prepay_credit;
46 use FS::part_event_condition;
49 use FS::payment_gateway;
50 use FS::agent_payment_gateway;
52 use FS::payinfo_Mixin;
55 @ISA = qw( FS::payinfo_Mixin FS::Record );
57 @EXPORT_OK = qw( smart_search );
59 $realtime_bop_decline_quiet = 0;
61 # 1 is mostly method/subroutine entry and options
62 # 2 traces progress of some operations
63 # 3 is even more information including possibly sensitive data
65 $me = '[FS::cust_main]';
69 $ignore_expired_card = 0;
71 @encrypted_fields = ('payinfo', 'paycvv');
72 @paytypes = ('', 'Personal checking', 'Personal savings', 'Business checking', 'Business savings');
74 #ask FS::UID to run this stuff for us later
75 #$FS::UID::callback{'FS::cust_main'} = sub {
76 install_callback FS::UID sub {
78 #yes, need it for stuff below (prolly should be cached)
83 my ( $hashref, $cache ) = @_;
84 if ( exists $hashref->{'pkgnum'} ) {
85 #@{ $self->{'_pkgnum'} } = ();
86 my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
87 $self->{'_pkgnum'} = $subcache;
88 #push @{ $self->{'_pkgnum'} },
89 FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
95 FS::cust_main - Object methods for cust_main records
101 $record = new FS::cust_main \%hash;
102 $record = new FS::cust_main { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 @cust_pkg = $record->all_pkgs;
114 @cust_pkg = $record->ncancelled_pkgs;
116 @cust_pkg = $record->suspended_pkgs;
118 $error = $record->bill;
119 $error = $record->bill %options;
120 $error = $record->bill 'time' => $time;
122 $error = $record->collect;
123 $error = $record->collect %options;
124 $error = $record->collect 'invoice_time' => $time,
129 An FS::cust_main object represents a customer. FS::cust_main inherits from
130 FS::Record. The following fields are currently supported:
134 =item custnum - primary key (assigned automatically for new customers)
136 =item agentnum - agent (see L<FS::agent>)
138 =item refnum - Advertising source (see L<FS::part_referral>)
144 =item ss - social security number (optional)
146 =item company - (optional)
150 =item address2 - (optional)
154 =item county - (optional, see L<FS::cust_main_county>)
156 =item state - (see L<FS::cust_main_county>)
160 =item country - (see L<FS::cust_main_county>)
162 =item daytime - phone (optional)
164 =item night - phone (optional)
166 =item fax - phone (optional)
168 =item ship_first - name
170 =item ship_last - name
172 =item ship_company - (optional)
176 =item ship_address2 - (optional)
180 =item ship_county - (optional, see L<FS::cust_main_county>)
182 =item ship_state - (see L<FS::cust_main_county>)
186 =item ship_country - (see L<FS::cust_main_county>)
188 =item ship_daytime - phone (optional)
190 =item ship_night - phone (optional)
192 =item ship_fax - phone (optional)
194 =item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values)
196 =item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format)
198 =item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works)
202 Card Verification Value, "CVV2" (also known as CVC2 or CID), the 3 or 4 digit number on the back (or front, for American Express) of the credit card
204 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
206 =item paystart_month - start date month (maestro/solo cards only)
208 =item paystart_year - start date year (maestro/solo cards only)
210 =item payissue - issue number (maestro/solo cards only)
212 =item payname - name on card or billing name
214 =item payip - IP address from which payment information was received
216 =item tax - tax exempt, empty or `Y'
218 =item otaker - order taker (assigned automatically, see L<FS::UID>)
220 =item comments - comments (optional)
222 =item referral_custnum - referring customer number
224 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
226 =item squelch_cdr - Discourage individual CDR printing, empty or `Y'
236 Creates a new customer. To add the customer to the database, see L<"insert">.
238 Note that this stores the hash reference, not a distinct copy of the hash it
239 points to. You can ask the object for a copy with the I<hash> method.
243 sub table { 'cust_main'; }
245 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
247 Adds this customer to the database. If there is an error, returns the error,
248 otherwise returns false.
250 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
251 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
252 are inserted atomicly, or the transaction is rolled back. Passing an empty
253 hash reference is equivalent to not supplying this parameter. There should be
254 a better explanation of this, but until then, here's an example:
257 tie %hash, 'Tie::RefHash'; #this part is important
259 $cust_pkg => [ $svc_acct ],
262 $cust_main->insert( \%hash );
264 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
265 be set as the invoicing list (see L<"invoicing_list">). Errors return as
266 expected and rollback the entire transaction; it is not necessary to call
267 check_invoicing_list first. The invoicing_list is set after the records in the
268 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
269 invoicing_list destination to the newly-created svc_acct. Here's an example:
271 $cust_main->insert( {}, [ $email, 'POST' ] );
273 Currently available options are: I<depend_jobnum> and I<noexport>.
275 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
276 on the supplied jobnum (they will not run until the specific job completes).
277 This can be used to defer provisioning until some action completes (such
278 as running the customer's credit card successfully).
280 The I<noexport> option is deprecated. If I<noexport> is set true, no
281 provisioning jobs (exports) are scheduled. (You can schedule them later with
282 the B<reexport> method.)
288 my $cust_pkgs = @_ ? shift : {};
289 my $invoicing_list = @_ ? shift : '';
291 warn "$me insert called with options ".
292 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
295 local $SIG{HUP} = 'IGNORE';
296 local $SIG{INT} = 'IGNORE';
297 local $SIG{QUIT} = 'IGNORE';
298 local $SIG{TERM} = 'IGNORE';
299 local $SIG{TSTP} = 'IGNORE';
300 local $SIG{PIPE} = 'IGNORE';
302 my $oldAutoCommit = $FS::UID::AutoCommit;
303 local $FS::UID::AutoCommit = 0;
306 my $prepay_identifier = '';
307 my( $amount, $seconds ) = ( 0, 0 );
309 if ( $self->payby eq 'PREPAY' ) {
311 $self->payby('BILL');
312 $prepay_identifier = $self->payinfo;
315 warn " looking up prepaid card $prepay_identifier\n"
318 my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
320 $dbh->rollback if $oldAutoCommit;
321 #return "error applying prepaid card (transaction rolled back): $error";
325 $payby = 'PREP' if $amount;
327 } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
330 $self->payby('BILL');
331 $amount = $self->paid;
335 warn " inserting $self\n"
338 $self->signupdate(time) unless $self->signupdate;
340 my $error = $self->SUPER::insert;
342 $dbh->rollback if $oldAutoCommit;
343 #return "inserting cust_main record (transaction rolled back): $error";
347 warn " setting invoicing list\n"
350 if ( $invoicing_list ) {
351 $error = $self->check_invoicing_list( $invoicing_list );
353 $dbh->rollback if $oldAutoCommit;
354 #return "checking invoicing_list (transaction rolled back): $error";
357 $self->invoicing_list( $invoicing_list );
360 if ( $conf->config('cust_main-skeleton_tables')
361 && $conf->config('cust_main-skeleton_custnum') ) {
363 warn " inserting skeleton records\n"
366 my $error = $self->start_copy_skel;
368 $dbh->rollback if $oldAutoCommit;
374 warn " ordering packages\n"
377 $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
379 $dbh->rollback if $oldAutoCommit;
384 $dbh->rollback if $oldAutoCommit;
385 return "No svc_acct record to apply pre-paid time";
389 warn " inserting initial $payby payment of $amount\n"
391 $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
393 $dbh->rollback if $oldAutoCommit;
394 return "inserting payment (transaction rolled back): $error";
398 unless ( $import || $skip_fuzzyfiles ) {
399 warn " queueing fuzzyfiles update\n"
401 $error = $self->queue_fuzzyfiles_update;
403 $dbh->rollback if $oldAutoCommit;
404 return "updating fuzzy search cache: $error";
408 warn " insert complete; committing transaction\n"
411 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
416 sub start_copy_skel {
419 #'mg_user_preference' => {},
420 #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
421 #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
422 #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
423 #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
424 my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
427 _copy_skel( 'cust_main', #tablename
428 $conf->config('cust_main-skeleton_custnum'), #sourceid
429 $self->custnum, #destid
430 @tables, #child tables
434 #recursive subroutine, not a method
436 my( $table, $sourceid, $destid, %child_tables ) = @_;
439 if ( $table =~ /^(\w+)\.(\w+)$/ ) {
440 ( $table, $primary_key ) = ( $1, $2 );
442 my $dbdef_table = dbdef->table($table);
443 $primary_key = $dbdef_table->primary_key
444 or return "$table has no primary key".
445 " (or do you need to run dbdef-create?)";
448 warn " _copy_skel: $table.$primary_key $sourceid to $destid for ".
449 join (', ', keys %child_tables). "\n"
452 foreach my $child_table_def ( keys %child_tables ) {
456 if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
457 ( $child_table, $child_pkey ) = ( $1, $2 );
459 $child_table = $child_table_def;
461 $child_pkey = dbdef->table($child_table)->primary_key;
462 # or return "$table has no primary key".
463 # " (or do you need to run dbdef-create?)\n";
467 if ( keys %{ $child_tables{$child_table_def} } ) {
469 return "$child_table has no primary key".
470 " (run dbdef-create or try specifying it?)\n"
473 #false laziness w/Record::insert and only works on Pg
474 #refactor the proper last-inserted-id stuff out of Record::insert if this
475 # ever gets use for anything besides a quick kludge for one customer
476 my $default = dbdef->table($child_table)->column($child_pkey)->default;
477 $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
478 or return "can't parse $child_table.$child_pkey default value ".
479 " for sequence name: $default";
484 my @sel_columns = grep { $_ ne $primary_key }
485 dbdef->table($child_table)->columns;
486 my $sel_columns = join(', ', @sel_columns );
488 my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
489 my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
490 my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
492 my $sel_st = "SELECT $sel_columns FROM $child_table".
493 " WHERE $primary_key = $sourceid";
496 my $sel_sth = dbh->prepare( $sel_st )
497 or return dbh->errstr;
499 $sel_sth->execute or return $sel_sth->errstr;
501 while ( my $row = $sel_sth->fetchrow_hashref ) {
503 warn " selected row: ".
504 join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
508 "INSERT INTO $child_table $ins_columns VALUES $placeholders";
509 my $ins_sth =dbh->prepare($statement)
510 or return dbh->errstr;
511 my @param = ( $destid, map $row->{$_}, @ins_columns );
512 warn " $statement: [ ". join(', ', @param). " ]\n"
514 $ins_sth->execute( @param )
515 or return $ins_sth->errstr;
517 #next unless keys %{ $child_tables{$child_table} };
518 next unless $sequence;
520 #another section of that laziness
521 my $seq_sql = "SELECT currval('$sequence')";
522 my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
523 $seq_sth->execute or return $seq_sth->errstr;
524 my $insertid = $seq_sth->fetchrow_arrayref->[0];
526 # don't drink soap! recurse! recurse! okay!
528 _copy_skel( $child_table_def,
529 $row->{$child_pkey}, #sourceid
531 %{ $child_tables{$child_table_def} },
533 return $error if $error;
543 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
545 Like the insert method on an existing record, this method orders a package
546 and included services atomicaly. Pass a Tie::RefHash data structure to this
547 method containing FS::cust_pkg and FS::svc_I<tablename> objects. There should
548 be a better explanation of this, but until then, here's an example:
551 tie %hash, 'Tie::RefHash'; #this part is important
553 $cust_pkg => [ $svc_acct ],
556 $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
558 Services can be new, in which case they are inserted, or existing unaudited
559 services, in which case they are linked to the newly-created package.
561 Currently available options are: I<depend_jobnum> and I<noexport>.
563 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
564 on the supplied jobnum (they will not run until the specific job completes).
565 This can be used to defer provisioning until some action completes (such
566 as running the customer's credit card successfully).
568 The I<noexport> option is deprecated. If I<noexport> is set true, no
569 provisioning jobs (exports) are scheduled. (You can schedule them later with
570 the B<reexport> method for each cust_pkg object. Using the B<reexport> method
571 on the cust_main object is not recommended, as existing services will also be
578 my $cust_pkgs = shift;
581 my %svc_options = ();
582 $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
583 if exists $options{'depend_jobnum'};
584 warn "$me order_pkgs called with options ".
585 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
588 local $SIG{HUP} = 'IGNORE';
589 local $SIG{INT} = 'IGNORE';
590 local $SIG{QUIT} = 'IGNORE';
591 local $SIG{TERM} = 'IGNORE';
592 local $SIG{TSTP} = 'IGNORE';
593 local $SIG{PIPE} = 'IGNORE';
595 my $oldAutoCommit = $FS::UID::AutoCommit;
596 local $FS::UID::AutoCommit = 0;
599 local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
601 foreach my $cust_pkg ( keys %$cust_pkgs ) {
602 $cust_pkg->custnum( $self->custnum );
603 my $error = $cust_pkg->insert;
605 $dbh->rollback if $oldAutoCommit;
606 return "inserting cust_pkg (transaction rolled back): $error";
608 foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
609 if ( $svc_something->svcnum ) {
610 my $old_cust_svc = $svc_something->cust_svc;
611 my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
612 $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
613 $error = $new_cust_svc->replace($old_cust_svc);
615 $svc_something->pkgnum( $cust_pkg->pkgnum );
616 if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
617 $svc_something->seconds( $svc_something->seconds + $$seconds );
620 $error = $svc_something->insert(%svc_options);
623 $dbh->rollback if $oldAutoCommit;
624 #return "inserting svc_ (transaction rolled back): $error";
630 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
634 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ]
636 Recharges this (existing) customer with the specified prepaid card (see
637 L<FS::prepay_credit>), specified either by I<identifier> or as an
638 FS::prepay_credit object. If there is an error, returns the error, otherwise
641 Optionally, four scalar references can be passed as well. They will have their
642 values filled in with the amount, number of seconds, and number of upload and
643 download bytes applied by this prepaid
648 sub recharge_prepay {
649 my( $self, $prepay_credit, $amountref, $secondsref,
650 $upbytesref, $downbytesref, $totalbytesref ) = @_;
652 local $SIG{HUP} = 'IGNORE';
653 local $SIG{INT} = 'IGNORE';
654 local $SIG{QUIT} = 'IGNORE';
655 local $SIG{TERM} = 'IGNORE';
656 local $SIG{TSTP} = 'IGNORE';
657 local $SIG{PIPE} = 'IGNORE';
659 my $oldAutoCommit = $FS::UID::AutoCommit;
660 local $FS::UID::AutoCommit = 0;
663 my( $amount, $seconds, $upbytes, $downbytes, $totalbytes) = ( 0, 0, 0, 0, 0 );
665 my $error = $self->get_prepay($prepay_credit, \$amount,
666 \$seconds, \$upbytes, \$downbytes, \$totalbytes)
667 || $self->increment_seconds($seconds)
668 || $self->increment_upbytes($upbytes)
669 || $self->increment_downbytes($downbytes)
670 || $self->increment_totalbytes($totalbytes)
671 || $self->insert_cust_pay_prepay( $amount,
673 ? $prepay_credit->identifier
678 $dbh->rollback if $oldAutoCommit;
682 if ( defined($amountref) ) { $$amountref = $amount; }
683 if ( defined($secondsref) ) { $$secondsref = $seconds; }
684 if ( defined($upbytesref) ) { $$upbytesref = $upbytes; }
685 if ( defined($downbytesref) ) { $$downbytesref = $downbytes; }
686 if ( defined($totalbytesref) ) { $$totalbytesref = $totalbytes; }
688 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
693 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ , AMOUNTREF, SECONDSREF
695 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
696 specified either by I<identifier> or as an FS::prepay_credit object.
698 References to I<amount> and I<seconds> scalars should be passed as arguments
699 and will be incremented by the values of the prepaid card.
701 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
702 check or set this customer's I<agentnum>.
704 If there is an error, returns the error, otherwise returns false.
710 my( $self, $prepay_credit, $amountref, $secondsref,
711 $upref, $downref, $totalref) = @_;
713 local $SIG{HUP} = 'IGNORE';
714 local $SIG{INT} = 'IGNORE';
715 local $SIG{QUIT} = 'IGNORE';
716 local $SIG{TERM} = 'IGNORE';
717 local $SIG{TSTP} = 'IGNORE';
718 local $SIG{PIPE} = 'IGNORE';
720 my $oldAutoCommit = $FS::UID::AutoCommit;
721 local $FS::UID::AutoCommit = 0;
724 unless ( ref($prepay_credit) ) {
726 my $identifier = $prepay_credit;
728 $prepay_credit = qsearchs(
730 { 'identifier' => $prepay_credit },
735 unless ( $prepay_credit ) {
736 $dbh->rollback if $oldAutoCommit;
737 return "Invalid prepaid card: ". $identifier;
742 if ( $prepay_credit->agentnum ) {
743 if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
744 $dbh->rollback if $oldAutoCommit;
745 return "prepaid card not valid for agent ". $self->agentnum;
747 $self->agentnum($prepay_credit->agentnum);
750 my $error = $prepay_credit->delete;
752 $dbh->rollback if $oldAutoCommit;
753 return "removing prepay_credit (transaction rolled back): $error";
756 $$amountref += $prepay_credit->amount;
757 $$secondsref += $prepay_credit->seconds;
758 $$upref += $prepay_credit->upbytes;
759 $$downref += $prepay_credit->downbytes;
760 $$totalref += $prepay_credit->totalbytes;
762 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
767 =item increment_upbytes SECONDS
769 Updates this customer's single or primary account (see L<FS::svc_acct>) by
770 the specified number of upbytes. If there is an error, returns the error,
771 otherwise returns false.
775 sub increment_upbytes {
776 _increment_column( shift, 'upbytes', @_);
779 =item increment_downbytes SECONDS
781 Updates this customer's single or primary account (see L<FS::svc_acct>) by
782 the specified number of downbytes. If there is an error, returns the error,
783 otherwise returns false.
787 sub increment_downbytes {
788 _increment_column( shift, 'downbytes', @_);
791 =item increment_totalbytes SECONDS
793 Updates this customer's single or primary account (see L<FS::svc_acct>) by
794 the specified number of totalbytes. If there is an error, returns the error,
795 otherwise returns false.
799 sub increment_totalbytes {
800 _increment_column( shift, 'totalbytes', @_);
803 =item increment_seconds SECONDS
805 Updates this customer's single or primary account (see L<FS::svc_acct>) by
806 the specified number of seconds. If there is an error, returns the error,
807 otherwise returns false.
811 sub increment_seconds {
812 _increment_column( shift, 'seconds', @_);
815 =item _increment_column AMOUNT
817 Updates this customer's single or primary account (see L<FS::svc_acct>) by
818 the specified number of seconds or bytes. If there is an error, returns
819 the error, otherwise returns false.
823 sub _increment_column {
824 my( $self, $column, $amount ) = @_;
825 warn "$me increment_column called: $column, $amount\n"
828 return '' unless $amount;
830 my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
831 $self->ncancelled_pkgs;
834 return 'No packages with primary or single services found'.
835 ' to apply pre-paid time';
836 } elsif ( scalar(@cust_pkg) > 1 ) {
837 #maybe have a way to specify the package/account?
838 return 'Multiple packages found to apply pre-paid time';
841 my $cust_pkg = $cust_pkg[0];
842 warn " found package pkgnum ". $cust_pkg->pkgnum. "\n"
846 $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
849 return 'No account found to apply pre-paid time';
850 } elsif ( scalar(@cust_svc) > 1 ) {
851 return 'Multiple accounts found to apply pre-paid time';
854 my $svc_acct = $cust_svc[0]->svc_x;
855 warn " found service svcnum ". $svc_acct->pkgnum.
856 ' ('. $svc_acct->email. ")\n"
859 $column = "increment_$column";
860 $svc_acct->$column($amount);
864 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
866 Inserts a prepayment in the specified amount for this customer. An optional
867 second argument can specify the prepayment identifier for tracking purposes.
868 If there is an error, returns the error, otherwise returns false.
872 sub insert_cust_pay_prepay {
873 shift->insert_cust_pay('PREP', @_);
876 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
878 Inserts a cash payment in the specified amount for this customer. An optional
879 second argument can specify the payment identifier for tracking purposes.
880 If there is an error, returns the error, otherwise returns false.
884 sub insert_cust_pay_cash {
885 shift->insert_cust_pay('CASH', @_);
888 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
890 Inserts a Western Union payment in the specified amount for this customer. An
891 optional second argument can specify the prepayment identifier for tracking
892 purposes. If there is an error, returns the error, otherwise returns false.
896 sub insert_cust_pay_west {
897 shift->insert_cust_pay('WEST', @_);
900 sub insert_cust_pay {
901 my( $self, $payby, $amount ) = splice(@_, 0, 3);
902 my $payinfo = scalar(@_) ? shift : '';
904 my $cust_pay = new FS::cust_pay {
905 'custnum' => $self->custnum,
906 'paid' => sprintf('%.2f', $amount),
907 #'_date' => #date the prepaid card was purchased???
909 'payinfo' => $payinfo,
917 This method is deprecated. See the I<depend_jobnum> option to the insert and
918 order_pkgs methods for a better way to defer provisioning.
920 Re-schedules all exports by calling the B<reexport> method of all associated
921 packages (see L<FS::cust_pkg>). If there is an error, returns the error;
922 otherwise returns false.
929 carp "WARNING: FS::cust_main::reexport is deprectated; ".
930 "use the depend_jobnum option to insert or order_pkgs to delay export";
932 local $SIG{HUP} = 'IGNORE';
933 local $SIG{INT} = 'IGNORE';
934 local $SIG{QUIT} = 'IGNORE';
935 local $SIG{TERM} = 'IGNORE';
936 local $SIG{TSTP} = 'IGNORE';
937 local $SIG{PIPE} = 'IGNORE';
939 my $oldAutoCommit = $FS::UID::AutoCommit;
940 local $FS::UID::AutoCommit = 0;
943 foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
944 my $error = $cust_pkg->reexport;
946 $dbh->rollback if $oldAutoCommit;
951 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
956 =item delete NEW_CUSTNUM
958 This deletes the customer. If there is an error, returns the error, otherwise
961 This will completely remove all traces of the customer record. This is not
962 what you want when a customer cancels service; for that, cancel all of the
963 customer's packages (see L</cancel>).
965 If the customer has any uncancelled packages, you need to pass a new (valid)
966 customer number for those packages to be transferred to. Cancelled packages
967 will be deleted. Did I mention that this is NOT what you want when a customer
968 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
970 You can't delete a customer with invoices (see L<FS::cust_bill>),
971 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
972 refunds (see L<FS::cust_refund>).
979 local $SIG{HUP} = 'IGNORE';
980 local $SIG{INT} = 'IGNORE';
981 local $SIG{QUIT} = 'IGNORE';
982 local $SIG{TERM} = 'IGNORE';
983 local $SIG{TSTP} = 'IGNORE';
984 local $SIG{PIPE} = 'IGNORE';
986 my $oldAutoCommit = $FS::UID::AutoCommit;
987 local $FS::UID::AutoCommit = 0;
990 if ( $self->cust_bill ) {
991 $dbh->rollback if $oldAutoCommit;
992 return "Can't delete a customer with invoices";
994 if ( $self->cust_credit ) {
995 $dbh->rollback if $oldAutoCommit;
996 return "Can't delete a customer with credits";
998 if ( $self->cust_pay ) {
999 $dbh->rollback if $oldAutoCommit;
1000 return "Can't delete a customer with payments";
1002 if ( $self->cust_refund ) {
1003 $dbh->rollback if $oldAutoCommit;
1004 return "Can't delete a customer with refunds";
1007 my @cust_pkg = $self->ncancelled_pkgs;
1009 my $new_custnum = shift;
1010 unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
1011 $dbh->rollback if $oldAutoCommit;
1012 return "Invalid new customer number: $new_custnum";
1014 foreach my $cust_pkg ( @cust_pkg ) {
1015 my %hash = $cust_pkg->hash;
1016 $hash{'custnum'} = $new_custnum;
1017 my $new_cust_pkg = new FS::cust_pkg ( \%hash );
1018 my $error = $new_cust_pkg->replace($cust_pkg,
1019 options => { $cust_pkg->options },
1022 $dbh->rollback if $oldAutoCommit;
1027 my @cancelled_cust_pkg = $self->all_pkgs;
1028 foreach my $cust_pkg ( @cancelled_cust_pkg ) {
1029 my $error = $cust_pkg->delete;
1031 $dbh->rollback if $oldAutoCommit;
1036 foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1037 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1039 my $error = $cust_main_invoice->delete;
1041 $dbh->rollback if $oldAutoCommit;
1046 my $error = $self->SUPER::delete;
1048 $dbh->rollback if $oldAutoCommit;
1052 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1057 =item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ]
1059 Replaces the OLD_RECORD with this one in the database. If there is an error,
1060 returns the error, otherwise returns false.
1062 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1063 be set as the invoicing list (see L<"invoicing_list">). Errors return as
1064 expected and rollback the entire transaction; it is not necessary to call
1065 check_invoicing_list first. Here's an example:
1067 $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1074 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
1076 : $self->replace_old;
1080 warn "$me replace called\n"
1083 my $curuser = $FS::CurrentUser::CurrentUser;
1084 if ( $self->payby eq 'COMP'
1085 && $self->payby ne $old->payby
1086 && ! $curuser->access_right('Complimentary customer')
1089 return "You are not permitted to create complimentary accounts.";
1092 local($ignore_expired_card) = 1
1093 if $old->payby =~ /^(CARD|DCRD)$/
1094 && $self->payby =~ /^(CARD|DCRD)$/
1095 && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
1097 local $SIG{HUP} = 'IGNORE';
1098 local $SIG{INT} = 'IGNORE';
1099 local $SIG{QUIT} = 'IGNORE';
1100 local $SIG{TERM} = 'IGNORE';
1101 local $SIG{TSTP} = 'IGNORE';
1102 local $SIG{PIPE} = 'IGNORE';
1104 my $oldAutoCommit = $FS::UID::AutoCommit;
1105 local $FS::UID::AutoCommit = 0;
1108 my $error = $self->SUPER::replace($old);
1111 $dbh->rollback if $oldAutoCommit;
1115 if ( @param ) { # INVOICING_LIST_ARYREF
1116 my $invoicing_list = shift @param;
1117 $error = $self->check_invoicing_list( $invoicing_list );
1119 $dbh->rollback if $oldAutoCommit;
1122 $self->invoicing_list( $invoicing_list );
1125 if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1126 grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1127 # card/check/lec info has changed, want to retry realtime_ invoice events
1128 my $error = $self->retry_realtime;
1130 $dbh->rollback if $oldAutoCommit;
1135 unless ( $import || $skip_fuzzyfiles ) {
1136 $error = $self->queue_fuzzyfiles_update;
1138 $dbh->rollback if $oldAutoCommit;
1139 return "updating fuzzy search cache: $error";
1143 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1148 =item queue_fuzzyfiles_update
1150 Used by insert & replace to update the fuzzy search cache
1154 sub queue_fuzzyfiles_update {
1157 local $SIG{HUP} = 'IGNORE';
1158 local $SIG{INT} = 'IGNORE';
1159 local $SIG{QUIT} = 'IGNORE';
1160 local $SIG{TERM} = 'IGNORE';
1161 local $SIG{TSTP} = 'IGNORE';
1162 local $SIG{PIPE} = 'IGNORE';
1164 my $oldAutoCommit = $FS::UID::AutoCommit;
1165 local $FS::UID::AutoCommit = 0;
1168 my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1169 my $error = $queue->insert( map $self->getfield($_),
1170 qw(first last company)
1173 $dbh->rollback if $oldAutoCommit;
1174 return "queueing job (transaction rolled back): $error";
1177 if ( $self->ship_last ) {
1178 $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1179 $error = $queue->insert( map $self->getfield("ship_$_"),
1180 qw(first last company)
1183 $dbh->rollback if $oldAutoCommit;
1184 return "queueing job (transaction rolled back): $error";
1188 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1195 Checks all fields to make sure this is a valid customer record. If there is
1196 an error, returns the error, otherwise returns false. Called by the insert
1197 and replace methods.
1204 warn "$me check BEFORE: \n". $self->_dump
1208 $self->ut_numbern('custnum')
1209 || $self->ut_number('agentnum')
1210 || $self->ut_textn('agent_custid')
1211 || $self->ut_number('refnum')
1212 || $self->ut_name('last')
1213 || $self->ut_name('first')
1214 || $self->ut_snumbern('birthdate')
1215 || $self->ut_snumbern('signupdate')
1216 || $self->ut_textn('company')
1217 || $self->ut_text('address1')
1218 || $self->ut_textn('address2')
1219 || $self->ut_text('city')
1220 || $self->ut_textn('county')
1221 || $self->ut_textn('state')
1222 || $self->ut_country('country')
1223 || $self->ut_anything('comments')
1224 || $self->ut_numbern('referral_custnum')
1225 || $self->ut_textn('stateid')
1226 || $self->ut_textn('stateid_state')
1227 || $self->ut_textn('invoice_terms')
1229 #barf. need message catalogs. i18n. etc.
1230 $error .= "Please select an advertising source."
1231 if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1232 return $error if $error;
1234 return "Unknown agent"
1235 unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1237 return "Unknown refnum"
1238 unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1240 return "Unknown referring custnum: ". $self->referral_custnum
1241 unless ! $self->referral_custnum
1242 || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1244 if ( $self->ss eq '' ) {
1249 $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1250 or return "Illegal social security number: ". $self->ss;
1251 $self->ss("$1-$2-$3");
1255 # bad idea to disable, causes billing to fail because of no tax rates later
1256 # unless ( $import ) {
1257 unless ( qsearch('cust_main_county', {
1258 'country' => $self->country,
1261 return "Unknown state/county/country: ".
1262 $self->state. "/". $self->county. "/". $self->country
1263 unless qsearch('cust_main_county',{
1264 'state' => $self->state,
1265 'county' => $self->county,
1266 'country' => $self->country,
1272 $self->ut_phonen('daytime', $self->country)
1273 || $self->ut_phonen('night', $self->country)
1274 || $self->ut_phonen('fax', $self->country)
1275 || $self->ut_zip('zip', $self->country)
1277 return $error if $error;
1279 if ( $conf->exists('cust_main-require_phone')
1280 && ! length($self->daytime) && ! length($self->night)
1283 my $daytime_label = FS::Msgcat::_gettext('daytime') =~ /^(daytime)?$/
1285 : FS::Msgcat::_gettext('daytime');
1286 my $night_label = FS::Msgcat::_gettext('night') =~ /^(night)?$/
1288 : FS::Msgcat::_gettext('night');
1290 return "$daytime_label or $night_label is required"
1294 if ( $self->has_ship_address
1295 && scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1296 $self->addr_fields )
1300 $self->ut_name('ship_last')
1301 || $self->ut_name('ship_first')
1302 || $self->ut_textn('ship_company')
1303 || $self->ut_text('ship_address1')
1304 || $self->ut_textn('ship_address2')
1305 || $self->ut_text('ship_city')
1306 || $self->ut_textn('ship_county')
1307 || $self->ut_textn('ship_state')
1308 || $self->ut_country('ship_country')
1310 return $error if $error;
1312 #false laziness with above
1313 unless ( qsearchs('cust_main_county', {
1314 'country' => $self->ship_country,
1317 return "Unknown ship_state/ship_county/ship_country: ".
1318 $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1319 unless qsearch('cust_main_county',{
1320 'state' => $self->ship_state,
1321 'county' => $self->ship_county,
1322 'country' => $self->ship_country,
1328 $self->ut_phonen('ship_daytime', $self->ship_country)
1329 || $self->ut_phonen('ship_night', $self->ship_country)
1330 || $self->ut_phonen('ship_fax', $self->ship_country)
1331 || $self->ut_zip('ship_zip', $self->ship_country)
1333 return $error if $error;
1335 return "Unit # is required."
1336 if $self->ship_address2 =~ /^\s*$/
1337 && $conf->exists('cust_main-require_address2');
1339 } else { # ship_ info eq billing info, so don't store dup info in database
1341 $self->setfield("ship_$_", '')
1342 foreach $self->addr_fields;
1344 return "Unit # is required."
1345 if $self->address2 =~ /^\s*$/
1346 && $conf->exists('cust_main-require_address2');
1350 #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1351 # or return "Illegal payby: ". $self->payby;
1353 FS::payby->can_payby($self->table, $self->payby)
1354 or return "Illegal payby: ". $self->payby;
1356 $error = $self->ut_numbern('paystart_month')
1357 || $self->ut_numbern('paystart_year')
1358 || $self->ut_numbern('payissue')
1359 || $self->ut_textn('paytype')
1361 return $error if $error;
1363 if ( $self->payip eq '' ) {
1366 $error = $self->ut_ip('payip');
1367 return $error if $error;
1370 # If it is encrypted and the private key is not availaible then we can't
1371 # check the credit card.
1373 my $check_payinfo = 1;
1375 if ($self->is_encrypted($self->payinfo)) {
1379 if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1381 my $payinfo = $self->payinfo;
1382 $payinfo =~ s/\D//g;
1383 $payinfo =~ /^(\d{13,16})$/
1384 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1386 $self->payinfo($payinfo);
1388 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1390 return gettext('unknown_card_type')
1391 if cardtype($self->payinfo) eq "Unknown";
1393 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1395 return 'Banned credit card: banned on '.
1396 time2str('%a %h %o at %r', $ban->_date).
1397 ' by '. $ban->otaker.
1398 ' (ban# '. $ban->bannum. ')';
1401 if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1402 if ( cardtype($self->payinfo) eq 'American Express card' ) {
1403 $self->paycvv =~ /^(\d{4})$/
1404 or return "CVV2 (CID) for American Express cards is four digits.";
1407 $self->paycvv =~ /^(\d{3})$/
1408 or return "CVV2 (CVC2/CID) is three digits.";
1415 my $cardtype = cardtype($payinfo);
1416 if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1418 return "Start date or issue number is required for $cardtype cards"
1419 unless $self->paystart_month && $self->paystart_year or $self->payissue;
1421 return "Start month must be between 1 and 12"
1422 if $self->paystart_month
1423 and $self->paystart_month < 1 || $self->paystart_month > 12;
1425 return "Start year must be 1990 or later"
1426 if $self->paystart_year
1427 and $self->paystart_year < 1990;
1429 return "Issue number must be beween 1 and 99"
1431 and $self->payissue < 1 || $self->payissue > 99;
1434 $self->paystart_month('');
1435 $self->paystart_year('');
1436 $self->payissue('');
1439 } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1441 my $payinfo = $self->payinfo;
1442 $payinfo =~ s/[^\d\@]//g;
1443 if ( $conf->exists('echeck-nonus') ) {
1444 $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1445 $payinfo = "$1\@$2";
1447 $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1448 $payinfo = "$1\@$2";
1450 $self->payinfo($payinfo);
1453 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1455 return 'Banned ACH account: banned on '.
1456 time2str('%a %h %o at %r', $ban->_date).
1457 ' by '. $ban->otaker.
1458 ' (ban# '. $ban->bannum. ')';
1461 } elsif ( $self->payby eq 'LECB' ) {
1463 my $payinfo = $self->payinfo;
1464 $payinfo =~ s/\D//g;
1465 $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1467 $self->payinfo($payinfo);
1470 } elsif ( $self->payby eq 'BILL' ) {
1472 $error = $self->ut_textn('payinfo');
1473 return "Illegal P.O. number: ". $self->payinfo if $error;
1476 } elsif ( $self->payby eq 'COMP' ) {
1478 my $curuser = $FS::CurrentUser::CurrentUser;
1479 if ( ! $self->custnum
1480 && ! $curuser->access_right('Complimentary customer')
1483 return "You are not permitted to create complimentary accounts."
1486 $error = $self->ut_textn('payinfo');
1487 return "Illegal comp account issuer: ". $self->payinfo if $error;
1490 } elsif ( $self->payby eq 'PREPAY' ) {
1492 my $payinfo = $self->payinfo;
1493 $payinfo =~ s/\W//g; #anything else would just confuse things
1494 $self->payinfo($payinfo);
1495 $error = $self->ut_alpha('payinfo');
1496 return "Illegal prepayment identifier: ". $self->payinfo if $error;
1497 return "Unknown prepayment identifier"
1498 unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1503 if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1504 return "Expiration date required"
1505 unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1509 if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1510 ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1511 } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1512 ( $m, $y ) = ( $3, "20$2" );
1514 return "Illegal expiration date: ". $self->paydate;
1516 $self->paydate("$y-$m-01");
1517 my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1518 return gettext('expired_card')
1520 && !$ignore_expired_card
1521 && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1524 if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1525 ( ! $conf->exists('require_cardname')
1526 || $self->payby !~ /^(CARD|DCRD)$/ )
1528 $self->payname( $self->first. " ". $self->getfield('last') );
1530 $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1531 or return gettext('illegal_name'). " payname: ". $self->payname;
1535 foreach my $flag (qw( tax spool_cdr squelch_cdr )) {
1536 $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1540 $self->otaker(getotaker) unless $self->otaker;
1542 warn "$me check AFTER: \n". $self->_dump
1545 $self->SUPER::check;
1550 Returns a list of fields which have ship_ duplicates.
1555 qw( last first company
1556 address1 address2 city county state zip country
1561 =item has_ship_address
1563 Returns true if this customer record has a separate shipping address.
1567 sub has_ship_address {
1569 scalar( grep { $self->getfield("ship_$_") ne '' } $self->addr_fields );
1574 Returns all packages (see L<FS::cust_pkg>) for this customer.
1581 return $self->num_pkgs unless wantarray;
1584 if ( $self->{'_pkgnum'} ) {
1585 @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
1587 @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1590 sort sort_packages @cust_pkg;
1595 Synonym for B<all_pkgs>.
1600 shift->all_pkgs(@_);
1603 =item ncancelled_pkgs
1605 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1609 sub ncancelled_pkgs {
1612 return $self->num_ncancelled_pkgs unless wantarray;
1615 if ( $self->{'_pkgnum'} ) {
1617 warn "$me ncancelled_pkgs: returning cached objects"
1620 @cust_pkg = grep { ! $_->getfield('cancel') }
1621 values %{ $self->{'_pkgnum'}->cache };
1625 warn "$me ncancelled_pkgs: searching for packages with custnum ".
1626 $self->custnum. "\n"
1630 qsearch( 'cust_pkg', {
1631 'custnum' => $self->custnum,
1635 qsearch( 'cust_pkg', {
1636 'custnum' => $self->custnum,
1641 sort sort_packages @cust_pkg;
1645 # This should be generalized to use config options to determine order.
1647 if ( $a->get('cancel') and $b->get('cancel') ) {
1648 $a->pkgnum <=> $b->pkgnum;
1649 } elsif ( $a->get('cancel') or $b->get('cancel') ) {
1650 return -1 if $b->get('cancel');
1651 return 1 if $a->get('cancel');
1654 $a->pkgnum <=> $b->pkgnum;
1658 =item suspended_pkgs
1660 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1664 sub suspended_pkgs {
1666 grep { $_->susp } $self->ncancelled_pkgs;
1669 =item unflagged_suspended_pkgs
1671 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1672 customer (thouse packages without the `manual_flag' set).
1676 sub unflagged_suspended_pkgs {
1678 return $self->suspended_pkgs
1679 unless dbdef->table('cust_pkg')->column('manual_flag');
1680 grep { ! $_->manual_flag } $self->suspended_pkgs;
1683 =item unsuspended_pkgs
1685 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1690 sub unsuspended_pkgs {
1692 grep { ! $_->susp } $self->ncancelled_pkgs;
1695 =item num_cancelled_pkgs
1697 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1702 sub num_cancelled_pkgs {
1703 shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
1706 sub num_ncancelled_pkgs {
1707 shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
1711 my( $self ) = shift;
1712 my $sql = scalar(@_) ? shift : '';
1713 $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
1714 my $sth = dbh->prepare(
1715 "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
1716 ) or die dbh->errstr;
1717 $sth->execute($self->custnum) or die $sth->errstr;
1718 $sth->fetchrow_arrayref->[0];
1723 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1724 and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list
1725 on success or a list of errors.
1731 grep { $_->unsuspend } $self->suspended_pkgs;
1736 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1738 Returns a list: an empty list on success or a list of errors.
1744 grep { $_->suspend(@_) } $self->unsuspended_pkgs;
1747 =item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1749 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1750 PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead
1751 of a list of pkgparts; the hashref has the following keys:
1755 =item pkgparts - listref of pkgparts
1757 =item (other options are passed to the suspend method)
1762 Returns a list: an empty list on success or a list of errors.
1766 sub suspend_if_pkgpart {
1768 my (@pkgparts, %opt);
1769 if (ref($_[0]) eq 'HASH'){
1770 @pkgparts = @{$_[0]{pkgparts}};
1775 grep { $_->suspend(%opt) }
1776 grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1777 $self->unsuspended_pkgs;
1780 =item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1782 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1783 given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref
1784 instead of a list of pkgparts; the hashref has the following keys:
1788 =item pkgparts - listref of pkgparts
1790 =item (other options are passed to the suspend method)
1794 Returns a list: an empty list on success or a list of errors.
1798 sub suspend_unless_pkgpart {
1800 my (@pkgparts, %opt);
1801 if (ref($_[0]) eq 'HASH'){
1802 @pkgparts = @{$_[0]{pkgparts}};
1807 grep { $_->suspend(%opt) }
1808 grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1809 $self->unsuspended_pkgs;
1812 =item cancel [ OPTION => VALUE ... ]
1814 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1816 Available options are:
1820 =item quiet - can be set true to supress email cancellation notices.
1822 =item reason - can be set to a cancellation reason (see L<FS:reason>), either a reasonnum of an existing reason, or passing a hashref will create a new reason. The hashref should have the following keys: typenum - Reason type (see L<FS::reason_type>, reason - Text of the new reason.
1824 =item ban - can be set true to ban this customer's credit card or ACH information, if present.
1828 Always returns a list: an empty list on success or a list of errors.
1833 my( $self, %opt ) = @_;
1835 warn "$me cancel called on customer ". $self->custnum. " with options ".
1836 join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n"
1839 return ( 'access denied' )
1840 unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer');
1842 if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1844 #should try decryption (we might have the private key)
1845 # and if not maybe queue a job for the server that does?
1846 return ( "Can't (yet) ban encrypted credit cards" )
1847 if $self->is_encrypted($self->payinfo);
1849 my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1850 my $error = $ban->insert;
1851 return ( $error ) if $error;
1855 my @pkgs = $self->ncancelled_pkgs;
1857 warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/".
1858 scalar(@pkgs). " packages for customer ". $self->custnum. "\n"
1861 grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs;
1864 sub _banned_pay_hashref {
1875 'payby' => $payby2ban{$self->payby},
1876 'payinfo' => md5_base64($self->payinfo),
1877 #don't ever *search* on reason! #'reason' =>
1883 Returns all notes (see L<FS::cust_main_note>) for this customer.
1890 qsearch( 'cust_main_note',
1891 { 'custnum' => $self->custnum },
1893 'ORDER BY _DATE DESC'
1899 Returns the agent (see L<FS::agent>) for this customer.
1905 qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1908 =item bill_and_collect
1910 Cancels and suspends any packages due, generates bills, applies payments and
1913 Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.)
1915 Options are passed as name-value pairs. Currently available options are:
1921 Bills the customer as if it were that time. Specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion functions. For example:
1925 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1929 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices. Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
1933 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1937 If set true, re-charges setup fees.
1941 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)
1947 sub bill_and_collect {
1948 my( $self, %options ) = @_;
1954 #$options{actual_time} not $options{time} because freeside-daily -d is for
1955 #pre-printing invoices
1956 my @cancel_pkgs = grep { $_->expire && $_->expire <= $options{actual_time} }
1957 $self->ncancelled_pkgs;
1959 foreach my $cust_pkg ( @cancel_pkgs ) {
1960 my $error = $cust_pkg->cancel;
1961 warn "Error cancelling expired pkg ". $cust_pkg->pkgnum.
1962 " for custnum ". $self->custnum. ": $error"
1970 #$options{actual_time} not $options{time} because freeside-daily -d is for
1971 #pre-printing invoices
1974 && ( ( $_->part_pkg->is_prepaid
1976 && $_->bill < $options{actual_time}
1979 && $_->adjourn <= $options{actual_time}
1983 $self->ncancelled_pkgs;
1985 foreach my $cust_pkg ( @susp_pkgs ) {
1986 my $error = $cust_pkg->suspend;
1987 warn "Error suspending package ". $cust_pkg->pkgnum.
1988 " for custnum ". $self->custnum. ": $error"
1996 my $error = $self->bill( %options );
1997 warn "Error billing, custnum ". $self->custnum. ": $error" if $error;
1999 $self->apply_payments_and_credits;
2001 $error = $self->collect( %options );
2002 warn "Error collecting, custnum". $self->custnum. ": $error" if $error;
2008 Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in
2009 conjunction with the collect method by calling B<bill_and_collect>.
2011 If there is an error, returns the error, otherwise returns false.
2013 Options are passed as name-value pairs. Currently available options are:
2019 If set true, re-charges setup fees.
2023 Bills the customer as if it were that time. Specified as a UNIX timestamp; see L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion functions. For example:
2027 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
2031 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
2033 $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
2037 Used in conjunction with the I<time> option, this option specifies the date of for the generated invoices. Other calculations, such as whether or not to generate the invoice in the first place, are not affected.
2044 my( $self, %options ) = @_;
2045 return '' if $self->payby eq 'COMP';
2046 warn "$me bill customer ". $self->custnum. "\n"
2049 my $time = $options{'time'} || time;
2052 local $SIG{HUP} = 'IGNORE';
2053 local $SIG{INT} = 'IGNORE';
2054 local $SIG{QUIT} = 'IGNORE';
2055 local $SIG{TERM} = 'IGNORE';
2056 local $SIG{TSTP} = 'IGNORE';
2057 local $SIG{PIPE} = 'IGNORE';
2059 my $oldAutoCommit = $FS::UID::AutoCommit;
2060 local $FS::UID::AutoCommit = 0;
2063 $self->select_for_update; #mutex
2065 my @cust_bill_pkg = ();
2066 my @appended_cust_bill_pkg = ();
2069 # find the packages which are due for billing, find out how much they are
2070 # & generate invoice database.
2073 my( $total_setup, $total_recur, $postal_charge ) = ( 0, 0, 0 );
2077 my @precommit_hooks = ();
2079 my @cust_pkgs = qsearch('cust_pkg', { 'custnum' => $self->custnum } );
2080 foreach my $cust_pkg (@cust_pkgs) {
2082 #NO!! next if $cust_pkg->cancel;
2083 next if $cust_pkg->getfield('cancel');
2085 warn " bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2087 #? to avoid use of uninitialized value errors... ?
2088 $cust_pkg->setfield('bill', '')
2089 unless defined($cust_pkg->bill);
2091 #my $part_pkg = $cust_pkg->part_pkg;
2093 my $real_pkgpart = $cust_pkg->pkgpart;
2094 my %hash = $cust_pkg->hash;
2095 my $old_cust_pkg = new FS::cust_pkg \%hash;
2097 foreach my $part_pkg ( $cust_pkg->part_pkg->self_and_bill_linked ) {
2099 $self->_make_lines( 'part_pkg' => $part_pkg,
2100 'cust_pkg' => $cust_pkg,
2101 'precommit_hooks' => \@precommit_hooks,
2102 'line_items' => \@cust_bill_pkg,
2103 'appended_line_items' => \@appended_cust_bill_pkg,
2104 'setup' => \$total_setup,
2105 'recur' => \$total_recur,
2106 'tax_matrix' => \%taxlisthash,
2108 'options' => \%options,
2111 $dbh->rollback if $oldAutoCommit;
2115 } #foreach my $part_pkg
2117 } #foreach my $cust_pkg
2119 push @cust_bill_pkg, @appended_cust_bill_pkg;
2121 unless ( @cust_bill_pkg ) { #don't create an invoice w/o line items
2122 #but do commit any package date cycling that happened
2123 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2127 my $postal_pkg = $self->charge_postal_fee();
2128 if ( $postal_pkg && !ref( $postal_pkg ) ) {
2129 $dbh->rollback if $oldAutoCommit;
2130 return "can't charge postal invoice fee for customer ".
2131 $self->custnum. ": $postal_pkg";
2133 if ( $postal_pkg ) {
2134 foreach my $part_pkg ( $postal_pkg->part_pkg->self_and_bill_linked ) {
2136 $self->_make_lines( 'part_pkg' => $part_pkg,
2137 'cust_pkg' => $postal_pkg,
2138 'precommit_hooks' => \@precommit_hooks,
2139 'line_items' => \@cust_bill_pkg,
2140 'appended_line_items' => \@appended_cust_bill_pkg,
2141 'setup' => \$total_setup,
2142 'recur' => \$total_recur,
2143 'tax_matrix' => \%taxlisthash,
2145 'options' => \%options,
2148 $dbh->rollback if $oldAutoCommit;
2154 warn "having a look at the taxes we found...\n" if $DEBUG > 2;
2155 foreach my $tax ( keys %taxlisthash ) {
2156 my $tax_object = shift @{ $taxlisthash{$tax} };
2157 warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
2158 my $listref_or_error = $tax_object->taxline( @{ $taxlisthash{$tax} } );
2159 unless (ref($listref_or_error)) {
2160 $dbh->rollback if $oldAutoCommit;
2161 return $listref_or_error;
2163 unshift @{ $taxlisthash{$tax} }, $tax_object;
2165 warn "adding ". $listref_or_error->[1].
2166 " as ". $listref_or_error->[0]. "\n"
2168 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2169 if ( $taxname{ $listref_or_error->[0] } ) {
2170 push @{ $taxname{ $listref_or_error->[0] } }, $tax_object->taxname;
2172 $taxname{ $listref_or_error->[0] } = [ $tax_object->taxname ];
2177 #some taxes are taxed
2180 warn "finding taxed taxes...\n" if $DEBUG > 2;
2181 foreach my $tax ( keys %taxlisthash ) {
2182 my $tax_object = shift @{ $taxlisthash{$tax} };
2183 warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
2185 next unless $tax_object->can('tax_on_tax');
2187 foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
2188 my $totname = ref( $tot ). ' '. $tot->taxnum;
2190 warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
2192 next unless exists( $taxlisthash{ $totname } ); # only increase
2194 warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
2195 if ( exists( $totlisthash{ $totname } ) ) {
2196 push @{ $totlisthash{ $totname } }, $tax{ $tax_object->taxname };
2198 $totlisthash{ $totname } = [ $tot, $tax{ $tax_object->taxname } ];
2203 warn "having a look at taxed taxes...\n" if $DEBUG > 2;
2204 foreach my $tax ( keys %totlisthash ) {
2205 my $tax_object = shift @{ $totlisthash{$tax} };
2206 warn "found previously found taxed tax ". $tax_object->taxname. "\n"
2208 my $listref_or_error = $tax_object->taxline( @{ $totlisthash{$tax} } );
2209 unless (ref($listref_or_error)) {
2210 $dbh->rollback if $oldAutoCommit;
2211 return $listref_or_error;
2214 warn "adding taxed tax amount ". $listref_or_error->[1].
2215 " as ". $tax_object->taxname. "\n"
2217 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2220 #consolidate and create tax line items
2221 warn "consolidating and generating...\n" if $DEBUG > 2;
2222 foreach my $taxname ( keys %taxname ) {
2225 warn "adding $taxname\n" if $DEBUG > 1;
2226 foreach my $taxitem ( @{ $taxname{$taxname} } ) {
2227 $tax += $tax{$taxitem} unless $seen{$taxitem};
2228 warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
2232 $tax = sprintf('%.2f', $tax );
2233 $total_setup = sprintf('%.2f', $total_setup+$tax );
2235 push @cust_bill_pkg, new FS::cust_bill_pkg {
2241 'itemdesc' => $taxname,
2246 my $charged = sprintf('%.2f', $total_setup + $total_recur );
2248 #create the new invoice
2249 my $cust_bill = new FS::cust_bill ( {
2250 'custnum' => $self->custnum,
2251 '_date' => ( $options{'invoice_time'} || $time ),
2252 'charged' => $charged,
2254 my $error = $cust_bill->insert;
2256 $dbh->rollback if $oldAutoCommit;
2257 return "can't create invoice for customer #". $self->custnum. ": $error";
2260 foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
2261 $cust_bill_pkg->invnum($cust_bill->invnum);
2262 my $error = $cust_bill_pkg->insert;
2264 $dbh->rollback if $oldAutoCommit;
2265 return "can't create invoice line item: $error";
2270 foreach my $hook ( @precommit_hooks ) {
2272 &{$hook}; #($self) ?
2275 $dbh->rollback if $oldAutoCommit;
2276 return "$@ running precommit hook $hook\n";
2280 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2286 my ($self, %params) = @_;
2288 my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
2289 my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
2290 my $precommit_hooks = $params{precommit_hooks} or die "no package specified";
2291 my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
2292 my $appended_cust_bill_pkg = $params{appended_line_items}
2293 or die "no appended line buffer specified";
2294 my $total_setup = $params{setup} or die "no setup accumulator specified";
2295 my $total_recur = $params{recur} or die "no recur accumulator specified";
2296 my $taxlisthash = $params{tax_matrix} or die "no tax accumulator specified";
2297 my $time = $params{'time'} or die "no time specified";
2298 my (%options) = %{$params{options}}; #hmmm only for 'resetup'
2301 my $real_pkgpart = $cust_pkg->pkgpart;
2302 my %hash = $cust_pkg->hash;
2303 my $old_cust_pkg = new FS::cust_pkg \%hash;
2305 $cust_pkg->pkgpart($part_pkg->pkgpart);
2306 $cust_pkg->set($_, $hash{$_}) foreach qw( setup last_bill bill );
2318 if ( ! $cust_pkg->setup &&
2320 ( $conf->exists('disable_setup_suspended_pkgs') &&
2321 ! $cust_pkg->getfield('susp')
2322 ) || ! $conf->exists('disable_setup_suspended_pkgs')
2324 || $options{'resetup'}
2327 warn " bill setup\n" if $DEBUG > 1;
2330 $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2331 return "$@ running calc_setup for $cust_pkg\n"
2334 $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
2336 $cust_pkg->setfield('setup', $time)
2337 unless $cust_pkg->setup;
2338 #do need it, but it won't get written to the db
2339 #|| $cust_pkg->pkgpart != $real_pkgpart;
2344 # bill recurring fee
2347 #XXX unit stuff here too
2351 if ( $part_pkg->getfield('freq') ne '0' &&
2352 ! $cust_pkg->getfield('susp') &&
2353 ( $cust_pkg->getfield('bill') || 0 ) <= $time
2356 # XXX should this be a package event? probably. events are called
2357 # at collection time at the moment, though...
2358 $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
2359 if $part_pkg->can('reset_usage');
2360 #don't want to reset usage just cause we want a line item??
2361 #&& $part_pkg->pkgpart == $real_pkgpart;
2363 warn " bill recur\n" if $DEBUG > 1;
2366 # XXX shared with $recur_prog
2367 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2369 #over two params! lets at least switch to a hashref for the rest...
2370 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2372 $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2373 return "$@ running calc_recur for $cust_pkg\n"
2377 #change this bit to use Date::Manip? CAREFUL with timezones (see
2378 # mailing list archive)
2379 my ($sec,$min,$hour,$mday,$mon,$year) =
2380 (localtime($sdate) )[0,1,2,3,4,5];
2382 #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2383 # only for figuring next bill date, nothing else, so, reset $sdate again
2385 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2386 $cust_pkg->last_bill($sdate);
2388 if ( $part_pkg->freq =~ /^\d+$/ ) {
2389 $mon += $part_pkg->freq;
2390 until ( $mon < 12 ) { $mon -= 12; $year++; }
2391 } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2393 $mday += $weeks * 7;
2394 } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2397 } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2401 return "unparsable frequency: ". $part_pkg->freq;
2403 $cust_pkg->setfield('bill',
2404 timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2408 warn "\$setup is undefined" unless defined($setup);
2409 warn "\$recur is undefined" unless defined($recur);
2410 warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2413 # If there's line items, create em cust_bill_pkg records
2414 # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2419 if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2420 # hmm.. and if just the options are modified in some weird price plan?
2422 warn " package ". $cust_pkg->pkgnum. " modified; updating\n"
2425 my $error = $cust_pkg->replace( $old_cust_pkg,
2426 'options' => { $cust_pkg->options },
2428 return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
2429 if $error; #just in case
2432 $setup = sprintf( "%.2f", $setup );
2433 $recur = sprintf( "%.2f", $recur );
2434 if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2435 return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2437 if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2438 return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2441 if ( $setup != 0 || $recur != 0 ) {
2443 warn " charges (setup=$setup, recur=$recur); adding line items\n"
2445 my $cust_bill_pkg = new FS::cust_bill_pkg {
2446 'pkgnum' => $cust_pkg->pkgnum,
2448 'unitsetup' => $unitsetup,
2450 'unitrecur' => $unitrecur,
2451 'quantity' => $cust_pkg->quantity,
2453 'edate' => $cust_pkg->bill,
2454 'details' => \@details,
2456 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2457 unless $part_pkg->pkgpart == $real_pkgpart;
2458 push @$cust_bill_pkgs, $cust_bill_pkg;
2460 $$total_setup += $setup;
2461 $$total_recur += $recur;
2467 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2469 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2471 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2473 } #if $setup != 0 || $recur != 0
2477 if ( $part_pkg->can('append_cust_bill_pkgs') ) {
2478 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2479 my ($more_cust_bill_pkgs) =
2480 eval { $part_pkg->append_cust_bill_pkgs( $cust_pkg, \$sdate, \%param ) };
2482 return "$@ running append_cust_bill_pkgs for $cust_pkg\n"
2484 return "$more_cust_bill_pkgs"
2485 unless ( ref($more_cust_bill_pkgs) );
2487 foreach my $cust_bill_pkg ( @{$more_cust_bill_pkgs} ) {
2489 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2490 unless $part_pkg->pkgpart == $real_pkgpart;
2491 push @$appended_cust_bill_pkg, $cust_bill_pkg;
2493 $$total_setup += $cust_bill_pkg->setup;
2494 $$total_recur += $cust_bill_pkg->recur;
2500 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2502 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2504 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2512 my $part_pkg = shift;
2513 my $taxlisthash = shift;
2514 my $cust_bill_pkg = shift;
2517 my @taxoverrides = $part_pkg->part_pkg_taxoverride;
2520 ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2524 if ( $conf->exists('enable_taxproducts')
2525 && (scalar(@taxoverrides) || $part_pkg->taxproductnum )
2529 my @taxclassnums = ();
2530 my $geocode = $self->geocode('cch');
2532 if ( scalar( @taxoverrides ) ) {
2533 @taxclassnums = map { $_->taxclassnum } @taxoverrides;
2534 }elsif ( $part_pkg->taxproductnum ) {
2535 @taxclassnums = map { $_->taxclassnum }
2536 $part_pkg->part_pkg_taxrate('cch', $geocode);
2541 join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
2543 @taxes = qsearch({ 'table' => 'tax_rate',
2544 'hashref' => { 'geocode' => $geocode, },
2545 'extra_sql' => $extra_sql,
2547 if scalar(@taxclassnums);
2552 my %taxhash = map { $_ => $self->get("$prefix$_") }
2553 qw( state county country );
2555 $taxhash{'taxclass'} = $part_pkg->taxclass;
2557 @taxes = qsearch( 'cust_main_county', \%taxhash );
2560 $taxhash{'taxclass'} = '';
2561 @taxes = qsearch( 'cust_main_county', \%taxhash );
2564 #one more try at a whole-country tax rate
2566 $taxhash{$_} = '' foreach qw( state county );
2567 @taxes = qsearch( 'cust_main_county', \%taxhash );
2570 } #if $conf->exists('enable_taxproducts')
2572 # maybe eliminate this entirely, along with all the 0% records
2575 if ( $conf->exists('enable_taxproducts') ) {
2577 "fatal: can't find tax rate for zip/taxproduct/pkgpart ".
2578 join('/', ( map $self->get("$prefix$_"),
2581 $part_pkg->taxproduct_description,
2582 $part_pkg->pkgpart ). "\n";
2585 "fatal: can't find tax rate for state/county/country/taxclass ".
2586 join('/', ( map $self->get("$prefix$_"),
2587 qw(state county country)
2589 $part_pkg->taxclass ). "\n";
2594 foreach my $tax ( @taxes ) {
2595 my $taxname = ref( $tax ). ' '. $tax->taxnum;
2596 if ( exists( $taxlisthash->{ $taxname } ) ) {
2597 push @{ $taxlisthash->{ $taxname } }, $cust_bill_pkg;
2599 $taxlisthash->{ $taxname } = [ $tax, $cust_bill_pkg ];
2605 =item collect OPTIONS
2607 (Attempt to) collect money for this customer's outstanding invoices (see
2608 L<FS::cust_bill>). Usually used after the bill method.
2610 Actions are now triggered by billing events; see L<FS::part_event> and the
2611 billing events web interface. Old-style invoice events (see
2612 L<FS::part_bill_event>) have been deprecated.
2614 If there is an error, returns the error, otherwise returns false.
2616 Options are passed as name-value pairs.
2618 Currently available options are:
2624 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.
2628 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2632 set true to surpress email card/ACH decline notices.
2636 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2640 allows for one time override of normal customer billing method
2644 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)
2652 my( $self, %options ) = @_;
2653 my $invoice_time = $options{'invoice_time'} || time;
2656 local $SIG{HUP} = 'IGNORE';
2657 local $SIG{INT} = 'IGNORE';
2658 local $SIG{QUIT} = 'IGNORE';
2659 local $SIG{TERM} = 'IGNORE';
2660 local $SIG{TSTP} = 'IGNORE';
2661 local $SIG{PIPE} = 'IGNORE';
2663 my $oldAutoCommit = $FS::UID::AutoCommit;
2664 local $FS::UID::AutoCommit = 0;
2667 $self->select_for_update; #mutex
2670 my $balance = $self->balance;
2671 warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2674 if ( exists($options{'retry_card'}) ) {
2675 carp 'retry_card option passed to collect is deprecated; use retry';
2676 $options{'retry'} ||= $options{'retry_card'};
2678 if ( exists($options{'retry'}) && $options{'retry'} ) {
2679 my $error = $self->retry_realtime;
2681 $dbh->rollback if $oldAutoCommit;
2686 # false laziness w/pay_batch::import_results
2688 my $due_cust_event = $self->due_cust_event(
2689 'debug' => ( $options{'debug'} || 0 ),
2690 'time' => $invoice_time,
2691 'check_freq' => $options{'check_freq'},
2693 unless( ref($due_cust_event) ) {
2694 $dbh->rollback if $oldAutoCommit;
2695 return $due_cust_event;
2698 foreach my $cust_event ( @$due_cust_event ) {
2702 #re-eval event conditions (a previous event could have changed things)
2703 unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
2704 #don't leave stray "new/locked" records around
2705 my $error = $cust_event->delete;
2707 #gah, even with transactions
2708 $dbh->commit if $oldAutoCommit; #well.
2715 local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2716 warn " running cust_event ". $cust_event->eventnum. "\n"
2720 #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2721 if ( my $error = $cust_event->do_event() ) {
2722 #XXX wtf is this? figure out a proper dealio with return value
2724 # gah, even with transactions.
2725 $dbh->commit if $oldAutoCommit; #well.
2732 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2737 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2739 Inserts database records for and returns an ordered listref of new events due
2740 for this customer, as FS::cust_event objects (see L<FS::cust_event>). If no
2741 events are due, an empty listref is returned. If there is an error, returns a
2742 scalar error message.
2744 To actually run the events, call each event's test_condition method, and if
2745 still true, call the event's do_event method.
2747 Options are passed as a hashref or as a list of name-value pairs. Available
2754 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.
2758 "Current time" for the events.
2762 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)
2766 Only return events for the specified eventtable (by default, events of all eventtables are returned)
2770 Explicitly pass the objects to be tested (typically used with eventtable).
2776 sub due_cust_event {
2778 my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2781 #my $DEBUG = $opt{'debug'}
2782 local($DEBUG) = $opt{'debug'}
2783 if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
2785 warn "$me due_cust_event called with options ".
2786 join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2789 $opt{'time'} ||= time;
2791 local $SIG{HUP} = 'IGNORE';
2792 local $SIG{INT} = 'IGNORE';
2793 local $SIG{QUIT} = 'IGNORE';
2794 local $SIG{TERM} = 'IGNORE';
2795 local $SIG{TSTP} = 'IGNORE';
2796 local $SIG{PIPE} = 'IGNORE';
2798 my $oldAutoCommit = $FS::UID::AutoCommit;
2799 local $FS::UID::AutoCommit = 0;
2802 $self->select_for_update; #mutex
2805 # 1: find possible events (initial search)
2808 my @cust_event = ();
2810 my @eventtable = $opt{'eventtable'}
2811 ? ( $opt{'eventtable'} )
2812 : FS::part_event->eventtables_runorder;
2814 foreach my $eventtable ( @eventtable ) {
2817 if ( $opt{'objects'} ) {
2819 @objects = @{ $opt{'objects'} };
2823 #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
2824 @objects = ( $eventtable eq 'cust_main' )
2826 : ( $self->$eventtable() );
2830 my @e_cust_event = ();
2832 my $cross = "CROSS JOIN $eventtable";
2833 $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2834 unless $eventtable eq 'cust_main';
2836 foreach my $object ( @objects ) {
2838 #this first search uses the condition_sql magic for optimization.
2839 #the more possible events we can eliminate in this step the better
2841 my $cross_where = '';
2842 my $pkey = $object->primary_key;
2843 $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2845 my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
2847 FS::part_event_condition->where_conditions_sql( $eventtable,
2848 'time'=>$opt{'time'}
2850 my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2852 $extra_sql = "AND $extra_sql" if $extra_sql;
2854 #here is the agent virtualization
2855 $extra_sql .= " AND ( part_event.agentnum IS NULL
2856 OR part_event.agentnum = ". $self->agentnum. ' )';
2858 $extra_sql .= " $order";
2860 warn "searching for events for $eventtable ". $object->$pkey. "\n"
2861 if $opt{'debug'} > 2;
2862 my @part_event = qsearch( {
2863 'debug' => ( $opt{'debug'} > 3 ? 1 : 0 ),
2864 'select' => 'part_event.*',
2865 'table' => 'part_event',
2866 'addl_from' => "$cross $join",
2867 'hashref' => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
2868 'eventtable' => $eventtable,
2871 'extra_sql' => "AND $cross_where $extra_sql",
2875 my $pkey = $object->primary_key;
2876 warn " ". scalar(@part_event).
2877 " possible events found for $eventtable ". $object->$pkey(). "\n";
2880 push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
2884 warn " ". scalar(@e_cust_event).
2885 " subtotal possible cust events found for $eventtable\n"
2888 push @cust_event, @e_cust_event;
2892 warn " ". scalar(@cust_event).
2893 " total possible cust events found in initial search\n"
2897 # 2: test conditions
2902 @cust_event = grep $_->test_conditions( 'time' => $opt{'time'},
2903 'stats_hashref' => \%unsat ),
2906 warn " ". scalar(@cust_event). " cust events left satisfying conditions\n"
2909 warn " invalid conditions not eliminated with condition_sql:\n".
2910 join('', map " $_: ".$unsat{$_}."\n", keys %unsat )
2917 foreach my $cust_event ( @cust_event ) {
2919 my $error = $cust_event->insert();
2921 $dbh->rollback if $oldAutoCommit;
2927 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2933 warn " returning events: ". Dumper(@cust_event). "\n"
2940 =item retry_realtime
2942 Schedules realtime / batch credit card / electronic check / LEC billing
2943 events for for retry. Useful if card information has changed or manual
2944 retry is desired. The 'collect' method must be called to actually retry
2947 Implementation details: For either this customer, or for each of this
2948 customer's open invoices, changes the status of the first "done" (with
2949 statustext error) realtime processing event to "failed".
2953 sub retry_realtime {
2956 local $SIG{HUP} = 'IGNORE';
2957 local $SIG{INT} = 'IGNORE';
2958 local $SIG{QUIT} = 'IGNORE';
2959 local $SIG{TERM} = 'IGNORE';
2960 local $SIG{TSTP} = 'IGNORE';
2961 local $SIG{PIPE} = 'IGNORE';
2963 my $oldAutoCommit = $FS::UID::AutoCommit;
2964 local $FS::UID::AutoCommit = 0;
2967 #a little false laziness w/due_cust_event (not too bad, really)
2969 my $join = FS::part_event_condition->join_conditions_sql;
2970 my $order = FS::part_event_condition->order_conditions_sql;
2973 . join ( ' OR ' , map {
2974 "( part_event.eventtable = " . dbh->quote($_)
2975 . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
2976 } FS::part_event->eventtables)
2979 #here is the agent virtualization
2980 my $agent_virt = " ( part_event.agentnum IS NULL
2981 OR part_event.agentnum = ". $self->agentnum. ' )';
2983 #XXX this shouldn't be hardcoded, actions should declare it...
2984 my @realtime_events = qw(
2985 cust_bill_realtime_card
2986 cust_bill_realtime_check
2987 cust_bill_realtime_lec
2991 my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
2996 my @cust_event = qsearchs({
2997 'table' => 'cust_event',
2998 'select' => 'cust_event.*',
2999 'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
3000 'hashref' => { 'status' => 'done' },
3001 'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
3002 " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
3005 my %seen_invnum = ();
3006 foreach my $cust_event (@cust_event) {
3008 #max one for the customer, one for each open invoice
3009 my $cust_X = $cust_event->cust_X;
3010 next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
3014 or $cust_event->part_event->eventtable eq 'cust_bill'
3017 my $error = $cust_event->retry;
3019 $dbh->rollback if $oldAutoCommit;
3020 return "error scheduling event for retry: $error";
3025 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3030 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
3032 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
3033 via a Business::OnlinePayment realtime gateway. See
3034 L<http://420.am/business-onlinepayment> for supported gateways.
3036 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3038 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
3040 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3041 I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3042 if set, will override the value from the customer record.
3044 I<description> is a free-text field passed to the gateway. It defaults to
3045 "Internet services".
3047 If an I<invnum> is specified, this payment (if successful) is applied to the
3048 specified invoice. If you don't specify an I<invnum> you might want to
3049 call the B<apply_payments> method.
3051 I<quiet> can be set true to surpress email decline notices.
3053 I<paynum_ref> can be set to a scalar reference. It will be filled in with the
3054 resulting paynum, if any.
3056 I<payunique> is a unique identifier for this payment.
3058 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
3063 my( $self, $method, $amount, %options ) = @_;
3065 warn "$me realtime_bop: $method $amount\n";
3066 warn " $_ => $options{$_}\n" foreach keys %options;
3069 $options{'description'} ||= 'Internet services';
3071 return $self->fake_bop($method, $amount, %options) if $options{'fake'};
3073 eval "use Business::OnlinePayment";
3076 my $payinfo = exists($options{'payinfo'})
3077 ? $options{'payinfo'}
3080 my %method2payby = (
3087 # check for banned credit card/ACH
3090 my $ban = qsearchs('banned_pay', {
3091 'payby' => $method2payby{$method},
3092 'payinfo' => md5_base64($payinfo),
3094 return "Banned credit card" if $ban;
3101 if ( $options{'invnum'} ) {
3102 my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3103 die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3105 map { $_->part_pkg->taxclass }
3107 map { $_->cust_pkg }
3108 $cust_bill->cust_bill_pkg;
3109 unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
3110 #different taxclasses
3111 $taxclass = $taxclasses[0];
3115 #look for an agent gateway override first
3117 if ( $method eq 'CC' ) {
3118 $cardtype = cardtype($payinfo);
3119 } elsif ( $method eq 'ECHECK' ) {
3122 $cardtype = $method;
3126 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3127 cardtype => $cardtype,
3128 taxclass => $taxclass, } )
3129 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3131 taxclass => $taxclass, } )
3132 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3133 cardtype => $cardtype,
3135 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3137 taxclass => '', } );
3139 my $payment_gateway = '';
3140 my( $processor, $login, $password, $action, @bop_options );
3141 if ( $override ) { #use a payment gateway override
3143 $payment_gateway = $override->payment_gateway;
3145 $processor = $payment_gateway->gateway_module;
3146 $login = $payment_gateway->gateway_username;
3147 $password = $payment_gateway->gateway_password;
3148 $action = $payment_gateway->gateway_action;
3149 @bop_options = $payment_gateway->options;
3151 } else { #use the standard settings from the config
3153 ( $processor, $login, $password, $action, @bop_options ) =
3154 $self->default_payment_gateway($method);
3162 my $address = exists($options{'address1'})
3163 ? $options{'address1'}
3165 my $address2 = exists($options{'address2'})
3166 ? $options{'address2'}
3168 $address .= ", ". $address2 if length($address2);
3170 my $o_payname = exists($options{'payname'})
3171 ? $options{'payname'}
3173 my($payname, $payfirst, $paylast);
3174 if ( $o_payname && $method ne 'ECHECK' ) {
3175 ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3176 or return "Illegal payname $payname";
3177 ($payfirst, $paylast) = ($1, $2);
3179 $payfirst = $self->getfield('first');
3180 $paylast = $self->getfield('last');
3181 $payname = "$payfirst $paylast";
3184 my @invoicing_list = $self->invoicing_list_emailonly;
3185 if ( $conf->exists('emailinvoiceautoalways')
3186 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3187 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3188 push @invoicing_list, $self->all_emails;
3191 my $email = ($conf->exists('business-onlinepayment-email-override'))
3192 ? $conf->config('business-onlinepayment-email-override')
3193 : $invoicing_list[0];
3197 my $payip = exists($options{'payip'})
3200 $content{customer_ip} = $payip
3203 $content{invoice_number} = $options{'invnum'}
3204 if exists($options{'invnum'}) && length($options{'invnum'});
3206 $content{email_customer} =
3207 ( $conf->exists('business-onlinepayment-email_customer')
3208 || $conf->exists('business-onlinepayment-email-override') );
3211 if ( $method eq 'CC' ) {
3213 $content{card_number} = $payinfo;
3214 $paydate = exists($options{'paydate'})
3215 ? $options{'paydate'}
3217 $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3218 $content{expiration} = "$2/$1";
3220 my $paycvv = exists($options{'paycvv'})
3221 ? $options{'paycvv'}
3223 $content{cvv2} = $paycvv
3226 my $paystart_month = exists($options{'paystart_month'})
3227 ? $options{'paystart_month'}
3228 : $self->paystart_month;
3230 my $paystart_year = exists($options{'paystart_year'})
3231 ? $options{'paystart_year'}
3232 : $self->paystart_year;
3234 $content{card_start} = "$paystart_month/$paystart_year"
3235 if $paystart_month && $paystart_year;
3237 my $payissue = exists($options{'payissue'})
3238 ? $options{'payissue'}
3240 $content{issue_number} = $payissue if $payissue;
3242 $content{recurring_billing} = 'YES'
3243 if qsearch('cust_pay', { 'custnum' => $self->custnum,
3245 'payinfo' => $payinfo,
3247 || qsearch('cust_pay', { 'custnum' => $self->custnum,
3249 'paymask' => $self->mask_payinfo('CARD', $payinfo),
3253 } elsif ( $method eq 'ECHECK' ) {
3254 ( $content{account_number}, $content{routing_code} ) =
3255 split('@', $payinfo);
3256 $content{bank_name} = $o_payname;
3257 $content{bank_state} = exists($options{'paystate'})
3258 ? $options{'paystate'}
3259 : $self->getfield('paystate');
3260 $content{account_type} = exists($options{'paytype'})
3261 ? uc($options{'paytype'}) || 'CHECKING'
3262 : uc($self->getfield('paytype')) || 'CHECKING';
3263 $content{account_name} = $payname;
3264 $content{customer_org} = $self->company ? 'B' : 'I';
3265 $content{state_id} = exists($options{'stateid'})
3266 ? $options{'stateid'}
3267 : $self->getfield('stateid');
3268 $content{state_id_state} = exists($options{'stateid_state'})
3269 ? $options{'stateid_state'}
3270 : $self->getfield('stateid_state');
3271 $content{customer_ssn} = exists($options{'ss'})
3274 } elsif ( $method eq 'LEC' ) {
3275 $content{phone} = $payinfo;
3279 # run transaction(s)
3282 my $balance = exists( $options{'balance'} )
3283 ? $options{'balance'}
3286 $self->select_for_update; #mutex ... just until we get our pending record in
3288 #the checks here are intended to catch concurrent payments
3289 #double-form-submission prevention is taken care of in cust_pay_pending::check
3292 return "The customer's balance has changed; $method transaction aborted."
3293 if $self->balance < $balance;
3294 #&& $self->balance < $amount; #might as well anyway?
3296 #also check and make sure there aren't *other* pending payments for this cust
3298 my @pending = qsearch('cust_pay_pending', {
3299 'custnum' => $self->custnum,
3300 'status' => { op=>'!=', value=>'done' }
3302 return "A payment is already being processed for this customer (".
3303 join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3304 "); $method transaction aborted."
3305 if scalar(@pending);
3307 #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3309 my $cust_pay_pending = new FS::cust_pay_pending {
3310 'custnum' => $self->custnum,
3311 #'invnum' => $options{'invnum'},
3314 'payby' => $method2payby{$method},
3315 'payinfo' => $payinfo,
3316 'paydate' => $paydate,
3318 'gatewaynum' => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3320 $cust_pay_pending->payunique( $options{payunique} )
3321 if defined($options{payunique}) && length($options{payunique});
3322 my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3323 return $cpp_new_err if $cpp_new_err;
3325 my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3327 my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3328 $transaction->content(
3331 'password' => $password,
3332 'action' => $action1,
3333 'description' => $options{'description'},
3334 'amount' => $amount,
3335 #'invoice_number' => $options{'invnum'},
3336 'customer_id' => $self->custnum,
3337 'last_name' => $paylast,
3338 'first_name' => $payfirst,
3340 'address' => $address,
3341 'city' => ( exists($options{'city'})
3344 'state' => ( exists($options{'state'})
3347 'zip' => ( exists($options{'zip'})
3350 'country' => ( exists($options{'country'})
3351 ? $options{'country'}
3353 'referer' => 'http://cleanwhisker.420.am/',
3355 'phone' => $self->daytime || $self->night,
3359 $cust_pay_pending->status('pending');
3360 my $cpp_pending_err = $cust_pay_pending->replace;
3361 return $cpp_pending_err if $cpp_pending_err;
3364 my $BOP_TESTING = 0;
3365 my $BOP_TESTING_SUCCESS = 1;
3367 unless ( $BOP_TESTING ) {
3368 $transaction->submit();
3370 if ( $BOP_TESTING_SUCCESS ) {
3371 $transaction->is_success(1);
3372 $transaction->authorization('fake auth');
3374 $transaction->is_success(0);
3375 $transaction->error_message('fake failure');
3379 if ( $transaction->is_success() && $action2 ) {
3381 $cust_pay_pending->status('authorized');
3382 my $cpp_authorized_err = $cust_pay_pending->replace;
3383 return $cpp_authorized_err if $cpp_authorized_err;
3385 my $auth = $transaction->authorization;
3386 my $ordernum = $transaction->can('order_number')
3387 ? $transaction->order_number
3391 new Business::OnlinePayment( $processor, @bop_options );
3398 password => $password,
3399 order_number => $ordernum,
3401 authorization => $auth,
3402 description => $options{'description'},
3405 foreach my $field (qw( authorization_source_code returned_ACI
3406 transaction_identifier validation_code
3407 transaction_sequence_num local_transaction_date
3408 local_transaction_time AVS_result_code )) {
3409 $capture{$field} = $transaction->$field() if $transaction->can($field);
3412 $capture->content( %capture );
3416 unless ( $capture->is_success ) {
3417 my $e = "Authorization successful but capture failed, custnum #".
3418 $self->custnum. ': '. $capture->result_code.
3419 ": ". $capture->error_message;
3426 $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3427 my $cpp_captured_err = $cust_pay_pending->replace;
3428 return $cpp_captured_err if $cpp_captured_err;
3431 # remove paycvv after initial transaction
3434 #false laziness w/misc/process/payment.cgi - check both to make sure working
3436 if ( defined $self->dbdef_table->column('paycvv')
3437 && length($self->paycvv)
3438 && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3440 my $error = $self->remove_cvv;
3442 warn "WARNING: error removing cvv: $error\n";
3450 if ( $transaction->is_success() ) {
3453 if ( $payment_gateway ) { # agent override
3454 $paybatch = $payment_gateway->gatewaynum. '-';
3457 $paybatch .= "$processor:". $transaction->authorization;
3459 $paybatch .= ':'. $transaction->order_number
3460 if $transaction->can('order_number')
3461 && length($transaction->order_number);
3463 my $cust_pay = new FS::cust_pay ( {
3464 'custnum' => $self->custnum,
3465 'invnum' => $options{'invnum'},
3468 'payby' => $method2payby{$method},
3469 'payinfo' => $payinfo,
3470 'paybatch' => $paybatch,
3471 'paydate' => $paydate,
3473 #doesn't hurt to know, even though the dup check is in cust_pay_pending now
3474 $cust_pay->payunique( $options{payunique} )
3475 if defined($options{payunique}) && length($options{payunique});
3477 my $oldAutoCommit = $FS::UID::AutoCommit;
3478 local $FS::UID::AutoCommit = 0;
3481 #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
3483 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3486 $cust_pay->invnum(''); #try again with no specific invnum
3487 my $error2 = $cust_pay->insert( $options{'manual'} ?
3488 ( 'manual' => 1 ) : ()
3491 # gah. but at least we have a record of the state we had to abort in
3492 # from cust_pay_pending now.
3493 my $e = "WARNING: $method captured but payment not recorded - ".
3494 "error inserting payment ($processor): $error2".
3495 " (previously tried insert with invnum #$options{'invnum'}" .
3496 ": $error ) - pending payment saved as paypendingnum ".
3497 $cust_pay_pending->paypendingnum. "\n";
3503 if ( $options{'paynum_ref'} ) {
3504 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3507 $cust_pay_pending->status('done');
3508 $cust_pay_pending->statustext('captured');
3509 my $cpp_done_err = $cust_pay_pending->replace;
3511 if ( $cpp_done_err ) {
3513 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3514 my $e = "WARNING: $method captured but payment not recorded - ".
3515 "error updating status for paypendingnum ".
3516 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3522 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3523 return ''; #no error
3529 my $perror = "$processor error: ". $transaction->error_message;
3531 unless ( $transaction->error_message ) {
3534 if ( $transaction->can('response_page') ) {
3536 'page' => ( $transaction->can('response_page')
3537 ? $transaction->response_page
3540 'code' => ( $transaction->can('response_code')
3541 ? $transaction->response_code
3544 'headers' => ( $transaction->can('response_headers')
3545 ? $transaction->response_headers
3551 "No additional debugging information available for $processor";
3554 $perror .= "No error_message returned from $processor -- ".
3555 ( ref($t_response) ? Dumper($t_response) : $t_response );
3559 if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3560 && $conf->exists('emaildecline')
3561 && grep { $_ ne 'POST' } $self->invoicing_list
3562 && ! grep { $transaction->error_message =~ /$_/ }
3563 $conf->config('emaildecline-exclude')
3565 my @templ = $conf->config('declinetemplate');
3566 my $template = new Text::Template (
3568 SOURCE => [ map "$_\n", @templ ],
3569 ) or return "($perror) can't create template: $Text::Template::ERROR";
3570 $template->compile()
3571 or return "($perror) can't compile template: $Text::Template::ERROR";
3573 my $templ_hash = { error => $transaction->error_message };
3575 my $error = send_email(
3576 'from' => $conf->config('invoice_from'),
3577 'to' => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3578 'subject' => 'Your payment could not be processed',
3579 'body' => [ $template->fill_in(HASH => $templ_hash) ],
3582 $perror .= " (also received error sending decline notification: $error)"
3587 $cust_pay_pending->status('done');
3588 $cust_pay_pending->statustext("declined: $perror");
3589 my $cpp_done_err = $cust_pay_pending->replace;
3590 if ( $cpp_done_err ) {
3591 my $e = "WARNING: $method declined but pending payment not resolved - ".
3592 "error updating status for paypendingnum ".
3593 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3595 $perror = "$e ($perror)";
3608 my( $self, $method, $amount, %options ) = @_;
3610 if ( $options{'fake_failure'} ) {
3611 return "Error: No error; test failure requested with fake_failure";
3614 my %method2payby = (
3621 #if ( $payment_gateway ) { # agent override
3622 # $paybatch = $payment_gateway->gatewaynum. '-';
3625 #$paybatch .= "$processor:". $transaction->authorization;
3627 #$paybatch .= ':'. $transaction->order_number
3628 # if $transaction->can('order_number')
3629 # && length($transaction->order_number);
3631 my $paybatch = 'FakeProcessor:54:32';
3633 my $cust_pay = new FS::cust_pay ( {
3634 'custnum' => $self->custnum,
3635 'invnum' => $options{'invnum'},
3638 'payby' => $method2payby{$method},
3639 #'payinfo' => $payinfo,
3640 'payinfo' => '4111111111111111',
3641 'paybatch' => $paybatch,
3642 #'paydate' => $paydate,
3643 'paydate' => '2012-05-01',
3645 $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
3647 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3650 $cust_pay->invnum(''); #try again with no specific invnum
3651 my $error2 = $cust_pay->insert( $options{'manual'} ?
3652 ( 'manual' => 1 ) : ()
3655 # gah, even with transactions.
3656 my $e = 'WARNING: Card/ACH debited but database not updated - '.
3657 "error inserting (fake!) payment: $error2".
3658 " (previously tried insert with invnum #$options{'invnum'}" .
3665 if ( $options{'paynum_ref'} ) {
3666 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3669 return ''; #no error
3673 =item default_payment_gateway
3677 sub default_payment_gateway {
3678 my( $self, $method ) = @_;
3680 die "Real-time processing not enabled\n"
3681 unless $conf->exists('business-onlinepayment');
3684 my $bop_config = 'business-onlinepayment';
3685 $bop_config .= '-ach'
3686 if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
3687 my ( $processor, $login, $password, $action, @bop_options ) =
3688 $conf->config($bop_config);
3689 $action ||= 'normal authorization';
3690 pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
3691 die "No real-time processor is enabled - ".
3692 "did you set the business-onlinepayment configuration value?\n"
3695 ( $processor, $login, $password, $action, @bop_options )
3700 Removes the I<paycvv> field from the database directly.
3702 If there is an error, returns the error, otherwise returns false.
3708 my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
3709 or return dbh->errstr;
3710 $sth->execute($self->custnum)
3711 or return $sth->errstr;
3716 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
3718 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
3719 via a Business::OnlinePayment realtime gateway. See
3720 L<http://420.am/business-onlinepayment> for supported gateways.
3722 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3724 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
3726 Most gateways require a reference to an original payment transaction to refund,
3727 so you probably need to specify a I<paynum>.
3729 I<amount> defaults to the original amount of the payment if not specified.
3731 I<reason> specifies a reason for the refund.
3733 I<paydate> specifies the expiration date for a credit card overriding the
3734 value from the customer record or the payment record. Specified as yyyy-mm-dd
3736 Implementation note: If I<amount> is unspecified or equal to the amount of the
3737 orignal payment, first an attempt is made to "void" the transaction via
3738 the gateway (to cancel a not-yet settled transaction) and then if that fails,
3739 the normal attempt is made to "refund" ("credit") the transaction via the
3740 gateway is attempted.
3742 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3743 #I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3744 #if set, will override the value from the customer record.
3746 #If an I<invnum> is specified, this payment (if successful) is applied to the
3747 #specified invoice. If you don't specify an I<invnum> you might want to
3748 #call the B<apply_payments> method.
3752 #some false laziness w/realtime_bop, not enough to make it worth merging
3753 #but some useful small subs should be pulled out
3754 sub realtime_refund_bop {
3755 my( $self, $method, %options ) = @_;
3757 warn "$me realtime_refund_bop: $method refund\n";
3758 warn " $_ => $options{$_}\n" foreach keys %options;
3761 eval "use Business::OnlinePayment";
3765 # look up the original payment and optionally a gateway for that payment
3769 my $amount = $options{'amount'};
3771 my( $processor, $login, $password, @bop_options ) ;
3772 my( $auth, $order_number ) = ( '', '', '' );
3774 if ( $options{'paynum'} ) {
3776 warn " paynum: $options{paynum}\n" if $DEBUG > 1;
3777 $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
3778 or return "Unknown paynum $options{'paynum'}";
3779 $amount ||= $cust_pay->paid;
3781 $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
3782 or return "Can't parse paybatch for paynum $options{'paynum'}: ".
3783 $cust_pay->paybatch;
3784 my $gatewaynum = '';
3785 ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
3787 if ( $gatewaynum ) { #gateway for the payment to be refunded
3789 my $payment_gateway =
3790 qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
3791 die "payment gateway $gatewaynum not found"
3792 unless $payment_gateway;
3794 $processor = $payment_gateway->gateway_module;
3795 $login = $payment_gateway->gateway_username;
3796 $password = $payment_gateway->gateway_password;
3797 @bop_options = $payment_gateway->options;
3799 } else { #try the default gateway
3801 my( $conf_processor, $unused_action );
3802 ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
3803 $self->default_payment_gateway($method);
3805 return "processor of payment $options{'paynum'} $processor does not".
3806 " match default processor $conf_processor"
3807 unless $processor eq $conf_processor;
3812 } else { # didn't specify a paynum, so look for agent gateway overrides
3813 # like a normal transaction
3816 if ( $method eq 'CC' ) {
3817 $cardtype = cardtype($self->payinfo);
3818 } elsif ( $method eq 'ECHECK' ) {
3821 $cardtype = $method;
3824 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3825 cardtype => $cardtype,
3827 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3829 taxclass => '', } );
3831 if ( $override ) { #use a payment gateway override
3833 my $payment_gateway = $override->payment_gateway;
3835 $processor = $payment_gateway->gateway_module;
3836 $login = $payment_gateway->gateway_username;
3837 $password = $payment_gateway->gateway_password;
3838 #$action = $payment_gateway->gateway_action;
3839 @bop_options = $payment_gateway->options;
3841 } else { #use the standard settings from the config
3844 ( $processor, $login, $password, $unused_action, @bop_options ) =
3845 $self->default_payment_gateway($method);
3850 return "neither amount nor paynum specified" unless $amount;
3855 'password' => $password,
3856 'order_number' => $order_number,
3857 'amount' => $amount,
3858 'referer' => 'http://cleanwhisker.420.am/',
3860 $content{authorization} = $auth
3861 if length($auth); #echeck/ACH transactions have an order # but no auth
3862 #(at least with authorize.net)
3864 my $disable_void_after;
3865 if ($conf->exists('disable_void_after')
3866 && $conf->config('disable_void_after') =~ /^(\d+)$/) {
3867 $disable_void_after = $1;
3870 #first try void if applicable
3871 if ( $cust_pay && $cust_pay->paid == $amount
3873 ( not defined($disable_void_after) )
3874 || ( time < ($cust_pay->_date + $disable_void_after ) )
3877 warn " attempting void\n" if $DEBUG > 1;
3878 my $void = new Business::OnlinePayment( $processor, @bop_options );
3879 $void->content( 'action' => 'void', %content );
3881 if ( $void->is_success ) {
3882 my $error = $cust_pay->void($options{'reason'});
3884 # gah, even with transactions.
3885 my $e = 'WARNING: Card/ACH voided but database not updated - '.
3886 "error voiding payment: $error";
3890 warn " void successful\n" if $DEBUG > 1;
3895 warn " void unsuccessful, trying refund\n"
3899 my $address = $self->address1;
3900 $address .= ", ". $self->address2 if $self->address2;
3902 my($payname, $payfirst, $paylast);
3903 if ( $self->payname && $method ne 'ECHECK' ) {
3904 $payname = $self->payname;
3905 $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3906 or return "Illegal payname $payname";
3907 ($payfirst, $paylast) = ($1, $2);
3909 $payfirst = $self->getfield('first');
3910 $paylast = $self->getfield('last');
3911 $payname = "$payfirst $paylast";
3914 my @invoicing_list = $self->invoicing_list_emailonly;
3915 if ( $conf->exists('emailinvoiceautoalways')
3916 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3917 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3918 push @invoicing_list, $self->all_emails;
3921 my $email = ($conf->exists('business-onlinepayment-email-override'))
3922 ? $conf->config('business-onlinepayment-email-override')
3923 : $invoicing_list[0];
3925 my $payip = exists($options{'payip'})
3928 $content{customer_ip} = $payip
3932 if ( $method eq 'CC' ) {
3935 $content{card_number} = $payinfo = $cust_pay->payinfo;
3936 (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
3937 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
3938 ($content{expiration} = "$2/$1"); # where available
3940 $content{card_number} = $payinfo = $self->payinfo;
3941 (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
3942 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3943 $content{expiration} = "$2/$1";
3946 } elsif ( $method eq 'ECHECK' ) {
3949 $payinfo = $cust_pay->payinfo;
3951 $payinfo = $self->payinfo;
3953 ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
3954 $content{bank_name} = $self->payname;
3955 $content{account_type} = 'CHECKING';
3956 $content{account_name} = $payname;
3957 $content{customer_org} = $self->company ? 'B' : 'I';
3958 $content{customer_ssn} = $self->ss;
3959 } elsif ( $method eq 'LEC' ) {
3960 $content{phone} = $payinfo = $self->payinfo;
3964 my $refund = new Business::OnlinePayment( $processor, @bop_options );
3965 my %sub_content = $refund->content(
3966 'action' => 'credit',
3967 'customer_id' => $self->custnum,
3968 'last_name' => $paylast,
3969 'first_name' => $payfirst,
3971 'address' => $address,
3972 'city' => $self->city,
3973 'state' => $self->state,
3974 'zip' => $self->zip,
3975 'country' => $self->country,
3977 'phone' => $self->daytime || $self->night,
3980 warn join('', map { " $_ => $sub_content{$_}\n" } keys %sub_content )
3984 return "$processor error: ". $refund->error_message
3985 unless $refund->is_success();
3987 my %method2payby = (
3993 my $paybatch = "$processor:". $refund->authorization;
3994 $paybatch .= ':'. $refund->order_number
3995 if $refund->can('order_number') && $refund->order_number;
3997 while ( $cust_pay && $cust_pay->unapplied < $amount ) {
3998 my @cust_bill_pay = $cust_pay->cust_bill_pay;
3999 last unless @cust_bill_pay;
4000 my $cust_bill_pay = pop @cust_bill_pay;
4001 my $error = $cust_bill_pay->delete;
4005 my $cust_refund = new FS::cust_refund ( {
4006 'custnum' => $self->custnum,
4007 'paynum' => $options{'paynum'},
4008 'refund' => $amount,
4010 'payby' => $method2payby{$method},
4011 'payinfo' => $payinfo,
4012 'paybatch' => $paybatch,
4013 'reason' => $options{'reason'} || 'card or ACH refund',
4015 my $error = $cust_refund->insert;
4017 $cust_refund->paynum(''); #try again with no specific paynum
4018 my $error2 = $cust_refund->insert;
4020 # gah, even with transactions.
4021 my $e = 'WARNING: Card/ACH refunded but database not updated - '.
4022 "error inserting refund ($processor): $error2".
4023 " (previously tried insert with paynum #$options{'paynum'}" .
4034 =item batch_card OPTION => VALUE...
4036 Adds a payment for this invoice to the pending credit card batch (see
4037 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
4038 runs the payment using a realtime gateway.
4043 my ($self, %options) = @_;
4046 if (exists($options{amount})) {
4047 $amount = $options{amount};
4049 $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
4051 return '' unless $amount > 0;
4053 my $invnum = delete $options{invnum};
4054 my $payby = $options{invnum} || $self->payby; #dubious
4056 if ($options{'realtime'}) {
4057 return $self->realtime_bop( FS::payby->payby2bop($self->payby),
4063 my $oldAutoCommit = $FS::UID::AutoCommit;
4064 local $FS::UID::AutoCommit = 0;
4067 #this needs to handle mysql as well as Pg, like svc_acct.pm
4068 #(make it into a common function if folks need to do batching with mysql)
4069 $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
4070 or return "Cannot lock pay_batch: " . $dbh->errstr;
4074 'payby' => FS::payby->payby2payment($payby),
4077 my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
4079 unless ( $pay_batch ) {
4080 $pay_batch = new FS::pay_batch \%pay_batch;
4081 my $error = $pay_batch->insert;
4083 $dbh->rollback if $oldAutoCommit;
4084 die "error creating new batch: $error\n";
4088 my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
4089 'batchnum' => $pay_batch->batchnum,
4090 'custnum' => $self->custnum,
4093 foreach (qw( address1 address2 city state zip country payby payinfo paydate
4095 $options{$_} = '' unless exists($options{$_});
4098 my $cust_pay_batch = new FS::cust_pay_batch ( {
4099 'batchnum' => $pay_batch->batchnum,
4100 'invnum' => $invnum || 0, # is there a better value?
4101 # this field should be
4103 # cust_bill_pay_batch now
4104 'custnum' => $self->custnum,
4105 'last' => $self->getfield('last'),
4106 'first' => $self->getfield('first'),
4107 'address1' => $options{address1} || $self->address1,
4108 'address2' => $options{address2} || $self->address2,
4109 'city' => $options{city} || $self->city,
4110 'state' => $options{state} || $self->state,
4111 'zip' => $options{zip} || $self->zip,
4112 'country' => $options{country} || $self->country,
4113 'payby' => $options{payby} || $self->payby,
4114 'payinfo' => $options{payinfo} || $self->payinfo,
4115 'exp' => $options{paydate} || $self->paydate,
4116 'payname' => $options{payname} || $self->payname,
4117 'amount' => $amount, # consolidating
4120 $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
4121 if $old_cust_pay_batch;
4124 if ($old_cust_pay_batch) {
4125 $error = $cust_pay_batch->replace($old_cust_pay_batch)
4127 $error = $cust_pay_batch->insert;
4131 $dbh->rollback if $oldAutoCommit;
4135 my $unapplied = $self->total_credited + $self->total_unapplied_payments + $self->in_transit_payments;
4136 foreach my $cust_bill ($self->open_cust_bill) {
4137 #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
4138 my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
4139 'invnum' => $cust_bill->invnum,
4140 'paybatchnum' => $cust_pay_batch->paybatchnum,
4141 'amount' => $cust_bill->owed,
4144 if ($unapplied >= $cust_bill_pay_batch->amount){
4145 $unapplied -= $cust_bill_pay_batch->amount;
4148 $cust_bill_pay_batch->amount(sprintf ( "%.2f",
4149 $cust_bill_pay_batch->amount - $unapplied )); $unapplied = 0;
4151 $error = $cust_bill_pay_batch->insert;
4153 $dbh->rollback if $oldAutoCommit;
4158 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4164 Returns the total owed for this customer on all invoices
4165 (see L<FS::cust_bill/owed>).
4171 $self->total_owed_date(2145859200); #12/31/2037
4174 =item total_owed_date TIME
4176 Returns the total owed for this customer on all invoices with date earlier than
4177 TIME. TIME is specified as a UNIX timestamp; see L<perlfunc/"time">). Also
4178 see L<Time::Local> and L<Date::Parse> for conversion functions.
4182 sub total_owed_date {
4186 foreach my $cust_bill (
4187 grep { $_->_date <= $time }
4188 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4190 $total_bill += $cust_bill->owed;
4192 sprintf( "%.2f", $total_bill );
4195 =item apply_payments_and_credits
4197 Applies unapplied payments and credits.
4199 In most cases, this new method should be used in place of sequential
4200 apply_payments and apply_credits methods.
4202 If there is an error, returns the error, otherwise returns false.
4206 sub apply_payments_and_credits {
4209 local $SIG{HUP} = 'IGNORE';
4210 local $SIG{INT} = 'IGNORE';
4211 local $SIG{QUIT} = 'IGNORE';
4212 local $SIG{TERM} = 'IGNORE';
4213 local $SIG{TSTP} = 'IGNORE';
4214 local $SIG{PIPE} = 'IGNORE';
4216 my $oldAutoCommit = $FS::UID::AutoCommit;
4217 local $FS::UID::AutoCommit = 0;
4220 $self->select_for_update; #mutex
4222 foreach my $cust_bill ( $self->open_cust_bill ) {
4223 my $error = $cust_bill->apply_payments_and_credits;
4225 $dbh->rollback if $oldAutoCommit;
4226 return "Error applying: $error";
4230 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4235 =item apply_credits OPTION => VALUE ...
4237 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
4238 to outstanding invoice balances in chronological order (or reverse
4239 chronological order if the I<order> option is set to B<newest>) and returns the
4240 value of any remaining unapplied credits available for refund (see
4241 L<FS::cust_refund>).
4243 Dies if there is an error.
4251 local $SIG{HUP} = 'IGNORE';
4252 local $SIG{INT} = 'IGNORE';
4253 local $SIG{QUIT} = 'IGNORE';
4254 local $SIG{TERM} = 'IGNORE';
4255 local $SIG{TSTP} = 'IGNORE';
4256 local $SIG{PIPE} = 'IGNORE';
4258 my $oldAutoCommit = $FS::UID::AutoCommit;
4259 local $FS::UID::AutoCommit = 0;
4262 $self->select_for_update; #mutex
4264 unless ( $self->total_credited ) {
4265 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4269 my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
4270 qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
4272 my @invoices = $self->open_cust_bill;
4273 @invoices = sort { $b->_date <=> $a->_date } @invoices
4274 if defined($opt{'order'}) && $opt{'order'} eq 'newest';
4277 foreach my $cust_bill ( @invoices ) {
4280 if ( !defined($credit) || $credit->credited == 0) {
4281 $credit = pop @credits or last;
4284 if ($cust_bill->owed >= $credit->credited) {
4285 $amount=$credit->credited;
4287 $amount=$cust_bill->owed;
4290 my $cust_credit_bill = new FS::cust_credit_bill ( {
4291 'crednum' => $credit->crednum,
4292 'invnum' => $cust_bill->invnum,
4293 'amount' => $amount,
4295 my $error = $cust_credit_bill->insert;
4297 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4301 redo if ($cust_bill->owed > 0);
4305 my $total_credited = $self->total_credited;
4307 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4309 return $total_credited;
4312 =item apply_payments
4314 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
4315 to outstanding invoice balances in chronological order.
4317 #and returns the value of any remaining unapplied payments.
4319 Dies if there is an error.
4323 sub apply_payments {
4326 local $SIG{HUP} = 'IGNORE';
4327 local $SIG{INT} = 'IGNORE';
4328 local $SIG{QUIT} = 'IGNORE';
4329 local $SIG{TERM} = 'IGNORE';
4330 local $SIG{TSTP} = 'IGNORE';
4331 local $SIG{PIPE} = 'IGNORE';
4333 my $oldAutoCommit = $FS::UID::AutoCommit;
4334 local $FS::UID::AutoCommit = 0;
4337 $self->select_for_update; #mutex
4341 my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
4342 qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
4344 my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
4345 qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
4349 foreach my $cust_bill ( @invoices ) {
4352 if ( !defined($payment) || $payment->unapplied == 0 ) {
4353 $payment = pop @payments or last;
4356 if ( $cust_bill->owed >= $payment->unapplied ) {
4357 $amount = $payment->unapplied;
4359 $amount = $cust_bill->owed;
4362 my $cust_bill_pay = new FS::cust_bill_pay ( {
4363 'paynum' => $payment->paynum,
4364 'invnum' => $cust_bill->invnum,
4365 'amount' => $amount,
4367 my $error = $cust_bill_pay->insert;
4369 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4373 redo if ( $cust_bill->owed > 0);
4377 my $total_unapplied_payments = $self->total_unapplied_payments;
4379 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4381 return $total_unapplied_payments;
4384 =item total_credited
4386 Returns the total outstanding credit (see L<FS::cust_credit>) for this
4387 customer. See L<FS::cust_credit/credited>.
4391 sub total_credited {
4393 my $total_credit = 0;
4394 foreach my $cust_credit ( qsearch('cust_credit', {
4395 'custnum' => $self->custnum,
4397 $total_credit += $cust_credit->credited;
4399 sprintf( "%.2f", $total_credit );
4402 =item total_unapplied_payments
4404 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
4405 See L<FS::cust_pay/unapplied>.
4409 sub total_unapplied_payments {
4411 my $total_unapplied = 0;
4412 foreach my $cust_pay ( qsearch('cust_pay', {
4413 'custnum' => $self->custnum,
4415 $total_unapplied += $cust_pay->unapplied;
4417 sprintf( "%.2f", $total_unapplied );
4420 =item total_unapplied_refunds
4422 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
4423 customer. See L<FS::cust_refund/unapplied>.
4427 sub total_unapplied_refunds {
4429 my $total_unapplied = 0;
4430 foreach my $cust_refund ( qsearch('cust_refund', {
4431 'custnum' => $self->custnum,
4433 $total_unapplied += $cust_refund->unapplied;
4435 sprintf( "%.2f", $total_unapplied );
4440 Returns the balance for this customer (total_owed plus total_unrefunded, minus
4441 total_credited minus total_unapplied_payments).
4449 + $self->total_unapplied_refunds
4450 - $self->total_credited
4451 - $self->total_unapplied_payments
4455 =item balance_date TIME
4457 Returns the balance for this customer, only considering invoices with date
4458 earlier than TIME (total_owed_date minus total_credited minus
4459 total_unapplied_payments). TIME is specified as a UNIX timestamp; see
4460 L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion
4469 $self->total_owed_date($time)
4470 + $self->total_unapplied_refunds
4471 - $self->total_credited
4472 - $self->total_unapplied_payments
4476 =item in_transit_payments
4478 Returns the total of requests for payments for this customer pending in
4479 batches in transit to the bank. See L<FS::pay_batch> and L<FS::cust_pay_batch>
4483 sub in_transit_payments {
4485 my $in_transit_payments = 0;
4486 foreach my $pay_batch ( qsearch('pay_batch', {
4489 foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4490 'batchnum' => $pay_batch->batchnum,
4491 'custnum' => $self->custnum,
4493 $in_transit_payments += $cust_pay_batch->amount;
4496 sprintf( "%.2f", $in_transit_payments );
4499 =item paydate_monthyear
4501 Returns a two-element list consisting of the month and year of this customer's
4502 paydate (credit card expiration date for CARD customers)
4506 sub paydate_monthyear {
4508 if ( $self->paydate =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4510 } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4517 =item invoicing_list [ ARRAYREF ]
4519 If an arguement is given, sets these email addresses as invoice recipients
4520 (see L<FS::cust_main_invoice>). Errors are not fatal and are not reported
4521 (except as warnings), so use check_invoicing_list first.
4523 Returns a list of email addresses (with svcnum entries expanded).
4525 Note: You can clear the invoicing list by passing an empty ARRAYREF. You can
4526 check it without disturbing anything by passing nothing.
4528 This interface may change in the future.
4532 sub invoicing_list {
4533 my( $self, $arrayref ) = @_;
4536 my @cust_main_invoice;
4537 if ( $self->custnum ) {
4538 @cust_main_invoice =
4539 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4541 @cust_main_invoice = ();
4543 foreach my $cust_main_invoice ( @cust_main_invoice ) {
4544 #warn $cust_main_invoice->destnum;
4545 unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4546 #warn $cust_main_invoice->destnum;
4547 my $error = $cust_main_invoice->delete;
4548 warn $error if $error;
4551 if ( $self->custnum ) {
4552 @cust_main_invoice =
4553 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4555 @cust_main_invoice = ();
4557 my %seen = map { $_->address => 1 } @cust_main_invoice;
4558 foreach my $address ( @{$arrayref} ) {
4559 next if exists $seen{$address} && $seen{$address};
4560 $seen{$address} = 1;
4561 my $cust_main_invoice = new FS::cust_main_invoice ( {
4562 'custnum' => $self->custnum,
4565 my $error = $cust_main_invoice->insert;
4566 warn $error if $error;
4570 if ( $self->custnum ) {
4572 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4579 =item check_invoicing_list ARRAYREF
4581 Checks these arguements as valid input for the invoicing_list method. If there
4582 is an error, returns the error, otherwise returns false.
4586 sub check_invoicing_list {
4587 my( $self, $arrayref ) = @_;
4589 foreach my $address ( @$arrayref ) {
4591 if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4592 return 'Can\'t add FAX invoice destination with a blank FAX number.';
4595 my $cust_main_invoice = new FS::cust_main_invoice ( {
4596 'custnum' => $self->custnum,
4599 my $error = $self->custnum
4600 ? $cust_main_invoice->check
4601 : $cust_main_invoice->checkdest
4603 return $error if $error;
4607 return "Email address required"
4608 if $conf->exists('cust_main-require_invoicing_list_email')
4609 && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
4614 =item set_default_invoicing_list
4616 Sets the invoicing list to all accounts associated with this customer,
4617 overwriting any previous invoicing list.
4621 sub set_default_invoicing_list {
4623 $self->invoicing_list($self->all_emails);
4628 Returns the email addresses of all accounts provisioned for this customer.
4635 foreach my $cust_pkg ( $self->all_pkgs ) {
4636 my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
4638 map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4639 grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4641 $list{$_}=1 foreach map { $_->email } @svc_acct;
4646 =item invoicing_list_addpost
4648 Adds postal invoicing to this customer. If this customer is already configured
4649 to receive postal invoices, does nothing.
4653 sub invoicing_list_addpost {
4655 return if grep { $_ eq 'POST' } $self->invoicing_list;
4656 my @invoicing_list = $self->invoicing_list;
4657 push @invoicing_list, 'POST';
4658 $self->invoicing_list(\@invoicing_list);
4661 =item invoicing_list_emailonly
4663 Returns the list of email invoice recipients (invoicing_list without non-email
4664 destinations such as POST and FAX).
4668 sub invoicing_list_emailonly {
4670 warn "$me invoicing_list_emailonly called"
4672 grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
4675 =item invoicing_list_emailonly_scalar
4677 Returns the list of email invoice recipients (invoicing_list without non-email
4678 destinations such as POST and FAX) as a comma-separated scalar.
4682 sub invoicing_list_emailonly_scalar {
4684 warn "$me invoicing_list_emailonly_scalar called"
4686 join(', ', $self->invoicing_list_emailonly);
4689 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
4691 Returns an array of customers referred by this customer (referral_custnum set
4692 to this custnum). If DEPTH is given, recurses up to the given depth, returning
4693 customers referred by customers referred by this customer and so on, inclusive.
4694 The default behavior is DEPTH 1 (no recursion).
4698 sub referral_cust_main {
4700 my $depth = @_ ? shift : 1;
4701 my $exclude = @_ ? shift : {};
4704 map { $exclude->{$_->custnum}++; $_; }
4705 grep { ! $exclude->{ $_->custnum } }
4706 qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
4710 map { $_->referral_cust_main($depth-1, $exclude) }
4717 =item referral_cust_main_ncancelled
4719 Same as referral_cust_main, except only returns customers with uncancelled
4724 sub referral_cust_main_ncancelled {
4726 grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
4729 =item referral_cust_pkg [ DEPTH ]
4731 Like referral_cust_main, except returns a flat list of all unsuspended (and
4732 uncancelled) packages for each customer. The number of items in this list may
4733 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
4737 sub referral_cust_pkg {
4739 my $depth = @_ ? shift : 1;
4741 map { $_->unsuspended_pkgs }
4742 grep { $_->unsuspended_pkgs }
4743 $self->referral_cust_main($depth);
4746 =item referring_cust_main
4748 Returns the single cust_main record for the customer who referred this customer
4749 (referral_custnum), or false.
4753 sub referring_cust_main {
4755 return '' unless $self->referral_custnum;
4756 qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
4759 =item credit AMOUNT, REASON
4761 Applies a credit to this customer. If there is an error, returns the error,
4762 otherwise returns false.
4767 my( $self, $amount, $reason, %options ) = @_;
4768 my $cust_credit = new FS::cust_credit {
4769 'custnum' => $self->custnum,
4770 'amount' => $amount,
4771 'reason' => $reason,
4773 $cust_credit->insert(%options);
4776 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
4778 Creates a one-time charge for this customer. If there is an error, returns
4779 the error, otherwise returns false.
4785 my ( $amount, $quantity, $pkg, $comment, $taxclass, $additional, $classnum );
4786 if ( ref( $_[0] ) ) {
4787 $amount = $_[0]->{amount};
4788 $quantity = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
4789 $pkg = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
4790 $comment = exists($_[0]->{comment}) ? $_[0]->{comment}
4791 : '$'. sprintf("%.2f",$amount);
4792 $taxclass = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
4793 $classnum = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
4794 $additional = $_[0]->{additional};
4798 $pkg = @_ ? shift : 'One-time charge';
4799 $comment = @_ ? shift : '$'. sprintf("%.2f",$amount);
4800 $taxclass = @_ ? shift : '';
4804 local $SIG{HUP} = 'IGNORE';
4805 local $SIG{INT} = 'IGNORE';
4806 local $SIG{QUIT} = 'IGNORE';
4807 local $SIG{TERM} = 'IGNORE';
4808 local $SIG{TSTP} = 'IGNORE';
4809 local $SIG{PIPE} = 'IGNORE';
4811 my $oldAutoCommit = $FS::UID::AutoCommit;
4812 local $FS::UID::AutoCommit = 0;
4815 my $part_pkg = new FS::part_pkg ( {
4817 'comment' => $comment,
4821 'classnum' => $classnum ? $classnum : '',
4822 'taxclass' => $taxclass,
4825 my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
4826 ( 0 .. @$additional - 1 )
4828 'additional_count' => scalar(@$additional),
4829 'setup_fee' => $amount,
4832 my $error = $part_pkg->insert( options => \%options );
4834 $dbh->rollback if $oldAutoCommit;
4838 my $pkgpart = $part_pkg->pkgpart;
4839 my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
4840 unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
4841 my $type_pkgs = new FS::type_pkgs \%type_pkgs;
4842 $error = $type_pkgs->insert;
4844 $dbh->rollback if $oldAutoCommit;
4849 my $cust_pkg = new FS::cust_pkg ( {
4850 'custnum' => $self->custnum,
4851 'pkgpart' => $pkgpart,
4852 'quantity' => $quantity,
4855 $error = $cust_pkg->insert;
4857 $dbh->rollback if $oldAutoCommit;
4861 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4866 #=item charge_postal_fee
4868 #Applies a one time charge this customer. If there is an error,
4869 #returns the error, returns the cust_pkg charge object or false
4870 #if there was no charge.
4874 # This should be a customer event. For that to work requires that bill
4875 # also be a customer event.
4877 sub charge_postal_fee {
4880 my $pkgpart = $conf->config('postal_invoice-fee_pkgpart');
4881 return '' unless ($pkgpart && grep { $_ eq 'POST' } $self->invoicing_list);
4883 my $cust_pkg = new FS::cust_pkg ( {
4884 'custnum' => $self->custnum,
4885 'pkgpart' => $pkgpart,
4889 my $error = $cust_pkg->insert;
4890 $error ? $error : $cust_pkg;
4895 Returns all the invoices (see L<FS::cust_bill>) for this customer.
4901 sort { $a->_date <=> $b->_date }
4902 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4905 =item open_cust_bill
4907 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
4912 sub open_cust_bill {
4914 grep { $_->owed > 0 } $self->cust_bill;
4919 Returns all the credits (see L<FS::cust_credit>) for this customer.
4925 sort { $a->_date <=> $b->_date }
4926 qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
4931 Returns all the payments (see L<FS::cust_pay>) for this customer.
4937 sort { $a->_date <=> $b->_date }
4938 qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
4943 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
4949 sort { $a->_date <=> $b->_date }
4950 qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
4953 =item cust_pay_batch
4955 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
4959 sub cust_pay_batch {
4961 sort { $a->_date <=> $b->_date }
4962 qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
4967 Returns all the refunds (see L<FS::cust_refund>) for this customer.
4973 sort { $a->_date <=> $b->_date }
4974 qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
4979 Returns a name string for this customer, either "Company (Last, First)" or
4986 my $name = $self->contact;
4987 $name = $self->company. " ($name)" if $self->company;
4993 Returns a name string for this (service/shipping) contact, either
4994 "Company (Last, First)" or "Last, First".
5000 if ( $self->get('ship_last') ) {
5001 my $name = $self->ship_contact;
5002 $name = $self->ship_company. " ($name)" if $self->ship_company;
5011 Returns this customer's full (billing) contact name only, "Last, First"
5017 $self->get('last'). ', '. $self->first;
5022 Returns this customer's full (shipping) contact name only, "Last, First"
5028 $self->get('ship_last')
5029 ? $self->get('ship_last'). ', '. $self->ship_first
5035 Returns this customer's full country name
5041 code2country($self->country);
5044 =item geocode DATA_VENDOR
5046 Returns a value for the customer location as encoded by DATA_VENDOR.
5047 Currently this only makes sense for "CCH" as DATA_VENDOR.
5052 my ($self, $data_vendor) = (shift, shift); #always cch for now
5054 my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
5058 my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
5059 if $self->country eq 'US';
5061 #CCH specific location stuff
5062 my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
5065 my $cust_tax_location =
5067 'table' => 'cust_tax_location',
5068 'hashref' => { 'zip' => $zip, 'data_vendor' => $data_vendor },
5069 'extra_sql' => $extra_sql,
5072 $geocode = $cust_tax_location->geocode
5073 if $cust_tax_location;
5082 Returns a status string for this customer, currently:
5086 =item prospect - No packages have ever been ordered
5088 =item active - One or more recurring packages is active
5090 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
5092 =item suspended - All non-cancelled recurring packages are suspended
5094 =item cancelled - All recurring packages are cancelled
5100 sub status { shift->cust_status(@_); }
5104 for my $status (qw( prospect active inactive suspended cancelled )) {
5105 my $method = $status.'_sql';
5106 my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
5107 my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
5108 $sth->execute( ($self->custnum) x $numnum )
5109 or die "Error executing 'SELECT $sql': ". $sth->errstr;
5110 return $status if $sth->fetchrow_arrayref->[0];
5114 =item ucfirst_cust_status
5116 =item ucfirst_status
5118 Returns the status with the first character capitalized.
5122 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
5124 sub ucfirst_cust_status {
5126 ucfirst($self->cust_status);
5131 Returns a hex triplet color string for this customer's status.
5135 use vars qw(%statuscolor);
5136 tie %statuscolor, 'Tie::IxHash',
5137 'prospect' => '7e0079', #'000000', #black? naw, purple
5138 'active' => '00CC00', #green
5139 'inactive' => '0000CC', #blue
5140 'suspended' => 'FF9900', #yellow
5141 'cancelled' => 'FF0000', #red
5144 sub statuscolor { shift->cust_statuscolor(@_); }
5146 sub cust_statuscolor {
5148 $statuscolor{$self->cust_status};
5153 Returns an array of hashes representing the customer's RT tickets.
5160 my $num = $conf->config('cust_main-max_tickets') || 10;
5163 unless ( $conf->config('ticket_system-custom_priority_field') ) {
5165 @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
5169 foreach my $priority (
5170 $conf->config('ticket_system-custom_priority_field-values'), ''
5172 last if scalar(@tickets) >= $num;
5174 @{ FS::TicketSystem->customer_tickets( $self->custnum,
5175 $num - scalar(@tickets),
5184 # Return services representing svc_accts in customer support packages
5185 sub support_services {
5187 my %packages = map { $_ => 1 } $conf->config('support_packages');
5189 grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
5190 grep { $_->part_svc->svcdb eq 'svc_acct' }
5191 map { $_->cust_svc }
5192 grep { exists $packages{ $_->pkgpart } }
5193 $self->ncancelled_pkgs;
5199 =head1 CLASS METHODS
5205 Class method that returns the list of possible status strings for customers
5206 (see L<the status method|/status>). For example:
5208 @statuses = FS::cust_main->statuses();
5213 #my $self = shift; #could be class...
5219 Returns an SQL expression identifying prospective cust_main records (customers
5220 with no packages ever ordered)
5224 use vars qw($select_count_pkgs);
5225 $select_count_pkgs =
5226 "SELECT COUNT(*) FROM cust_pkg
5227 WHERE cust_pkg.custnum = cust_main.custnum";
5229 sub select_count_pkgs_sql {
5233 sub prospect_sql { "
5234 0 = ( $select_count_pkgs )
5239 Returns an SQL expression identifying active cust_main records (customers with
5240 active recurring packages).
5245 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
5251 Returns an SQL expression identifying inactive cust_main records (customers with
5252 no active recurring packages, but otherwise unsuspended/uncancelled).
5256 sub inactive_sql { "
5257 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5259 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5265 Returns an SQL expression identifying suspended cust_main records.
5270 sub suspended_sql { susp_sql(@_); }
5272 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
5274 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5280 Returns an SQL expression identifying cancelled cust_main records.
5284 sub cancelled_sql { cancel_sql(@_); }
5287 my $recurring_sql = FS::cust_pkg->recurring_sql;
5288 my $cancelled_sql = FS::cust_pkg->cancelled_sql;
5291 0 < ( $select_count_pkgs )
5292 AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql )
5293 AND 0 = ( $select_count_pkgs AND $recurring_sql
5294 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5296 AND 0 = ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5302 =item uncancelled_sql
5304 Returns an SQL expression identifying un-cancelled cust_main records.
5308 sub uncancelled_sql { uncancel_sql(@_); }
5309 sub uncancel_sql { "
5310 ( 0 < ( $select_count_pkgs
5311 AND ( cust_pkg.cancel IS NULL
5312 OR cust_pkg.cancel = 0
5315 OR 0 = ( $select_count_pkgs )
5321 Returns an SQL fragment to retreive the balance.
5326 ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
5327 WHERE cust_bill.custnum = cust_main.custnum )
5328 - ( SELECT COALESCE( SUM(paid), 0 ) FROM cust_pay
5329 WHERE cust_pay.custnum = cust_main.custnum )
5330 - ( SELECT COALESCE( SUM(amount), 0 ) FROM cust_credit
5331 WHERE cust_credit.custnum = cust_main.custnum )
5332 + ( SELECT COALESCE( SUM(refund), 0 ) FROM cust_refund
5333 WHERE cust_refund.custnum = cust_main.custnum )
5336 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5338 Returns an SQL fragment to retreive the balance for this customer, only
5339 considering invoices with date earlier than START_TIME, and optionally not
5340 later than END_TIME (total_owed_date minus total_credited minus
5341 total_unapplied_payments).
5343 Times are specified as SQL fragments or numeric
5344 UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
5345 L<Date::Parse> for conversion functions. The empty string can be passed
5346 to disable that time constraint completely.
5348 Available options are:
5352 =item unapplied_date
5354 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)
5359 set to true to remove all customer comparison clauses, for totals
5364 WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
5369 JOIN clause (typically used with the total option)
5375 sub balance_date_sql {
5376 my( $class, $start, $end, %opt ) = @_;
5378 my $owed = FS::cust_bill->owed_sql;
5379 my $unapp_refund = FS::cust_refund->unapplied_sql;
5380 my $unapp_credit = FS::cust_credit->unapplied_sql;
5381 my $unapp_pay = FS::cust_pay->unapplied_sql;
5383 my $j = $opt{'join'} || '';
5385 my $owed_wh = $class->_money_table_where( 'cust_bill', $start,$end,%opt );
5386 my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
5387 my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
5388 my $pay_wh = $class->_money_table_where( 'cust_pay', $start,$end,%opt );
5390 " ( SELECT COALESCE(SUM($owed), 0) FROM cust_bill $j $owed_wh )
5391 + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
5392 - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
5393 - ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $j $pay_wh )
5398 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5400 Helper method for balance_date_sql; name (and usage) subject to change
5401 (suggestions welcome).
5403 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
5404 cust_refund, cust_credit or cust_pay).
5406 If TABLE is "cust_bill" or the unapplied_date option is true, only
5407 considers records with date earlier than START_TIME, and optionally not
5408 later than END_TIME .
5412 sub _money_table_where {
5413 my( $class, $table, $start, $end, %opt ) = @_;
5416 push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
5417 if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
5418 push @where, "$table._date <= $start" if defined($start) && length($start);
5419 push @where, "$table._date > $end" if defined($end) && length($end);
5421 push @where, @{$opt{'where'}} if $opt{'where'};
5422 my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
5428 =item search_sql HASHREF
5432 Returns a qsearch hash expression to search for parameters specified in HREF.
5433 Valid parameters are
5441 =item cancelled_pkgs
5447 listref of start date, end date
5453 =item current_balance
5455 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
5459 =item flattened_pkgs
5468 my ($class, $params) = @_;
5479 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5481 "cust_main.agentnum = $1";
5488 #prospect active inactive suspended cancelled
5489 if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
5490 my $method = $params->{'status'}. '_sql';
5491 #push @where, $class->$method();
5492 push @where, FS::cust_main->$method();
5496 # parse cancelled package checkbox
5501 $pkgwhere .= "AND (cancel = 0 or cancel is null)"
5502 unless $params->{'cancelled_pkgs'};
5508 foreach my $field (qw( signupdate )) {
5510 next unless exists($params->{$field});
5512 my($beginning, $ending) = @{$params->{$field}};
5515 "cust_main.$field IS NOT NULL",
5516 "cust_main.$field >= $beginning",
5517 "cust_main.$field <= $ending";
5519 $orderby ||= "ORDER BY cust_main.$field";
5527 my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
5529 push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
5536 #my $balance_sql = $class->balance_sql();
5537 my $balance_sql = FS::cust_main->balance_sql();
5539 push @where, map { s/current_balance/$balance_sql/; $_ }
5540 @{ $params->{'current_balance'} };
5543 # setup queries, subs, etc. for the search
5546 $orderby ||= 'ORDER BY custnum';
5548 # here is the agent virtualization
5549 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
5551 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
5553 my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum ) ';
5555 my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
5557 my $select = join(', ',
5558 'cust_main.custnum',
5559 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
5562 my(@extra_headers) = ();
5563 my(@extra_fields) = ();
5565 if ($params->{'flattened_pkgs'}) {
5567 if ($dbh->{Driver}->{Name} eq 'Pg') {
5569 $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";
5571 }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
5572 $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
5573 $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
5575 warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
5576 "omitting packing information from report.";
5579 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";
5581 my $sth = dbh->prepare($header_query) or die dbh->errstr;
5582 $sth->execute() or die $sth->errstr;
5583 my $headerrow = $sth->fetchrow_arrayref;
5584 my $headercount = $headerrow ? $headerrow->[0] : 0;
5585 while($headercount) {
5586 unshift @extra_headers, "Package ". $headercount;
5587 unshift @extra_fields, eval q!sub {my $c = shift;
5588 my @a = split '\|', $c->magic;
5589 my $p = $a[!.--$headercount. q!];
5597 'table' => 'cust_main',
5598 'select' => $select,
5600 'extra_sql' => $extra_sql,
5601 'order_by' => $orderby,
5602 'count_query' => $count_query,
5603 'extra_headers' => \@extra_headers,
5604 'extra_fields' => \@extra_fields,
5609 =item email_search_sql HASHREF
5613 Emails a notice to the specified customers.
5615 Valid parameters are those of the L<search_sql> method, plus the following:
5637 Optional job queue job for status updates.
5641 Returns an error message, or false for success.
5643 If an error occurs during any email, stops the enture send and returns that
5644 error. Presumably if you're getting SMTP errors aborting is better than
5645 retrying everything.
5649 sub email_search_sql {
5650 my($class, $params) = @_;
5652 my $from = delete $params->{from};
5653 my $subject = delete $params->{subject};
5654 my $html_body = delete $params->{html_body};
5655 my $text_body = delete $params->{text_body};
5657 my $job = delete $params->{'job'};
5659 my $sql_query = $class->search_sql($params);
5661 my $count_query = delete($sql_query->{'count_query'});
5662 my $count_sth = dbh->prepare($count_query)
5663 or die "Error preparing $count_query: ". dbh->errstr;
5665 or die "Error executing $count_query: ". $count_sth->errstr;
5666 my $count_arrayref = $count_sth->fetchrow_arrayref;
5667 my $num_cust = $count_arrayref->[0];
5669 #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
5670 #my @extra_fields = @{ delete($sql_query->{'extra_fields'}) };
5673 my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
5675 #eventually order+limit magic to reduce memory use?
5676 foreach my $cust_main ( qsearch($sql_query) ) {
5678 my $to = $cust_main->invoicing_list_emailonly_scalar;
5681 my $error = send_email(
5685 'subject' => $subject,
5686 'html_body' => $html_body,
5687 'text_body' => $text_body,
5690 return $error if $error;
5692 if ( $job ) { #progressbar foo
5694 if ( time - $min_sec > $last ) {
5695 my $error = $job->update_statustext(
5696 int( 100 * $num / $num_cust )
5698 die $error if $error;
5708 use Storable qw(thaw);
5711 sub process_email_search_sql {
5713 #warn "$me process_re_X $method for job $job\n" if $DEBUG;
5715 my $param = thaw(decode_base64(shift));
5716 warn Dumper($param) if $DEBUG;
5718 $param->{'job'} = $job;
5720 my $error = FS::cust_main->email_search_sql( $param );
5721 die $error if $error;
5725 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
5727 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
5728 records. Currently, I<first>, I<last> and/or I<company> may be specified (the
5729 appropriate ship_ field is also searched).
5731 Additional options are the same as FS::Record::qsearch
5736 my( $self, $fuzzy, $hash, @opt) = @_;
5741 check_and_rebuild_fuzzyfiles();
5742 foreach my $field ( keys %$fuzzy ) {
5744 my $all = $self->all_X($field);
5745 next unless scalar(@$all);
5748 $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
5751 foreach ( keys %match ) {
5752 push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
5753 push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
5756 push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
5759 # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
5761 @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
5769 Returns a masked version of the named field
5774 my ($self,$field) = @_;
5778 'x'x(length($self->getfield($field))-4).
5779 substr($self->getfield($field), (length($self->getfield($field))-4));
5789 =item smart_search OPTION => VALUE ...
5791 Accepts the following options: I<search>, the string to search for. The string
5792 will be searched for as a customer number, phone number, name or company name,
5793 as an exact, or, in some cases, a substring or fuzzy match (see the source code
5794 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
5795 skip fuzzy matching when an exact match is found.
5797 Any additional options are treated as an additional qualifier on the search
5800 Returns a (possibly empty) array of FS::cust_main objects.
5807 #here is the agent virtualization
5808 my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
5812 my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
5813 my $search = delete $options{'search'};
5814 ( my $alphanum_search = $search ) =~ s/\W//g;
5816 if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
5818 #false laziness w/Record::ut_phone
5819 my $phonen = "$1-$2-$3";
5820 $phonen .= " x$4" if $4;
5822 push @cust_main, qsearch( {
5823 'table' => 'cust_main',
5824 'hashref' => { %options },
5825 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5827 join(' OR ', map "$_ = '$phonen'",
5828 qw( daytime night fax
5829 ship_daytime ship_night ship_fax )
5832 " AND $agentnums_sql", #agent virtualization
5835 unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
5836 #try looking for matches with extensions unless one was specified
5838 push @cust_main, qsearch( {
5839 'table' => 'cust_main',
5840 'hashref' => { %options },
5841 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5843 join(' OR ', map "$_ LIKE '$phonen\%'",
5845 ship_daytime ship_night )
5848 " AND $agentnums_sql", #agent virtualization
5853 # custnum search (also try agent_custid), with some tweaking options if your
5854 # legacy cust "numbers" have letters
5855 } elsif ( $search =~ /^\s*(\d+)\s*$/
5856 || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
5857 && $search =~ /^\s*(\w\w?\d+)\s*$/
5862 push @cust_main, qsearch( {
5863 'table' => 'cust_main',
5864 'hashref' => { 'custnum' => $1, %options },
5865 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5868 push @cust_main, qsearch( {
5869 'table' => 'cust_main',
5870 'hashref' => { 'agent_custid' => $1, %options },
5871 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5874 } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
5876 my($company, $last, $first) = ( $1, $2, $3 );
5878 # "Company (Last, First)"
5879 #this is probably something a browser remembered,
5880 #so just do an exact search
5882 foreach my $prefix ( '', 'ship_' ) {
5883 push @cust_main, qsearch( {
5884 'table' => 'cust_main',
5885 'hashref' => { $prefix.'first' => $first,
5886 $prefix.'last' => $last,
5887 $prefix.'company' => $company,
5890 'extra_sql' => " AND $agentnums_sql",
5894 } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
5895 # try (ship_){last,company}
5899 # # remove "(Last, First)" in "Company (Last, First)", otherwise the
5900 # # full strings the browser remembers won't work
5901 # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
5903 use Lingua::EN::NameParse;
5904 my $NameParse = new Lingua::EN::NameParse(
5906 allow_reversed => 1,
5909 my($last, $first) = ( '', '' );
5910 #maybe disable this too and just rely on NameParse?
5911 if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
5913 ($last, $first) = ( $1, $2 );
5915 #} elsif ( $value =~ /^(.+)\s+(.+)$/ ) {
5916 } elsif ( ! $NameParse->parse($value) ) {
5918 my %name = $NameParse->components;
5919 $first = $name{'given_name_1'};
5920 $last = $name{'surname_1'};
5924 if ( $first && $last ) {
5926 my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
5929 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5931 ( ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
5932 OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
5935 push @cust_main, qsearch( {
5936 'table' => 'cust_main',
5937 'hashref' => \%options,
5938 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5941 # or it just be something that was typed in... (try that in a sec)
5945 my $q_value = dbh->quote($value);
5948 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5949 $sql .= " ( LOWER(last) = $q_value
5950 OR LOWER(company) = $q_value
5951 OR LOWER(ship_last) = $q_value
5952 OR LOWER(ship_company) = $q_value
5955 push @cust_main, qsearch( {
5956 'table' => 'cust_main',
5957 'hashref' => \%options,
5958 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5961 #no exact match, trying substring/fuzzy
5962 #always do substring & fuzzy (unless they're explicity config'ed off)
5963 #getting complaints searches are not returning enough
5964 unless ( @cust_main && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
5966 #still some false laziness w/search_sql (was search/cust_main.cgi)
5971 { 'company' => { op=>'ILIKE', value=>"%$value%" }, },
5972 { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
5975 if ( $first && $last ) {
5978 { 'first' => { op=>'ILIKE', value=>"%$first%" },
5979 'last' => { op=>'ILIKE', value=>"%$last%" },
5981 { 'ship_first' => { op=>'ILIKE', value=>"%$first%" },
5982 'ship_last' => { op=>'ILIKE', value=>"%$last%" },
5989 { 'last' => { op=>'ILIKE', value=>"%$value%" }, },
5990 { 'ship_last' => { op=>'ILIKE', value=>"%$value%" }, },
5994 foreach my $hashref ( @hashrefs ) {
5996 push @cust_main, qsearch( {
5997 'table' => 'cust_main',
5998 'hashref' => { %$hashref,
6001 'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
6010 " AND $agentnums_sql", #extra_sql #agent virtualization
6013 if ( $first && $last ) {
6014 push @cust_main, FS::cust_main->fuzzy_search(
6015 { 'last' => $last, #fuzzy hashref
6016 'first' => $first }, #
6020 foreach my $field ( 'last', 'company' ) {
6022 FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
6027 #eliminate duplicates
6029 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6039 Accepts the following options: I<email>, the email address to search for. The
6040 email address will be searched for as an email invoice destination and as an
6043 #Any additional options are treated as an additional qualifier on the search
6044 #(i.e. I<agentnum>).
6046 Returns a (possibly empty) array of FS::cust_main objects (but usually just
6056 my $email = delete $options{'email'};
6058 #we're only being used by RT at the moment... no agent virtualization yet
6059 #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
6063 if ( $email =~ /([^@]+)\@([^@]+)/ ) {
6065 my ( $user, $domain ) = ( $1, $2 );
6067 warn "$me smart_search: searching for $user in domain $domain"
6073 'table' => 'cust_main_invoice',
6074 'hashref' => { 'dest' => $email },
6081 map $_->cust_svc->cust_pkg,
6083 'table' => 'svc_acct',
6084 'hashref' => { 'username' => $user, },
6086 'AND ( SELECT domain FROM svc_domain
6087 WHERE svc_acct.domsvc = svc_domain.svcnum
6088 ) = '. dbh->quote($domain),
6094 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6096 warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
6103 =item check_and_rebuild_fuzzyfiles
6107 use vars qw(@fuzzyfields);
6108 @fuzzyfields = ( 'last', 'first', 'company' );
6110 sub check_and_rebuild_fuzzyfiles {
6111 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6112 rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
6115 =item rebuild_fuzzyfiles
6119 sub rebuild_fuzzyfiles {
6121 use Fcntl qw(:flock);
6123 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6124 mkdir $dir, 0700 unless -d $dir;
6126 foreach my $fuzzy ( @fuzzyfields ) {
6128 open(LOCK,">>$dir/cust_main.$fuzzy")
6129 or die "can't open $dir/cust_main.$fuzzy: $!";
6131 or die "can't lock $dir/cust_main.$fuzzy: $!";
6133 open (CACHE,">$dir/cust_main.$fuzzy.tmp")
6134 or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
6136 foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
6137 my $sth = dbh->prepare("SELECT $field FROM cust_main".
6138 " WHERE $field != '' AND $field IS NOT NULL");
6139 $sth->execute or die $sth->errstr;
6141 while ( my $row = $sth->fetchrow_arrayref ) {
6142 print CACHE $row->[0]. "\n";
6147 close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
6149 rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
6160 my( $self, $field ) = @_;
6161 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6162 open(CACHE,"<$dir/cust_main.$field")
6163 or die "can't open $dir/cust_main.$field: $!";
6164 my @array = map { chomp; $_; } <CACHE>;
6169 =item append_fuzzyfiles LASTNAME COMPANY
6173 sub append_fuzzyfiles {
6174 #my( $first, $last, $company ) = @_;
6176 &check_and_rebuild_fuzzyfiles;
6178 use Fcntl qw(:flock);
6180 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6182 foreach my $field (qw( first last company )) {
6187 open(CACHE,">>$dir/cust_main.$field")
6188 or die "can't open $dir/cust_main.$field: $!";
6189 flock(CACHE,LOCK_EX)
6190 or die "can't lock $dir/cust_main.$field: $!";
6192 print CACHE "$value\n";
6194 flock(CACHE,LOCK_UN)
6195 or die "can't unlock $dir/cust_main.$field: $!";
6210 #warn join('-',keys %$param);
6211 my $fh = $param->{filehandle};
6212 my $agentnum = $param->{agentnum};
6214 my $refnum = $param->{refnum};
6215 my $pkgpart = $param->{pkgpart};
6217 #my @fields = @{$param->{fields}};
6218 my $format = $param->{'format'};
6221 if ( $format eq 'simple' ) {
6222 @fields = qw( cust_pkg.setup dayphone first last
6223 address1 address2 city state zip comments );
6225 } elsif ( $format eq 'extended' ) {
6226 @fields = qw( agent_custid refnum
6227 last first address1 address2 city state zip country
6229 ship_last ship_first ship_address1 ship_address2
6230 ship_city ship_state ship_zip ship_country
6231 payinfo paycvv paydate
6234 svc_acct.username svc_acct._password
6237 } elsif ( $format eq 'extended-plus_company' ) {
6238 @fields = qw( agent_custid refnum
6239 last first company address1 address2 city state zip country
6241 ship_last ship_first ship_company ship_address1 ship_address2
6242 ship_city ship_state ship_zip ship_country
6243 payinfo paycvv paydate
6246 svc_acct.username svc_acct._password
6250 die "unknown format $format";
6253 eval "use Text::CSV_XS;";
6256 my $csv = new Text::CSV_XS;
6263 local $SIG{HUP} = 'IGNORE';
6264 local $SIG{INT} = 'IGNORE';
6265 local $SIG{QUIT} = 'IGNORE';
6266 local $SIG{TERM} = 'IGNORE';
6267 local $SIG{TSTP} = 'IGNORE';
6268 local $SIG{PIPE} = 'IGNORE';
6270 my $oldAutoCommit = $FS::UID::AutoCommit;
6271 local $FS::UID::AutoCommit = 0;
6274 #while ( $columns = $csv->getline($fh) ) {
6276 while ( defined($line=<$fh>) ) {
6278 $csv->parse($line) or do {
6279 $dbh->rollback if $oldAutoCommit;
6280 return "can't parse: ". $csv->error_input();
6283 my @columns = $csv->fields();
6284 #warn join('-',@columns);
6287 agentnum => $agentnum,
6289 country => $conf->config('countrydefault') || 'US',
6290 payby => $payby, #default
6291 paydate => '12/2037', #default
6293 my $billtime = time;
6294 my %cust_pkg = ( pkgpart => $pkgpart );
6296 foreach my $field ( @fields ) {
6298 if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|adjourn|expire|cancel)$/ ) {
6300 #$cust_pkg{$1} = str2time( shift @$columns );
6301 if ( $1 eq 'pkgpart' ) {
6302 $cust_pkg{$1} = shift @columns;
6303 } elsif ( $1 eq 'setup' ) {
6304 $billtime = str2time(shift @columns);
6306 $cust_pkg{$1} = str2time( shift @columns );
6309 } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
6311 $svc_acct{$1} = shift @columns;
6315 #refnum interception
6316 if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
6318 my $referral = $columns[0];
6319 my %hash = ( 'referral' => $referral,
6320 'agentnum' => $agentnum,
6324 my $part_referral = qsearchs('part_referral', \%hash )
6325 || new FS::part_referral \%hash;
6327 unless ( $part_referral->refnum ) {
6328 my $error = $part_referral->insert;
6330 $dbh->rollback if $oldAutoCommit;
6331 return "can't auto-insert advertising source: $referral: $error";
6335 $columns[0] = $part_referral->refnum;
6338 #$cust_main{$field} = shift @$columns;
6339 $cust_main{$field} = shift @columns;
6343 $cust_main{'payby'} = 'CARD' if length($cust_main{'payinfo'});
6345 my $invoicing_list = $cust_main{'invoicing_list'}
6346 ? [ delete $cust_main{'invoicing_list'} ]
6349 my $cust_main = new FS::cust_main ( \%cust_main );
6352 tie my %hash, 'Tie::RefHash'; #this part is important
6354 if ( $cust_pkg{'pkgpart'} ) {
6355 my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
6358 if ( $svc_acct{'username'} ) {
6359 my $part_pkg = $cust_pkg->part_pkg;
6360 unless ( $part_pkg ) {
6361 $dbh->rollback if $oldAutoCommit;
6362 return "unknown pkgpart: ". $cust_pkg{'pkgpart'};
6364 $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
6365 push @svc_acct, new FS::svc_acct ( \%svc_acct )
6368 $hash{$cust_pkg} = \@svc_acct;
6371 my $error = $cust_main->insert( \%hash, $invoicing_list );
6374 $dbh->rollback if $oldAutoCommit;
6375 return "can't insert customer for $line: $error";
6378 if ( $format eq 'simple' ) {
6380 #false laziness w/bill.cgi
6381 $error = $cust_main->bill( 'time' => $billtime );
6383 $dbh->rollback if $oldAutoCommit;
6384 return "can't bill customer for $line: $error";
6387 $error = $cust_main->apply_payments_and_credits;
6389 $dbh->rollback if $oldAutoCommit;
6390 return "can't bill customer for $line: $error";
6393 $error = $cust_main->collect();
6395 $dbh->rollback if $oldAutoCommit;
6396 return "can't collect customer for $line: $error";
6404 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6406 return "Empty file!" unless $imported;
6418 #warn join('-',keys %$param);
6419 my $fh = $param->{filehandle};
6420 my @fields = @{$param->{fields}};
6422 eval "use Text::CSV_XS;";
6425 my $csv = new Text::CSV_XS;
6432 local $SIG{HUP} = 'IGNORE';
6433 local $SIG{INT} = 'IGNORE';
6434 local $SIG{QUIT} = 'IGNORE';
6435 local $SIG{TERM} = 'IGNORE';
6436 local $SIG{TSTP} = 'IGNORE';
6437 local $SIG{PIPE} = 'IGNORE';
6439 my $oldAutoCommit = $FS::UID::AutoCommit;
6440 local $FS::UID::AutoCommit = 0;
6443 #while ( $columns = $csv->getline($fh) ) {
6445 while ( defined($line=<$fh>) ) {
6447 $csv->parse($line) or do {
6448 $dbh->rollback if $oldAutoCommit;
6449 return "can't parse: ". $csv->error_input();
6452 my @columns = $csv->fields();
6453 #warn join('-',@columns);
6456 foreach my $field ( @fields ) {
6457 $row{$field} = shift @columns;
6460 my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
6461 unless ( $cust_main ) {
6462 $dbh->rollback if $oldAutoCommit;
6463 return "unknown custnum $row{'custnum'}";
6466 if ( $row{'amount'} > 0 ) {
6467 my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
6469 $dbh->rollback if $oldAutoCommit;
6473 } elsif ( $row{'amount'} < 0 ) {
6474 my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
6477 $dbh->rollback if $oldAutoCommit;
6487 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6489 return "Empty file!" unless $imported;
6495 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6497 Sends a templated email notification to the customer (see L<Text::Template>).
6499 OPTIONS is a hash and may include
6501 I<from> - the email sender (default is invoice_from)
6503 I<to> - comma-separated scalar or arrayref of recipients
6504 (default is invoicing_list)
6506 I<subject> - The subject line of the sent email notification
6507 (default is "Notice from company_name")
6509 I<extra_fields> - a hashref of name/value pairs which will be substituted
6512 The following variables are vavailable in the template.
6514 I<$first> - the customer first name
6515 I<$last> - the customer last name
6516 I<$company> - the customer company
6517 I<$payby> - a description of the method of payment for the customer
6518 # would be nice to use FS::payby::shortname
6519 I<$payinfo> - the account information used to collect for this customer
6520 I<$expdate> - the expiration of the customer payment in seconds from epoch
6525 my ($customer, $template, %options) = @_;
6527 return unless $conf->exists($template);
6529 my $from = $conf->config('invoice_from') if $conf->exists('invoice_from');
6530 $from = $options{from} if exists($options{from});
6532 my $to = join(',', $customer->invoicing_list_emailonly);
6533 $to = $options{to} if exists($options{to});
6535 my $subject = "Notice from " . $conf->config('company_name')
6536 if $conf->exists('company_name');
6537 $subject = $options{subject} if exists($options{subject});
6539 my $notify_template = new Text::Template (TYPE => 'ARRAY',
6540 SOURCE => [ map "$_\n",
6541 $conf->config($template)]
6543 or die "can't create new Text::Template object: Text::Template::ERROR";
6544 $notify_template->compile()
6545 or die "can't compile template: Text::Template::ERROR";
6547 $FS::notify_template::_template::company_name = $conf->config('company_name');
6548 $FS::notify_template::_template::company_address =
6549 join("\n", $conf->config('company_address') ). "\n";
6551 my $paydate = $customer->paydate || '2037-12-31';
6552 $FS::notify_template::_template::first = $customer->first;
6553 $FS::notify_template::_template::last = $customer->last;
6554 $FS::notify_template::_template::company = $customer->company;
6555 $FS::notify_template::_template::payinfo = $customer->mask_payinfo;
6556 my $payby = $customer->payby;
6557 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6558 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6560 #credit cards expire at the end of the month/year of their exp date
6561 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6562 $FS::notify_template::_template::payby = 'credit card';
6563 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6564 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6566 }elsif ($payby eq 'COMP') {
6567 $FS::notify_template::_template::payby = 'complimentary account';
6569 $FS::notify_template::_template::payby = 'current method';
6571 $FS::notify_template::_template::expdate = $expire_time;
6573 for (keys %{$options{extra_fields}}){
6575 ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
6578 send_email(from => $from,
6580 subject => $subject,
6581 body => $notify_template->fill_in( PACKAGE =>
6582 'FS::notify_template::_template' ),
6587 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6589 Generates a templated notification to the customer (see L<Text::Template>).
6591 OPTIONS is a hash and may include
6593 I<extra_fields> - a hashref of name/value pairs which will be substituted
6594 into the template. These values may override values mentioned below
6595 and those from the customer record.
6597 The following variables are available in the template instead of or in addition
6598 to the fields of the customer record.
6600 I<$payby> - a description of the method of payment for the customer
6601 # would be nice to use FS::payby::shortname
6602 I<$payinfo> - the masked account information used to collect for this customer
6603 I<$expdate> - the expiration of the customer payment method in seconds from epoch
6604 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
6608 sub generate_letter {
6609 my ($self, $template, %options) = @_;
6611 return unless $conf->exists($template);
6613 my $letter_template = new Text::Template
6615 SOURCE => [ map "$_\n", $conf->config($template)],
6616 DELIMITERS => [ '[@--', '--@]' ],
6618 or die "can't create new Text::Template object: Text::Template::ERROR";
6620 $letter_template->compile()
6621 or die "can't compile template: Text::Template::ERROR";
6623 my %letter_data = map { $_ => $self->$_ } $self->fields;
6624 $letter_data{payinfo} = $self->mask_payinfo;
6626 #my $paydate = $self->paydate || '2037-12-31';
6627 my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
6629 my $payby = $self->payby;
6630 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6631 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6633 #credit cards expire at the end of the month/year of their exp date
6634 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6635 $letter_data{payby} = 'credit card';
6636 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6637 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6639 }elsif ($payby eq 'COMP') {
6640 $letter_data{payby} = 'complimentary account';
6642 $letter_data{payby} = 'current method';
6644 $letter_data{expdate} = $expire_time;
6646 for (keys %{$options{extra_fields}}){
6647 $letter_data{$_} = $options{extra_fields}->{$_};
6650 unless(exists($letter_data{returnaddress})){
6651 my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
6652 $self->agent_template)
6654 if ( length($retadd) ) {
6655 $letter_data{returnaddress} = $retadd;
6656 } elsif ( grep /\S/, $conf->config('company_address') ) {
6657 $letter_data{returnaddress} =
6658 join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
6659 $conf->config('company_address')
6662 $letter_data{returnaddress} = '~';
6666 $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
6668 $letter_data{company_name} = $conf->config('company_name');
6670 my $dir = $FS::UID::conf_dir."cache.". $FS::UID::datasrc;
6671 my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
6675 ) or die "can't open temp file: $!\n";
6677 $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
6679 $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
6683 =item print_ps TEMPLATE
6685 Returns an postscript letter filled in from TEMPLATE, as a scalar.
6691 my $file = $self->generate_letter(@_);
6692 FS::Misc::generate_ps($file);
6695 =item print TEMPLATE
6697 Prints the filled in template.
6699 TEMPLATE is the name of a L<Text::Template> to fill in and print.
6703 sub queueable_print {
6706 my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
6707 or die "invalid customer number: " . $opt{custvnum};
6709 my $error = $self->print( $opt{template} );
6710 die $error if $error;
6714 my ($self, $template) = (shift, shift);
6715 do_print [ $self->print_ps($template) ];
6718 sub agent_template {
6720 $self->_agent_plandata('agent_templatename');
6723 sub agent_invoice_from {
6725 $self->_agent_plandata('agent_invoice_from');
6728 sub _agent_plandata {
6729 my( $self, $option ) = @_;
6731 #yuck. this whole thing needs to be reconciled better with 1.9's idea of
6732 #agent-specific Conf
6734 use FS::part_event::Condition;
6736 my $agentnum = $self->agentnum;
6739 if ( driver_name =~ /^Pg/i ) {
6741 } elsif ( driver_name =~ /^mysql/i ) {
6744 die "don't know how to use regular expressions in ". driver_name. " databases";
6747 my $part_event_option =
6749 'select' => 'part_event_option.*',
6750 'table' => 'part_event_option',
6752 LEFT JOIN part_event USING ( eventpart )
6753 LEFT JOIN part_event_option AS peo_agentnum
6754 ON ( part_event.eventpart = peo_agentnum.eventpart
6755 AND peo_agentnum.optionname = 'agentnum'
6756 AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
6758 LEFT JOIN part_event_option AS peo_cust_bill_age
6759 ON ( part_event.eventpart = peo_cust_bill_age.eventpart
6760 AND peo_cust_bill_age.optionname = 'cust_bill_age'
6763 #'hashref' => { 'optionname' => $option },
6764 #'hashref' => { 'part_event_option.optionname' => $option },
6766 " WHERE part_event_option.optionname = ". dbh->quote($option).
6767 " AND action = 'cust_bill_send_agent' ".
6768 " AND ( disabled IS NULL OR disabled != 'Y' ) ".
6769 " AND peo_agentnum.optionname = 'agentnum' ".
6770 " AND agentnum IS NULL OR agentnum = $agentnum ".
6772 CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age'
6774 ELSE ". FS::part_event::Condition->age2seconds_sql('peo_cust_bill_age.optionvalue').
6776 , part_event.weight".
6780 unless ( $part_event_option ) {
6781 return $self->agent->invoice_template || ''
6782 if $option eq 'agent_templatename';
6786 $part_event_option->optionvalue;
6791 ## actual sub, not a method, designed to be called from the queue.
6792 ## sets up the customer, and calls the bill_and_collect
6793 my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
6794 my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
6795 $cust_main->bill_and_collect(
6806 The delete method should possibly take an FS::cust_main object reference
6807 instead of a scalar customer number.
6809 Bill and collect options should probably be passed as references instead of a
6812 There should probably be a configuration file with a list of allowed credit
6815 No multiple currency support (probably a larger project than just this module).
6817 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
6819 Birthdates rely on negative epoch values.
6821 The payby for card/check batches is broken. With mixed batching, bad
6824 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
6828 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
6829 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
6830 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.