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 File::Slurp qw( slurp );
20 use File::Temp qw( tempfile );
21 use String::Approx qw(amatch);
22 use Business::CreditCard 0.28;
24 use FS::UID qw( getotaker dbh driver_name );
25 use FS::Record qw( qsearchs qsearch dbdef );
26 use FS::Misc qw( generate_email send_email generate_ps do_print );
27 use FS::Msgcat qw(gettext);
31 use FS::cust_bill_pkg;
33 use FS::cust_pay_pending;
34 use FS::cust_pay_void;
35 use FS::cust_pay_batch;
38 use FS::part_referral;
39 use FS::cust_main_county;
41 use FS::cust_main_invoice;
42 use FS::cust_credit_bill;
43 use FS::cust_bill_pay;
44 use FS::prepay_credit;
48 use FS::part_event_condition;
51 use FS::payment_gateway;
52 use FS::agent_payment_gateway;
54 use FS::payinfo_Mixin;
57 @ISA = qw( FS::payinfo_Mixin FS::Record );
59 @EXPORT_OK = qw( smart_search );
61 $realtime_bop_decline_quiet = 0;
63 # 1 is mostly method/subroutine entry and options
64 # 2 traces progress of some operations
65 # 3 is even more information including possibly sensitive data
67 $me = '[FS::cust_main]';
71 $ignore_expired_card = 0;
73 @encrypted_fields = ('payinfo', 'paycvv');
74 @paytypes = ('', 'Personal checking', 'Personal savings', 'Business checking', 'Business savings');
76 #ask FS::UID to run this stuff for us later
77 #$FS::UID::callback{'FS::cust_main'} = sub {
78 install_callback FS::UID sub {
80 #yes, need it for stuff below (prolly should be cached)
85 my ( $hashref, $cache ) = @_;
86 if ( exists $hashref->{'pkgnum'} ) {
87 #@{ $self->{'_pkgnum'} } = ();
88 my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
89 $self->{'_pkgnum'} = $subcache;
90 #push @{ $self->{'_pkgnum'} },
91 FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
97 FS::cust_main - Object methods for cust_main records
103 $record = new FS::cust_main \%hash;
104 $record = new FS::cust_main { 'column' => 'value' };
106 $error = $record->insert;
108 $error = $new_record->replace($old_record);
110 $error = $record->delete;
112 $error = $record->check;
114 @cust_pkg = $record->all_pkgs;
116 @cust_pkg = $record->ncancelled_pkgs;
118 @cust_pkg = $record->suspended_pkgs;
120 $error = $record->bill;
121 $error = $record->bill %options;
122 $error = $record->bill 'time' => $time;
124 $error = $record->collect;
125 $error = $record->collect %options;
126 $error = $record->collect 'invoice_time' => $time,
131 An FS::cust_main object represents a customer. FS::cust_main inherits from
132 FS::Record. The following fields are currently supported:
136 =item custnum - primary key (assigned automatically for new customers)
138 =item agentnum - agent (see L<FS::agent>)
140 =item refnum - Advertising source (see L<FS::part_referral>)
146 =item ss - social security number (optional)
148 =item company - (optional)
152 =item address2 - (optional)
156 =item county - (optional, see L<FS::cust_main_county>)
158 =item state - (see L<FS::cust_main_county>)
162 =item country - (see L<FS::cust_main_county>)
164 =item daytime - phone (optional)
166 =item night - phone (optional)
168 =item fax - phone (optional)
170 =item ship_first - name
172 =item ship_last - name
174 =item ship_company - (optional)
178 =item ship_address2 - (optional)
182 =item ship_county - (optional, see L<FS::cust_main_county>)
184 =item ship_state - (see L<FS::cust_main_county>)
188 =item ship_country - (see L<FS::cust_main_county>)
190 =item ship_daytime - phone (optional)
192 =item ship_night - phone (optional)
194 =item ship_fax - phone (optional)
196 =item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values)
198 =item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format)
200 =item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works)
204 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
206 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
208 =item paystart_month - start date month (maestro/solo cards only)
210 =item paystart_year - start date year (maestro/solo cards only)
212 =item payissue - issue number (maestro/solo cards only)
214 =item payname - name on card or billing name
216 =item payip - IP address from which payment information was received
218 =item tax - tax exempt, empty or `Y'
220 =item otaker - order taker (assigned automatically, see L<FS::UID>)
222 =item comments - comments (optional)
224 =item referral_custnum - referring customer number
226 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
228 =item squelch_cdr - Discourage individual CDR printing, empty or `Y'
238 Creates a new customer. To add the customer to the database, see L<"insert">.
240 Note that this stores the hash reference, not a distinct copy of the hash it
241 points to. You can ask the object for a copy with the I<hash> method.
245 sub table { 'cust_main'; }
247 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
249 Adds this customer to the database. If there is an error, returns the error,
250 otherwise returns false.
252 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
253 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
254 are inserted atomicly, or the transaction is rolled back. Passing an empty
255 hash reference is equivalent to not supplying this parameter. There should be
256 a better explanation of this, but until then, here's an example:
259 tie %hash, 'Tie::RefHash'; #this part is important
261 $cust_pkg => [ $svc_acct ],
264 $cust_main->insert( \%hash );
266 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
267 be set as the invoicing list (see L<"invoicing_list">). Errors return as
268 expected and rollback the entire transaction; it is not necessary to call
269 check_invoicing_list first. The invoicing_list is set after the records in the
270 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
271 invoicing_list destination to the newly-created svc_acct. Here's an example:
273 $cust_main->insert( {}, [ $email, 'POST' ] );
275 Currently available options are: I<depend_jobnum> and I<noexport>.
277 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
278 on the supplied jobnum (they will not run until the specific job completes).
279 This can be used to defer provisioning until some action completes (such
280 as running the customer's credit card successfully).
282 The I<noexport> option is deprecated. If I<noexport> is set true, no
283 provisioning jobs (exports) are scheduled. (You can schedule them later with
284 the B<reexport> method.)
290 my $cust_pkgs = @_ ? shift : {};
291 my $invoicing_list = @_ ? shift : '';
293 warn "$me insert called with options ".
294 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
297 local $SIG{HUP} = 'IGNORE';
298 local $SIG{INT} = 'IGNORE';
299 local $SIG{QUIT} = 'IGNORE';
300 local $SIG{TERM} = 'IGNORE';
301 local $SIG{TSTP} = 'IGNORE';
302 local $SIG{PIPE} = 'IGNORE';
304 my $oldAutoCommit = $FS::UID::AutoCommit;
305 local $FS::UID::AutoCommit = 0;
308 my $prepay_identifier = '';
309 my( $amount, $seconds ) = ( 0, 0 );
311 if ( $self->payby eq 'PREPAY' ) {
313 $self->payby('BILL');
314 $prepay_identifier = $self->payinfo;
317 warn " looking up prepaid card $prepay_identifier\n"
320 my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
322 $dbh->rollback if $oldAutoCommit;
323 #return "error applying prepaid card (transaction rolled back): $error";
327 $payby = 'PREP' if $amount;
329 } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
332 $self->payby('BILL');
333 $amount = $self->paid;
337 warn " inserting $self\n"
340 $self->signupdate(time) unless $self->signupdate;
342 my $error = $self->SUPER::insert;
344 $dbh->rollback if $oldAutoCommit;
345 #return "inserting cust_main record (transaction rolled back): $error";
349 warn " setting invoicing list\n"
352 if ( $invoicing_list ) {
353 $error = $self->check_invoicing_list( $invoicing_list );
355 $dbh->rollback if $oldAutoCommit;
356 #return "checking invoicing_list (transaction rolled back): $error";
359 $self->invoicing_list( $invoicing_list );
362 if ( $conf->config('cust_main-skeleton_tables')
363 && $conf->config('cust_main-skeleton_custnum') ) {
365 warn " inserting skeleton records\n"
368 my $error = $self->start_copy_skel;
370 $dbh->rollback if $oldAutoCommit;
376 warn " ordering packages\n"
379 $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
381 $dbh->rollback if $oldAutoCommit;
386 $dbh->rollback if $oldAutoCommit;
387 return "No svc_acct record to apply pre-paid time";
391 warn " inserting initial $payby payment of $amount\n"
393 $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
395 $dbh->rollback if $oldAutoCommit;
396 return "inserting payment (transaction rolled back): $error";
400 unless ( $import || $skip_fuzzyfiles ) {
401 warn " queueing fuzzyfiles update\n"
403 $error = $self->queue_fuzzyfiles_update;
405 $dbh->rollback if $oldAutoCommit;
406 return "updating fuzzy search cache: $error";
410 warn " insert complete; committing transaction\n"
413 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
418 sub start_copy_skel {
421 #'mg_user_preference' => {},
422 #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
423 #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
424 #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
425 #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
426 my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
429 _copy_skel( 'cust_main', #tablename
430 $conf->config('cust_main-skeleton_custnum'), #sourceid
431 $self->custnum, #destid
432 @tables, #child tables
436 #recursive subroutine, not a method
438 my( $table, $sourceid, $destid, %child_tables ) = @_;
441 if ( $table =~ /^(\w+)\.(\w+)$/ ) {
442 ( $table, $primary_key ) = ( $1, $2 );
444 my $dbdef_table = dbdef->table($table);
445 $primary_key = $dbdef_table->primary_key
446 or return "$table has no primary key".
447 " (or do you need to run dbdef-create?)";
450 warn " _copy_skel: $table.$primary_key $sourceid to $destid for ".
451 join (', ', keys %child_tables). "\n"
454 foreach my $child_table_def ( keys %child_tables ) {
458 if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
459 ( $child_table, $child_pkey ) = ( $1, $2 );
461 $child_table = $child_table_def;
463 $child_pkey = dbdef->table($child_table)->primary_key;
464 # or return "$table has no primary key".
465 # " (or do you need to run dbdef-create?)\n";
469 if ( keys %{ $child_tables{$child_table_def} } ) {
471 return "$child_table has no primary key".
472 " (run dbdef-create or try specifying it?)\n"
475 #false laziness w/Record::insert and only works on Pg
476 #refactor the proper last-inserted-id stuff out of Record::insert if this
477 # ever gets use for anything besides a quick kludge for one customer
478 my $default = dbdef->table($child_table)->column($child_pkey)->default;
479 $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
480 or return "can't parse $child_table.$child_pkey default value ".
481 " for sequence name: $default";
486 my @sel_columns = grep { $_ ne $primary_key }
487 dbdef->table($child_table)->columns;
488 my $sel_columns = join(', ', @sel_columns );
490 my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
491 my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
492 my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
494 my $sel_st = "SELECT $sel_columns FROM $child_table".
495 " WHERE $primary_key = $sourceid";
498 my $sel_sth = dbh->prepare( $sel_st )
499 or return dbh->errstr;
501 $sel_sth->execute or return $sel_sth->errstr;
503 while ( my $row = $sel_sth->fetchrow_hashref ) {
505 warn " selected row: ".
506 join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
510 "INSERT INTO $child_table $ins_columns VALUES $placeholders";
511 my $ins_sth =dbh->prepare($statement)
512 or return dbh->errstr;
513 my @param = ( $destid, map $row->{$_}, @ins_columns );
514 warn " $statement: [ ". join(', ', @param). " ]\n"
516 $ins_sth->execute( @param )
517 or return $ins_sth->errstr;
519 #next unless keys %{ $child_tables{$child_table} };
520 next unless $sequence;
522 #another section of that laziness
523 my $seq_sql = "SELECT currval('$sequence')";
524 my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
525 $seq_sth->execute or return $seq_sth->errstr;
526 my $insertid = $seq_sth->fetchrow_arrayref->[0];
528 # don't drink soap! recurse! recurse! okay!
530 _copy_skel( $child_table_def,
531 $row->{$child_pkey}, #sourceid
533 %{ $child_tables{$child_table_def} },
535 return $error if $error;
545 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
547 Like the insert method on an existing record, this method orders a package
548 and included services atomicaly. Pass a Tie::RefHash data structure to this
549 method containing FS::cust_pkg and FS::svc_I<tablename> objects. There should
550 be a better explanation of this, but until then, here's an example:
553 tie %hash, 'Tie::RefHash'; #this part is important
555 $cust_pkg => [ $svc_acct ],
558 $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
560 Services can be new, in which case they are inserted, or existing unaudited
561 services, in which case they are linked to the newly-created package.
563 Currently available options are: I<depend_jobnum> and I<noexport>.
565 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
566 on the supplied jobnum (they will not run until the specific job completes).
567 This can be used to defer provisioning until some action completes (such
568 as running the customer's credit card successfully).
570 The I<noexport> option is deprecated. If I<noexport> is set true, no
571 provisioning jobs (exports) are scheduled. (You can schedule them later with
572 the B<reexport> method for each cust_pkg object. Using the B<reexport> method
573 on the cust_main object is not recommended, as existing services will also be
580 my $cust_pkgs = shift;
583 my %svc_options = ();
584 $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
585 if exists $options{'depend_jobnum'};
586 warn "$me order_pkgs called with options ".
587 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
590 local $SIG{HUP} = 'IGNORE';
591 local $SIG{INT} = 'IGNORE';
592 local $SIG{QUIT} = 'IGNORE';
593 local $SIG{TERM} = 'IGNORE';
594 local $SIG{TSTP} = 'IGNORE';
595 local $SIG{PIPE} = 'IGNORE';
597 my $oldAutoCommit = $FS::UID::AutoCommit;
598 local $FS::UID::AutoCommit = 0;
601 local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
603 foreach my $cust_pkg ( keys %$cust_pkgs ) {
604 $cust_pkg->custnum( $self->custnum );
605 my $error = $cust_pkg->insert;
607 $dbh->rollback if $oldAutoCommit;
608 return "inserting cust_pkg (transaction rolled back): $error";
610 foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
611 if ( $svc_something->svcnum ) {
612 my $old_cust_svc = $svc_something->cust_svc;
613 my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
614 $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
615 $error = $new_cust_svc->replace($old_cust_svc);
617 $svc_something->pkgnum( $cust_pkg->pkgnum );
618 if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
619 $svc_something->seconds( $svc_something->seconds + $$seconds );
622 $error = $svc_something->insert(%svc_options);
625 $dbh->rollback if $oldAutoCommit;
626 #return "inserting svc_ (transaction rolled back): $error";
632 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
636 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ]
638 Recharges this (existing) customer with the specified prepaid card (see
639 L<FS::prepay_credit>), specified either by I<identifier> or as an
640 FS::prepay_credit object. If there is an error, returns the error, otherwise
643 Optionally, four scalar references can be passed as well. They will have their
644 values filled in with the amount, number of seconds, and number of upload and
645 download bytes applied by this prepaid
650 sub recharge_prepay {
651 my( $self, $prepay_credit, $amountref, $secondsref,
652 $upbytesref, $downbytesref, $totalbytesref ) = @_;
654 local $SIG{HUP} = 'IGNORE';
655 local $SIG{INT} = 'IGNORE';
656 local $SIG{QUIT} = 'IGNORE';
657 local $SIG{TERM} = 'IGNORE';
658 local $SIG{TSTP} = 'IGNORE';
659 local $SIG{PIPE} = 'IGNORE';
661 my $oldAutoCommit = $FS::UID::AutoCommit;
662 local $FS::UID::AutoCommit = 0;
665 my( $amount, $seconds, $upbytes, $downbytes, $totalbytes) = ( 0, 0, 0, 0, 0 );
667 my $error = $self->get_prepay($prepay_credit, \$amount,
668 \$seconds, \$upbytes, \$downbytes, \$totalbytes)
669 || $self->increment_seconds($seconds)
670 || $self->increment_upbytes($upbytes)
671 || $self->increment_downbytes($downbytes)
672 || $self->increment_totalbytes($totalbytes)
673 || $self->insert_cust_pay_prepay( $amount,
675 ? $prepay_credit->identifier
680 $dbh->rollback if $oldAutoCommit;
684 if ( defined($amountref) ) { $$amountref = $amount; }
685 if ( defined($secondsref) ) { $$secondsref = $seconds; }
686 if ( defined($upbytesref) ) { $$upbytesref = $upbytes; }
687 if ( defined($downbytesref) ) { $$downbytesref = $downbytes; }
688 if ( defined($totalbytesref) ) { $$totalbytesref = $totalbytes; }
690 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
695 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ , AMOUNTREF, SECONDSREF
697 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
698 specified either by I<identifier> or as an FS::prepay_credit object.
700 References to I<amount> and I<seconds> scalars should be passed as arguments
701 and will be incremented by the values of the prepaid card.
703 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
704 check or set this customer's I<agentnum>.
706 If there is an error, returns the error, otherwise returns false.
712 my( $self, $prepay_credit, $amountref, $secondsref,
713 $upref, $downref, $totalref) = @_;
715 local $SIG{HUP} = 'IGNORE';
716 local $SIG{INT} = 'IGNORE';
717 local $SIG{QUIT} = 'IGNORE';
718 local $SIG{TERM} = 'IGNORE';
719 local $SIG{TSTP} = 'IGNORE';
720 local $SIG{PIPE} = 'IGNORE';
722 my $oldAutoCommit = $FS::UID::AutoCommit;
723 local $FS::UID::AutoCommit = 0;
726 unless ( ref($prepay_credit) ) {
728 my $identifier = $prepay_credit;
730 $prepay_credit = qsearchs(
732 { 'identifier' => $prepay_credit },
737 unless ( $prepay_credit ) {
738 $dbh->rollback if $oldAutoCommit;
739 return "Invalid prepaid card: ". $identifier;
744 if ( $prepay_credit->agentnum ) {
745 if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
746 $dbh->rollback if $oldAutoCommit;
747 return "prepaid card not valid for agent ". $self->agentnum;
749 $self->agentnum($prepay_credit->agentnum);
752 my $error = $prepay_credit->delete;
754 $dbh->rollback if $oldAutoCommit;
755 return "removing prepay_credit (transaction rolled back): $error";
758 $$amountref += $prepay_credit->amount;
759 $$secondsref += $prepay_credit->seconds;
760 $$upref += $prepay_credit->upbytes;
761 $$downref += $prepay_credit->downbytes;
762 $$totalref += $prepay_credit->totalbytes;
764 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
769 =item increment_upbytes SECONDS
771 Updates this customer's single or primary account (see L<FS::svc_acct>) by
772 the specified number of upbytes. If there is an error, returns the error,
773 otherwise returns false.
777 sub increment_upbytes {
778 _increment_column( shift, 'upbytes', @_);
781 =item increment_downbytes SECONDS
783 Updates this customer's single or primary account (see L<FS::svc_acct>) by
784 the specified number of downbytes. If there is an error, returns the error,
785 otherwise returns false.
789 sub increment_downbytes {
790 _increment_column( shift, 'downbytes', @_);
793 =item increment_totalbytes SECONDS
795 Updates this customer's single or primary account (see L<FS::svc_acct>) by
796 the specified number of totalbytes. If there is an error, returns the error,
797 otherwise returns false.
801 sub increment_totalbytes {
802 _increment_column( shift, 'totalbytes', @_);
805 =item increment_seconds SECONDS
807 Updates this customer's single or primary account (see L<FS::svc_acct>) by
808 the specified number of seconds. If there is an error, returns the error,
809 otherwise returns false.
813 sub increment_seconds {
814 _increment_column( shift, 'seconds', @_);
817 =item _increment_column AMOUNT
819 Updates this customer's single or primary account (see L<FS::svc_acct>) by
820 the specified number of seconds or bytes. If there is an error, returns
821 the error, otherwise returns false.
825 sub _increment_column {
826 my( $self, $column, $amount ) = @_;
827 warn "$me increment_column called: $column, $amount\n"
830 return '' unless $amount;
832 my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
833 $self->ncancelled_pkgs;
836 return 'No packages with primary or single services found'.
837 ' to apply pre-paid time';
838 } elsif ( scalar(@cust_pkg) > 1 ) {
839 #maybe have a way to specify the package/account?
840 return 'Multiple packages found to apply pre-paid time';
843 my $cust_pkg = $cust_pkg[0];
844 warn " found package pkgnum ". $cust_pkg->pkgnum. "\n"
848 $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
851 return 'No account found to apply pre-paid time';
852 } elsif ( scalar(@cust_svc) > 1 ) {
853 return 'Multiple accounts found to apply pre-paid time';
856 my $svc_acct = $cust_svc[0]->svc_x;
857 warn " found service svcnum ". $svc_acct->pkgnum.
858 ' ('. $svc_acct->email. ")\n"
861 $column = "increment_$column";
862 $svc_acct->$column($amount);
866 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
868 Inserts a prepayment in the specified amount for this customer. An optional
869 second argument can specify the prepayment identifier for tracking purposes.
870 If there is an error, returns the error, otherwise returns false.
874 sub insert_cust_pay_prepay {
875 shift->insert_cust_pay('PREP', @_);
878 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
880 Inserts a cash payment in the specified amount for this customer. An optional
881 second argument can specify the payment identifier for tracking purposes.
882 If there is an error, returns the error, otherwise returns false.
886 sub insert_cust_pay_cash {
887 shift->insert_cust_pay('CASH', @_);
890 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
892 Inserts a Western Union payment in the specified amount for this customer. An
893 optional second argument can specify the prepayment identifier for tracking
894 purposes. If there is an error, returns the error, otherwise returns false.
898 sub insert_cust_pay_west {
899 shift->insert_cust_pay('WEST', @_);
902 sub insert_cust_pay {
903 my( $self, $payby, $amount ) = splice(@_, 0, 3);
904 my $payinfo = scalar(@_) ? shift : '';
906 my $cust_pay = new FS::cust_pay {
907 'custnum' => $self->custnum,
908 'paid' => sprintf('%.2f', $amount),
909 #'_date' => #date the prepaid card was purchased???
911 'payinfo' => $payinfo,
919 This method is deprecated. See the I<depend_jobnum> option to the insert and
920 order_pkgs methods for a better way to defer provisioning.
922 Re-schedules all exports by calling the B<reexport> method of all associated
923 packages (see L<FS::cust_pkg>). If there is an error, returns the error;
924 otherwise returns false.
931 carp "WARNING: FS::cust_main::reexport is deprectated; ".
932 "use the depend_jobnum option to insert or order_pkgs to delay export";
934 local $SIG{HUP} = 'IGNORE';
935 local $SIG{INT} = 'IGNORE';
936 local $SIG{QUIT} = 'IGNORE';
937 local $SIG{TERM} = 'IGNORE';
938 local $SIG{TSTP} = 'IGNORE';
939 local $SIG{PIPE} = 'IGNORE';
941 my $oldAutoCommit = $FS::UID::AutoCommit;
942 local $FS::UID::AutoCommit = 0;
945 foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
946 my $error = $cust_pkg->reexport;
948 $dbh->rollback if $oldAutoCommit;
953 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
958 =item delete NEW_CUSTNUM
960 This deletes the customer. If there is an error, returns the error, otherwise
963 This will completely remove all traces of the customer record. This is not
964 what you want when a customer cancels service; for that, cancel all of the
965 customer's packages (see L</cancel>).
967 If the customer has any uncancelled packages, you need to pass a new (valid)
968 customer number for those packages to be transferred to. Cancelled packages
969 will be deleted. Did I mention that this is NOT what you want when a customer
970 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
972 You can't delete a customer with invoices (see L<FS::cust_bill>),
973 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
974 refunds (see L<FS::cust_refund>).
981 local $SIG{HUP} = 'IGNORE';
982 local $SIG{INT} = 'IGNORE';
983 local $SIG{QUIT} = 'IGNORE';
984 local $SIG{TERM} = 'IGNORE';
985 local $SIG{TSTP} = 'IGNORE';
986 local $SIG{PIPE} = 'IGNORE';
988 my $oldAutoCommit = $FS::UID::AutoCommit;
989 local $FS::UID::AutoCommit = 0;
992 if ( $self->cust_bill ) {
993 $dbh->rollback if $oldAutoCommit;
994 return "Can't delete a customer with invoices";
996 if ( $self->cust_credit ) {
997 $dbh->rollback if $oldAutoCommit;
998 return "Can't delete a customer with credits";
1000 if ( $self->cust_pay ) {
1001 $dbh->rollback if $oldAutoCommit;
1002 return "Can't delete a customer with payments";
1004 if ( $self->cust_refund ) {
1005 $dbh->rollback if $oldAutoCommit;
1006 return "Can't delete a customer with refunds";
1009 my @cust_pkg = $self->ncancelled_pkgs;
1011 my $new_custnum = shift;
1012 unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
1013 $dbh->rollback if $oldAutoCommit;
1014 return "Invalid new customer number: $new_custnum";
1016 foreach my $cust_pkg ( @cust_pkg ) {
1017 my %hash = $cust_pkg->hash;
1018 $hash{'custnum'} = $new_custnum;
1019 my $new_cust_pkg = new FS::cust_pkg ( \%hash );
1020 my $error = $new_cust_pkg->replace($cust_pkg,
1021 options => { $cust_pkg->options },
1024 $dbh->rollback if $oldAutoCommit;
1029 my @cancelled_cust_pkg = $self->all_pkgs;
1030 foreach my $cust_pkg ( @cancelled_cust_pkg ) {
1031 my $error = $cust_pkg->delete;
1033 $dbh->rollback if $oldAutoCommit;
1038 foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1039 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1041 my $error = $cust_main_invoice->delete;
1043 $dbh->rollback if $oldAutoCommit;
1048 my $error = $self->SUPER::delete;
1050 $dbh->rollback if $oldAutoCommit;
1054 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1059 =item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ]
1061 Replaces the OLD_RECORD with this one in the database. If there is an error,
1062 returns the error, otherwise returns false.
1064 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1065 be set as the invoicing list (see L<"invoicing_list">). Errors return as
1066 expected and rollback the entire transaction; it is not necessary to call
1067 check_invoicing_list first. Here's an example:
1069 $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1076 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
1078 : $self->replace_old;
1082 warn "$me replace called\n"
1085 my $curuser = $FS::CurrentUser::CurrentUser;
1086 if ( $self->payby eq 'COMP'
1087 && $self->payby ne $old->payby
1088 && ! $curuser->access_right('Complimentary customer')
1091 return "You are not permitted to create complimentary accounts.";
1094 local($ignore_expired_card) = 1
1095 if $old->payby =~ /^(CARD|DCRD)$/
1096 && $self->payby =~ /^(CARD|DCRD)$/
1097 && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
1099 local $SIG{HUP} = 'IGNORE';
1100 local $SIG{INT} = 'IGNORE';
1101 local $SIG{QUIT} = 'IGNORE';
1102 local $SIG{TERM} = 'IGNORE';
1103 local $SIG{TSTP} = 'IGNORE';
1104 local $SIG{PIPE} = 'IGNORE';
1106 my $oldAutoCommit = $FS::UID::AutoCommit;
1107 local $FS::UID::AutoCommit = 0;
1110 my $error = $self->SUPER::replace($old);
1113 $dbh->rollback if $oldAutoCommit;
1117 if ( @param ) { # INVOICING_LIST_ARYREF
1118 my $invoicing_list = shift @param;
1119 $error = $self->check_invoicing_list( $invoicing_list );
1121 $dbh->rollback if $oldAutoCommit;
1124 $self->invoicing_list( $invoicing_list );
1127 if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1128 grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1129 # card/check/lec info has changed, want to retry realtime_ invoice events
1130 my $error = $self->retry_realtime;
1132 $dbh->rollback if $oldAutoCommit;
1137 unless ( $import || $skip_fuzzyfiles ) {
1138 $error = $self->queue_fuzzyfiles_update;
1140 $dbh->rollback if $oldAutoCommit;
1141 return "updating fuzzy search cache: $error";
1145 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1150 =item queue_fuzzyfiles_update
1152 Used by insert & replace to update the fuzzy search cache
1156 sub queue_fuzzyfiles_update {
1159 local $SIG{HUP} = 'IGNORE';
1160 local $SIG{INT} = 'IGNORE';
1161 local $SIG{QUIT} = 'IGNORE';
1162 local $SIG{TERM} = 'IGNORE';
1163 local $SIG{TSTP} = 'IGNORE';
1164 local $SIG{PIPE} = 'IGNORE';
1166 my $oldAutoCommit = $FS::UID::AutoCommit;
1167 local $FS::UID::AutoCommit = 0;
1170 my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1171 my $error = $queue->insert( map $self->getfield($_),
1172 qw(first last company)
1175 $dbh->rollback if $oldAutoCommit;
1176 return "queueing job (transaction rolled back): $error";
1179 if ( $self->ship_last ) {
1180 $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1181 $error = $queue->insert( map $self->getfield("ship_$_"),
1182 qw(first last company)
1185 $dbh->rollback if $oldAutoCommit;
1186 return "queueing job (transaction rolled back): $error";
1190 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1197 Checks all fields to make sure this is a valid customer record. If there is
1198 an error, returns the error, otherwise returns false. Called by the insert
1199 and replace methods.
1206 warn "$me check BEFORE: \n". $self->_dump
1210 $self->ut_numbern('custnum')
1211 || $self->ut_number('agentnum')
1212 || $self->ut_textn('agent_custid')
1213 || $self->ut_number('refnum')
1214 || $self->ut_textn('custbatch')
1215 || $self->ut_name('last')
1216 || $self->ut_name('first')
1217 || $self->ut_snumbern('birthdate')
1218 || $self->ut_snumbern('signupdate')
1219 || $self->ut_textn('company')
1220 || $self->ut_text('address1')
1221 || $self->ut_textn('address2')
1222 || $self->ut_text('city')
1223 || $self->ut_textn('county')
1224 || $self->ut_textn('state')
1225 || $self->ut_country('country')
1226 || $self->ut_anything('comments')
1227 || $self->ut_numbern('referral_custnum')
1228 || $self->ut_textn('stateid')
1229 || $self->ut_textn('stateid_state')
1230 || $self->ut_textn('invoice_terms')
1232 #barf. need message catalogs. i18n. etc.
1233 $error .= "Please select an advertising source."
1234 if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1235 return $error if $error;
1237 return "Unknown agent"
1238 unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1240 return "Unknown refnum"
1241 unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1243 return "Unknown referring custnum: ". $self->referral_custnum
1244 unless ! $self->referral_custnum
1245 || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1247 if ( $self->ss eq '' ) {
1252 $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1253 or return "Illegal social security number: ". $self->ss;
1254 $self->ss("$1-$2-$3");
1258 # bad idea to disable, causes billing to fail because of no tax rates later
1259 # unless ( $import ) {
1260 unless ( qsearch('cust_main_county', {
1261 'country' => $self->country,
1264 return "Unknown state/county/country: ".
1265 $self->state. "/". $self->county. "/". $self->country
1266 unless qsearch('cust_main_county',{
1267 'state' => $self->state,
1268 'county' => $self->county,
1269 'country' => $self->country,
1275 $self->ut_phonen('daytime', $self->country)
1276 || $self->ut_phonen('night', $self->country)
1277 || $self->ut_phonen('fax', $self->country)
1278 || $self->ut_zip('zip', $self->country)
1280 return $error if $error;
1282 if ( $conf->exists('cust_main-require_phone')
1283 && ! length($self->daytime) && ! length($self->night)
1286 my $daytime_label = FS::Msgcat::_gettext('daytime') =~ /^(daytime)?$/
1288 : FS::Msgcat::_gettext('daytime');
1289 my $night_label = FS::Msgcat::_gettext('night') =~ /^(night)?$/
1291 : FS::Msgcat::_gettext('night');
1293 return "$daytime_label or $night_label is required"
1297 if ( $self->has_ship_address
1298 && scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1299 $self->addr_fields )
1303 $self->ut_name('ship_last')
1304 || $self->ut_name('ship_first')
1305 || $self->ut_textn('ship_company')
1306 || $self->ut_text('ship_address1')
1307 || $self->ut_textn('ship_address2')
1308 || $self->ut_text('ship_city')
1309 || $self->ut_textn('ship_county')
1310 || $self->ut_textn('ship_state')
1311 || $self->ut_country('ship_country')
1313 return $error if $error;
1315 #false laziness with above
1316 unless ( qsearchs('cust_main_county', {
1317 'country' => $self->ship_country,
1320 return "Unknown ship_state/ship_county/ship_country: ".
1321 $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1322 unless qsearch('cust_main_county',{
1323 'state' => $self->ship_state,
1324 'county' => $self->ship_county,
1325 'country' => $self->ship_country,
1331 $self->ut_phonen('ship_daytime', $self->ship_country)
1332 || $self->ut_phonen('ship_night', $self->ship_country)
1333 || $self->ut_phonen('ship_fax', $self->ship_country)
1334 || $self->ut_zip('ship_zip', $self->ship_country)
1336 return $error if $error;
1338 return "Unit # is required."
1339 if $self->ship_address2 =~ /^\s*$/
1340 && $conf->exists('cust_main-require_address2');
1342 } else { # ship_ info eq billing info, so don't store dup info in database
1344 $self->setfield("ship_$_", '')
1345 foreach $self->addr_fields;
1347 return "Unit # is required."
1348 if $self->address2 =~ /^\s*$/
1349 && $conf->exists('cust_main-require_address2');
1353 #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1354 # or return "Illegal payby: ". $self->payby;
1356 FS::payby->can_payby($self->table, $self->payby)
1357 or return "Illegal payby: ". $self->payby;
1359 $error = $self->ut_numbern('paystart_month')
1360 || $self->ut_numbern('paystart_year')
1361 || $self->ut_numbern('payissue')
1362 || $self->ut_textn('paytype')
1364 return $error if $error;
1366 if ( $self->payip eq '' ) {
1369 $error = $self->ut_ip('payip');
1370 return $error if $error;
1373 # If it is encrypted and the private key is not availaible then we can't
1374 # check the credit card.
1376 my $check_payinfo = 1;
1378 if ($self->is_encrypted($self->payinfo)) {
1382 if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1384 my $payinfo = $self->payinfo;
1385 $payinfo =~ s/\D//g;
1386 $payinfo =~ /^(\d{13,16})$/
1387 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1389 $self->payinfo($payinfo);
1391 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1393 return gettext('unknown_card_type')
1394 if cardtype($self->payinfo) eq "Unknown";
1396 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1398 return 'Banned credit card: banned on '.
1399 time2str('%a %h %o at %r', $ban->_date).
1400 ' by '. $ban->otaker.
1401 ' (ban# '. $ban->bannum. ')';
1404 if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1405 if ( cardtype($self->payinfo) eq 'American Express card' ) {
1406 $self->paycvv =~ /^(\d{4})$/
1407 or return "CVV2 (CID) for American Express cards is four digits.";
1410 $self->paycvv =~ /^(\d{3})$/
1411 or return "CVV2 (CVC2/CID) is three digits.";
1418 my $cardtype = cardtype($payinfo);
1419 if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1421 return "Start date or issue number is required for $cardtype cards"
1422 unless $self->paystart_month && $self->paystart_year or $self->payissue;
1424 return "Start month must be between 1 and 12"
1425 if $self->paystart_month
1426 and $self->paystart_month < 1 || $self->paystart_month > 12;
1428 return "Start year must be 1990 or later"
1429 if $self->paystart_year
1430 and $self->paystart_year < 1990;
1432 return "Issue number must be beween 1 and 99"
1434 and $self->payissue < 1 || $self->payissue > 99;
1437 $self->paystart_month('');
1438 $self->paystart_year('');
1439 $self->payissue('');
1442 } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1444 my $payinfo = $self->payinfo;
1445 $payinfo =~ s/[^\d\@]//g;
1446 if ( $conf->exists('echeck-nonus') ) {
1447 $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1448 $payinfo = "$1\@$2";
1450 $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1451 $payinfo = "$1\@$2";
1453 $self->payinfo($payinfo);
1456 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1458 return 'Banned ACH account: banned on '.
1459 time2str('%a %h %o at %r', $ban->_date).
1460 ' by '. $ban->otaker.
1461 ' (ban# '. $ban->bannum. ')';
1464 } elsif ( $self->payby eq 'LECB' ) {
1466 my $payinfo = $self->payinfo;
1467 $payinfo =~ s/\D//g;
1468 $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1470 $self->payinfo($payinfo);
1473 } elsif ( $self->payby eq 'BILL' ) {
1475 $error = $self->ut_textn('payinfo');
1476 return "Illegal P.O. number: ". $self->payinfo if $error;
1479 } elsif ( $self->payby eq 'COMP' ) {
1481 my $curuser = $FS::CurrentUser::CurrentUser;
1482 if ( ! $self->custnum
1483 && ! $curuser->access_right('Complimentary customer')
1486 return "You are not permitted to create complimentary accounts."
1489 $error = $self->ut_textn('payinfo');
1490 return "Illegal comp account issuer: ". $self->payinfo if $error;
1493 } elsif ( $self->payby eq 'PREPAY' ) {
1495 my $payinfo = $self->payinfo;
1496 $payinfo =~ s/\W//g; #anything else would just confuse things
1497 $self->payinfo($payinfo);
1498 $error = $self->ut_alpha('payinfo');
1499 return "Illegal prepayment identifier: ". $self->payinfo if $error;
1500 return "Unknown prepayment identifier"
1501 unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1506 if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1507 return "Expiration date required"
1508 unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1512 if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1513 ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1514 } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1515 ( $m, $y ) = ( $3, "20$2" );
1517 return "Illegal expiration date: ". $self->paydate;
1519 $self->paydate("$y-$m-01");
1520 my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1521 return gettext('expired_card')
1523 && !$ignore_expired_card
1524 && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1527 if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1528 ( ! $conf->exists('require_cardname')
1529 || $self->payby !~ /^(CARD|DCRD)$/ )
1531 $self->payname( $self->first. " ". $self->getfield('last') );
1533 $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1534 or return gettext('illegal_name'). " payname: ". $self->payname;
1538 foreach my $flag (qw( tax spool_cdr squelch_cdr )) {
1539 $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1543 $self->otaker(getotaker) unless $self->otaker;
1545 warn "$me check AFTER: \n". $self->_dump
1548 $self->SUPER::check;
1553 Returns a list of fields which have ship_ duplicates.
1558 qw( last first company
1559 address1 address2 city county state zip country
1564 =item has_ship_address
1566 Returns true if this customer record has a separate shipping address.
1570 sub has_ship_address {
1572 scalar( grep { $self->getfield("ship_$_") ne '' } $self->addr_fields );
1577 Returns all packages (see L<FS::cust_pkg>) for this customer.
1584 return $self->num_pkgs unless wantarray;
1587 if ( $self->{'_pkgnum'} ) {
1588 @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
1590 @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1593 sort sort_packages @cust_pkg;
1598 Synonym for B<all_pkgs>.
1603 shift->all_pkgs(@_);
1606 =item ncancelled_pkgs
1608 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1612 sub ncancelled_pkgs {
1615 return $self->num_ncancelled_pkgs unless wantarray;
1618 if ( $self->{'_pkgnum'} ) {
1620 warn "$me ncancelled_pkgs: returning cached objects"
1623 @cust_pkg = grep { ! $_->getfield('cancel') }
1624 values %{ $self->{'_pkgnum'}->cache };
1628 warn "$me ncancelled_pkgs: searching for packages with custnum ".
1629 $self->custnum. "\n"
1633 qsearch( 'cust_pkg', {
1634 'custnum' => $self->custnum,
1638 qsearch( 'cust_pkg', {
1639 'custnum' => $self->custnum,
1644 sort sort_packages @cust_pkg;
1648 # This should be generalized to use config options to determine order.
1650 if ( $a->get('cancel') and $b->get('cancel') ) {
1651 $a->pkgnum <=> $b->pkgnum;
1652 } elsif ( $a->get('cancel') or $b->get('cancel') ) {
1653 return -1 if $b->get('cancel');
1654 return 1 if $a->get('cancel');
1657 $a->pkgnum <=> $b->pkgnum;
1661 =item suspended_pkgs
1663 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1667 sub suspended_pkgs {
1669 grep { $_->susp } $self->ncancelled_pkgs;
1672 =item unflagged_suspended_pkgs
1674 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1675 customer (thouse packages without the `manual_flag' set).
1679 sub unflagged_suspended_pkgs {
1681 return $self->suspended_pkgs
1682 unless dbdef->table('cust_pkg')->column('manual_flag');
1683 grep { ! $_->manual_flag } $self->suspended_pkgs;
1686 =item unsuspended_pkgs
1688 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1693 sub unsuspended_pkgs {
1695 grep { ! $_->susp } $self->ncancelled_pkgs;
1698 =item num_cancelled_pkgs
1700 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1705 sub num_cancelled_pkgs {
1706 shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
1709 sub num_ncancelled_pkgs {
1710 shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
1714 my( $self ) = shift;
1715 my $sql = scalar(@_) ? shift : '';
1716 $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
1717 my $sth = dbh->prepare(
1718 "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
1719 ) or die dbh->errstr;
1720 $sth->execute($self->custnum) or die $sth->errstr;
1721 $sth->fetchrow_arrayref->[0];
1726 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1727 and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list
1728 on success or a list of errors.
1734 grep { $_->unsuspend } $self->suspended_pkgs;
1739 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1741 Returns a list: an empty list on success or a list of errors.
1747 grep { $_->suspend(@_) } $self->unsuspended_pkgs;
1750 =item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1752 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1753 PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead
1754 of a list of pkgparts; the hashref has the following keys:
1758 =item pkgparts - listref of pkgparts
1760 =item (other options are passed to the suspend method)
1765 Returns a list: an empty list on success or a list of errors.
1769 sub suspend_if_pkgpart {
1771 my (@pkgparts, %opt);
1772 if (ref($_[0]) eq 'HASH'){
1773 @pkgparts = @{$_[0]{pkgparts}};
1778 grep { $_->suspend(%opt) }
1779 grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1780 $self->unsuspended_pkgs;
1783 =item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1785 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1786 given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref
1787 instead of a list of pkgparts; the hashref has the following keys:
1791 =item pkgparts - listref of pkgparts
1793 =item (other options are passed to the suspend method)
1797 Returns a list: an empty list on success or a list of errors.
1801 sub suspend_unless_pkgpart {
1803 my (@pkgparts, %opt);
1804 if (ref($_[0]) eq 'HASH'){
1805 @pkgparts = @{$_[0]{pkgparts}};
1810 grep { $_->suspend(%opt) }
1811 grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1812 $self->unsuspended_pkgs;
1815 =item cancel [ OPTION => VALUE ... ]
1817 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1819 Available options are:
1823 =item quiet - can be set true to supress email cancellation notices.
1825 =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.
1827 =item ban - can be set true to ban this customer's credit card or ACH information, if present.
1831 Always returns a list: an empty list on success or a list of errors.
1836 my( $self, %opt ) = @_;
1838 warn "$me cancel called on customer ". $self->custnum. " with options ".
1839 join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n"
1842 return ( 'access denied' )
1843 unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer');
1845 if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1847 #should try decryption (we might have the private key)
1848 # and if not maybe queue a job for the server that does?
1849 return ( "Can't (yet) ban encrypted credit cards" )
1850 if $self->is_encrypted($self->payinfo);
1852 my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1853 my $error = $ban->insert;
1854 return ( $error ) if $error;
1858 my @pkgs = $self->ncancelled_pkgs;
1860 warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/".
1861 scalar(@pkgs). " packages for customer ". $self->custnum. "\n"
1864 grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs;
1867 sub _banned_pay_hashref {
1878 'payby' => $payby2ban{$self->payby},
1879 'payinfo' => md5_base64($self->payinfo),
1880 #don't ever *search* on reason! #'reason' =>
1886 Returns all notes (see L<FS::cust_main_note>) for this customer.
1893 qsearch( 'cust_main_note',
1894 { 'custnum' => $self->custnum },
1896 'ORDER BY _DATE DESC'
1902 Returns the agent (see L<FS::agent>) for this customer.
1908 qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1911 =item bill_and_collect
1913 Cancels and suspends any packages due, generates bills, applies payments and
1916 Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.)
1918 Options are passed as name-value pairs. Currently available options are:
1924 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:
1928 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1932 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.
1936 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1940 If set true, re-charges setup fees.
1944 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)
1950 sub bill_and_collect {
1951 my( $self, %options ) = @_;
1957 #$options{actual_time} not $options{time} because freeside-daily -d is for
1958 #pre-printing invoices
1959 my @cancel_pkgs = grep { $_->expire && $_->expire <= $options{actual_time} }
1960 $self->ncancelled_pkgs;
1962 foreach my $cust_pkg ( @cancel_pkgs ) {
1963 my $error = $cust_pkg->cancel;
1964 warn "Error cancelling expired pkg ". $cust_pkg->pkgnum.
1965 " for custnum ". $self->custnum. ": $error"
1973 #$options{actual_time} not $options{time} because freeside-daily -d is for
1974 #pre-printing invoices
1977 && ( ( $_->part_pkg->is_prepaid
1979 && $_->bill < $options{actual_time}
1982 && $_->adjourn <= $options{actual_time}
1986 $self->ncancelled_pkgs;
1988 foreach my $cust_pkg ( @susp_pkgs ) {
1989 my $error = $cust_pkg->suspend;
1990 warn "Error suspending package ". $cust_pkg->pkgnum.
1991 " for custnum ". $self->custnum. ": $error"
1999 my $error = $self->bill( %options );
2000 warn "Error billing, custnum ". $self->custnum. ": $error" if $error;
2002 $self->apply_payments_and_credits;
2004 $error = $self->collect( %options );
2005 warn "Error collecting, custnum". $self->custnum. ": $error" if $error;
2011 Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in
2012 conjunction with the collect method by calling B<bill_and_collect>.
2014 If there is an error, returns the error, otherwise returns false.
2016 Options are passed as name-value pairs. Currently available options are:
2022 If set true, re-charges setup fees.
2026 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:
2030 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
2034 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
2036 $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
2040 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.
2047 my( $self, %options ) = @_;
2048 return '' if $self->payby eq 'COMP';
2049 warn "$me bill customer ". $self->custnum. "\n"
2052 my $time = $options{'time'} || time;
2055 local $SIG{HUP} = 'IGNORE';
2056 local $SIG{INT} = 'IGNORE';
2057 local $SIG{QUIT} = 'IGNORE';
2058 local $SIG{TERM} = 'IGNORE';
2059 local $SIG{TSTP} = 'IGNORE';
2060 local $SIG{PIPE} = 'IGNORE';
2062 my $oldAutoCommit = $FS::UID::AutoCommit;
2063 local $FS::UID::AutoCommit = 0;
2066 $self->select_for_update; #mutex
2068 my @cust_bill_pkg = ();
2069 my @appended_cust_bill_pkg = ();
2072 # find the packages which are due for billing, find out how much they are
2073 # & generate invoice database.
2076 my( $total_setup, $total_recur, $postal_charge ) = ( 0, 0, 0 );
2080 my @precommit_hooks = ();
2082 my @cust_pkgs = qsearch('cust_pkg', { 'custnum' => $self->custnum } );
2083 foreach my $cust_pkg (@cust_pkgs) {
2085 #NO!! next if $cust_pkg->cancel;
2086 next if $cust_pkg->getfield('cancel');
2088 warn " bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2090 #? to avoid use of uninitialized value errors... ?
2091 $cust_pkg->setfield('bill', '')
2092 unless defined($cust_pkg->bill);
2094 #my $part_pkg = $cust_pkg->part_pkg;
2096 my $real_pkgpart = $cust_pkg->pkgpart;
2097 my %hash = $cust_pkg->hash;
2099 foreach my $part_pkg ( $cust_pkg->part_pkg->self_and_bill_linked ) {
2101 $cust_pkg->set($_, $hash{$_}) foreach qw ( setup last_bill bill );
2104 $self->_make_lines( 'part_pkg' => $part_pkg,
2105 'cust_pkg' => $cust_pkg,
2106 'precommit_hooks' => \@precommit_hooks,
2107 'line_items' => \@cust_bill_pkg,
2108 'appended_line_items' => \@appended_cust_bill_pkg,
2109 'setup' => \$total_setup,
2110 'recur' => \$total_recur,
2111 'tax_matrix' => \%taxlisthash,
2113 'options' => \%options,
2116 $dbh->rollback if $oldAutoCommit;
2120 } #foreach my $part_pkg
2122 } #foreach my $cust_pkg
2124 push @cust_bill_pkg, @appended_cust_bill_pkg;
2126 unless ( @cust_bill_pkg ) { #don't create an invoice w/o line items
2127 #but do commit any package date cycling that happened
2128 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2132 my $postal_pkg = $self->charge_postal_fee();
2133 if ( $postal_pkg && !ref( $postal_pkg ) ) {
2134 $dbh->rollback if $oldAutoCommit;
2135 return "can't charge postal invoice fee for customer ".
2136 $self->custnum. ": $postal_pkg";
2138 if ( $postal_pkg ) {
2139 foreach my $part_pkg ( $postal_pkg->part_pkg->self_and_bill_linked ) {
2141 $self->_make_lines( 'part_pkg' => $part_pkg,
2142 'cust_pkg' => $postal_pkg,
2143 'precommit_hooks' => \@precommit_hooks,
2144 'line_items' => \@cust_bill_pkg,
2145 'appended_line_items' => \@appended_cust_bill_pkg,
2146 'setup' => \$total_setup,
2147 'recur' => \$total_recur,
2148 'tax_matrix' => \%taxlisthash,
2150 'options' => \%options,
2153 $dbh->rollback if $oldAutoCommit;
2159 warn "having a look at the taxes we found...\n" if $DEBUG > 2;
2160 foreach my $tax ( keys %taxlisthash ) {
2161 my $tax_object = shift @{ $taxlisthash{$tax} };
2162 warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
2163 my $listref_or_error = $tax_object->taxline( @{ $taxlisthash{$tax} } );
2164 unless (ref($listref_or_error)) {
2165 $dbh->rollback if $oldAutoCommit;
2166 return $listref_or_error;
2168 unshift @{ $taxlisthash{$tax} }, $tax_object;
2170 warn "adding ". $listref_or_error->[1].
2171 " as ". $listref_or_error->[0]. "\n"
2173 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2174 if ( $taxname{ $listref_or_error->[0] } ) {
2175 push @{ $taxname{ $listref_or_error->[0] } }, $tax_object->taxname;
2177 $taxname{ $listref_or_error->[0] } = [ $tax_object->taxname ];
2182 #some taxes are taxed
2185 warn "finding taxed taxes...\n" if $DEBUG > 2;
2186 foreach my $tax ( keys %taxlisthash ) {
2187 my $tax_object = shift @{ $taxlisthash{$tax} };
2188 warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
2190 next unless $tax_object->can('tax_on_tax');
2192 foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
2193 my $totname = ref( $tot ). ' '. $tot->taxnum;
2195 warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
2197 next unless exists( $taxlisthash{ $totname } ); # only increase
2199 warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
2200 if ( exists( $totlisthash{ $totname } ) ) {
2201 push @{ $totlisthash{ $totname } }, $tax{ $tax_object->taxname };
2203 $totlisthash{ $totname } = [ $tot, $tax{ $tax_object->taxname } ];
2208 warn "having a look at taxed taxes...\n" if $DEBUG > 2;
2209 foreach my $tax ( keys %totlisthash ) {
2210 my $tax_object = shift @{ $totlisthash{$tax} };
2211 warn "found previously found taxed tax ". $tax_object->taxname. "\n"
2213 my $listref_or_error = $tax_object->taxline( @{ $totlisthash{$tax} } );
2214 unless (ref($listref_or_error)) {
2215 $dbh->rollback if $oldAutoCommit;
2216 return $listref_or_error;
2219 warn "adding taxed tax amount ". $listref_or_error->[1].
2220 " as ". $tax_object->taxname. "\n"
2222 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2225 #consolidate and create tax line items
2226 warn "consolidating and generating...\n" if $DEBUG > 2;
2227 foreach my $taxname ( keys %taxname ) {
2230 warn "adding $taxname\n" if $DEBUG > 1;
2231 foreach my $taxitem ( @{ $taxname{$taxname} } ) {
2232 $tax += $tax{$taxitem} unless $seen{$taxitem};
2233 warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
2237 $tax = sprintf('%.2f', $tax );
2238 $total_setup = sprintf('%.2f', $total_setup+$tax );
2240 push @cust_bill_pkg, new FS::cust_bill_pkg {
2246 'itemdesc' => $taxname,
2251 my $charged = sprintf('%.2f', $total_setup + $total_recur );
2253 #create the new invoice
2254 my $cust_bill = new FS::cust_bill ( {
2255 'custnum' => $self->custnum,
2256 '_date' => ( $options{'invoice_time'} || $time ),
2257 'charged' => $charged,
2259 my $error = $cust_bill->insert;
2261 $dbh->rollback if $oldAutoCommit;
2262 return "can't create invoice for customer #". $self->custnum. ": $error";
2265 foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
2266 $cust_bill_pkg->invnum($cust_bill->invnum);
2267 my $error = $cust_bill_pkg->insert;
2269 $dbh->rollback if $oldAutoCommit;
2270 return "can't create invoice line item: $error";
2275 foreach my $hook ( @precommit_hooks ) {
2277 &{$hook}; #($self) ?
2280 $dbh->rollback if $oldAutoCommit;
2281 return "$@ running precommit hook $hook\n";
2285 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2291 my ($self, %params) = @_;
2293 my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
2294 my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
2295 my $precommit_hooks = $params{precommit_hooks} or die "no package specified";
2296 my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
2297 my $appended_cust_bill_pkg = $params{appended_line_items}
2298 or die "no appended line buffer specified";
2299 my $total_setup = $params{setup} or die "no setup accumulator specified";
2300 my $total_recur = $params{recur} or die "no recur accumulator specified";
2301 my $taxlisthash = $params{tax_matrix} or die "no tax accumulator specified";
2302 my $time = $params{'time'} or die "no time specified";
2303 my (%options) = %{$params{options}}; #hmmm only for 'resetup'
2306 my $real_pkgpart = $cust_pkg->pkgpart;
2307 my %hash = $cust_pkg->hash;
2308 my $old_cust_pkg = new FS::cust_pkg \%hash;
2314 $cust_pkg->pkgpart($part_pkg->pkgpart);
2322 if ( ! $cust_pkg->setup &&
2324 ( $conf->exists('disable_setup_suspended_pkgs') &&
2325 ! $cust_pkg->getfield('susp')
2326 ) || ! $conf->exists('disable_setup_suspended_pkgs')
2328 || $options{'resetup'}
2331 warn " bill setup\n" if $DEBUG > 1;
2334 $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2335 return "$@ running calc_setup for $cust_pkg\n"
2338 $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
2340 $cust_pkg->setfield('setup', $time)
2341 unless $cust_pkg->setup;
2342 #do need it, but it won't get written to the db
2343 #|| $cust_pkg->pkgpart != $real_pkgpart;
2348 # bill recurring fee
2351 #XXX unit stuff here too
2355 if ( $part_pkg->getfield('freq') ne '0' &&
2356 ! $cust_pkg->getfield('susp') &&
2357 ( $cust_pkg->getfield('bill') || 0 ) <= $time
2360 # XXX should this be a package event? probably. events are called
2361 # at collection time at the moment, though...
2362 $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
2363 if $part_pkg->can('reset_usage');
2364 #don't want to reset usage just cause we want a line item??
2365 #&& $part_pkg->pkgpart == $real_pkgpart;
2367 warn " bill recur\n" if $DEBUG > 1;
2370 # XXX shared with $recur_prog
2371 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2373 #over two params! lets at least switch to a hashref for the rest...
2374 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2376 $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2377 return "$@ running calc_recur for $cust_pkg\n"
2381 #change this bit to use Date::Manip? CAREFUL with timezones (see
2382 # mailing list archive)
2383 my ($sec,$min,$hour,$mday,$mon,$year) =
2384 (localtime($sdate) )[0,1,2,3,4,5];
2386 #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2387 # only for figuring next bill date, nothing else, so, reset $sdate again
2389 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2390 $cust_pkg->last_bill($sdate);
2392 if ( $part_pkg->freq =~ /^\d+$/ ) {
2393 $mon += $part_pkg->freq;
2394 until ( $mon < 12 ) { $mon -= 12; $year++; }
2395 } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2397 $mday += $weeks * 7;
2398 } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2401 } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2405 return "unparsable frequency: ". $part_pkg->freq;
2407 $cust_pkg->setfield('bill',
2408 timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2412 warn "\$setup is undefined" unless defined($setup);
2413 warn "\$recur is undefined" unless defined($recur);
2414 warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2417 # If there's line items, create em cust_bill_pkg records
2418 # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2423 if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2424 # hmm.. and if just the options are modified in some weird price plan?
2426 warn " package ". $cust_pkg->pkgnum. " modified; updating\n"
2429 my $error = $cust_pkg->replace( $old_cust_pkg,
2430 'options' => { $cust_pkg->options },
2432 return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
2433 if $error; #just in case
2436 $setup = sprintf( "%.2f", $setup );
2437 $recur = sprintf( "%.2f", $recur );
2438 if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2439 return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2441 if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2442 return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2445 if ( $setup != 0 || $recur != 0 ) {
2447 warn " charges (setup=$setup, recur=$recur); adding line items\n"
2449 my $cust_bill_pkg = new FS::cust_bill_pkg {
2450 'pkgnum' => $cust_pkg->pkgnum,
2452 'unitsetup' => $unitsetup,
2454 'unitrecur' => $unitrecur,
2455 'quantity' => $cust_pkg->quantity,
2457 'edate' => $cust_pkg->bill,
2458 'details' => \@details,
2460 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2461 unless $part_pkg->pkgpart == $real_pkgpart;
2462 push @$cust_bill_pkgs, $cust_bill_pkg;
2464 $$total_setup += $setup;
2465 $$total_recur += $recur;
2471 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2473 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2475 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2477 } #if $setup != 0 || $recur != 0
2481 if ( $part_pkg->can('append_cust_bill_pkgs') ) {
2482 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2483 my ($more_cust_bill_pkgs) =
2484 eval { $part_pkg->append_cust_bill_pkgs( $cust_pkg, \$sdate, \%param ) };
2486 return "$@ running append_cust_bill_pkgs for $cust_pkg\n"
2488 return "$more_cust_bill_pkgs"
2489 unless ( ref($more_cust_bill_pkgs) );
2491 foreach my $cust_bill_pkg ( @{$more_cust_bill_pkgs} ) {
2493 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2494 unless $part_pkg->pkgpart == $real_pkgpart;
2495 push @$appended_cust_bill_pkg, $cust_bill_pkg;
2497 unless ($cust_bill_pkg->duplicate) {
2498 $$total_setup += $cust_bill_pkg->setup;
2499 $$total_recur += $cust_bill_pkg->recur;
2505 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2507 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2509 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2518 my $part_pkg = shift;
2519 my $taxlisthash = shift;
2520 my $cust_bill_pkg = shift;
2523 my @taxoverrides = $part_pkg->part_pkg_taxoverride;
2526 ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2530 if ( $conf->exists('enable_taxproducts')
2531 && (scalar(@taxoverrides) || $part_pkg->taxproductnum )
2535 my @taxclassnums = ();
2536 my $geocode = $self->geocode('cch');
2538 if ( scalar( @taxoverrides ) ) {
2539 @taxclassnums = map { $_->taxclassnum } @taxoverrides;
2540 }elsif ( $part_pkg->taxproductnum ) {
2541 @taxclassnums = map { $_->taxclassnum }
2542 $part_pkg->part_pkg_taxrate('cch', $geocode);
2547 join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
2549 @taxes = qsearch({ 'table' => 'tax_rate',
2550 'hashref' => { 'geocode' => $geocode, },
2551 'extra_sql' => $extra_sql,
2553 if scalar(@taxclassnums);
2558 my %taxhash = map { $_ => $self->get("$prefix$_") }
2559 qw( state county country );
2561 $taxhash{'taxclass'} = $part_pkg->taxclass;
2563 @taxes = qsearch( 'cust_main_county', \%taxhash );
2566 $taxhash{'taxclass'} = '';
2567 @taxes = qsearch( 'cust_main_county', \%taxhash );
2570 #one more try at a whole-country tax rate
2572 $taxhash{$_} = '' foreach qw( state county );
2573 @taxes = qsearch( 'cust_main_county', \%taxhash );
2576 } #if $conf->exists('enable_taxproducts')
2578 # maybe eliminate this entirely, along with all the 0% records
2581 if ( $conf->exists('enable_taxproducts') ) {
2583 "fatal: can't find tax rate for zip/taxproduct/pkgpart ".
2584 join('/', ( map $self->get("$prefix$_"),
2587 $part_pkg->taxproduct_description,
2588 $part_pkg->pkgpart ). "\n";
2591 "fatal: can't find tax rate for state/county/country/taxclass ".
2592 join('/', ( map $self->get("$prefix$_"),
2593 qw(state county country)
2595 $part_pkg->taxclass ). "\n";
2600 foreach my $tax ( @taxes ) {
2601 my $taxname = ref( $tax ). ' '. $tax->taxnum;
2602 if ( exists( $taxlisthash->{ $taxname } ) ) {
2603 push @{ $taxlisthash->{ $taxname } }, $cust_bill_pkg;
2605 $taxlisthash->{ $taxname } = [ $tax, $cust_bill_pkg ];
2611 =item collect OPTIONS
2613 (Attempt to) collect money for this customer's outstanding invoices (see
2614 L<FS::cust_bill>). Usually used after the bill method.
2616 Actions are now triggered by billing events; see L<FS::part_event> and the
2617 billing events web interface. Old-style invoice events (see
2618 L<FS::part_bill_event>) have been deprecated.
2620 If there is an error, returns the error, otherwise returns false.
2622 Options are passed as name-value pairs.
2624 Currently available options are:
2630 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.
2634 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2638 set true to surpress email card/ACH decline notices.
2642 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2646 allows for one time override of normal customer billing method
2650 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)
2658 my( $self, %options ) = @_;
2659 my $invoice_time = $options{'invoice_time'} || time;
2662 local $SIG{HUP} = 'IGNORE';
2663 local $SIG{INT} = 'IGNORE';
2664 local $SIG{QUIT} = 'IGNORE';
2665 local $SIG{TERM} = 'IGNORE';
2666 local $SIG{TSTP} = 'IGNORE';
2667 local $SIG{PIPE} = 'IGNORE';
2669 my $oldAutoCommit = $FS::UID::AutoCommit;
2670 local $FS::UID::AutoCommit = 0;
2673 $self->select_for_update; #mutex
2676 my $balance = $self->balance;
2677 warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2680 if ( exists($options{'retry_card'}) ) {
2681 carp 'retry_card option passed to collect is deprecated; use retry';
2682 $options{'retry'} ||= $options{'retry_card'};
2684 if ( exists($options{'retry'}) && $options{'retry'} ) {
2685 my $error = $self->retry_realtime;
2687 $dbh->rollback if $oldAutoCommit;
2692 # false laziness w/pay_batch::import_results
2694 my $due_cust_event = $self->due_cust_event(
2695 'debug' => ( $options{'debug'} || 0 ),
2696 'time' => $invoice_time,
2697 'check_freq' => $options{'check_freq'},
2699 unless( ref($due_cust_event) ) {
2700 $dbh->rollback if $oldAutoCommit;
2701 return $due_cust_event;
2704 foreach my $cust_event ( @$due_cust_event ) {
2708 #re-eval event conditions (a previous event could have changed things)
2709 unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
2710 #don't leave stray "new/locked" records around
2711 my $error = $cust_event->delete;
2713 #gah, even with transactions
2714 $dbh->commit if $oldAutoCommit; #well.
2721 local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2722 warn " running cust_event ". $cust_event->eventnum. "\n"
2726 #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2727 if ( my $error = $cust_event->do_event() ) {
2728 #XXX wtf is this? figure out a proper dealio with return value
2730 # gah, even with transactions.
2731 $dbh->commit if $oldAutoCommit; #well.
2738 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2743 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2745 Inserts database records for and returns an ordered listref of new events due
2746 for this customer, as FS::cust_event objects (see L<FS::cust_event>). If no
2747 events are due, an empty listref is returned. If there is an error, returns a
2748 scalar error message.
2750 To actually run the events, call each event's test_condition method, and if
2751 still true, call the event's do_event method.
2753 Options are passed as a hashref or as a list of name-value pairs. Available
2760 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.
2764 "Current time" for the events.
2768 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)
2772 Only return events for the specified eventtable (by default, events of all eventtables are returned)
2776 Explicitly pass the objects to be tested (typically used with eventtable).
2782 sub due_cust_event {
2784 my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2787 #my $DEBUG = $opt{'debug'}
2788 local($DEBUG) = $opt{'debug'}
2789 if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
2791 warn "$me due_cust_event called with options ".
2792 join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2795 $opt{'time'} ||= time;
2797 local $SIG{HUP} = 'IGNORE';
2798 local $SIG{INT} = 'IGNORE';
2799 local $SIG{QUIT} = 'IGNORE';
2800 local $SIG{TERM} = 'IGNORE';
2801 local $SIG{TSTP} = 'IGNORE';
2802 local $SIG{PIPE} = 'IGNORE';
2804 my $oldAutoCommit = $FS::UID::AutoCommit;
2805 local $FS::UID::AutoCommit = 0;
2808 $self->select_for_update; #mutex
2811 # 1: find possible events (initial search)
2814 my @cust_event = ();
2816 my @eventtable = $opt{'eventtable'}
2817 ? ( $opt{'eventtable'} )
2818 : FS::part_event->eventtables_runorder;
2820 foreach my $eventtable ( @eventtable ) {
2823 if ( $opt{'objects'} ) {
2825 @objects = @{ $opt{'objects'} };
2829 #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
2830 @objects = ( $eventtable eq 'cust_main' )
2832 : ( $self->$eventtable() );
2836 my @e_cust_event = ();
2838 my $cross = "CROSS JOIN $eventtable";
2839 $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2840 unless $eventtable eq 'cust_main';
2842 foreach my $object ( @objects ) {
2844 #this first search uses the condition_sql magic for optimization.
2845 #the more possible events we can eliminate in this step the better
2847 my $cross_where = '';
2848 my $pkey = $object->primary_key;
2849 $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2851 my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
2853 FS::part_event_condition->where_conditions_sql( $eventtable,
2854 'time'=>$opt{'time'}
2856 my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2858 $extra_sql = "AND $extra_sql" if $extra_sql;
2860 #here is the agent virtualization
2861 $extra_sql .= " AND ( part_event.agentnum IS NULL
2862 OR part_event.agentnum = ". $self->agentnum. ' )';
2864 $extra_sql .= " $order";
2866 warn "searching for events for $eventtable ". $object->$pkey. "\n"
2867 if $opt{'debug'} > 2;
2868 my @part_event = qsearch( {
2869 'debug' => ( $opt{'debug'} > 3 ? 1 : 0 ),
2870 'select' => 'part_event.*',
2871 'table' => 'part_event',
2872 'addl_from' => "$cross $join",
2873 'hashref' => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
2874 'eventtable' => $eventtable,
2877 'extra_sql' => "AND $cross_where $extra_sql",
2881 my $pkey = $object->primary_key;
2882 warn " ". scalar(@part_event).
2883 " possible events found for $eventtable ". $object->$pkey(). "\n";
2886 push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
2890 warn " ". scalar(@e_cust_event).
2891 " subtotal possible cust events found for $eventtable\n"
2894 push @cust_event, @e_cust_event;
2898 warn " ". scalar(@cust_event).
2899 " total possible cust events found in initial search\n"
2903 # 2: test conditions
2908 @cust_event = grep $_->test_conditions( 'time' => $opt{'time'},
2909 'stats_hashref' => \%unsat ),
2912 warn " ". scalar(@cust_event). " cust events left satisfying conditions\n"
2915 warn " invalid conditions not eliminated with condition_sql:\n".
2916 join('', map " $_: ".$unsat{$_}."\n", keys %unsat )
2923 foreach my $cust_event ( @cust_event ) {
2925 my $error = $cust_event->insert();
2927 $dbh->rollback if $oldAutoCommit;
2933 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2939 warn " returning events: ". Dumper(@cust_event). "\n"
2946 =item retry_realtime
2948 Schedules realtime / batch credit card / electronic check / LEC billing
2949 events for for retry. Useful if card information has changed or manual
2950 retry is desired. The 'collect' method must be called to actually retry
2953 Implementation details: For either this customer, or for each of this
2954 customer's open invoices, changes the status of the first "done" (with
2955 statustext error) realtime processing event to "failed".
2959 sub retry_realtime {
2962 local $SIG{HUP} = 'IGNORE';
2963 local $SIG{INT} = 'IGNORE';
2964 local $SIG{QUIT} = 'IGNORE';
2965 local $SIG{TERM} = 'IGNORE';
2966 local $SIG{TSTP} = 'IGNORE';
2967 local $SIG{PIPE} = 'IGNORE';
2969 my $oldAutoCommit = $FS::UID::AutoCommit;
2970 local $FS::UID::AutoCommit = 0;
2973 #a little false laziness w/due_cust_event (not too bad, really)
2975 my $join = FS::part_event_condition->join_conditions_sql;
2976 my $order = FS::part_event_condition->order_conditions_sql;
2979 . join ( ' OR ' , map {
2980 "( part_event.eventtable = " . dbh->quote($_)
2981 . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
2982 } FS::part_event->eventtables)
2985 #here is the agent virtualization
2986 my $agent_virt = " ( part_event.agentnum IS NULL
2987 OR part_event.agentnum = ". $self->agentnum. ' )';
2989 #XXX this shouldn't be hardcoded, actions should declare it...
2990 my @realtime_events = qw(
2991 cust_bill_realtime_card
2992 cust_bill_realtime_check
2993 cust_bill_realtime_lec
2997 my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
3002 my @cust_event = qsearchs({
3003 'table' => 'cust_event',
3004 'select' => 'cust_event.*',
3005 'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
3006 'hashref' => { 'status' => 'done' },
3007 'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
3008 " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
3011 my %seen_invnum = ();
3012 foreach my $cust_event (@cust_event) {
3014 #max one for the customer, one for each open invoice
3015 my $cust_X = $cust_event->cust_X;
3016 next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
3020 or $cust_event->part_event->eventtable eq 'cust_bill'
3023 my $error = $cust_event->retry;
3025 $dbh->rollback if $oldAutoCommit;
3026 return "error scheduling event for retry: $error";
3031 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3036 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
3038 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
3039 via a Business::OnlinePayment realtime gateway. See
3040 L<http://420.am/business-onlinepayment> for supported gateways.
3042 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3044 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
3046 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3047 I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3048 if set, will override the value from the customer record.
3050 I<description> is a free-text field passed to the gateway. It defaults to
3051 "Internet services".
3053 If an I<invnum> is specified, this payment (if successful) is applied to the
3054 specified invoice. If you don't specify an I<invnum> you might want to
3055 call the B<apply_payments> method.
3057 I<quiet> can be set true to surpress email decline notices.
3059 I<paynum_ref> can be set to a scalar reference. It will be filled in with the
3060 resulting paynum, if any.
3062 I<payunique> is a unique identifier for this payment.
3064 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
3069 my( $self, $method, $amount, %options ) = @_;
3071 warn "$me realtime_bop: $method $amount\n";
3072 warn " $_ => $options{$_}\n" foreach keys %options;
3075 $options{'description'} ||= 'Internet services';
3077 return $self->fake_bop($method, $amount, %options) if $options{'fake'};
3079 eval "use Business::OnlinePayment";
3082 my $payinfo = exists($options{'payinfo'})
3083 ? $options{'payinfo'}
3086 my %method2payby = (
3093 # check for banned credit card/ACH
3096 my $ban = qsearchs('banned_pay', {
3097 'payby' => $method2payby{$method},
3098 'payinfo' => md5_base64($payinfo),
3100 return "Banned credit card" if $ban;
3107 if ( $options{'invnum'} ) {
3108 my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3109 die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3111 map { $_->part_pkg->taxclass }
3113 map { $_->cust_pkg }
3114 $cust_bill->cust_bill_pkg;
3115 unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
3116 #different taxclasses
3117 $taxclass = $taxclasses[0];
3121 #look for an agent gateway override first
3123 if ( $method eq 'CC' ) {
3124 $cardtype = cardtype($payinfo);
3125 } elsif ( $method eq 'ECHECK' ) {
3128 $cardtype = $method;
3132 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3133 cardtype => $cardtype,
3134 taxclass => $taxclass, } )
3135 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3137 taxclass => $taxclass, } )
3138 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3139 cardtype => $cardtype,
3141 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3143 taxclass => '', } );
3145 my $payment_gateway = '';
3146 my( $processor, $login, $password, $action, @bop_options );
3147 if ( $override ) { #use a payment gateway override
3149 $payment_gateway = $override->payment_gateway;
3151 $processor = $payment_gateway->gateway_module;
3152 $login = $payment_gateway->gateway_username;
3153 $password = $payment_gateway->gateway_password;
3154 $action = $payment_gateway->gateway_action;
3155 @bop_options = $payment_gateway->options;
3157 } else { #use the standard settings from the config
3159 ( $processor, $login, $password, $action, @bop_options ) =
3160 $self->default_payment_gateway($method);
3168 my $address = exists($options{'address1'})
3169 ? $options{'address1'}
3171 my $address2 = exists($options{'address2'})
3172 ? $options{'address2'}
3174 $address .= ", ". $address2 if length($address2);
3176 my $o_payname = exists($options{'payname'})
3177 ? $options{'payname'}
3179 my($payname, $payfirst, $paylast);
3180 if ( $o_payname && $method ne 'ECHECK' ) {
3181 ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3182 or return "Illegal payname $payname";
3183 ($payfirst, $paylast) = ($1, $2);
3185 $payfirst = $self->getfield('first');
3186 $paylast = $self->getfield('last');
3187 $payname = "$payfirst $paylast";
3190 my @invoicing_list = $self->invoicing_list_emailonly;
3191 if ( $conf->exists('emailinvoiceautoalways')
3192 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3193 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3194 push @invoicing_list, $self->all_emails;
3197 my $email = ($conf->exists('business-onlinepayment-email-override'))
3198 ? $conf->config('business-onlinepayment-email-override')
3199 : $invoicing_list[0];
3203 my $payip = exists($options{'payip'})
3206 $content{customer_ip} = $payip
3209 $content{invoice_number} = $options{'invnum'}
3210 if exists($options{'invnum'}) && length($options{'invnum'});
3212 $content{email_customer} =
3213 ( $conf->exists('business-onlinepayment-email_customer')
3214 || $conf->exists('business-onlinepayment-email-override') );
3217 if ( $method eq 'CC' ) {
3219 $content{card_number} = $payinfo;
3220 $paydate = exists($options{'paydate'})
3221 ? $options{'paydate'}
3223 $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3224 $content{expiration} = "$2/$1";
3226 my $paycvv = exists($options{'paycvv'})
3227 ? $options{'paycvv'}
3229 $content{cvv2} = $paycvv
3232 my $paystart_month = exists($options{'paystart_month'})
3233 ? $options{'paystart_month'}
3234 : $self->paystart_month;
3236 my $paystart_year = exists($options{'paystart_year'})
3237 ? $options{'paystart_year'}
3238 : $self->paystart_year;
3240 $content{card_start} = "$paystart_month/$paystart_year"
3241 if $paystart_month && $paystart_year;
3243 my $payissue = exists($options{'payissue'})
3244 ? $options{'payissue'}
3246 $content{issue_number} = $payissue if $payissue;
3248 $content{recurring_billing} = 'YES'
3249 if qsearch('cust_pay', { 'custnum' => $self->custnum,
3251 'payinfo' => $payinfo,
3253 || qsearch('cust_pay', { 'custnum' => $self->custnum,
3255 'paymask' => $self->mask_payinfo('CARD', $payinfo),
3259 } elsif ( $method eq 'ECHECK' ) {
3260 ( $content{account_number}, $content{routing_code} ) =
3261 split('@', $payinfo);
3262 $content{bank_name} = $o_payname;
3263 $content{bank_state} = exists($options{'paystate'})
3264 ? $options{'paystate'}
3265 : $self->getfield('paystate');
3266 $content{account_type} = exists($options{'paytype'})
3267 ? uc($options{'paytype'}) || 'CHECKING'
3268 : uc($self->getfield('paytype')) || 'CHECKING';
3269 $content{account_name} = $payname;
3270 $content{customer_org} = $self->company ? 'B' : 'I';
3271 $content{state_id} = exists($options{'stateid'})
3272 ? $options{'stateid'}
3273 : $self->getfield('stateid');
3274 $content{state_id_state} = exists($options{'stateid_state'})
3275 ? $options{'stateid_state'}
3276 : $self->getfield('stateid_state');
3277 $content{customer_ssn} = exists($options{'ss'})
3280 } elsif ( $method eq 'LEC' ) {
3281 $content{phone} = $payinfo;
3285 # run transaction(s)
3288 my $balance = exists( $options{'balance'} )
3289 ? $options{'balance'}
3292 $self->select_for_update; #mutex ... just until we get our pending record in
3294 #the checks here are intended to catch concurrent payments
3295 #double-form-submission prevention is taken care of in cust_pay_pending::check
3298 return "The customer's balance has changed; $method transaction aborted."
3299 if $self->balance < $balance;
3300 #&& $self->balance < $amount; #might as well anyway?
3302 #also check and make sure there aren't *other* pending payments for this cust
3304 my @pending = qsearch('cust_pay_pending', {
3305 'custnum' => $self->custnum,
3306 'status' => { op=>'!=', value=>'done' }
3308 return "A payment is already being processed for this customer (".
3309 join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3310 "); $method transaction aborted."
3311 if scalar(@pending);
3313 #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3315 my $cust_pay_pending = new FS::cust_pay_pending {
3316 'custnum' => $self->custnum,
3317 #'invnum' => $options{'invnum'},
3320 'payby' => $method2payby{$method},
3321 'payinfo' => $payinfo,
3322 'paydate' => $paydate,
3324 'gatewaynum' => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3326 $cust_pay_pending->payunique( $options{payunique} )
3327 if defined($options{payunique}) && length($options{payunique});
3328 my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3329 return $cpp_new_err if $cpp_new_err;
3331 my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3333 my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3334 $transaction->content(
3337 'password' => $password,
3338 'action' => $action1,
3339 'description' => $options{'description'},
3340 'amount' => $amount,
3341 #'invoice_number' => $options{'invnum'},
3342 'customer_id' => $self->custnum,
3343 'last_name' => $paylast,
3344 'first_name' => $payfirst,
3346 'address' => $address,
3347 'city' => ( exists($options{'city'})
3350 'state' => ( exists($options{'state'})
3353 'zip' => ( exists($options{'zip'})
3356 'country' => ( exists($options{'country'})
3357 ? $options{'country'}
3359 'referer' => 'http://cleanwhisker.420.am/',
3361 'phone' => $self->daytime || $self->night,
3365 $cust_pay_pending->status('pending');
3366 my $cpp_pending_err = $cust_pay_pending->replace;
3367 return $cpp_pending_err if $cpp_pending_err;
3370 my $BOP_TESTING = 0;
3371 my $BOP_TESTING_SUCCESS = 1;
3373 unless ( $BOP_TESTING ) {
3374 $transaction->submit();
3376 if ( $BOP_TESTING_SUCCESS ) {
3377 $transaction->is_success(1);
3378 $transaction->authorization('fake auth');
3380 $transaction->is_success(0);
3381 $transaction->error_message('fake failure');
3385 if ( $transaction->is_success() && $action2 ) {
3387 $cust_pay_pending->status('authorized');
3388 my $cpp_authorized_err = $cust_pay_pending->replace;
3389 return $cpp_authorized_err if $cpp_authorized_err;
3391 my $auth = $transaction->authorization;
3392 my $ordernum = $transaction->can('order_number')
3393 ? $transaction->order_number
3397 new Business::OnlinePayment( $processor, @bop_options );
3404 password => $password,
3405 order_number => $ordernum,
3407 authorization => $auth,
3408 description => $options{'description'},
3411 foreach my $field (qw( authorization_source_code returned_ACI
3412 transaction_identifier validation_code
3413 transaction_sequence_num local_transaction_date
3414 local_transaction_time AVS_result_code )) {
3415 $capture{$field} = $transaction->$field() if $transaction->can($field);
3418 $capture->content( %capture );
3422 unless ( $capture->is_success ) {
3423 my $e = "Authorization successful but capture failed, custnum #".
3424 $self->custnum. ': '. $capture->result_code.
3425 ": ". $capture->error_message;
3432 $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3433 my $cpp_captured_err = $cust_pay_pending->replace;
3434 return $cpp_captured_err if $cpp_captured_err;
3437 # remove paycvv after initial transaction
3440 #false laziness w/misc/process/payment.cgi - check both to make sure working
3442 if ( defined $self->dbdef_table->column('paycvv')
3443 && length($self->paycvv)
3444 && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3446 my $error = $self->remove_cvv;
3448 warn "WARNING: error removing cvv: $error\n";
3456 if ( $transaction->is_success() ) {
3459 if ( $payment_gateway ) { # agent override
3460 $paybatch = $payment_gateway->gatewaynum. '-';
3463 $paybatch .= "$processor:". $transaction->authorization;
3465 $paybatch .= ':'. $transaction->order_number
3466 if $transaction->can('order_number')
3467 && length($transaction->order_number);
3469 my $cust_pay = new FS::cust_pay ( {
3470 'custnum' => $self->custnum,
3471 'invnum' => $options{'invnum'},
3474 'payby' => $method2payby{$method},
3475 'payinfo' => $payinfo,
3476 'paybatch' => $paybatch,
3477 'paydate' => $paydate,
3479 #doesn't hurt to know, even though the dup check is in cust_pay_pending now
3480 $cust_pay->payunique( $options{payunique} )
3481 if defined($options{payunique}) && length($options{payunique});
3483 my $oldAutoCommit = $FS::UID::AutoCommit;
3484 local $FS::UID::AutoCommit = 0;
3487 #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
3489 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3492 $cust_pay->invnum(''); #try again with no specific invnum
3493 my $error2 = $cust_pay->insert( $options{'manual'} ?
3494 ( 'manual' => 1 ) : ()
3497 # gah. but at least we have a record of the state we had to abort in
3498 # from cust_pay_pending now.
3499 my $e = "WARNING: $method captured but payment not recorded - ".
3500 "error inserting payment ($processor): $error2".
3501 " (previously tried insert with invnum #$options{'invnum'}" .
3502 ": $error ) - pending payment saved as paypendingnum ".
3503 $cust_pay_pending->paypendingnum. "\n";
3509 if ( $options{'paynum_ref'} ) {
3510 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3513 $cust_pay_pending->status('done');
3514 $cust_pay_pending->statustext('captured');
3515 my $cpp_done_err = $cust_pay_pending->replace;
3517 if ( $cpp_done_err ) {
3519 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3520 my $e = "WARNING: $method captured but payment not recorded - ".
3521 "error updating status for paypendingnum ".
3522 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3528 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3529 return ''; #no error
3535 my $perror = "$processor error: ". $transaction->error_message;
3537 unless ( $transaction->error_message ) {
3540 if ( $transaction->can('response_page') ) {
3542 'page' => ( $transaction->can('response_page')
3543 ? $transaction->response_page
3546 'code' => ( $transaction->can('response_code')
3547 ? $transaction->response_code
3550 'headers' => ( $transaction->can('response_headers')
3551 ? $transaction->response_headers
3557 "No additional debugging information available for $processor";
3560 $perror .= "No error_message returned from $processor -- ".
3561 ( ref($t_response) ? Dumper($t_response) : $t_response );
3565 if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3566 && $conf->exists('emaildecline')
3567 && grep { $_ ne 'POST' } $self->invoicing_list
3568 && ! grep { $transaction->error_message =~ /$_/ }
3569 $conf->config('emaildecline-exclude')
3571 my @templ = $conf->config('declinetemplate');
3572 my $template = new Text::Template (
3574 SOURCE => [ map "$_\n", @templ ],
3575 ) or return "($perror) can't create template: $Text::Template::ERROR";
3576 $template->compile()
3577 or return "($perror) can't compile template: $Text::Template::ERROR";
3579 my $templ_hash = { error => $transaction->error_message };
3581 my $error = send_email(
3582 'from' => $conf->config('invoice_from'),
3583 'to' => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3584 'subject' => 'Your payment could not be processed',
3585 'body' => [ $template->fill_in(HASH => $templ_hash) ],
3588 $perror .= " (also received error sending decline notification: $error)"
3593 $cust_pay_pending->status('done');
3594 $cust_pay_pending->statustext("declined: $perror");
3595 my $cpp_done_err = $cust_pay_pending->replace;
3596 if ( $cpp_done_err ) {
3597 my $e = "WARNING: $method declined but pending payment not resolved - ".
3598 "error updating status for paypendingnum ".
3599 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3601 $perror = "$e ($perror)";
3614 my( $self, $method, $amount, %options ) = @_;
3616 if ( $options{'fake_failure'} ) {
3617 return "Error: No error; test failure requested with fake_failure";
3620 my %method2payby = (
3627 #if ( $payment_gateway ) { # agent override
3628 # $paybatch = $payment_gateway->gatewaynum. '-';
3631 #$paybatch .= "$processor:". $transaction->authorization;
3633 #$paybatch .= ':'. $transaction->order_number
3634 # if $transaction->can('order_number')
3635 # && length($transaction->order_number);
3637 my $paybatch = 'FakeProcessor:54:32';
3639 my $cust_pay = new FS::cust_pay ( {
3640 'custnum' => $self->custnum,
3641 'invnum' => $options{'invnum'},
3644 'payby' => $method2payby{$method},
3645 #'payinfo' => $payinfo,
3646 'payinfo' => '4111111111111111',
3647 'paybatch' => $paybatch,
3648 #'paydate' => $paydate,
3649 'paydate' => '2012-05-01',
3651 $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
3653 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3656 $cust_pay->invnum(''); #try again with no specific invnum
3657 my $error2 = $cust_pay->insert( $options{'manual'} ?
3658 ( 'manual' => 1 ) : ()
3661 # gah, even with transactions.
3662 my $e = 'WARNING: Card/ACH debited but database not updated - '.
3663 "error inserting (fake!) payment: $error2".
3664 " (previously tried insert with invnum #$options{'invnum'}" .
3671 if ( $options{'paynum_ref'} ) {
3672 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3675 return ''; #no error
3679 =item default_payment_gateway
3683 sub default_payment_gateway {
3684 my( $self, $method ) = @_;
3686 die "Real-time processing not enabled\n"
3687 unless $conf->exists('business-onlinepayment');
3690 my $bop_config = 'business-onlinepayment';
3691 $bop_config .= '-ach'
3692 if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
3693 my ( $processor, $login, $password, $action, @bop_options ) =
3694 $conf->config($bop_config);
3695 $action ||= 'normal authorization';
3696 pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
3697 die "No real-time processor is enabled - ".
3698 "did you set the business-onlinepayment configuration value?\n"
3701 ( $processor, $login, $password, $action, @bop_options )
3706 Removes the I<paycvv> field from the database directly.
3708 If there is an error, returns the error, otherwise returns false.
3714 my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
3715 or return dbh->errstr;
3716 $sth->execute($self->custnum)
3717 or return $sth->errstr;
3722 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
3724 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
3725 via a Business::OnlinePayment realtime gateway. See
3726 L<http://420.am/business-onlinepayment> for supported gateways.
3728 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3730 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
3732 Most gateways require a reference to an original payment transaction to refund,
3733 so you probably need to specify a I<paynum>.
3735 I<amount> defaults to the original amount of the payment if not specified.
3737 I<reason> specifies a reason for the refund.
3739 I<paydate> specifies the expiration date for a credit card overriding the
3740 value from the customer record or the payment record. Specified as yyyy-mm-dd
3742 Implementation note: If I<amount> is unspecified or equal to the amount of the
3743 orignal payment, first an attempt is made to "void" the transaction via
3744 the gateway (to cancel a not-yet settled transaction) and then if that fails,
3745 the normal attempt is made to "refund" ("credit") the transaction via the
3746 gateway is attempted.
3748 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3749 #I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3750 #if set, will override the value from the customer record.
3752 #If an I<invnum> is specified, this payment (if successful) is applied to the
3753 #specified invoice. If you don't specify an I<invnum> you might want to
3754 #call the B<apply_payments> method.
3758 #some false laziness w/realtime_bop, not enough to make it worth merging
3759 #but some useful small subs should be pulled out
3760 sub realtime_refund_bop {
3761 my( $self, $method, %options ) = @_;
3763 warn "$me realtime_refund_bop: $method refund\n";
3764 warn " $_ => $options{$_}\n" foreach keys %options;
3767 eval "use Business::OnlinePayment";
3771 # look up the original payment and optionally a gateway for that payment
3775 my $amount = $options{'amount'};
3777 my( $processor, $login, $password, @bop_options ) ;
3778 my( $auth, $order_number ) = ( '', '', '' );
3780 if ( $options{'paynum'} ) {
3782 warn " paynum: $options{paynum}\n" if $DEBUG > 1;
3783 $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
3784 or return "Unknown paynum $options{'paynum'}";
3785 $amount ||= $cust_pay->paid;
3787 $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
3788 or return "Can't parse paybatch for paynum $options{'paynum'}: ".
3789 $cust_pay->paybatch;
3790 my $gatewaynum = '';
3791 ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
3793 if ( $gatewaynum ) { #gateway for the payment to be refunded
3795 my $payment_gateway =
3796 qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
3797 die "payment gateway $gatewaynum not found"
3798 unless $payment_gateway;
3800 $processor = $payment_gateway->gateway_module;
3801 $login = $payment_gateway->gateway_username;
3802 $password = $payment_gateway->gateway_password;
3803 @bop_options = $payment_gateway->options;
3805 } else { #try the default gateway
3807 my( $conf_processor, $unused_action );
3808 ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
3809 $self->default_payment_gateway($method);
3811 return "processor of payment $options{'paynum'} $processor does not".
3812 " match default processor $conf_processor"
3813 unless $processor eq $conf_processor;
3818 } else { # didn't specify a paynum, so look for agent gateway overrides
3819 # like a normal transaction
3822 if ( $method eq 'CC' ) {
3823 $cardtype = cardtype($self->payinfo);
3824 } elsif ( $method eq 'ECHECK' ) {
3827 $cardtype = $method;
3830 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3831 cardtype => $cardtype,
3833 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3835 taxclass => '', } );
3837 if ( $override ) { #use a payment gateway override
3839 my $payment_gateway = $override->payment_gateway;
3841 $processor = $payment_gateway->gateway_module;
3842 $login = $payment_gateway->gateway_username;
3843 $password = $payment_gateway->gateway_password;
3844 #$action = $payment_gateway->gateway_action;
3845 @bop_options = $payment_gateway->options;
3847 } else { #use the standard settings from the config
3850 ( $processor, $login, $password, $unused_action, @bop_options ) =
3851 $self->default_payment_gateway($method);
3856 return "neither amount nor paynum specified" unless $amount;
3861 'password' => $password,
3862 'order_number' => $order_number,
3863 'amount' => $amount,
3864 'referer' => 'http://cleanwhisker.420.am/',
3866 $content{authorization} = $auth
3867 if length($auth); #echeck/ACH transactions have an order # but no auth
3868 #(at least with authorize.net)
3870 my $disable_void_after;
3871 if ($conf->exists('disable_void_after')
3872 && $conf->config('disable_void_after') =~ /^(\d+)$/) {
3873 $disable_void_after = $1;
3876 #first try void if applicable
3877 if ( $cust_pay && $cust_pay->paid == $amount
3879 ( not defined($disable_void_after) )
3880 || ( time < ($cust_pay->_date + $disable_void_after ) )
3883 warn " attempting void\n" if $DEBUG > 1;
3884 my $void = new Business::OnlinePayment( $processor, @bop_options );
3885 $void->content( 'action' => 'void', %content );
3887 if ( $void->is_success ) {
3888 my $error = $cust_pay->void($options{'reason'});
3890 # gah, even with transactions.
3891 my $e = 'WARNING: Card/ACH voided but database not updated - '.
3892 "error voiding payment: $error";
3896 warn " void successful\n" if $DEBUG > 1;
3901 warn " void unsuccessful, trying refund\n"
3905 my $address = $self->address1;
3906 $address .= ", ". $self->address2 if $self->address2;
3908 my($payname, $payfirst, $paylast);
3909 if ( $self->payname && $method ne 'ECHECK' ) {
3910 $payname = $self->payname;
3911 $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3912 or return "Illegal payname $payname";
3913 ($payfirst, $paylast) = ($1, $2);
3915 $payfirst = $self->getfield('first');
3916 $paylast = $self->getfield('last');
3917 $payname = "$payfirst $paylast";
3920 my @invoicing_list = $self->invoicing_list_emailonly;
3921 if ( $conf->exists('emailinvoiceautoalways')
3922 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3923 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3924 push @invoicing_list, $self->all_emails;
3927 my $email = ($conf->exists('business-onlinepayment-email-override'))
3928 ? $conf->config('business-onlinepayment-email-override')
3929 : $invoicing_list[0];
3931 my $payip = exists($options{'payip'})
3934 $content{customer_ip} = $payip
3938 if ( $method eq 'CC' ) {
3941 $content{card_number} = $payinfo = $cust_pay->payinfo;
3942 (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
3943 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
3944 ($content{expiration} = "$2/$1"); # where available
3946 $content{card_number} = $payinfo = $self->payinfo;
3947 (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
3948 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3949 $content{expiration} = "$2/$1";
3952 } elsif ( $method eq 'ECHECK' ) {
3955 $payinfo = $cust_pay->payinfo;
3957 $payinfo = $self->payinfo;
3959 ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
3960 $content{bank_name} = $self->payname;
3961 $content{account_type} = 'CHECKING';
3962 $content{account_name} = $payname;
3963 $content{customer_org} = $self->company ? 'B' : 'I';
3964 $content{customer_ssn} = $self->ss;
3965 } elsif ( $method eq 'LEC' ) {
3966 $content{phone} = $payinfo = $self->payinfo;
3970 my $refund = new Business::OnlinePayment( $processor, @bop_options );
3971 my %sub_content = $refund->content(
3972 'action' => 'credit',
3973 'customer_id' => $self->custnum,
3974 'last_name' => $paylast,
3975 'first_name' => $payfirst,
3977 'address' => $address,
3978 'city' => $self->city,
3979 'state' => $self->state,
3980 'zip' => $self->zip,
3981 'country' => $self->country,
3983 'phone' => $self->daytime || $self->night,
3986 warn join('', map { " $_ => $sub_content{$_}\n" } keys %sub_content )
3990 return "$processor error: ". $refund->error_message
3991 unless $refund->is_success();
3993 my %method2payby = (
3999 my $paybatch = "$processor:". $refund->authorization;
4000 $paybatch .= ':'. $refund->order_number
4001 if $refund->can('order_number') && $refund->order_number;
4003 while ( $cust_pay && $cust_pay->unapplied < $amount ) {
4004 my @cust_bill_pay = $cust_pay->cust_bill_pay;
4005 last unless @cust_bill_pay;
4006 my $cust_bill_pay = pop @cust_bill_pay;
4007 my $error = $cust_bill_pay->delete;
4011 my $cust_refund = new FS::cust_refund ( {
4012 'custnum' => $self->custnum,
4013 'paynum' => $options{'paynum'},
4014 'refund' => $amount,
4016 'payby' => $method2payby{$method},
4017 'payinfo' => $payinfo,
4018 'paybatch' => $paybatch,
4019 'reason' => $options{'reason'} || 'card or ACH refund',
4021 my $error = $cust_refund->insert;
4023 $cust_refund->paynum(''); #try again with no specific paynum
4024 my $error2 = $cust_refund->insert;
4026 # gah, even with transactions.
4027 my $e = 'WARNING: Card/ACH refunded but database not updated - '.
4028 "error inserting refund ($processor): $error2".
4029 " (previously tried insert with paynum #$options{'paynum'}" .
4040 =item batch_card OPTION => VALUE...
4042 Adds a payment for this invoice to the pending credit card batch (see
4043 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
4044 runs the payment using a realtime gateway.
4049 my ($self, %options) = @_;
4052 if (exists($options{amount})) {
4053 $amount = $options{amount};
4055 $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
4057 return '' unless $amount > 0;
4059 my $invnum = delete $options{invnum};
4060 my $payby = $options{invnum} || $self->payby; #dubious
4062 if ($options{'realtime'}) {
4063 return $self->realtime_bop( FS::payby->payby2bop($self->payby),
4069 my $oldAutoCommit = $FS::UID::AutoCommit;
4070 local $FS::UID::AutoCommit = 0;
4073 #this needs to handle mysql as well as Pg, like svc_acct.pm
4074 #(make it into a common function if folks need to do batching with mysql)
4075 $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
4076 or return "Cannot lock pay_batch: " . $dbh->errstr;
4080 'payby' => FS::payby->payby2payment($payby),
4083 my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
4085 unless ( $pay_batch ) {
4086 $pay_batch = new FS::pay_batch \%pay_batch;
4087 my $error = $pay_batch->insert;
4089 $dbh->rollback if $oldAutoCommit;
4090 die "error creating new batch: $error\n";
4094 my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
4095 'batchnum' => $pay_batch->batchnum,
4096 'custnum' => $self->custnum,
4099 foreach (qw( address1 address2 city state zip country payby payinfo paydate
4101 $options{$_} = '' unless exists($options{$_});
4104 my $cust_pay_batch = new FS::cust_pay_batch ( {
4105 'batchnum' => $pay_batch->batchnum,
4106 'invnum' => $invnum || 0, # is there a better value?
4107 # this field should be
4109 # cust_bill_pay_batch now
4110 'custnum' => $self->custnum,
4111 'last' => $self->getfield('last'),
4112 'first' => $self->getfield('first'),
4113 'address1' => $options{address1} || $self->address1,
4114 'address2' => $options{address2} || $self->address2,
4115 'city' => $options{city} || $self->city,
4116 'state' => $options{state} || $self->state,
4117 'zip' => $options{zip} || $self->zip,
4118 'country' => $options{country} || $self->country,
4119 'payby' => $options{payby} || $self->payby,
4120 'payinfo' => $options{payinfo} || $self->payinfo,
4121 'exp' => $options{paydate} || $self->paydate,
4122 'payname' => $options{payname} || $self->payname,
4123 'amount' => $amount, # consolidating
4126 $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
4127 if $old_cust_pay_batch;
4130 if ($old_cust_pay_batch) {
4131 $error = $cust_pay_batch->replace($old_cust_pay_batch)
4133 $error = $cust_pay_batch->insert;
4137 $dbh->rollback if $oldAutoCommit;
4141 my $unapplied = $self->total_credited + $self->total_unapplied_payments + $self->in_transit_payments;
4142 foreach my $cust_bill ($self->open_cust_bill) {
4143 #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
4144 my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
4145 'invnum' => $cust_bill->invnum,
4146 'paybatchnum' => $cust_pay_batch->paybatchnum,
4147 'amount' => $cust_bill->owed,
4150 if ($unapplied >= $cust_bill_pay_batch->amount){
4151 $unapplied -= $cust_bill_pay_batch->amount;
4154 $cust_bill_pay_batch->amount(sprintf ( "%.2f",
4155 $cust_bill_pay_batch->amount - $unapplied )); $unapplied = 0;
4157 $error = $cust_bill_pay_batch->insert;
4159 $dbh->rollback if $oldAutoCommit;
4164 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4170 Returns the total owed for this customer on all invoices
4171 (see L<FS::cust_bill/owed>).
4177 $self->total_owed_date(2145859200); #12/31/2037
4180 =item total_owed_date TIME
4182 Returns the total owed for this customer on all invoices with date earlier than
4183 TIME. TIME is specified as a UNIX timestamp; see L<perlfunc/"time">). Also
4184 see L<Time::Local> and L<Date::Parse> for conversion functions.
4188 sub total_owed_date {
4192 foreach my $cust_bill (
4193 grep { $_->_date <= $time }
4194 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4196 $total_bill += $cust_bill->owed;
4198 sprintf( "%.2f", $total_bill );
4201 =item apply_payments_and_credits
4203 Applies unapplied payments and credits.
4205 In most cases, this new method should be used in place of sequential
4206 apply_payments and apply_credits methods.
4208 If there is an error, returns the error, otherwise returns false.
4212 sub apply_payments_and_credits {
4215 local $SIG{HUP} = 'IGNORE';
4216 local $SIG{INT} = 'IGNORE';
4217 local $SIG{QUIT} = 'IGNORE';
4218 local $SIG{TERM} = 'IGNORE';
4219 local $SIG{TSTP} = 'IGNORE';
4220 local $SIG{PIPE} = 'IGNORE';
4222 my $oldAutoCommit = $FS::UID::AutoCommit;
4223 local $FS::UID::AutoCommit = 0;
4226 $self->select_for_update; #mutex
4228 foreach my $cust_bill ( $self->open_cust_bill ) {
4229 my $error = $cust_bill->apply_payments_and_credits;
4231 $dbh->rollback if $oldAutoCommit;
4232 return "Error applying: $error";
4236 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4241 =item apply_credits OPTION => VALUE ...
4243 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
4244 to outstanding invoice balances in chronological order (or reverse
4245 chronological order if the I<order> option is set to B<newest>) and returns the
4246 value of any remaining unapplied credits available for refund (see
4247 L<FS::cust_refund>).
4249 Dies if there is an error.
4257 local $SIG{HUP} = 'IGNORE';
4258 local $SIG{INT} = 'IGNORE';
4259 local $SIG{QUIT} = 'IGNORE';
4260 local $SIG{TERM} = 'IGNORE';
4261 local $SIG{TSTP} = 'IGNORE';
4262 local $SIG{PIPE} = 'IGNORE';
4264 my $oldAutoCommit = $FS::UID::AutoCommit;
4265 local $FS::UID::AutoCommit = 0;
4268 $self->select_for_update; #mutex
4270 unless ( $self->total_credited ) {
4271 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4275 my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
4276 qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
4278 my @invoices = $self->open_cust_bill;
4279 @invoices = sort { $b->_date <=> $a->_date } @invoices
4280 if defined($opt{'order'}) && $opt{'order'} eq 'newest';
4283 foreach my $cust_bill ( @invoices ) {
4286 if ( !defined($credit) || $credit->credited == 0) {
4287 $credit = pop @credits or last;
4290 if ($cust_bill->owed >= $credit->credited) {
4291 $amount=$credit->credited;
4293 $amount=$cust_bill->owed;
4296 my $cust_credit_bill = new FS::cust_credit_bill ( {
4297 'crednum' => $credit->crednum,
4298 'invnum' => $cust_bill->invnum,
4299 'amount' => $amount,
4301 my $error = $cust_credit_bill->insert;
4303 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4307 redo if ($cust_bill->owed > 0);
4311 my $total_credited = $self->total_credited;
4313 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4315 return $total_credited;
4318 =item apply_payments
4320 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
4321 to outstanding invoice balances in chronological order.
4323 #and returns the value of any remaining unapplied payments.
4325 Dies if there is an error.
4329 sub apply_payments {
4332 local $SIG{HUP} = 'IGNORE';
4333 local $SIG{INT} = 'IGNORE';
4334 local $SIG{QUIT} = 'IGNORE';
4335 local $SIG{TERM} = 'IGNORE';
4336 local $SIG{TSTP} = 'IGNORE';
4337 local $SIG{PIPE} = 'IGNORE';
4339 my $oldAutoCommit = $FS::UID::AutoCommit;
4340 local $FS::UID::AutoCommit = 0;
4343 $self->select_for_update; #mutex
4347 my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
4348 qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
4350 my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
4351 qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
4355 foreach my $cust_bill ( @invoices ) {
4358 if ( !defined($payment) || $payment->unapplied == 0 ) {
4359 $payment = pop @payments or last;
4362 if ( $cust_bill->owed >= $payment->unapplied ) {
4363 $amount = $payment->unapplied;
4365 $amount = $cust_bill->owed;
4368 my $cust_bill_pay = new FS::cust_bill_pay ( {
4369 'paynum' => $payment->paynum,
4370 'invnum' => $cust_bill->invnum,
4371 'amount' => $amount,
4373 my $error = $cust_bill_pay->insert;
4375 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4379 redo if ( $cust_bill->owed > 0);
4383 my $total_unapplied_payments = $self->total_unapplied_payments;
4385 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4387 return $total_unapplied_payments;
4390 =item total_credited
4392 Returns the total outstanding credit (see L<FS::cust_credit>) for this
4393 customer. See L<FS::cust_credit/credited>.
4397 sub total_credited {
4399 my $total_credit = 0;
4400 foreach my $cust_credit ( qsearch('cust_credit', {
4401 'custnum' => $self->custnum,
4403 $total_credit += $cust_credit->credited;
4405 sprintf( "%.2f", $total_credit );
4408 =item total_unapplied_payments
4410 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
4411 See L<FS::cust_pay/unapplied>.
4415 sub total_unapplied_payments {
4417 my $total_unapplied = 0;
4418 foreach my $cust_pay ( qsearch('cust_pay', {
4419 'custnum' => $self->custnum,
4421 $total_unapplied += $cust_pay->unapplied;
4423 sprintf( "%.2f", $total_unapplied );
4426 =item total_unapplied_refunds
4428 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
4429 customer. See L<FS::cust_refund/unapplied>.
4433 sub total_unapplied_refunds {
4435 my $total_unapplied = 0;
4436 foreach my $cust_refund ( qsearch('cust_refund', {
4437 'custnum' => $self->custnum,
4439 $total_unapplied += $cust_refund->unapplied;
4441 sprintf( "%.2f", $total_unapplied );
4446 Returns the balance for this customer (total_owed plus total_unrefunded, minus
4447 total_credited minus total_unapplied_payments).
4455 + $self->total_unapplied_refunds
4456 - $self->total_credited
4457 - $self->total_unapplied_payments
4461 =item balance_date TIME
4463 Returns the balance for this customer, only considering invoices with date
4464 earlier than TIME (total_owed_date minus total_credited minus
4465 total_unapplied_payments). TIME is specified as a UNIX timestamp; see
4466 L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion
4475 $self->total_owed_date($time)
4476 + $self->total_unapplied_refunds
4477 - $self->total_credited
4478 - $self->total_unapplied_payments
4482 =item in_transit_payments
4484 Returns the total of requests for payments for this customer pending in
4485 batches in transit to the bank. See L<FS::pay_batch> and L<FS::cust_pay_batch>
4489 sub in_transit_payments {
4491 my $in_transit_payments = 0;
4492 foreach my $pay_batch ( qsearch('pay_batch', {
4495 foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4496 'batchnum' => $pay_batch->batchnum,
4497 'custnum' => $self->custnum,
4499 $in_transit_payments += $cust_pay_batch->amount;
4502 sprintf( "%.2f", $in_transit_payments );
4505 =item paydate_monthyear
4507 Returns a two-element list consisting of the month and year of this customer's
4508 paydate (credit card expiration date for CARD customers)
4512 sub paydate_monthyear {
4514 if ( $self->paydate =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4516 } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4523 =item invoicing_list [ ARRAYREF ]
4525 If an arguement is given, sets these email addresses as invoice recipients
4526 (see L<FS::cust_main_invoice>). Errors are not fatal and are not reported
4527 (except as warnings), so use check_invoicing_list first.
4529 Returns a list of email addresses (with svcnum entries expanded).
4531 Note: You can clear the invoicing list by passing an empty ARRAYREF. You can
4532 check it without disturbing anything by passing nothing.
4534 This interface may change in the future.
4538 sub invoicing_list {
4539 my( $self, $arrayref ) = @_;
4542 my @cust_main_invoice;
4543 if ( $self->custnum ) {
4544 @cust_main_invoice =
4545 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4547 @cust_main_invoice = ();
4549 foreach my $cust_main_invoice ( @cust_main_invoice ) {
4550 #warn $cust_main_invoice->destnum;
4551 unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4552 #warn $cust_main_invoice->destnum;
4553 my $error = $cust_main_invoice->delete;
4554 warn $error if $error;
4557 if ( $self->custnum ) {
4558 @cust_main_invoice =
4559 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4561 @cust_main_invoice = ();
4563 my %seen = map { $_->address => 1 } @cust_main_invoice;
4564 foreach my $address ( @{$arrayref} ) {
4565 next if exists $seen{$address} && $seen{$address};
4566 $seen{$address} = 1;
4567 my $cust_main_invoice = new FS::cust_main_invoice ( {
4568 'custnum' => $self->custnum,
4571 my $error = $cust_main_invoice->insert;
4572 warn $error if $error;
4576 if ( $self->custnum ) {
4578 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4585 =item check_invoicing_list ARRAYREF
4587 Checks these arguements as valid input for the invoicing_list method. If there
4588 is an error, returns the error, otherwise returns false.
4592 sub check_invoicing_list {
4593 my( $self, $arrayref ) = @_;
4595 foreach my $address ( @$arrayref ) {
4597 if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4598 return 'Can\'t add FAX invoice destination with a blank FAX number.';
4601 my $cust_main_invoice = new FS::cust_main_invoice ( {
4602 'custnum' => $self->custnum,
4605 my $error = $self->custnum
4606 ? $cust_main_invoice->check
4607 : $cust_main_invoice->checkdest
4609 return $error if $error;
4613 return "Email address required"
4614 if $conf->exists('cust_main-require_invoicing_list_email')
4615 && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
4620 =item set_default_invoicing_list
4622 Sets the invoicing list to all accounts associated with this customer,
4623 overwriting any previous invoicing list.
4627 sub set_default_invoicing_list {
4629 $self->invoicing_list($self->all_emails);
4634 Returns the email addresses of all accounts provisioned for this customer.
4641 foreach my $cust_pkg ( $self->all_pkgs ) {
4642 my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
4644 map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4645 grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4647 $list{$_}=1 foreach map { $_->email } @svc_acct;
4652 =item invoicing_list_addpost
4654 Adds postal invoicing to this customer. If this customer is already configured
4655 to receive postal invoices, does nothing.
4659 sub invoicing_list_addpost {
4661 return if grep { $_ eq 'POST' } $self->invoicing_list;
4662 my @invoicing_list = $self->invoicing_list;
4663 push @invoicing_list, 'POST';
4664 $self->invoicing_list(\@invoicing_list);
4667 =item invoicing_list_emailonly
4669 Returns the list of email invoice recipients (invoicing_list without non-email
4670 destinations such as POST and FAX).
4674 sub invoicing_list_emailonly {
4676 warn "$me invoicing_list_emailonly called"
4678 grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
4681 =item invoicing_list_emailonly_scalar
4683 Returns the list of email invoice recipients (invoicing_list without non-email
4684 destinations such as POST and FAX) as a comma-separated scalar.
4688 sub invoicing_list_emailonly_scalar {
4690 warn "$me invoicing_list_emailonly_scalar called"
4692 join(', ', $self->invoicing_list_emailonly);
4695 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
4697 Returns an array of customers referred by this customer (referral_custnum set
4698 to this custnum). If DEPTH is given, recurses up to the given depth, returning
4699 customers referred by customers referred by this customer and so on, inclusive.
4700 The default behavior is DEPTH 1 (no recursion).
4704 sub referral_cust_main {
4706 my $depth = @_ ? shift : 1;
4707 my $exclude = @_ ? shift : {};
4710 map { $exclude->{$_->custnum}++; $_; }
4711 grep { ! $exclude->{ $_->custnum } }
4712 qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
4716 map { $_->referral_cust_main($depth-1, $exclude) }
4723 =item referral_cust_main_ncancelled
4725 Same as referral_cust_main, except only returns customers with uncancelled
4730 sub referral_cust_main_ncancelled {
4732 grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
4735 =item referral_cust_pkg [ DEPTH ]
4737 Like referral_cust_main, except returns a flat list of all unsuspended (and
4738 uncancelled) packages for each customer. The number of items in this list may
4739 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
4743 sub referral_cust_pkg {
4745 my $depth = @_ ? shift : 1;
4747 map { $_->unsuspended_pkgs }
4748 grep { $_->unsuspended_pkgs }
4749 $self->referral_cust_main($depth);
4752 =item referring_cust_main
4754 Returns the single cust_main record for the customer who referred this customer
4755 (referral_custnum), or false.
4759 sub referring_cust_main {
4761 return '' unless $self->referral_custnum;
4762 qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
4765 =item credit AMOUNT, REASON
4767 Applies a credit to this customer. If there is an error, returns the error,
4768 otherwise returns false.
4773 my( $self, $amount, $reason, %options ) = @_;
4774 my $cust_credit = new FS::cust_credit {
4775 'custnum' => $self->custnum,
4776 'amount' => $amount,
4777 'reason' => $reason,
4779 $cust_credit->insert(%options);
4782 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
4784 Creates a one-time charge for this customer. If there is an error, returns
4785 the error, otherwise returns false.
4791 my ( $amount, $quantity, $pkg, $comment, $taxclass, $additional, $classnum );
4792 if ( ref( $_[0] ) ) {
4793 $amount = $_[0]->{amount};
4794 $quantity = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
4795 $pkg = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
4796 $comment = exists($_[0]->{comment}) ? $_[0]->{comment}
4797 : '$'. sprintf("%.2f",$amount);
4798 $taxclass = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
4799 $classnum = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
4800 $additional = $_[0]->{additional};
4804 $pkg = @_ ? shift : 'One-time charge';
4805 $comment = @_ ? shift : '$'. sprintf("%.2f",$amount);
4806 $taxclass = @_ ? shift : '';
4810 local $SIG{HUP} = 'IGNORE';
4811 local $SIG{INT} = 'IGNORE';
4812 local $SIG{QUIT} = 'IGNORE';
4813 local $SIG{TERM} = 'IGNORE';
4814 local $SIG{TSTP} = 'IGNORE';
4815 local $SIG{PIPE} = 'IGNORE';
4817 my $oldAutoCommit = $FS::UID::AutoCommit;
4818 local $FS::UID::AutoCommit = 0;
4821 my $part_pkg = new FS::part_pkg ( {
4823 'comment' => $comment,
4827 'classnum' => $classnum ? $classnum : '',
4828 'taxclass' => $taxclass,
4831 my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
4832 ( 0 .. @$additional - 1 )
4834 'additional_count' => scalar(@$additional),
4835 'setup_fee' => $amount,
4838 my $error = $part_pkg->insert( options => \%options );
4840 $dbh->rollback if $oldAutoCommit;
4844 my $pkgpart = $part_pkg->pkgpart;
4845 my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
4846 unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
4847 my $type_pkgs = new FS::type_pkgs \%type_pkgs;
4848 $error = $type_pkgs->insert;
4850 $dbh->rollback if $oldAutoCommit;
4855 my $cust_pkg = new FS::cust_pkg ( {
4856 'custnum' => $self->custnum,
4857 'pkgpart' => $pkgpart,
4858 'quantity' => $quantity,
4861 $error = $cust_pkg->insert;
4863 $dbh->rollback if $oldAutoCommit;
4867 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4872 #=item charge_postal_fee
4874 #Applies a one time charge this customer. If there is an error,
4875 #returns the error, returns the cust_pkg charge object or false
4876 #if there was no charge.
4880 # This should be a customer event. For that to work requires that bill
4881 # also be a customer event.
4883 sub charge_postal_fee {
4886 my $pkgpart = $conf->config('postal_invoice-fee_pkgpart');
4887 return '' unless ($pkgpart && grep { $_ eq 'POST' } $self->invoicing_list);
4889 my $cust_pkg = new FS::cust_pkg ( {
4890 'custnum' => $self->custnum,
4891 'pkgpart' => $pkgpart,
4895 my $error = $cust_pkg->insert;
4896 $error ? $error : $cust_pkg;
4901 Returns all the invoices (see L<FS::cust_bill>) for this customer.
4907 sort { $a->_date <=> $b->_date }
4908 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4911 =item open_cust_bill
4913 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
4918 sub open_cust_bill {
4920 grep { $_->owed > 0 } $self->cust_bill;
4925 Returns all the credits (see L<FS::cust_credit>) for this customer.
4931 sort { $a->_date <=> $b->_date }
4932 qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
4937 Returns all the payments (see L<FS::cust_pay>) for this customer.
4943 sort { $a->_date <=> $b->_date }
4944 qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
4949 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
4955 sort { $a->_date <=> $b->_date }
4956 qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
4959 =item cust_pay_batch
4961 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
4965 sub cust_pay_batch {
4967 sort { $a->_date <=> $b->_date }
4968 qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
4973 Returns all the refunds (see L<FS::cust_refund>) for this customer.
4979 sort { $a->_date <=> $b->_date }
4980 qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
4985 Returns a name string for this customer, either "Company (Last, First)" or
4992 my $name = $self->contact;
4993 $name = $self->company. " ($name)" if $self->company;
4999 Returns a name string for this (service/shipping) contact, either
5000 "Company (Last, First)" or "Last, First".
5006 if ( $self->get('ship_last') ) {
5007 my $name = $self->ship_contact;
5008 $name = $self->ship_company. " ($name)" if $self->ship_company;
5017 Returns this customer's full (billing) contact name only, "Last, First"
5023 $self->get('last'). ', '. $self->first;
5028 Returns this customer's full (shipping) contact name only, "Last, First"
5034 $self->get('ship_last')
5035 ? $self->get('ship_last'). ', '. $self->ship_first
5041 Returns this customer's full country name
5047 code2country($self->country);
5050 =item geocode DATA_VENDOR
5052 Returns a value for the customer location as encoded by DATA_VENDOR.
5053 Currently this only makes sense for "CCH" as DATA_VENDOR.
5058 my ($self, $data_vendor) = (shift, shift); #always cch for now
5060 my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
5064 my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
5065 if $self->country eq 'US';
5067 #CCH specific location stuff
5068 my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
5071 my $cust_tax_location =
5073 'table' => 'cust_tax_location',
5074 'hashref' => { 'zip' => $zip, 'data_vendor' => $data_vendor },
5075 'extra_sql' => $extra_sql,
5078 $geocode = $cust_tax_location->geocode
5079 if $cust_tax_location;
5088 Returns a status string for this customer, currently:
5092 =item prospect - No packages have ever been ordered
5094 =item active - One or more recurring packages is active
5096 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
5098 =item suspended - All non-cancelled recurring packages are suspended
5100 =item cancelled - All recurring packages are cancelled
5106 sub status { shift->cust_status(@_); }
5110 for my $status (qw( prospect active inactive suspended cancelled )) {
5111 my $method = $status.'_sql';
5112 my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
5113 my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
5114 $sth->execute( ($self->custnum) x $numnum )
5115 or die "Error executing 'SELECT $sql': ". $sth->errstr;
5116 return $status if $sth->fetchrow_arrayref->[0];
5120 =item ucfirst_cust_status
5122 =item ucfirst_status
5124 Returns the status with the first character capitalized.
5128 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
5130 sub ucfirst_cust_status {
5132 ucfirst($self->cust_status);
5137 Returns a hex triplet color string for this customer's status.
5141 use vars qw(%statuscolor);
5142 tie %statuscolor, 'Tie::IxHash',
5143 'prospect' => '7e0079', #'000000', #black? naw, purple
5144 'active' => '00CC00', #green
5145 'inactive' => '0000CC', #blue
5146 'suspended' => 'FF9900', #yellow
5147 'cancelled' => 'FF0000', #red
5150 sub statuscolor { shift->cust_statuscolor(@_); }
5152 sub cust_statuscolor {
5154 $statuscolor{$self->cust_status};
5159 Returns an array of hashes representing the customer's RT tickets.
5166 my $num = $conf->config('cust_main-max_tickets') || 10;
5169 unless ( $conf->config('ticket_system-custom_priority_field') ) {
5171 @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
5175 foreach my $priority (
5176 $conf->config('ticket_system-custom_priority_field-values'), ''
5178 last if scalar(@tickets) >= $num;
5180 @{ FS::TicketSystem->customer_tickets( $self->custnum,
5181 $num - scalar(@tickets),
5190 # Return services representing svc_accts in customer support packages
5191 sub support_services {
5193 my %packages = map { $_ => 1 } $conf->config('support_packages');
5195 grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
5196 grep { $_->part_svc->svcdb eq 'svc_acct' }
5197 map { $_->cust_svc }
5198 grep { exists $packages{ $_->pkgpart } }
5199 $self->ncancelled_pkgs;
5205 =head1 CLASS METHODS
5211 Class method that returns the list of possible status strings for customers
5212 (see L<the status method|/status>). For example:
5214 @statuses = FS::cust_main->statuses();
5219 #my $self = shift; #could be class...
5225 Returns an SQL expression identifying prospective cust_main records (customers
5226 with no packages ever ordered)
5230 use vars qw($select_count_pkgs);
5231 $select_count_pkgs =
5232 "SELECT COUNT(*) FROM cust_pkg
5233 WHERE cust_pkg.custnum = cust_main.custnum";
5235 sub select_count_pkgs_sql {
5239 sub prospect_sql { "
5240 0 = ( $select_count_pkgs )
5245 Returns an SQL expression identifying active cust_main records (customers with
5246 active recurring packages).
5251 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
5257 Returns an SQL expression identifying inactive cust_main records (customers with
5258 no active recurring packages, but otherwise unsuspended/uncancelled).
5262 sub inactive_sql { "
5263 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5265 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5271 Returns an SQL expression identifying suspended cust_main records.
5276 sub suspended_sql { susp_sql(@_); }
5278 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
5280 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5286 Returns an SQL expression identifying cancelled cust_main records.
5290 sub cancelled_sql { cancel_sql(@_); }
5293 my $recurring_sql = FS::cust_pkg->recurring_sql;
5294 my $cancelled_sql = FS::cust_pkg->cancelled_sql;
5297 0 < ( $select_count_pkgs )
5298 AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql )
5299 AND 0 = ( $select_count_pkgs AND $recurring_sql
5300 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5302 AND 0 = ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5308 =item uncancelled_sql
5310 Returns an SQL expression identifying un-cancelled cust_main records.
5314 sub uncancelled_sql { uncancel_sql(@_); }
5315 sub uncancel_sql { "
5316 ( 0 < ( $select_count_pkgs
5317 AND ( cust_pkg.cancel IS NULL
5318 OR cust_pkg.cancel = 0
5321 OR 0 = ( $select_count_pkgs )
5327 Returns an SQL fragment to retreive the balance.
5332 ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
5333 WHERE cust_bill.custnum = cust_main.custnum )
5334 - ( SELECT COALESCE( SUM(paid), 0 ) FROM cust_pay
5335 WHERE cust_pay.custnum = cust_main.custnum )
5336 - ( SELECT COALESCE( SUM(amount), 0 ) FROM cust_credit
5337 WHERE cust_credit.custnum = cust_main.custnum )
5338 + ( SELECT COALESCE( SUM(refund), 0 ) FROM cust_refund
5339 WHERE cust_refund.custnum = cust_main.custnum )
5342 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5344 Returns an SQL fragment to retreive the balance for this customer, only
5345 considering invoices with date earlier than START_TIME, and optionally not
5346 later than END_TIME (total_owed_date minus total_credited minus
5347 total_unapplied_payments).
5349 Times are specified as SQL fragments or numeric
5350 UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
5351 L<Date::Parse> for conversion functions. The empty string can be passed
5352 to disable that time constraint completely.
5354 Available options are:
5358 =item unapplied_date
5360 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)
5365 set to true to remove all customer comparison clauses, for totals
5370 WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
5375 JOIN clause (typically used with the total option)
5381 sub balance_date_sql {
5382 my( $class, $start, $end, %opt ) = @_;
5384 my $owed = FS::cust_bill->owed_sql;
5385 my $unapp_refund = FS::cust_refund->unapplied_sql;
5386 my $unapp_credit = FS::cust_credit->unapplied_sql;
5387 my $unapp_pay = FS::cust_pay->unapplied_sql;
5389 my $j = $opt{'join'} || '';
5391 my $owed_wh = $class->_money_table_where( 'cust_bill', $start,$end,%opt );
5392 my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
5393 my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
5394 my $pay_wh = $class->_money_table_where( 'cust_pay', $start,$end,%opt );
5396 " ( SELECT COALESCE(SUM($owed), 0) FROM cust_bill $j $owed_wh )
5397 + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
5398 - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
5399 - ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $j $pay_wh )
5404 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5406 Helper method for balance_date_sql; name (and usage) subject to change
5407 (suggestions welcome).
5409 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
5410 cust_refund, cust_credit or cust_pay).
5412 If TABLE is "cust_bill" or the unapplied_date option is true, only
5413 considers records with date earlier than START_TIME, and optionally not
5414 later than END_TIME .
5418 sub _money_table_where {
5419 my( $class, $table, $start, $end, %opt ) = @_;
5422 push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
5423 if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
5424 push @where, "$table._date <= $start" if defined($start) && length($start);
5425 push @where, "$table._date > $end" if defined($end) && length($end);
5427 push @where, @{$opt{'where'}} if $opt{'where'};
5428 my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
5434 =item search_sql HASHREF
5438 Returns a qsearch hash expression to search for parameters specified in HREF.
5439 Valid parameters are
5447 =item cancelled_pkgs
5453 listref of start date, end date
5459 =item current_balance
5461 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
5465 =item flattened_pkgs
5474 my ($class, $params) = @_;
5485 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5487 "cust_main.agentnum = $1";
5494 #prospect active inactive suspended cancelled
5495 if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
5496 my $method = $params->{'status'}. '_sql';
5497 #push @where, $class->$method();
5498 push @where, FS::cust_main->$method();
5502 # parse cancelled package checkbox
5507 $pkgwhere .= "AND (cancel = 0 or cancel is null)"
5508 unless $params->{'cancelled_pkgs'};
5514 foreach my $field (qw( signupdate )) {
5516 next unless exists($params->{$field});
5518 my($beginning, $ending) = @{$params->{$field}};
5521 "cust_main.$field IS NOT NULL",
5522 "cust_main.$field >= $beginning",
5523 "cust_main.$field <= $ending";
5525 $orderby ||= "ORDER BY cust_main.$field";
5533 my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
5535 push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
5542 #my $balance_sql = $class->balance_sql();
5543 my $balance_sql = FS::cust_main->balance_sql();
5545 push @where, map { s/current_balance/$balance_sql/; $_ }
5546 @{ $params->{'current_balance'} };
5552 if ( $params->{'custbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
5554 "cust_main.custbatch = '$1'";
5558 # setup queries, subs, etc. for the search
5561 $orderby ||= 'ORDER BY custnum';
5563 # here is the agent virtualization
5564 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
5566 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
5568 my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum ) ';
5570 my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
5572 my $select = join(', ',
5573 'cust_main.custnum',
5574 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
5577 my(@extra_headers) = ();
5578 my(@extra_fields) = ();
5580 if ($params->{'flattened_pkgs'}) {
5582 if ($dbh->{Driver}->{Name} eq 'Pg') {
5584 $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";
5586 }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
5587 $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
5588 $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
5590 warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
5591 "omitting packing information from report.";
5594 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";
5596 my $sth = dbh->prepare($header_query) or die dbh->errstr;
5597 $sth->execute() or die $sth->errstr;
5598 my $headerrow = $sth->fetchrow_arrayref;
5599 my $headercount = $headerrow ? $headerrow->[0] : 0;
5600 while($headercount) {
5601 unshift @extra_headers, "Package ". $headercount;
5602 unshift @extra_fields, eval q!sub {my $c = shift;
5603 my @a = split '\|', $c->magic;
5604 my $p = $a[!.--$headercount. q!];
5612 'table' => 'cust_main',
5613 'select' => $select,
5615 'extra_sql' => $extra_sql,
5616 'order_by' => $orderby,
5617 'count_query' => $count_query,
5618 'extra_headers' => \@extra_headers,
5619 'extra_fields' => \@extra_fields,
5624 =item email_search_sql HASHREF
5628 Emails a notice to the specified customers.
5630 Valid parameters are those of the L<search_sql> method, plus the following:
5652 Optional job queue job for status updates.
5656 Returns an error message, or false for success.
5658 If an error occurs during any email, stops the enture send and returns that
5659 error. Presumably if you're getting SMTP errors aborting is better than
5660 retrying everything.
5664 sub email_search_sql {
5665 my($class, $params) = @_;
5667 my $from = delete $params->{from};
5668 my $subject = delete $params->{subject};
5669 my $html_body = delete $params->{html_body};
5670 my $text_body = delete $params->{text_body};
5672 my $job = delete $params->{'job'};
5674 my $sql_query = $class->search_sql($params);
5676 my $count_query = delete($sql_query->{'count_query'});
5677 my $count_sth = dbh->prepare($count_query)
5678 or die "Error preparing $count_query: ". dbh->errstr;
5680 or die "Error executing $count_query: ". $count_sth->errstr;
5681 my $count_arrayref = $count_sth->fetchrow_arrayref;
5682 my $num_cust = $count_arrayref->[0];
5684 #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
5685 #my @extra_fields = @{ delete($sql_query->{'extra_fields'}) };
5688 my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
5690 #eventually order+limit magic to reduce memory use?
5691 foreach my $cust_main ( qsearch($sql_query) ) {
5693 my $to = $cust_main->invoicing_list_emailonly_scalar;
5696 my $error = send_email(
5700 'subject' => $subject,
5701 'html_body' => $html_body,
5702 'text_body' => $text_body,
5705 return $error if $error;
5707 if ( $job ) { #progressbar foo
5709 if ( time - $min_sec > $last ) {
5710 my $error = $job->update_statustext(
5711 int( 100 * $num / $num_cust )
5713 die $error if $error;
5723 use Storable qw(thaw);
5726 sub process_email_search_sql {
5728 #warn "$me process_re_X $method for job $job\n" if $DEBUG;
5730 my $param = thaw(decode_base64(shift));
5731 warn Dumper($param) if $DEBUG;
5733 $param->{'job'} = $job;
5735 my $error = FS::cust_main->email_search_sql( $param );
5736 die $error if $error;
5740 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
5742 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
5743 records. Currently, I<first>, I<last> and/or I<company> may be specified (the
5744 appropriate ship_ field is also searched).
5746 Additional options are the same as FS::Record::qsearch
5751 my( $self, $fuzzy, $hash, @opt) = @_;
5756 check_and_rebuild_fuzzyfiles();
5757 foreach my $field ( keys %$fuzzy ) {
5759 my $all = $self->all_X($field);
5760 next unless scalar(@$all);
5763 $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
5766 foreach ( keys %match ) {
5767 push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
5768 push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
5771 push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
5774 # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
5776 @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
5784 Returns a masked version of the named field
5789 my ($self,$field) = @_;
5793 'x'x(length($self->getfield($field))-4).
5794 substr($self->getfield($field), (length($self->getfield($field))-4));
5804 =item smart_search OPTION => VALUE ...
5806 Accepts the following options: I<search>, the string to search for. The string
5807 will be searched for as a customer number, phone number, name or company name,
5808 as an exact, or, in some cases, a substring or fuzzy match (see the source code
5809 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
5810 skip fuzzy matching when an exact match is found.
5812 Any additional options are treated as an additional qualifier on the search
5815 Returns a (possibly empty) array of FS::cust_main objects.
5822 #here is the agent virtualization
5823 my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
5827 my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
5828 my $search = delete $options{'search'};
5829 ( my $alphanum_search = $search ) =~ s/\W//g;
5831 if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
5833 #false laziness w/Record::ut_phone
5834 my $phonen = "$1-$2-$3";
5835 $phonen .= " x$4" if $4;
5837 push @cust_main, qsearch( {
5838 'table' => 'cust_main',
5839 'hashref' => { %options },
5840 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5842 join(' OR ', map "$_ = '$phonen'",
5843 qw( daytime night fax
5844 ship_daytime ship_night ship_fax )
5847 " AND $agentnums_sql", #agent virtualization
5850 unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
5851 #try looking for matches with extensions unless one was specified
5853 push @cust_main, qsearch( {
5854 'table' => 'cust_main',
5855 'hashref' => { %options },
5856 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5858 join(' OR ', map "$_ LIKE '$phonen\%'",
5860 ship_daytime ship_night )
5863 " AND $agentnums_sql", #agent virtualization
5868 # custnum search (also try agent_custid), with some tweaking options if your
5869 # legacy cust "numbers" have letters
5870 } elsif ( $search =~ /^\s*(\d+)\s*$/
5871 || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
5872 && $search =~ /^\s*(\w\w?\d+)\s*$/
5877 push @cust_main, qsearch( {
5878 'table' => 'cust_main',
5879 'hashref' => { 'custnum' => $1, %options },
5880 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5883 push @cust_main, qsearch( {
5884 'table' => 'cust_main',
5885 'hashref' => { 'agent_custid' => $1, %options },
5886 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5889 } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
5891 my($company, $last, $first) = ( $1, $2, $3 );
5893 # "Company (Last, First)"
5894 #this is probably something a browser remembered,
5895 #so just do an exact search
5897 foreach my $prefix ( '', 'ship_' ) {
5898 push @cust_main, qsearch( {
5899 'table' => 'cust_main',
5900 'hashref' => { $prefix.'first' => $first,
5901 $prefix.'last' => $last,
5902 $prefix.'company' => $company,
5905 'extra_sql' => " AND $agentnums_sql",
5909 } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
5910 # try (ship_){last,company}
5914 # # remove "(Last, First)" in "Company (Last, First)", otherwise the
5915 # # full strings the browser remembers won't work
5916 # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
5918 use Lingua::EN::NameParse;
5919 my $NameParse = new Lingua::EN::NameParse(
5921 allow_reversed => 1,
5924 my($last, $first) = ( '', '' );
5925 #maybe disable this too and just rely on NameParse?
5926 if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
5928 ($last, $first) = ( $1, $2 );
5930 #} elsif ( $value =~ /^(.+)\s+(.+)$/ ) {
5931 } elsif ( ! $NameParse->parse($value) ) {
5933 my %name = $NameParse->components;
5934 $first = $name{'given_name_1'};
5935 $last = $name{'surname_1'};
5939 if ( $first && $last ) {
5941 my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
5944 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5946 ( ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
5947 OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
5950 push @cust_main, qsearch( {
5951 'table' => 'cust_main',
5952 'hashref' => \%options,
5953 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5956 # or it just be something that was typed in... (try that in a sec)
5960 my $q_value = dbh->quote($value);
5963 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5964 $sql .= " ( LOWER(last) = $q_value
5965 OR LOWER(company) = $q_value
5966 OR LOWER(ship_last) = $q_value
5967 OR LOWER(ship_company) = $q_value
5970 push @cust_main, qsearch( {
5971 'table' => 'cust_main',
5972 'hashref' => \%options,
5973 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5976 #no exact match, trying substring/fuzzy
5977 #always do substring & fuzzy (unless they're explicity config'ed off)
5978 #getting complaints searches are not returning enough
5979 unless ( @cust_main && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
5981 #still some false laziness w/search_sql (was search/cust_main.cgi)
5986 { 'company' => { op=>'ILIKE', value=>"%$value%" }, },
5987 { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
5990 if ( $first && $last ) {
5993 { 'first' => { op=>'ILIKE', value=>"%$first%" },
5994 'last' => { op=>'ILIKE', value=>"%$last%" },
5996 { 'ship_first' => { op=>'ILIKE', value=>"%$first%" },
5997 'ship_last' => { op=>'ILIKE', value=>"%$last%" },
6004 { 'last' => { op=>'ILIKE', value=>"%$value%" }, },
6005 { 'ship_last' => { op=>'ILIKE', value=>"%$value%" }, },
6009 foreach my $hashref ( @hashrefs ) {
6011 push @cust_main, qsearch( {
6012 'table' => 'cust_main',
6013 'hashref' => { %$hashref,
6016 'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
6025 " AND $agentnums_sql", #extra_sql #agent virtualization
6028 if ( $first && $last ) {
6029 push @cust_main, FS::cust_main->fuzzy_search(
6030 { 'last' => $last, #fuzzy hashref
6031 'first' => $first }, #
6035 foreach my $field ( 'last', 'company' ) {
6037 FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
6042 #eliminate duplicates
6044 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6054 Accepts the following options: I<email>, the email address to search for. The
6055 email address will be searched for as an email invoice destination and as an
6058 #Any additional options are treated as an additional qualifier on the search
6059 #(i.e. I<agentnum>).
6061 Returns a (possibly empty) array of FS::cust_main objects (but usually just
6071 my $email = delete $options{'email'};
6073 #we're only being used by RT at the moment... no agent virtualization yet
6074 #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
6078 if ( $email =~ /([^@]+)\@([^@]+)/ ) {
6080 my ( $user, $domain ) = ( $1, $2 );
6082 warn "$me smart_search: searching for $user in domain $domain"
6088 'table' => 'cust_main_invoice',
6089 'hashref' => { 'dest' => $email },
6096 map $_->cust_svc->cust_pkg,
6098 'table' => 'svc_acct',
6099 'hashref' => { 'username' => $user, },
6101 'AND ( SELECT domain FROM svc_domain
6102 WHERE svc_acct.domsvc = svc_domain.svcnum
6103 ) = '. dbh->quote($domain),
6109 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6111 warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
6118 =item check_and_rebuild_fuzzyfiles
6122 use vars qw(@fuzzyfields);
6123 @fuzzyfields = ( 'last', 'first', 'company' );
6125 sub check_and_rebuild_fuzzyfiles {
6126 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6127 rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
6130 =item rebuild_fuzzyfiles
6134 sub rebuild_fuzzyfiles {
6136 use Fcntl qw(:flock);
6138 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6139 mkdir $dir, 0700 unless -d $dir;
6141 foreach my $fuzzy ( @fuzzyfields ) {
6143 open(LOCK,">>$dir/cust_main.$fuzzy")
6144 or die "can't open $dir/cust_main.$fuzzy: $!";
6146 or die "can't lock $dir/cust_main.$fuzzy: $!";
6148 open (CACHE,">$dir/cust_main.$fuzzy.tmp")
6149 or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
6151 foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
6152 my $sth = dbh->prepare("SELECT $field FROM cust_main".
6153 " WHERE $field != '' AND $field IS NOT NULL");
6154 $sth->execute or die $sth->errstr;
6156 while ( my $row = $sth->fetchrow_arrayref ) {
6157 print CACHE $row->[0]. "\n";
6162 close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
6164 rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
6175 my( $self, $field ) = @_;
6176 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6177 open(CACHE,"<$dir/cust_main.$field")
6178 or die "can't open $dir/cust_main.$field: $!";
6179 my @array = map { chomp; $_; } <CACHE>;
6184 =item append_fuzzyfiles LASTNAME COMPANY
6188 sub append_fuzzyfiles {
6189 #my( $first, $last, $company ) = @_;
6191 &check_and_rebuild_fuzzyfiles;
6193 use Fcntl qw(:flock);
6195 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6197 foreach my $field (qw( first last company )) {
6202 open(CACHE,">>$dir/cust_main.$field")
6203 or die "can't open $dir/cust_main.$field: $!";
6204 flock(CACHE,LOCK_EX)
6205 or die "can't lock $dir/cust_main.$field: $!";
6207 print CACHE "$value\n";
6209 flock(CACHE,LOCK_UN)
6210 or die "can't unlock $dir/cust_main.$field: $!";
6219 =item process_batch_import
6221 Load a batch import as a queued JSRPC job
6225 use Storable qw(thaw);
6228 sub process_batch_import {
6231 my $param = thaw(decode_base64(shift));
6232 warn Dumper($param) if $DEBUG;
6234 my $files = $param->{'uploaded_files'}
6235 or die "No files provided.\n";
6237 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
6239 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
6240 my $file = $dir. $files{'file'};
6243 if ( $file =~ /\.(\w+)$/i ) {
6247 warn "can't parse file type from filename $file; defaulting to CSV";
6252 FS::cust_main::batch_import( {
6256 custbatch => $param->{custbatch},
6257 agentnum => $param->{'agentnum'},
6258 refnum => $param->{'refnum'},
6259 pkgpart => $param->{'pkgpart'},
6260 #'fields' => [qw( cust_pkg.setup dayphone first last address1 address2
6261 # city state zip comments )],
6262 'format' => $param->{'format'},
6267 die "$error\n" if $error;
6275 #some false laziness w/cdr.pm now
6279 my $job = $param->{job};
6281 my $filename = $param->{file};
6282 my $type = $param->{type} || 'csv';
6284 my $custbatch = $param->{custbatch};
6286 my $agentnum = $param->{agentnum};
6287 my $refnum = $param->{refnum};
6288 my $pkgpart = $param->{pkgpart};
6290 my $format = $param->{'format'};
6294 if ( $format eq 'simple' ) {
6295 @fields = qw( cust_pkg.setup dayphone first last
6296 address1 address2 city state zip comments );
6298 } elsif ( $format eq 'extended' ) {
6299 @fields = qw( agent_custid refnum
6300 last first address1 address2 city state zip country
6302 ship_last ship_first ship_address1 ship_address2
6303 ship_city ship_state ship_zip ship_country
6304 payinfo paycvv paydate
6307 svc_acct.username svc_acct._password
6310 } elsif ( $format eq 'extended-plus_company' ) {
6311 @fields = qw( agent_custid refnum
6312 last first company address1 address2 city state zip country
6314 ship_last ship_first ship_company ship_address1 ship_address2
6315 ship_city ship_state ship_zip ship_country
6316 payinfo paycvv paydate
6319 svc_acct.username svc_acct._password
6323 die "unknown format $format";
6329 if ( $type eq 'csv' ) {
6331 eval "use Text::CSV_XS;";
6334 $parser = new Text::CSV_XS;
6336 @buffer = split(/\r?\n/, slurp($filename) );
6337 $count = scalar(@buffer);
6339 } elsif ( $type eq 'xls' ) {
6341 eval "use Spreadsheet::ParseExcel;";
6344 my $excel = new Spreadsheet::ParseExcel::Workbook->Parse($filename);
6345 $parser = $excel->{Worksheet}[0]; #first sheet
6347 $count = $parser->{MaxRow} || $parser->{MinRow};
6351 die "Unknown file type $type\n";
6356 local $SIG{HUP} = 'IGNORE';
6357 local $SIG{INT} = 'IGNORE';
6358 local $SIG{QUIT} = 'IGNORE';
6359 local $SIG{TERM} = 'IGNORE';
6360 local $SIG{TSTP} = 'IGNORE';
6361 local $SIG{PIPE} = 'IGNORE';
6363 my $oldAutoCommit = $FS::UID::AutoCommit;
6364 local $FS::UID::AutoCommit = 0;
6369 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
6373 if ( $type eq 'csv' ) {
6375 last unless scalar(@buffer);
6376 $line = shift(@buffer);
6378 $parser->parse($line) or do {
6379 $dbh->rollback if $oldAutoCommit;
6380 return "can't parse: ". $parser->error_input();
6382 @columns = $parser->fields();
6384 } elsif ( $type eq 'xls' ) {
6386 last if $row > ($parser->{MaxRow} || $parser->{MinRow});
6388 my @row = @{ $parser->{Cells}[$row] };
6389 @columns = map $_->{Val}, @row;
6392 #warn $z++. ": $_\n" for @columns;
6395 die "Unknown file type $type\n";
6398 #warn join('-',@columns);
6401 custbatch => $custbatch,
6402 agentnum => $agentnum,
6404 country => $conf->config('countrydefault') || 'US',
6405 payby => $payby, #default
6406 paydate => '12/2037', #default
6408 my $billtime = time;
6409 my %cust_pkg = ( pkgpart => $pkgpart );
6411 foreach my $field ( @fields ) {
6413 if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|adjourn|expire|cancel)$/ ) {
6415 #$cust_pkg{$1} = str2time( shift @$columns );
6416 if ( $1 eq 'pkgpart' ) {
6417 $cust_pkg{$1} = shift @columns;
6418 } elsif ( $1 eq 'setup' ) {
6419 $billtime = str2time(shift @columns);
6421 $cust_pkg{$1} = str2time( shift @columns );
6424 } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
6426 $svc_acct{$1} = shift @columns;
6430 #refnum interception
6431 if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
6433 my $referral = $columns[0];
6434 my %hash = ( 'referral' => $referral,
6435 'agentnum' => $agentnum,
6439 my $part_referral = qsearchs('part_referral', \%hash )
6440 || new FS::part_referral \%hash;
6442 unless ( $part_referral->refnum ) {
6443 my $error = $part_referral->insert;
6445 $dbh->rollback if $oldAutoCommit;
6446 return "can't auto-insert advertising source: $referral: $error";
6450 $columns[0] = $part_referral->refnum;
6453 #$cust_main{$field} = shift @$columns;
6454 $cust_main{$field} = shift @columns;
6458 $cust_main{'payby'} = 'CARD'
6459 if defined $cust_main{'payinfo'}
6460 && length $cust_main{'payinfo'};
6462 my $invoicing_list = $cust_main{'invoicing_list'}
6463 ? [ delete $cust_main{'invoicing_list'} ]
6466 my $cust_main = new FS::cust_main ( \%cust_main );
6469 tie my %hash, 'Tie::RefHash'; #this part is important
6471 if ( $cust_pkg{'pkgpart'} ) {
6472 my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
6475 if ( $svc_acct{'username'} ) {
6476 my $part_pkg = $cust_pkg->part_pkg;
6477 unless ( $part_pkg ) {
6478 $dbh->rollback if $oldAutoCommit;
6479 return "unknown pkgpart: ". $cust_pkg{'pkgpart'};
6481 $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
6482 push @svc_acct, new FS::svc_acct ( \%svc_acct )
6485 $hash{$cust_pkg} = \@svc_acct;
6488 my $error = $cust_main->insert( \%hash, $invoicing_list );
6491 $dbh->rollback if $oldAutoCommit;
6492 return "can't insert customer". ( $line ? " for $line" : '' ). ": $error";
6495 if ( $format eq 'simple' ) {
6497 #false laziness w/bill.cgi
6498 $error = $cust_main->bill( 'time' => $billtime );
6500 $dbh->rollback if $oldAutoCommit;
6501 return "can't bill customer for $line: $error";
6504 $error = $cust_main->apply_payments_and_credits;
6506 $dbh->rollback if $oldAutoCommit;
6507 return "can't bill customer for $line: $error";
6510 $error = $cust_main->collect();
6512 $dbh->rollback if $oldAutoCommit;
6513 return "can't collect customer for $line: $error";
6520 if ( $job && time - $min_sec > $last ) { #progress bar
6521 $job->update_statustext( int(100 * $row / $count) );
6527 $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
6529 return "Empty file!" unless $row;
6541 #warn join('-',keys %$param);
6542 my $fh = $param->{filehandle};
6543 my @fields = @{$param->{fields}};
6545 eval "use Text::CSV_XS;";
6548 my $csv = new Text::CSV_XS;
6555 local $SIG{HUP} = 'IGNORE';
6556 local $SIG{INT} = 'IGNORE';
6557 local $SIG{QUIT} = 'IGNORE';
6558 local $SIG{TERM} = 'IGNORE';
6559 local $SIG{TSTP} = 'IGNORE';
6560 local $SIG{PIPE} = 'IGNORE';
6562 my $oldAutoCommit = $FS::UID::AutoCommit;
6563 local $FS::UID::AutoCommit = 0;
6566 #while ( $columns = $csv->getline($fh) ) {
6568 while ( defined($line=<$fh>) ) {
6570 $csv->parse($line) or do {
6571 $dbh->rollback if $oldAutoCommit;
6572 return "can't parse: ". $csv->error_input();
6575 my @columns = $csv->fields();
6576 #warn join('-',@columns);
6579 foreach my $field ( @fields ) {
6580 $row{$field} = shift @columns;
6583 my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
6584 unless ( $cust_main ) {
6585 $dbh->rollback if $oldAutoCommit;
6586 return "unknown custnum $row{'custnum'}";
6589 if ( $row{'amount'} > 0 ) {
6590 my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
6592 $dbh->rollback if $oldAutoCommit;
6596 } elsif ( $row{'amount'} < 0 ) {
6597 my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
6600 $dbh->rollback if $oldAutoCommit;
6610 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6612 return "Empty file!" unless $imported;
6618 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6620 Sends a templated email notification to the customer (see L<Text::Template>).
6622 OPTIONS is a hash and may include
6624 I<from> - the email sender (default is invoice_from)
6626 I<to> - comma-separated scalar or arrayref of recipients
6627 (default is invoicing_list)
6629 I<subject> - The subject line of the sent email notification
6630 (default is "Notice from company_name")
6632 I<extra_fields> - a hashref of name/value pairs which will be substituted
6635 The following variables are vavailable in the template.
6637 I<$first> - the customer first name
6638 I<$last> - the customer last name
6639 I<$company> - the customer company
6640 I<$payby> - a description of the method of payment for the customer
6641 # would be nice to use FS::payby::shortname
6642 I<$payinfo> - the account information used to collect for this customer
6643 I<$expdate> - the expiration of the customer payment in seconds from epoch
6648 my ($customer, $template, %options) = @_;
6650 return unless $conf->exists($template);
6652 my $from = $conf->config('invoice_from') if $conf->exists('invoice_from');
6653 $from = $options{from} if exists($options{from});
6655 my $to = join(',', $customer->invoicing_list_emailonly);
6656 $to = $options{to} if exists($options{to});
6658 my $subject = "Notice from " . $conf->config('company_name')
6659 if $conf->exists('company_name');
6660 $subject = $options{subject} if exists($options{subject});
6662 my $notify_template = new Text::Template (TYPE => 'ARRAY',
6663 SOURCE => [ map "$_\n",
6664 $conf->config($template)]
6666 or die "can't create new Text::Template object: Text::Template::ERROR";
6667 $notify_template->compile()
6668 or die "can't compile template: Text::Template::ERROR";
6670 $FS::notify_template::_template::company_name = $conf->config('company_name');
6671 $FS::notify_template::_template::company_address =
6672 join("\n", $conf->config('company_address') ). "\n";
6674 my $paydate = $customer->paydate || '2037-12-31';
6675 $FS::notify_template::_template::first = $customer->first;
6676 $FS::notify_template::_template::last = $customer->last;
6677 $FS::notify_template::_template::company = $customer->company;
6678 $FS::notify_template::_template::payinfo = $customer->mask_payinfo;
6679 my $payby = $customer->payby;
6680 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6681 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6683 #credit cards expire at the end of the month/year of their exp date
6684 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6685 $FS::notify_template::_template::payby = 'credit card';
6686 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6687 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6689 }elsif ($payby eq 'COMP') {
6690 $FS::notify_template::_template::payby = 'complimentary account';
6692 $FS::notify_template::_template::payby = 'current method';
6694 $FS::notify_template::_template::expdate = $expire_time;
6696 for (keys %{$options{extra_fields}}){
6698 ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
6701 send_email(from => $from,
6703 subject => $subject,
6704 body => $notify_template->fill_in( PACKAGE =>
6705 'FS::notify_template::_template' ),
6710 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6712 Generates a templated notification to the customer (see L<Text::Template>).
6714 OPTIONS is a hash and may include
6716 I<extra_fields> - a hashref of name/value pairs which will be substituted
6717 into the template. These values may override values mentioned below
6718 and those from the customer record.
6720 The following variables are available in the template instead of or in addition
6721 to the fields of the customer record.
6723 I<$payby> - a description of the method of payment for the customer
6724 # would be nice to use FS::payby::shortname
6725 I<$payinfo> - the masked account information used to collect for this customer
6726 I<$expdate> - the expiration of the customer payment method in seconds from epoch
6727 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
6731 sub generate_letter {
6732 my ($self, $template, %options) = @_;
6734 return unless $conf->exists($template);
6736 my $letter_template = new Text::Template
6738 SOURCE => [ map "$_\n", $conf->config($template)],
6739 DELIMITERS => [ '[@--', '--@]' ],
6741 or die "can't create new Text::Template object: Text::Template::ERROR";
6743 $letter_template->compile()
6744 or die "can't compile template: Text::Template::ERROR";
6746 my %letter_data = map { $_ => $self->$_ } $self->fields;
6747 $letter_data{payinfo} = $self->mask_payinfo;
6749 #my $paydate = $self->paydate || '2037-12-31';
6750 my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
6752 my $payby = $self->payby;
6753 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6754 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6756 #credit cards expire at the end of the month/year of their exp date
6757 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6758 $letter_data{payby} = 'credit card';
6759 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6760 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6762 }elsif ($payby eq 'COMP') {
6763 $letter_data{payby} = 'complimentary account';
6765 $letter_data{payby} = 'current method';
6767 $letter_data{expdate} = $expire_time;
6769 for (keys %{$options{extra_fields}}){
6770 $letter_data{$_} = $options{extra_fields}->{$_};
6773 unless(exists($letter_data{returnaddress})){
6774 my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
6775 $self->agent_template)
6777 if ( length($retadd) ) {
6778 $letter_data{returnaddress} = $retadd;
6779 } elsif ( grep /\S/, $conf->config('company_address') ) {
6780 $letter_data{returnaddress} =
6781 join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
6782 $conf->config('company_address')
6785 $letter_data{returnaddress} = '~';
6789 $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
6791 $letter_data{company_name} = $conf->config('company_name');
6793 my $dir = $FS::UID::conf_dir."cache.". $FS::UID::datasrc;
6794 my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
6798 ) or die "can't open temp file: $!\n";
6800 $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
6802 $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
6806 =item print_ps TEMPLATE
6808 Returns an postscript letter filled in from TEMPLATE, as a scalar.
6814 my $file = $self->generate_letter(@_);
6815 FS::Misc::generate_ps($file);
6818 =item print TEMPLATE
6820 Prints the filled in template.
6822 TEMPLATE is the name of a L<Text::Template> to fill in and print.
6826 sub queueable_print {
6829 my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
6830 or die "invalid customer number: " . $opt{custvnum};
6832 my $error = $self->print( $opt{template} );
6833 die $error if $error;
6837 my ($self, $template) = (shift, shift);
6838 do_print [ $self->print_ps($template) ];
6841 sub agent_template {
6843 $self->_agent_plandata('agent_templatename');
6846 sub agent_invoice_from {
6848 $self->_agent_plandata('agent_invoice_from');
6851 sub _agent_plandata {
6852 my( $self, $option ) = @_;
6854 #yuck. this whole thing needs to be reconciled better with 1.9's idea of
6855 #agent-specific Conf
6857 use FS::part_event::Condition;
6859 my $agentnum = $self->agentnum;
6862 if ( driver_name =~ /^Pg/i ) {
6864 } elsif ( driver_name =~ /^mysql/i ) {
6867 die "don't know how to use regular expressions in ". driver_name. " databases";
6870 my $part_event_option =
6872 'select' => 'part_event_option.*',
6873 'table' => 'part_event_option',
6875 LEFT JOIN part_event USING ( eventpart )
6876 LEFT JOIN part_event_option AS peo_agentnum
6877 ON ( part_event.eventpart = peo_agentnum.eventpart
6878 AND peo_agentnum.optionname = 'agentnum'
6879 AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
6881 LEFT JOIN part_event_option AS peo_cust_bill_age
6882 ON ( part_event.eventpart = peo_cust_bill_age.eventpart
6883 AND peo_cust_bill_age.optionname = 'cust_bill_age'
6886 #'hashref' => { 'optionname' => $option },
6887 #'hashref' => { 'part_event_option.optionname' => $option },
6889 " WHERE part_event_option.optionname = ". dbh->quote($option).
6890 " AND action = 'cust_bill_send_agent' ".
6891 " AND ( disabled IS NULL OR disabled != 'Y' ) ".
6892 " AND peo_agentnum.optionname = 'agentnum' ".
6893 " AND agentnum IS NULL OR agentnum = $agentnum ".
6895 CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age'
6897 ELSE ". FS::part_event::Condition->age2seconds_sql('peo_cust_bill_age.optionvalue').
6899 , part_event.weight".
6903 unless ( $part_event_option ) {
6904 return $self->agent->invoice_template || ''
6905 if $option eq 'agent_templatename';
6909 $part_event_option->optionvalue;
6914 ## actual sub, not a method, designed to be called from the queue.
6915 ## sets up the customer, and calls the bill_and_collect
6916 my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
6917 my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
6918 $cust_main->bill_and_collect(
6929 The delete method should possibly take an FS::cust_main object reference
6930 instead of a scalar customer number.
6932 Bill and collect options should probably be passed as references instead of a
6935 There should probably be a configuration file with a list of allowed credit
6938 No multiple currency support (probably a larger project than just this module).
6940 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
6942 Birthdates rely on negative epoch values.
6944 The payby for card/check batches is broken. With mixed batching, bad
6947 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
6951 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
6952 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
6953 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.