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;
40 use FS::cust_tax_location;
42 use FS::cust_main_invoice;
43 use FS::cust_credit_bill;
44 use FS::cust_bill_pay;
45 use FS::prepay_credit;
49 use FS::part_event_condition;
52 use FS::payment_gateway;
53 use FS::agent_payment_gateway;
55 use FS::payinfo_Mixin;
58 @ISA = qw( FS::payinfo_Mixin FS::Record );
60 @EXPORT_OK = qw( smart_search );
62 $realtime_bop_decline_quiet = 0;
64 # 1 is mostly method/subroutine entry and options
65 # 2 traces progress of some operations
66 # 3 is even more information including possibly sensitive data
68 $me = '[FS::cust_main]';
72 $ignore_expired_card = 0;
74 @encrypted_fields = ('payinfo', 'paycvv');
75 @paytypes = ('', 'Personal checking', 'Personal savings', 'Business checking', 'Business savings');
77 #ask FS::UID to run this stuff for us later
78 #$FS::UID::callback{'FS::cust_main'} = sub {
79 install_callback FS::UID sub {
81 #yes, need it for stuff below (prolly should be cached)
86 my ( $hashref, $cache ) = @_;
87 if ( exists $hashref->{'pkgnum'} ) {
88 #@{ $self->{'_pkgnum'} } = ();
89 my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum});
90 $self->{'_pkgnum'} = $subcache;
91 #push @{ $self->{'_pkgnum'} },
92 FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum};
98 FS::cust_main - Object methods for cust_main records
104 $record = new FS::cust_main \%hash;
105 $record = new FS::cust_main { 'column' => 'value' };
107 $error = $record->insert;
109 $error = $new_record->replace($old_record);
111 $error = $record->delete;
113 $error = $record->check;
115 @cust_pkg = $record->all_pkgs;
117 @cust_pkg = $record->ncancelled_pkgs;
119 @cust_pkg = $record->suspended_pkgs;
121 $error = $record->bill;
122 $error = $record->bill %options;
123 $error = $record->bill 'time' => $time;
125 $error = $record->collect;
126 $error = $record->collect %options;
127 $error = $record->collect 'invoice_time' => $time,
132 An FS::cust_main object represents a customer. FS::cust_main inherits from
133 FS::Record. The following fields are currently supported:
137 =item custnum - primary key (assigned automatically for new customers)
139 =item agentnum - agent (see L<FS::agent>)
141 =item refnum - Advertising source (see L<FS::part_referral>)
147 =item ss - social security number (optional)
149 =item company - (optional)
153 =item address2 - (optional)
157 =item county - (optional, see L<FS::cust_main_county>)
159 =item state - (see L<FS::cust_main_county>)
163 =item country - (see L<FS::cust_main_county>)
165 =item daytime - phone (optional)
167 =item night - phone (optional)
169 =item fax - phone (optional)
171 =item ship_first - name
173 =item ship_last - name
175 =item ship_company - (optional)
179 =item ship_address2 - (optional)
183 =item ship_county - (optional, see L<FS::cust_main_county>)
185 =item ship_state - (see L<FS::cust_main_county>)
189 =item ship_country - (see L<FS::cust_main_county>)
191 =item ship_daytime - phone (optional)
193 =item ship_night - phone (optional)
195 =item ship_fax - phone (optional)
197 =item payby - Payment Type (See L<FS::payinfo_Mixin> for valid payby values)
199 =item payinfo - Payment Information (See L<FS::payinfo_Mixin> for data format)
201 =item paymask - Masked payinfo (See L<FS::payinfo_Mixin> for how this works)
205 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
207 =item paydate - expiration date, mm/yyyy, m/yyyy, mm/yy or m/yy
209 =item paystart_month - start date month (maestro/solo cards only)
211 =item paystart_year - start date year (maestro/solo cards only)
213 =item payissue - issue number (maestro/solo cards only)
215 =item payname - name on card or billing name
217 =item payip - IP address from which payment information was received
219 =item tax - tax exempt, empty or `Y'
221 =item otaker - order taker (assigned automatically, see L<FS::UID>)
223 =item comments - comments (optional)
225 =item referral_custnum - referring customer number
227 =item spool_cdr - Enable individual CDR spooling, empty or `Y'
229 =item squelch_cdr - Discourage individual CDR printing, empty or `Y'
239 Creates a new customer. To add the customer to the database, see L<"insert">.
241 Note that this stores the hash reference, not a distinct copy of the hash it
242 points to. You can ask the object for a copy with the I<hash> method.
246 sub table { 'cust_main'; }
248 =item insert [ CUST_PKG_HASHREF [ , INVOICING_LIST_ARYREF ] [ , OPTION => VALUE ... ] ]
250 Adds this customer to the database. If there is an error, returns the error,
251 otherwise returns false.
253 CUST_PKG_HASHREF: If you pass a Tie::RefHash data structure to the insert
254 method containing FS::cust_pkg and FS::svc_I<tablename> objects, all records
255 are inserted atomicly, or the transaction is rolled back. Passing an empty
256 hash reference is equivalent to not supplying this parameter. There should be
257 a better explanation of this, but until then, here's an example:
260 tie %hash, 'Tie::RefHash'; #this part is important
262 $cust_pkg => [ $svc_acct ],
265 $cust_main->insert( \%hash );
267 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
268 be set as the invoicing list (see L<"invoicing_list">). Errors return as
269 expected and rollback the entire transaction; it is not necessary to call
270 check_invoicing_list first. The invoicing_list is set after the records in the
271 CUST_PKG_HASHREF above are inserted, so it is now possible to set an
272 invoicing_list destination to the newly-created svc_acct. Here's an example:
274 $cust_main->insert( {}, [ $email, 'POST' ] );
276 Currently available options are: I<depend_jobnum> and I<noexport>.
278 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
279 on the supplied jobnum (they will not run until the specific job completes).
280 This can be used to defer provisioning until some action completes (such
281 as running the customer's credit card successfully).
283 The I<noexport> option is deprecated. If I<noexport> is set true, no
284 provisioning jobs (exports) are scheduled. (You can schedule them later with
285 the B<reexport> method.)
291 my $cust_pkgs = @_ ? shift : {};
292 my $invoicing_list = @_ ? shift : '';
294 warn "$me insert called with options ".
295 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
298 local $SIG{HUP} = 'IGNORE';
299 local $SIG{INT} = 'IGNORE';
300 local $SIG{QUIT} = 'IGNORE';
301 local $SIG{TERM} = 'IGNORE';
302 local $SIG{TSTP} = 'IGNORE';
303 local $SIG{PIPE} = 'IGNORE';
305 my $oldAutoCommit = $FS::UID::AutoCommit;
306 local $FS::UID::AutoCommit = 0;
309 my $prepay_identifier = '';
310 my( $amount, $seconds ) = ( 0, 0 );
312 if ( $self->payby eq 'PREPAY' ) {
314 $self->payby('BILL');
315 $prepay_identifier = $self->payinfo;
318 warn " looking up prepaid card $prepay_identifier\n"
321 my $error = $self->get_prepay($prepay_identifier, \$amount, \$seconds);
323 $dbh->rollback if $oldAutoCommit;
324 #return "error applying prepaid card (transaction rolled back): $error";
328 $payby = 'PREP' if $amount;
330 } elsif ( $self->payby =~ /^(CASH|WEST|MCRD)$/ ) {
333 $self->payby('BILL');
334 $amount = $self->paid;
338 warn " inserting $self\n"
341 $self->signupdate(time) unless $self->signupdate;
343 my $error = $self->SUPER::insert;
345 $dbh->rollback if $oldAutoCommit;
346 #return "inserting cust_main record (transaction rolled back): $error";
350 warn " setting invoicing list\n"
353 if ( $invoicing_list ) {
354 $error = $self->check_invoicing_list( $invoicing_list );
356 $dbh->rollback if $oldAutoCommit;
357 #return "checking invoicing_list (transaction rolled back): $error";
360 $self->invoicing_list( $invoicing_list );
363 if ( $conf->config('cust_main-skeleton_tables')
364 && $conf->config('cust_main-skeleton_custnum') ) {
366 warn " inserting skeleton records\n"
369 my $error = $self->start_copy_skel;
371 $dbh->rollback if $oldAutoCommit;
377 warn " ordering packages\n"
380 $error = $self->order_pkgs($cust_pkgs, \$seconds, %options);
382 $dbh->rollback if $oldAutoCommit;
387 $dbh->rollback if $oldAutoCommit;
388 return "No svc_acct record to apply pre-paid time";
392 warn " inserting initial $payby payment of $amount\n"
394 $error = $self->insert_cust_pay($payby, $amount, $prepay_identifier);
396 $dbh->rollback if $oldAutoCommit;
397 return "inserting payment (transaction rolled back): $error";
401 unless ( $import || $skip_fuzzyfiles ) {
402 warn " queueing fuzzyfiles update\n"
404 $error = $self->queue_fuzzyfiles_update;
406 $dbh->rollback if $oldAutoCommit;
407 return "updating fuzzy search cache: $error";
411 warn " insert complete; committing transaction\n"
414 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
419 sub start_copy_skel {
422 #'mg_user_preference' => {},
423 #'mg_user_indicator_profile.user_indicator_profile_id' => { 'mg_profile_indicator.profile_indicator_id' => { 'mg_profile_details.profile_detail_id' }, },
424 #'mg_watchlist_header.watchlist_header_id' => { 'mg_watchlist_details.watchlist_details_id' },
425 #'mg_user_grid_header.grid_header_id' => { 'mg_user_grid_details.user_grid_details_id' },
426 #'mg_portfolio_header.portfolio_header_id' => { 'mg_portfolio_trades.portfolio_trades_id' => { 'mg_portfolio_trades_positions.portfolio_trades_positions_id' } },
427 my @tables = eval(join('\n',$conf->config('cust_main-skeleton_tables')));
430 _copy_skel( 'cust_main', #tablename
431 $conf->config('cust_main-skeleton_custnum'), #sourceid
432 $self->custnum, #destid
433 @tables, #child tables
437 #recursive subroutine, not a method
439 my( $table, $sourceid, $destid, %child_tables ) = @_;
442 if ( $table =~ /^(\w+)\.(\w+)$/ ) {
443 ( $table, $primary_key ) = ( $1, $2 );
445 my $dbdef_table = dbdef->table($table);
446 $primary_key = $dbdef_table->primary_key
447 or return "$table has no primary key".
448 " (or do you need to run dbdef-create?)";
451 warn " _copy_skel: $table.$primary_key $sourceid to $destid for ".
452 join (', ', keys %child_tables). "\n"
455 foreach my $child_table_def ( keys %child_tables ) {
459 if ( $child_table_def =~ /^(\w+)\.(\w+)$/ ) {
460 ( $child_table, $child_pkey ) = ( $1, $2 );
462 $child_table = $child_table_def;
464 $child_pkey = dbdef->table($child_table)->primary_key;
465 # or return "$table has no primary key".
466 # " (or do you need to run dbdef-create?)\n";
470 if ( keys %{ $child_tables{$child_table_def} } ) {
472 return "$child_table has no primary key".
473 " (run dbdef-create or try specifying it?)\n"
476 #false laziness w/Record::insert and only works on Pg
477 #refactor the proper last-inserted-id stuff out of Record::insert if this
478 # ever gets use for anything besides a quick kludge for one customer
479 my $default = dbdef->table($child_table)->column($child_pkey)->default;
480 $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i
481 or return "can't parse $child_table.$child_pkey default value ".
482 " for sequence name: $default";
487 my @sel_columns = grep { $_ ne $primary_key }
488 dbdef->table($child_table)->columns;
489 my $sel_columns = join(', ', @sel_columns );
491 my @ins_columns = grep { $_ ne $child_pkey } @sel_columns;
492 my $ins_columns = ' ( '. join(', ', $primary_key, @ins_columns ). ' ) ';
493 my $placeholders = ' ( ?, '. join(', ', map '?', @ins_columns ). ' ) ';
495 my $sel_st = "SELECT $sel_columns FROM $child_table".
496 " WHERE $primary_key = $sourceid";
499 my $sel_sth = dbh->prepare( $sel_st )
500 or return dbh->errstr;
502 $sel_sth->execute or return $sel_sth->errstr;
504 while ( my $row = $sel_sth->fetchrow_hashref ) {
506 warn " selected row: ".
507 join(', ', map { "$_=".$row->{$_} } keys %$row ). "\n"
511 "INSERT INTO $child_table $ins_columns VALUES $placeholders";
512 my $ins_sth =dbh->prepare($statement)
513 or return dbh->errstr;
514 my @param = ( $destid, map $row->{$_}, @ins_columns );
515 warn " $statement: [ ". join(', ', @param). " ]\n"
517 $ins_sth->execute( @param )
518 or return $ins_sth->errstr;
520 #next unless keys %{ $child_tables{$child_table} };
521 next unless $sequence;
523 #another section of that laziness
524 my $seq_sql = "SELECT currval('$sequence')";
525 my $seq_sth = dbh->prepare($seq_sql) or return dbh->errstr;
526 $seq_sth->execute or return $seq_sth->errstr;
527 my $insertid = $seq_sth->fetchrow_arrayref->[0];
529 # don't drink soap! recurse! recurse! okay!
531 _copy_skel( $child_table_def,
532 $row->{$child_pkey}, #sourceid
534 %{ $child_tables{$child_table_def} },
536 return $error if $error;
546 =item order_pkgs HASHREF, [ SECONDSREF, [ , OPTION => VALUE ... ] ]
548 Like the insert method on an existing record, this method orders a package
549 and included services atomicaly. Pass a Tie::RefHash data structure to this
550 method containing FS::cust_pkg and FS::svc_I<tablename> objects. There should
551 be a better explanation of this, but until then, here's an example:
554 tie %hash, 'Tie::RefHash'; #this part is important
556 $cust_pkg => [ $svc_acct ],
559 $cust_main->order_pkgs( \%hash, \'0', 'noexport'=>1 );
561 Services can be new, in which case they are inserted, or existing unaudited
562 services, in which case they are linked to the newly-created package.
564 Currently available options are: I<depend_jobnum> and I<noexport>.
566 If I<depend_jobnum> is set, all provisioning jobs will have a dependancy
567 on the supplied jobnum (they will not run until the specific job completes).
568 This can be used to defer provisioning until some action completes (such
569 as running the customer's credit card successfully).
571 The I<noexport> option is deprecated. If I<noexport> is set true, no
572 provisioning jobs (exports) are scheduled. (You can schedule them later with
573 the B<reexport> method for each cust_pkg object. Using the B<reexport> method
574 on the cust_main object is not recommended, as existing services will also be
581 my $cust_pkgs = shift;
584 my %svc_options = ();
585 $svc_options{'depend_jobnum'} = $options{'depend_jobnum'}
586 if exists $options{'depend_jobnum'};
587 warn "$me order_pkgs called with options ".
588 join(', ', map { "$_: $options{$_}" } keys %options ). "\n"
591 local $SIG{HUP} = 'IGNORE';
592 local $SIG{INT} = 'IGNORE';
593 local $SIG{QUIT} = 'IGNORE';
594 local $SIG{TERM} = 'IGNORE';
595 local $SIG{TSTP} = 'IGNORE';
596 local $SIG{PIPE} = 'IGNORE';
598 my $oldAutoCommit = $FS::UID::AutoCommit;
599 local $FS::UID::AutoCommit = 0;
602 local $FS::svc_Common::noexport_hack = 1 if $options{'noexport'};
604 foreach my $cust_pkg ( keys %$cust_pkgs ) {
605 $cust_pkg->custnum( $self->custnum );
606 my $error = $cust_pkg->insert;
608 $dbh->rollback if $oldAutoCommit;
609 return "inserting cust_pkg (transaction rolled back): $error";
611 foreach my $svc_something ( @{$cust_pkgs->{$cust_pkg}} ) {
612 if ( $svc_something->svcnum ) {
613 my $old_cust_svc = $svc_something->cust_svc;
614 my $new_cust_svc = new FS::cust_svc { $old_cust_svc->hash };
615 $new_cust_svc->pkgnum( $cust_pkg->pkgnum);
616 $error = $new_cust_svc->replace($old_cust_svc);
618 $svc_something->pkgnum( $cust_pkg->pkgnum );
619 if ( $seconds && $$seconds && $svc_something->isa('FS::svc_acct') ) {
620 $svc_something->seconds( $svc_something->seconds + $$seconds );
623 $error = $svc_something->insert(%svc_options);
626 $dbh->rollback if $oldAutoCommit;
627 #return "inserting svc_ (transaction rolled back): $error";
633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
637 =item recharge_prepay IDENTIFIER | PREPAY_CREDIT_OBJ [ , AMOUNTREF, SECONDSREF, UPBYTEREF, DOWNBYTEREF ]
639 Recharges this (existing) customer with the specified prepaid card (see
640 L<FS::prepay_credit>), specified either by I<identifier> or as an
641 FS::prepay_credit object. If there is an error, returns the error, otherwise
644 Optionally, four scalar references can be passed as well. They will have their
645 values filled in with the amount, number of seconds, and number of upload and
646 download bytes applied by this prepaid
651 sub recharge_prepay {
652 my( $self, $prepay_credit, $amountref, $secondsref,
653 $upbytesref, $downbytesref, $totalbytesref ) = @_;
655 local $SIG{HUP} = 'IGNORE';
656 local $SIG{INT} = 'IGNORE';
657 local $SIG{QUIT} = 'IGNORE';
658 local $SIG{TERM} = 'IGNORE';
659 local $SIG{TSTP} = 'IGNORE';
660 local $SIG{PIPE} = 'IGNORE';
662 my $oldAutoCommit = $FS::UID::AutoCommit;
663 local $FS::UID::AutoCommit = 0;
666 my( $amount, $seconds, $upbytes, $downbytes, $totalbytes) = ( 0, 0, 0, 0, 0 );
668 my $error = $self->get_prepay($prepay_credit, \$amount,
669 \$seconds, \$upbytes, \$downbytes, \$totalbytes)
670 || $self->increment_seconds($seconds)
671 || $self->increment_upbytes($upbytes)
672 || $self->increment_downbytes($downbytes)
673 || $self->increment_totalbytes($totalbytes)
674 || $self->insert_cust_pay_prepay( $amount,
676 ? $prepay_credit->identifier
681 $dbh->rollback if $oldAutoCommit;
685 if ( defined($amountref) ) { $$amountref = $amount; }
686 if ( defined($secondsref) ) { $$secondsref = $seconds; }
687 if ( defined($upbytesref) ) { $$upbytesref = $upbytes; }
688 if ( defined($downbytesref) ) { $$downbytesref = $downbytes; }
689 if ( defined($totalbytesref) ) { $$totalbytesref = $totalbytes; }
691 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
696 =item get_prepay IDENTIFIER | PREPAY_CREDIT_OBJ , AMOUNTREF, SECONDSREF
698 Looks up and deletes a prepaid card (see L<FS::prepay_credit>),
699 specified either by I<identifier> or as an FS::prepay_credit object.
701 References to I<amount> and I<seconds> scalars should be passed as arguments
702 and will be incremented by the values of the prepaid card.
704 If the prepaid card specifies an I<agentnum> (see L<FS::agent>), it is used to
705 check or set this customer's I<agentnum>.
707 If there is an error, returns the error, otherwise returns false.
713 my( $self, $prepay_credit, $amountref, $secondsref,
714 $upref, $downref, $totalref) = @_;
716 local $SIG{HUP} = 'IGNORE';
717 local $SIG{INT} = 'IGNORE';
718 local $SIG{QUIT} = 'IGNORE';
719 local $SIG{TERM} = 'IGNORE';
720 local $SIG{TSTP} = 'IGNORE';
721 local $SIG{PIPE} = 'IGNORE';
723 my $oldAutoCommit = $FS::UID::AutoCommit;
724 local $FS::UID::AutoCommit = 0;
727 unless ( ref($prepay_credit) ) {
729 my $identifier = $prepay_credit;
731 $prepay_credit = qsearchs(
733 { 'identifier' => $prepay_credit },
738 unless ( $prepay_credit ) {
739 $dbh->rollback if $oldAutoCommit;
740 return "Invalid prepaid card: ". $identifier;
745 if ( $prepay_credit->agentnum ) {
746 if ( $self->agentnum && $self->agentnum != $prepay_credit->agentnum ) {
747 $dbh->rollback if $oldAutoCommit;
748 return "prepaid card not valid for agent ". $self->agentnum;
750 $self->agentnum($prepay_credit->agentnum);
753 my $error = $prepay_credit->delete;
755 $dbh->rollback if $oldAutoCommit;
756 return "removing prepay_credit (transaction rolled back): $error";
759 $$amountref += $prepay_credit->amount;
760 $$secondsref += $prepay_credit->seconds;
761 $$upref += $prepay_credit->upbytes;
762 $$downref += $prepay_credit->downbytes;
763 $$totalref += $prepay_credit->totalbytes;
765 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
770 =item increment_upbytes SECONDS
772 Updates this customer's single or primary account (see L<FS::svc_acct>) by
773 the specified number of upbytes. If there is an error, returns the error,
774 otherwise returns false.
778 sub increment_upbytes {
779 _increment_column( shift, 'upbytes', @_);
782 =item increment_downbytes SECONDS
784 Updates this customer's single or primary account (see L<FS::svc_acct>) by
785 the specified number of downbytes. If there is an error, returns the error,
786 otherwise returns false.
790 sub increment_downbytes {
791 _increment_column( shift, 'downbytes', @_);
794 =item increment_totalbytes SECONDS
796 Updates this customer's single or primary account (see L<FS::svc_acct>) by
797 the specified number of totalbytes. If there is an error, returns the error,
798 otherwise returns false.
802 sub increment_totalbytes {
803 _increment_column( shift, 'totalbytes', @_);
806 =item increment_seconds SECONDS
808 Updates this customer's single or primary account (see L<FS::svc_acct>) by
809 the specified number of seconds. If there is an error, returns the error,
810 otherwise returns false.
814 sub increment_seconds {
815 _increment_column( shift, 'seconds', @_);
818 =item _increment_column AMOUNT
820 Updates this customer's single or primary account (see L<FS::svc_acct>) by
821 the specified number of seconds or bytes. If there is an error, returns
822 the error, otherwise returns false.
826 sub _increment_column {
827 my( $self, $column, $amount ) = @_;
828 warn "$me increment_column called: $column, $amount\n"
831 return '' unless $amount;
833 my @cust_pkg = grep { $_->part_pkg->svcpart('svc_acct') }
834 $self->ncancelled_pkgs;
837 return 'No packages with primary or single services found'.
838 ' to apply pre-paid time';
839 } elsif ( scalar(@cust_pkg) > 1 ) {
840 #maybe have a way to specify the package/account?
841 return 'Multiple packages found to apply pre-paid time';
844 my $cust_pkg = $cust_pkg[0];
845 warn " found package pkgnum ". $cust_pkg->pkgnum. "\n"
849 $cust_pkg->cust_svc( $cust_pkg->part_pkg->svcpart('svc_acct') );
852 return 'No account found to apply pre-paid time';
853 } elsif ( scalar(@cust_svc) > 1 ) {
854 return 'Multiple accounts found to apply pre-paid time';
857 my $svc_acct = $cust_svc[0]->svc_x;
858 warn " found service svcnum ". $svc_acct->pkgnum.
859 ' ('. $svc_acct->email. ")\n"
862 $column = "increment_$column";
863 $svc_acct->$column($amount);
867 =item insert_cust_pay_prepay AMOUNT [ PAYINFO ]
869 Inserts a prepayment in the specified amount for this customer. An optional
870 second argument can specify the prepayment identifier for tracking purposes.
871 If there is an error, returns the error, otherwise returns false.
875 sub insert_cust_pay_prepay {
876 shift->insert_cust_pay('PREP', @_);
879 =item insert_cust_pay_cash AMOUNT [ PAYINFO ]
881 Inserts a cash payment in the specified amount for this customer. An optional
882 second argument can specify the payment identifier for tracking purposes.
883 If there is an error, returns the error, otherwise returns false.
887 sub insert_cust_pay_cash {
888 shift->insert_cust_pay('CASH', @_);
891 =item insert_cust_pay_west AMOUNT [ PAYINFO ]
893 Inserts a Western Union payment in the specified amount for this customer. An
894 optional second argument can specify the prepayment identifier for tracking
895 purposes. If there is an error, returns the error, otherwise returns false.
899 sub insert_cust_pay_west {
900 shift->insert_cust_pay('WEST', @_);
903 sub insert_cust_pay {
904 my( $self, $payby, $amount ) = splice(@_, 0, 3);
905 my $payinfo = scalar(@_) ? shift : '';
907 my $cust_pay = new FS::cust_pay {
908 'custnum' => $self->custnum,
909 'paid' => sprintf('%.2f', $amount),
910 #'_date' => #date the prepaid card was purchased???
912 'payinfo' => $payinfo,
920 This method is deprecated. See the I<depend_jobnum> option to the insert and
921 order_pkgs methods for a better way to defer provisioning.
923 Re-schedules all exports by calling the B<reexport> method of all associated
924 packages (see L<FS::cust_pkg>). If there is an error, returns the error;
925 otherwise returns false.
932 carp "WARNING: FS::cust_main::reexport is deprectated; ".
933 "use the depend_jobnum option to insert or order_pkgs to delay export";
935 local $SIG{HUP} = 'IGNORE';
936 local $SIG{INT} = 'IGNORE';
937 local $SIG{QUIT} = 'IGNORE';
938 local $SIG{TERM} = 'IGNORE';
939 local $SIG{TSTP} = 'IGNORE';
940 local $SIG{PIPE} = 'IGNORE';
942 my $oldAutoCommit = $FS::UID::AutoCommit;
943 local $FS::UID::AutoCommit = 0;
946 foreach my $cust_pkg ( $self->ncancelled_pkgs ) {
947 my $error = $cust_pkg->reexport;
949 $dbh->rollback if $oldAutoCommit;
954 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
959 =item delete NEW_CUSTNUM
961 This deletes the customer. If there is an error, returns the error, otherwise
964 This will completely remove all traces of the customer record. This is not
965 what you want when a customer cancels service; for that, cancel all of the
966 customer's packages (see L</cancel>).
968 If the customer has any uncancelled packages, you need to pass a new (valid)
969 customer number for those packages to be transferred to. Cancelled packages
970 will be deleted. Did I mention that this is NOT what you want when a customer
971 cancels service and that you really should be looking see L<FS::cust_pkg/cancel>?
973 You can't delete a customer with invoices (see L<FS::cust_bill>),
974 or credits (see L<FS::cust_credit>), payments (see L<FS::cust_pay>) or
975 refunds (see L<FS::cust_refund>).
982 local $SIG{HUP} = 'IGNORE';
983 local $SIG{INT} = 'IGNORE';
984 local $SIG{QUIT} = 'IGNORE';
985 local $SIG{TERM} = 'IGNORE';
986 local $SIG{TSTP} = 'IGNORE';
987 local $SIG{PIPE} = 'IGNORE';
989 my $oldAutoCommit = $FS::UID::AutoCommit;
990 local $FS::UID::AutoCommit = 0;
993 if ( $self->cust_bill ) {
994 $dbh->rollback if $oldAutoCommit;
995 return "Can't delete a customer with invoices";
997 if ( $self->cust_credit ) {
998 $dbh->rollback if $oldAutoCommit;
999 return "Can't delete a customer with credits";
1001 if ( $self->cust_pay ) {
1002 $dbh->rollback if $oldAutoCommit;
1003 return "Can't delete a customer with payments";
1005 if ( $self->cust_refund ) {
1006 $dbh->rollback if $oldAutoCommit;
1007 return "Can't delete a customer with refunds";
1010 my @cust_pkg = $self->ncancelled_pkgs;
1012 my $new_custnum = shift;
1013 unless ( qsearchs( 'cust_main', { 'custnum' => $new_custnum } ) ) {
1014 $dbh->rollback if $oldAutoCommit;
1015 return "Invalid new customer number: $new_custnum";
1017 foreach my $cust_pkg ( @cust_pkg ) {
1018 my %hash = $cust_pkg->hash;
1019 $hash{'custnum'} = $new_custnum;
1020 my $new_cust_pkg = new FS::cust_pkg ( \%hash );
1021 my $error = $new_cust_pkg->replace($cust_pkg,
1022 options => { $cust_pkg->options },
1025 $dbh->rollback if $oldAutoCommit;
1030 my @cancelled_cust_pkg = $self->all_pkgs;
1031 foreach my $cust_pkg ( @cancelled_cust_pkg ) {
1032 my $error = $cust_pkg->delete;
1034 $dbh->rollback if $oldAutoCommit;
1039 foreach my $cust_main_invoice ( #(email invoice destinations, not invoices)
1040 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } )
1042 my $error = $cust_main_invoice->delete;
1044 $dbh->rollback if $oldAutoCommit;
1049 my $error = $self->SUPER::delete;
1051 $dbh->rollback if $oldAutoCommit;
1055 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1060 =item replace [ OLD_RECORD ] [ INVOICING_LIST_ARYREF ]
1062 Replaces the OLD_RECORD with this one in the database. If there is an error,
1063 returns the error, otherwise returns false.
1065 INVOICING_LIST_ARYREF: If you pass an arrarref to the insert method, it will
1066 be set as the invoicing list (see L<"invoicing_list">). Errors return as
1067 expected and rollback the entire transaction; it is not necessary to call
1068 check_invoicing_list first. Here's an example:
1070 $new_cust_main->replace( $old_cust_main, [ $email, 'POST' ] );
1077 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
1079 : $self->replace_old;
1083 warn "$me replace called\n"
1086 my $curuser = $FS::CurrentUser::CurrentUser;
1087 if ( $self->payby eq 'COMP'
1088 && $self->payby ne $old->payby
1089 && ! $curuser->access_right('Complimentary customer')
1092 return "You are not permitted to create complimentary accounts.";
1095 local($ignore_expired_card) = 1
1096 if $old->payby =~ /^(CARD|DCRD)$/
1097 && $self->payby =~ /^(CARD|DCRD)$/
1098 && ( $old->payinfo eq $self->payinfo || $old->paymask eq $self->paymask );
1100 local $SIG{HUP} = 'IGNORE';
1101 local $SIG{INT} = 'IGNORE';
1102 local $SIG{QUIT} = 'IGNORE';
1103 local $SIG{TERM} = 'IGNORE';
1104 local $SIG{TSTP} = 'IGNORE';
1105 local $SIG{PIPE} = 'IGNORE';
1107 my $oldAutoCommit = $FS::UID::AutoCommit;
1108 local $FS::UID::AutoCommit = 0;
1111 my $error = $self->SUPER::replace($old);
1114 $dbh->rollback if $oldAutoCommit;
1118 if ( @param ) { # INVOICING_LIST_ARYREF
1119 my $invoicing_list = shift @param;
1120 $error = $self->check_invoicing_list( $invoicing_list );
1122 $dbh->rollback if $oldAutoCommit;
1125 $self->invoicing_list( $invoicing_list );
1128 if ( $self->payby =~ /^(CARD|CHEK|LECB)$/ &&
1129 grep { $self->get($_) ne $old->get($_) } qw(payinfo paydate payname) ) {
1130 # card/check/lec info has changed, want to retry realtime_ invoice events
1131 my $error = $self->retry_realtime;
1133 $dbh->rollback if $oldAutoCommit;
1138 unless ( $import || $skip_fuzzyfiles ) {
1139 $error = $self->queue_fuzzyfiles_update;
1141 $dbh->rollback if $oldAutoCommit;
1142 return "updating fuzzy search cache: $error";
1146 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1151 =item queue_fuzzyfiles_update
1153 Used by insert & replace to update the fuzzy search cache
1157 sub queue_fuzzyfiles_update {
1160 local $SIG{HUP} = 'IGNORE';
1161 local $SIG{INT} = 'IGNORE';
1162 local $SIG{QUIT} = 'IGNORE';
1163 local $SIG{TERM} = 'IGNORE';
1164 local $SIG{TSTP} = 'IGNORE';
1165 local $SIG{PIPE} = 'IGNORE';
1167 my $oldAutoCommit = $FS::UID::AutoCommit;
1168 local $FS::UID::AutoCommit = 0;
1171 my $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1172 my $error = $queue->insert( map $self->getfield($_),
1173 qw(first last company)
1176 $dbh->rollback if $oldAutoCommit;
1177 return "queueing job (transaction rolled back): $error";
1180 if ( $self->ship_last ) {
1181 $queue = new FS::queue { 'job' => 'FS::cust_main::append_fuzzyfiles' };
1182 $error = $queue->insert( map $self->getfield("ship_$_"),
1183 qw(first last company)
1186 $dbh->rollback if $oldAutoCommit;
1187 return "queueing job (transaction rolled back): $error";
1191 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1198 Checks all fields to make sure this is a valid customer record. If there is
1199 an error, returns the error, otherwise returns false. Called by the insert
1200 and replace methods.
1207 warn "$me check BEFORE: \n". $self->_dump
1211 $self->ut_numbern('custnum')
1212 || $self->ut_number('agentnum')
1213 || $self->ut_textn('agent_custid')
1214 || $self->ut_number('refnum')
1215 || $self->ut_textn('custbatch')
1216 || $self->ut_name('last')
1217 || $self->ut_name('first')
1218 || $self->ut_snumbern('birthdate')
1219 || $self->ut_snumbern('signupdate')
1220 || $self->ut_textn('company')
1221 || $self->ut_text('address1')
1222 || $self->ut_textn('address2')
1223 || $self->ut_text('city')
1224 || $self->ut_textn('county')
1225 || $self->ut_textn('state')
1226 || $self->ut_country('country')
1227 || $self->ut_anything('comments')
1228 || $self->ut_numbern('referral_custnum')
1229 || $self->ut_textn('stateid')
1230 || $self->ut_textn('stateid_state')
1231 || $self->ut_textn('invoice_terms')
1233 #barf. need message catalogs. i18n. etc.
1234 $error .= "Please select an advertising source."
1235 if $error =~ /^Illegal or empty \(numeric\) refnum: /;
1236 return $error if $error;
1238 return "Unknown agent"
1239 unless qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1241 return "Unknown refnum"
1242 unless qsearchs( 'part_referral', { 'refnum' => $self->refnum } );
1244 return "Unknown referring custnum: ". $self->referral_custnum
1245 unless ! $self->referral_custnum
1246 || qsearchs( 'cust_main', { 'custnum' => $self->referral_custnum } );
1248 if ( $self->ss eq '' ) {
1253 $ss =~ /^(\d{3})(\d{2})(\d{4})$/
1254 or return "Illegal social security number: ". $self->ss;
1255 $self->ss("$1-$2-$3");
1259 # bad idea to disable, causes billing to fail because of no tax rates later
1260 # unless ( $import ) {
1261 unless ( qsearch('cust_main_county', {
1262 'country' => $self->country,
1265 return "Unknown state/county/country: ".
1266 $self->state. "/". $self->county. "/". $self->country
1267 unless qsearch('cust_main_county',{
1268 'state' => $self->state,
1269 'county' => $self->county,
1270 'country' => $self->country,
1276 $self->ut_phonen('daytime', $self->country)
1277 || $self->ut_phonen('night', $self->country)
1278 || $self->ut_phonen('fax', $self->country)
1279 || $self->ut_zip('zip', $self->country)
1281 return $error if $error;
1283 if ( $conf->exists('cust_main-require_phone')
1284 && ! length($self->daytime) && ! length($self->night)
1287 my $daytime_label = FS::Msgcat::_gettext('daytime') =~ /^(daytime)?$/
1289 : FS::Msgcat::_gettext('daytime');
1290 my $night_label = FS::Msgcat::_gettext('night') =~ /^(night)?$/
1292 : FS::Msgcat::_gettext('night');
1294 return "$daytime_label or $night_label is required"
1298 if ( $self->has_ship_address
1299 && scalar ( grep { $self->getfield($_) ne $self->getfield("ship_$_") }
1300 $self->addr_fields )
1304 $self->ut_name('ship_last')
1305 || $self->ut_name('ship_first')
1306 || $self->ut_textn('ship_company')
1307 || $self->ut_text('ship_address1')
1308 || $self->ut_textn('ship_address2')
1309 || $self->ut_text('ship_city')
1310 || $self->ut_textn('ship_county')
1311 || $self->ut_textn('ship_state')
1312 || $self->ut_country('ship_country')
1314 return $error if $error;
1316 #false laziness with above
1317 unless ( qsearchs('cust_main_county', {
1318 'country' => $self->ship_country,
1321 return "Unknown ship_state/ship_county/ship_country: ".
1322 $self->ship_state. "/". $self->ship_county. "/". $self->ship_country
1323 unless qsearch('cust_main_county',{
1324 'state' => $self->ship_state,
1325 'county' => $self->ship_county,
1326 'country' => $self->ship_country,
1332 $self->ut_phonen('ship_daytime', $self->ship_country)
1333 || $self->ut_phonen('ship_night', $self->ship_country)
1334 || $self->ut_phonen('ship_fax', $self->ship_country)
1335 || $self->ut_zip('ship_zip', $self->ship_country)
1337 return $error if $error;
1339 return "Unit # is required."
1340 if $self->ship_address2 =~ /^\s*$/
1341 && $conf->exists('cust_main-require_address2');
1343 } else { # ship_ info eq billing info, so don't store dup info in database
1345 $self->setfield("ship_$_", '')
1346 foreach $self->addr_fields;
1348 return "Unit # is required."
1349 if $self->address2 =~ /^\s*$/
1350 && $conf->exists('cust_main-require_address2');
1354 #$self->payby =~ /^(CARD|DCRD|CHEK|DCHK|LECB|BILL|COMP|PREPAY|CASH|WEST|MCRD)$/
1355 # or return "Illegal payby: ". $self->payby;
1357 FS::payby->can_payby($self->table, $self->payby)
1358 or return "Illegal payby: ". $self->payby;
1360 $error = $self->ut_numbern('paystart_month')
1361 || $self->ut_numbern('paystart_year')
1362 || $self->ut_numbern('payissue')
1363 || $self->ut_textn('paytype')
1365 return $error if $error;
1367 if ( $self->payip eq '' ) {
1370 $error = $self->ut_ip('payip');
1371 return $error if $error;
1374 # If it is encrypted and the private key is not availaible then we can't
1375 # check the credit card.
1377 my $check_payinfo = 1;
1379 if ($self->is_encrypted($self->payinfo)) {
1383 if ( $check_payinfo && $self->payby =~ /^(CARD|DCRD)$/ ) {
1385 my $payinfo = $self->payinfo;
1386 $payinfo =~ s/\D//g;
1387 $payinfo =~ /^(\d{13,16})$/
1388 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1390 $self->payinfo($payinfo);
1392 or return gettext('invalid_card'); # . ": ". $self->payinfo;
1394 return gettext('unknown_card_type')
1395 if cardtype($self->payinfo) eq "Unknown";
1397 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1399 return 'Banned credit card: banned on '.
1400 time2str('%a %h %o at %r', $ban->_date).
1401 ' by '. $ban->otaker.
1402 ' (ban# '. $ban->bannum. ')';
1405 if (length($self->paycvv) && !$self->is_encrypted($self->paycvv)) {
1406 if ( cardtype($self->payinfo) eq 'American Express card' ) {
1407 $self->paycvv =~ /^(\d{4})$/
1408 or return "CVV2 (CID) for American Express cards is four digits.";
1411 $self->paycvv =~ /^(\d{3})$/
1412 or return "CVV2 (CVC2/CID) is three digits.";
1419 my $cardtype = cardtype($payinfo);
1420 if ( $cardtype =~ /^(Switch|Solo)$/i ) {
1422 return "Start date or issue number is required for $cardtype cards"
1423 unless $self->paystart_month && $self->paystart_year or $self->payissue;
1425 return "Start month must be between 1 and 12"
1426 if $self->paystart_month
1427 and $self->paystart_month < 1 || $self->paystart_month > 12;
1429 return "Start year must be 1990 or later"
1430 if $self->paystart_year
1431 and $self->paystart_year < 1990;
1433 return "Issue number must be beween 1 and 99"
1435 and $self->payissue < 1 || $self->payissue > 99;
1438 $self->paystart_month('');
1439 $self->paystart_year('');
1440 $self->payissue('');
1443 } elsif ( $check_payinfo && $self->payby =~ /^(CHEK|DCHK)$/ ) {
1445 my $payinfo = $self->payinfo;
1446 $payinfo =~ s/[^\d\@]//g;
1447 if ( $conf->exists('echeck-nonus') ) {
1448 $payinfo =~ /^(\d+)\@(\d+)$/ or return 'invalid echeck account@aba';
1449 $payinfo = "$1\@$2";
1451 $payinfo =~ /^(\d+)\@(\d{9})$/ or return 'invalid echeck account@aba';
1452 $payinfo = "$1\@$2";
1454 $self->payinfo($payinfo);
1457 my $ban = qsearchs('banned_pay', $self->_banned_pay_hashref);
1459 return 'Banned ACH account: banned on '.
1460 time2str('%a %h %o at %r', $ban->_date).
1461 ' by '. $ban->otaker.
1462 ' (ban# '. $ban->bannum. ')';
1465 } elsif ( $self->payby eq 'LECB' ) {
1467 my $payinfo = $self->payinfo;
1468 $payinfo =~ s/\D//g;
1469 $payinfo =~ /^1?(\d{10})$/ or return 'invalid btn billing telephone number';
1471 $self->payinfo($payinfo);
1474 } elsif ( $self->payby eq 'BILL' ) {
1476 $error = $self->ut_textn('payinfo');
1477 return "Illegal P.O. number: ". $self->payinfo if $error;
1480 } elsif ( $self->payby eq 'COMP' ) {
1482 my $curuser = $FS::CurrentUser::CurrentUser;
1483 if ( ! $self->custnum
1484 && ! $curuser->access_right('Complimentary customer')
1487 return "You are not permitted to create complimentary accounts."
1490 $error = $self->ut_textn('payinfo');
1491 return "Illegal comp account issuer: ". $self->payinfo if $error;
1494 } elsif ( $self->payby eq 'PREPAY' ) {
1496 my $payinfo = $self->payinfo;
1497 $payinfo =~ s/\W//g; #anything else would just confuse things
1498 $self->payinfo($payinfo);
1499 $error = $self->ut_alpha('payinfo');
1500 return "Illegal prepayment identifier: ". $self->payinfo if $error;
1501 return "Unknown prepayment identifier"
1502 unless qsearchs('prepay_credit', { 'identifier' => $self->payinfo } );
1507 if ( $self->paydate eq '' || $self->paydate eq '-' ) {
1508 return "Expiration date required"
1509 unless $self->payby =~ /^(BILL|PREPAY|CHEK|DCHK|LECB|CASH|WEST|MCRD)$/;
1513 if ( $self->paydate =~ /^(\d{1,2})[\/\-](\d{2}(\d{2})?)$/ ) {
1514 ( $m, $y ) = ( $1, length($2) == 4 ? $2 : "20$2" );
1515 } elsif ( $self->paydate =~ /^(20)?(\d{2})[\/\-](\d{1,2})[\/\-]\d+$/ ) {
1516 ( $m, $y ) = ( $3, "20$2" );
1518 return "Illegal expiration date: ". $self->paydate;
1520 $self->paydate("$y-$m-01");
1521 my($nowm,$nowy)=(localtime(time))[4,5]; $nowm++; $nowy+=1900;
1522 return gettext('expired_card')
1524 && !$ignore_expired_card
1525 && ( $y<$nowy || ( $y==$nowy && $1<$nowm ) );
1528 if ( $self->payname eq '' && $self->payby !~ /^(CHEK|DCHK)$/ &&
1529 ( ! $conf->exists('require_cardname')
1530 || $self->payby !~ /^(CARD|DCRD)$/ )
1532 $self->payname( $self->first. " ". $self->getfield('last') );
1534 $self->payname =~ /^([\w \,\.\-\'\&]+)$/
1535 or return gettext('illegal_name'). " payname: ". $self->payname;
1539 foreach my $flag (qw( tax spool_cdr squelch_cdr )) {
1540 $self->$flag() =~ /^(Y?)$/ or return "Illegal $flag: ". $self->$flag();
1544 $self->otaker(getotaker) unless $self->otaker;
1546 warn "$me check AFTER: \n". $self->_dump
1549 $self->SUPER::check;
1554 Returns a list of fields which have ship_ duplicates.
1559 qw( last first company
1560 address1 address2 city county state zip country
1565 =item has_ship_address
1567 Returns true if this customer record has a separate shipping address.
1571 sub has_ship_address {
1573 scalar( grep { $self->getfield("ship_$_") ne '' } $self->addr_fields );
1578 Returns all packages (see L<FS::cust_pkg>) for this customer.
1585 return $self->num_pkgs unless wantarray;
1588 if ( $self->{'_pkgnum'} ) {
1589 @cust_pkg = values %{ $self->{'_pkgnum'}->cache };
1591 @cust_pkg = qsearch( 'cust_pkg', { 'custnum' => $self->custnum });
1594 sort sort_packages @cust_pkg;
1599 Synonym for B<all_pkgs>.
1604 shift->all_pkgs(@_);
1607 =item ncancelled_pkgs
1609 Returns all non-cancelled packages (see L<FS::cust_pkg>) for this customer.
1613 sub ncancelled_pkgs {
1616 return $self->num_ncancelled_pkgs unless wantarray;
1619 if ( $self->{'_pkgnum'} ) {
1621 warn "$me ncancelled_pkgs: returning cached objects"
1624 @cust_pkg = grep { ! $_->getfield('cancel') }
1625 values %{ $self->{'_pkgnum'}->cache };
1629 warn "$me ncancelled_pkgs: searching for packages with custnum ".
1630 $self->custnum. "\n"
1634 qsearch( 'cust_pkg', {
1635 'custnum' => $self->custnum,
1639 qsearch( 'cust_pkg', {
1640 'custnum' => $self->custnum,
1645 sort sort_packages @cust_pkg;
1649 # This should be generalized to use config options to determine order.
1651 if ( $a->get('cancel') and $b->get('cancel') ) {
1652 $a->pkgnum <=> $b->pkgnum;
1653 } elsif ( $a->get('cancel') or $b->get('cancel') ) {
1654 return -1 if $b->get('cancel');
1655 return 1 if $a->get('cancel');
1658 $a->pkgnum <=> $b->pkgnum;
1662 =item suspended_pkgs
1664 Returns all suspended packages (see L<FS::cust_pkg>) for this customer.
1668 sub suspended_pkgs {
1670 grep { $_->susp } $self->ncancelled_pkgs;
1673 =item unflagged_suspended_pkgs
1675 Returns all unflagged suspended packages (see L<FS::cust_pkg>) for this
1676 customer (thouse packages without the `manual_flag' set).
1680 sub unflagged_suspended_pkgs {
1682 return $self->suspended_pkgs
1683 unless dbdef->table('cust_pkg')->column('manual_flag');
1684 grep { ! $_->manual_flag } $self->suspended_pkgs;
1687 =item unsuspended_pkgs
1689 Returns all unsuspended (and uncancelled) packages (see L<FS::cust_pkg>) for
1694 sub unsuspended_pkgs {
1696 grep { ! $_->susp } $self->ncancelled_pkgs;
1699 =item num_cancelled_pkgs
1701 Returns the number of cancelled packages (see L<FS::cust_pkg>) for this
1706 sub num_cancelled_pkgs {
1707 shift->num_pkgs("cust_pkg.cancel IS NOT NULL AND cust_pkg.cancel != 0");
1710 sub num_ncancelled_pkgs {
1711 shift->num_pkgs("( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )");
1715 my( $self ) = shift;
1716 my $sql = scalar(@_) ? shift : '';
1717 $sql = "AND $sql" if $sql && $sql !~ /^\s*$/ && $sql !~ /^\s*AND/i;
1718 my $sth = dbh->prepare(
1719 "SELECT COUNT(*) FROM cust_pkg WHERE custnum = ? $sql"
1720 ) or die dbh->errstr;
1721 $sth->execute($self->custnum) or die $sth->errstr;
1722 $sth->fetchrow_arrayref->[0];
1727 Unsuspends all unflagged suspended packages (see L</unflagged_suspended_pkgs>
1728 and L<FS::cust_pkg>) for this customer. Always returns a list: an empty list
1729 on success or a list of errors.
1735 grep { $_->unsuspend } $self->suspended_pkgs;
1740 Suspends all unsuspended packages (see L<FS::cust_pkg>) for this customer.
1742 Returns a list: an empty list on success or a list of errors.
1748 grep { $_->suspend(@_) } $self->unsuspended_pkgs;
1751 =item suspend_if_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1753 Suspends all unsuspended packages (see L<FS::cust_pkg>) matching the listed
1754 PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref instead
1755 of a list of pkgparts; the hashref has the following keys:
1759 =item pkgparts - listref of pkgparts
1761 =item (other options are passed to the suspend method)
1766 Returns a list: an empty list on success or a list of errors.
1770 sub suspend_if_pkgpart {
1772 my (@pkgparts, %opt);
1773 if (ref($_[0]) eq 'HASH'){
1774 @pkgparts = @{$_[0]{pkgparts}};
1779 grep { $_->suspend(%opt) }
1780 grep { my $pkgpart = $_->pkgpart; grep { $pkgpart eq $_ } @pkgparts }
1781 $self->unsuspended_pkgs;
1784 =item suspend_unless_pkgpart HASHREF | PKGPART [ , PKGPART ... ]
1786 Suspends all unsuspended packages (see L<FS::cust_pkg>) unless they match the
1787 given PKGPARTs (see L<FS::part_pkg>). Preferred usage is to pass a hashref
1788 instead of a list of pkgparts; the hashref has the following keys:
1792 =item pkgparts - listref of pkgparts
1794 =item (other options are passed to the suspend method)
1798 Returns a list: an empty list on success or a list of errors.
1802 sub suspend_unless_pkgpart {
1804 my (@pkgparts, %opt);
1805 if (ref($_[0]) eq 'HASH'){
1806 @pkgparts = @{$_[0]{pkgparts}};
1811 grep { $_->suspend(%opt) }
1812 grep { my $pkgpart = $_->pkgpart; ! grep { $pkgpart eq $_ } @pkgparts }
1813 $self->unsuspended_pkgs;
1816 =item cancel [ OPTION => VALUE ... ]
1818 Cancels all uncancelled packages (see L<FS::cust_pkg>) for this customer.
1820 Available options are:
1824 =item quiet - can be set true to supress email cancellation notices.
1826 =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.
1828 =item ban - can be set true to ban this customer's credit card or ACH information, if present.
1832 Always returns a list: an empty list on success or a list of errors.
1837 my( $self, %opt ) = @_;
1839 warn "$me cancel called on customer ". $self->custnum. " with options ".
1840 join(', ', map { "$_: $opt{$_}" } keys %opt ). "\n"
1843 return ( 'access denied' )
1844 unless $FS::CurrentUser::CurrentUser->access_right('Cancel customer');
1846 if ( $opt{'ban'} && $self->payby =~ /^(CARD|DCRD|CHEK|DCHK)$/ ) {
1848 #should try decryption (we might have the private key)
1849 # and if not maybe queue a job for the server that does?
1850 return ( "Can't (yet) ban encrypted credit cards" )
1851 if $self->is_encrypted($self->payinfo);
1853 my $ban = new FS::banned_pay $self->_banned_pay_hashref;
1854 my $error = $ban->insert;
1855 return ( $error ) if $error;
1859 my @pkgs = $self->ncancelled_pkgs;
1861 warn "$me cancelling ". scalar($self->ncancelled_pkgs). "/".
1862 scalar(@pkgs). " packages for customer ". $self->custnum. "\n"
1865 grep { $_ } map { $_->cancel(%opt) } $self->ncancelled_pkgs;
1868 sub _banned_pay_hashref {
1879 'payby' => $payby2ban{$self->payby},
1880 'payinfo' => md5_base64($self->payinfo),
1881 #don't ever *search* on reason! #'reason' =>
1887 Returns all notes (see L<FS::cust_main_note>) for this customer.
1894 qsearch( 'cust_main_note',
1895 { 'custnum' => $self->custnum },
1897 'ORDER BY _DATE DESC'
1903 Returns the agent (see L<FS::agent>) for this customer.
1909 qsearchs( 'agent', { 'agentnum' => $self->agentnum } );
1912 =item bill_and_collect
1914 Cancels and suspends any packages due, generates bills, applies payments and
1917 Warns on errors (Does not currently: If there is an error, returns the error, otherwise returns false.)
1919 Options are passed as name-value pairs. Currently available options are:
1925 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:
1929 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
1933 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.
1937 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
1941 If set true, re-charges setup fees.
1945 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)
1951 sub bill_and_collect {
1952 my( $self, %options ) = @_;
1958 #$options{actual_time} not $options{time} because freeside-daily -d is for
1959 #pre-printing invoices
1960 my @cancel_pkgs = grep { $_->expire && $_->expire <= $options{actual_time} }
1961 $self->ncancelled_pkgs;
1963 foreach my $cust_pkg ( @cancel_pkgs ) {
1964 my $error = $cust_pkg->cancel;
1965 warn "Error cancelling expired pkg ". $cust_pkg->pkgnum.
1966 " for custnum ". $self->custnum. ": $error"
1974 #$options{actual_time} not $options{time} because freeside-daily -d is for
1975 #pre-printing invoices
1978 && ( ( $_->part_pkg->is_prepaid
1980 && $_->bill < $options{actual_time}
1983 && $_->adjourn <= $options{actual_time}
1987 $self->ncancelled_pkgs;
1989 foreach my $cust_pkg ( @susp_pkgs ) {
1990 my $error = $cust_pkg->suspend;
1991 warn "Error suspending package ". $cust_pkg->pkgnum.
1992 " for custnum ". $self->custnum. ": $error"
2000 my $error = $self->bill( %options );
2001 warn "Error billing, custnum ". $self->custnum. ": $error" if $error;
2003 $self->apply_payments_and_credits;
2005 $error = $self->collect( %options );
2006 warn "Error collecting, custnum". $self->custnum. ": $error" if $error;
2012 Generates invoices (see L<FS::cust_bill>) for this customer. Usually used in
2013 conjunction with the collect method by calling B<bill_and_collect>.
2015 If there is an error, returns the error, otherwise returns false.
2017 Options are passed as name-value pairs. Currently available options are:
2023 If set true, re-charges setup fees.
2027 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:
2031 $cust_main->bill( 'time' => str2time('April 20th, 2001') );
2035 An array ref of specific packages (objects) to attempt billing, instead trying all of them.
2037 $cust_main->bill( pkg_list => [$pkg1, $pkg2] );
2041 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.
2048 my( $self, %options ) = @_;
2049 return '' if $self->payby eq 'COMP';
2050 warn "$me bill customer ". $self->custnum. "\n"
2053 my $time = $options{'time'} || time;
2056 local $SIG{HUP} = 'IGNORE';
2057 local $SIG{INT} = 'IGNORE';
2058 local $SIG{QUIT} = 'IGNORE';
2059 local $SIG{TERM} = 'IGNORE';
2060 local $SIG{TSTP} = 'IGNORE';
2061 local $SIG{PIPE} = 'IGNORE';
2063 my $oldAutoCommit = $FS::UID::AutoCommit;
2064 local $FS::UID::AutoCommit = 0;
2067 $self->select_for_update; #mutex
2069 my @cust_bill_pkg = ();
2070 my @appended_cust_bill_pkg = ();
2073 # find the packages which are due for billing, find out how much they are
2074 # & generate invoice database.
2077 my( $total_setup, $total_recur, $postal_charge ) = ( 0, 0, 0 );
2081 my @precommit_hooks = ();
2083 my @cust_pkgs = qsearch('cust_pkg', { 'custnum' => $self->custnum } );
2084 foreach my $cust_pkg (@cust_pkgs) {
2086 #NO!! next if $cust_pkg->cancel;
2087 next if $cust_pkg->getfield('cancel');
2089 warn " bill package ". $cust_pkg->pkgnum. "\n" if $DEBUG > 1;
2091 #? to avoid use of uninitialized value errors... ?
2092 $cust_pkg->setfield('bill', '')
2093 unless defined($cust_pkg->bill);
2095 #my $part_pkg = $cust_pkg->part_pkg;
2097 my $real_pkgpart = $cust_pkg->pkgpart;
2098 my %hash = $cust_pkg->hash;
2100 foreach my $part_pkg ( $cust_pkg->part_pkg->self_and_bill_linked ) {
2102 $cust_pkg->set($_, $hash{$_}) foreach qw ( setup last_bill bill );
2105 $self->_make_lines( 'part_pkg' => $part_pkg,
2106 'cust_pkg' => $cust_pkg,
2107 'precommit_hooks' => \@precommit_hooks,
2108 'line_items' => \@cust_bill_pkg,
2109 'appended_line_items' => \@appended_cust_bill_pkg,
2110 'setup' => \$total_setup,
2111 'recur' => \$total_recur,
2112 'tax_matrix' => \%taxlisthash,
2114 'options' => \%options,
2117 $dbh->rollback if $oldAutoCommit;
2121 } #foreach my $part_pkg
2123 } #foreach my $cust_pkg
2125 push @cust_bill_pkg, @appended_cust_bill_pkg;
2127 unless ( @cust_bill_pkg ) { #don't create an invoice w/o line items
2128 #but do commit any package date cycling that happened
2129 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2133 my $postal_pkg = $self->charge_postal_fee();
2134 if ( $postal_pkg && !ref( $postal_pkg ) ) {
2135 $dbh->rollback if $oldAutoCommit;
2136 return "can't charge postal invoice fee for customer ".
2137 $self->custnum. ": $postal_pkg";
2139 if ( $postal_pkg ) {
2140 foreach my $part_pkg ( $postal_pkg->part_pkg->self_and_bill_linked ) {
2142 $self->_make_lines( 'part_pkg' => $part_pkg,
2143 'cust_pkg' => $postal_pkg,
2144 'precommit_hooks' => \@precommit_hooks,
2145 'line_items' => \@cust_bill_pkg,
2146 'appended_line_items' => \@appended_cust_bill_pkg,
2147 'setup' => \$total_setup,
2148 'recur' => \$total_recur,
2149 'tax_matrix' => \%taxlisthash,
2151 'options' => \%options,
2154 $dbh->rollback if $oldAutoCommit;
2160 warn "having a look at the taxes we found...\n" if $DEBUG > 2;
2161 foreach my $tax ( keys %taxlisthash ) {
2162 my $tax_object = shift @{ $taxlisthash{$tax} };
2163 warn "found ". $tax_object->taxname. " as $tax\n" if $DEBUG > 2;
2164 my $listref_or_error = $tax_object->taxline( @{ $taxlisthash{$tax} } );
2165 unless (ref($listref_or_error)) {
2166 $dbh->rollback if $oldAutoCommit;
2167 return $listref_or_error;
2169 unshift @{ $taxlisthash{$tax} }, $tax_object;
2171 warn "adding ". $listref_or_error->[1].
2172 " as ". $listref_or_error->[0]. "\n"
2174 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2175 if ( $taxname{ $listref_or_error->[0] } ) {
2176 push @{ $taxname{ $listref_or_error->[0] } }, $tax_object->taxname;
2178 $taxname{ $listref_or_error->[0] } = [ $tax_object->taxname ];
2183 #some taxes are taxed
2186 warn "finding taxed taxes...\n" if $DEBUG > 2;
2187 foreach my $tax ( keys %taxlisthash ) {
2188 my $tax_object = shift @{ $taxlisthash{$tax} };
2189 warn "found possible taxed tax ". $tax_object->taxname. " we call $tax\n"
2191 next unless $tax_object->can('tax_on_tax');
2193 foreach my $tot ( $tax_object->tax_on_tax( $self ) ) {
2194 my $totname = ref( $tot ). ' '. $tot->taxnum;
2196 warn "checking $totname which we call ". $tot->taxname. " as applicable\n"
2198 next unless exists( $taxlisthash{ $totname } ); # only increase
2200 warn "adding $totname to taxed taxes\n" if $DEBUG > 2;
2201 if ( exists( $totlisthash{ $totname } ) ) {
2202 push @{ $totlisthash{ $totname } }, $tax{ $tax_object->taxname };
2204 $totlisthash{ $totname } = [ $tot, $tax{ $tax_object->taxname } ];
2209 warn "having a look at taxed taxes...\n" if $DEBUG > 2;
2210 foreach my $tax ( keys %totlisthash ) {
2211 my $tax_object = shift @{ $totlisthash{$tax} };
2212 warn "found previously found taxed tax ". $tax_object->taxname. "\n"
2214 my $listref_or_error = $tax_object->taxline( @{ $totlisthash{$tax} } );
2215 unless (ref($listref_or_error)) {
2216 $dbh->rollback if $oldAutoCommit;
2217 return $listref_or_error;
2220 warn "adding taxed tax amount ". $listref_or_error->[1].
2221 " as ". $tax_object->taxname. "\n"
2223 $tax{ $tax_object->taxname } += $listref_or_error->[1];
2226 #consolidate and create tax line items
2227 warn "consolidating and generating...\n" if $DEBUG > 2;
2228 foreach my $taxname ( keys %taxname ) {
2231 warn "adding $taxname\n" if $DEBUG > 1;
2232 foreach my $taxitem ( @{ $taxname{$taxname} } ) {
2233 $tax += $tax{$taxitem} unless $seen{$taxitem};
2234 warn "adding $tax{$taxitem}\n" if $DEBUG > 1;
2238 $tax = sprintf('%.2f', $tax );
2239 $total_setup = sprintf('%.2f', $total_setup+$tax );
2241 push @cust_bill_pkg, new FS::cust_bill_pkg {
2247 'itemdesc' => $taxname,
2252 my $charged = sprintf('%.2f', $total_setup + $total_recur );
2254 #create the new invoice
2255 my $cust_bill = new FS::cust_bill ( {
2256 'custnum' => $self->custnum,
2257 '_date' => ( $options{'invoice_time'} || $time ),
2258 'charged' => $charged,
2260 my $error = $cust_bill->insert;
2262 $dbh->rollback if $oldAutoCommit;
2263 return "can't create invoice for customer #". $self->custnum. ": $error";
2266 foreach my $cust_bill_pkg ( @cust_bill_pkg ) {
2267 $cust_bill_pkg->invnum($cust_bill->invnum);
2268 my $error = $cust_bill_pkg->insert;
2270 $dbh->rollback if $oldAutoCommit;
2271 return "can't create invoice line item: $error";
2276 foreach my $hook ( @precommit_hooks ) {
2278 &{$hook}; #($self) ?
2281 $dbh->rollback if $oldAutoCommit;
2282 return "$@ running precommit hook $hook\n";
2286 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2292 my ($self, %params) = @_;
2294 my $part_pkg = $params{part_pkg} or die "no part_pkg specified";
2295 my $cust_pkg = $params{cust_pkg} or die "no cust_pkg specified";
2296 my $precommit_hooks = $params{precommit_hooks} or die "no package specified";
2297 my $cust_bill_pkgs = $params{line_items} or die "no line buffer specified";
2298 my $appended_cust_bill_pkg = $params{appended_line_items}
2299 or die "no appended line buffer specified";
2300 my $total_setup = $params{setup} or die "no setup accumulator specified";
2301 my $total_recur = $params{recur} or die "no recur accumulator specified";
2302 my $taxlisthash = $params{tax_matrix} or die "no tax accumulator specified";
2303 my $time = $params{'time'} or die "no time specified";
2304 my (%options) = %{$params{options}}; #hmmm only for 'resetup'
2307 my $real_pkgpart = $cust_pkg->pkgpart;
2308 my %hash = $cust_pkg->hash;
2309 my $old_cust_pkg = new FS::cust_pkg \%hash;
2315 $cust_pkg->pkgpart($part_pkg->pkgpart);
2323 if ( ! $cust_pkg->setup &&
2325 ( $conf->exists('disable_setup_suspended_pkgs') &&
2326 ! $cust_pkg->getfield('susp')
2327 ) || ! $conf->exists('disable_setup_suspended_pkgs')
2329 || $options{'resetup'}
2332 warn " bill setup\n" if $DEBUG > 1;
2335 $setup = eval { $cust_pkg->calc_setup( $time, \@details ) };
2336 return "$@ running calc_setup for $cust_pkg\n"
2339 $unitsetup = $cust_pkg->part_pkg->unit_setup || $setup; #XXX uuh
2341 $cust_pkg->setfield('setup', $time)
2342 unless $cust_pkg->setup;
2343 #do need it, but it won't get written to the db
2344 #|| $cust_pkg->pkgpart != $real_pkgpart;
2349 # bill recurring fee
2352 #XXX unit stuff here too
2356 if ( $part_pkg->getfield('freq') ne '0' &&
2357 ! $cust_pkg->getfield('susp') &&
2358 ( $cust_pkg->getfield('bill') || 0 ) <= $time
2361 # XXX should this be a package event? probably. events are called
2362 # at collection time at the moment, though...
2363 $part_pkg->reset_usage($cust_pkg, 'debug'=>$DEBUG)
2364 if $part_pkg->can('reset_usage');
2365 #don't want to reset usage just cause we want a line item??
2366 #&& $part_pkg->pkgpart == $real_pkgpart;
2368 warn " bill recur\n" if $DEBUG > 1;
2371 # XXX shared with $recur_prog
2372 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2374 #over two params! lets at least switch to a hashref for the rest...
2375 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2377 $recur = eval { $cust_pkg->calc_recur( \$sdate, \@details, \%param ) };
2378 return "$@ running calc_recur for $cust_pkg\n"
2382 #change this bit to use Date::Manip? CAREFUL with timezones (see
2383 # mailing list archive)
2384 my ($sec,$min,$hour,$mday,$mon,$year) =
2385 (localtime($sdate) )[0,1,2,3,4,5];
2387 #pro-rating magic - if $recur_prog fiddles $sdate, want to use that
2388 # only for figuring next bill date, nothing else, so, reset $sdate again
2390 $sdate = $cust_pkg->bill || $cust_pkg->setup || $time;
2391 $cust_pkg->last_bill($sdate);
2393 if ( $part_pkg->freq =~ /^\d+$/ ) {
2394 $mon += $part_pkg->freq;
2395 until ( $mon < 12 ) { $mon -= 12; $year++; }
2396 } elsif ( $part_pkg->freq =~ /^(\d+)w$/ ) {
2398 $mday += $weeks * 7;
2399 } elsif ( $part_pkg->freq =~ /^(\d+)d$/ ) {
2402 } elsif ( $part_pkg->freq =~ /^(\d+)h$/ ) {
2406 return "unparsable frequency: ". $part_pkg->freq;
2408 $cust_pkg->setfield('bill',
2409 timelocal_nocheck($sec,$min,$hour,$mday,$mon,$year));
2413 warn "\$setup is undefined" unless defined($setup);
2414 warn "\$recur is undefined" unless defined($recur);
2415 warn "\$cust_pkg->bill is undefined" unless defined($cust_pkg->bill);
2418 # If there's line items, create em cust_bill_pkg records
2419 # If $cust_pkg has been modified, update it (if we're a real pkgpart)
2424 if ( $cust_pkg->modified && $cust_pkg->pkgpart == $real_pkgpart ) {
2425 # hmm.. and if just the options are modified in some weird price plan?
2427 warn " package ". $cust_pkg->pkgnum. " modified; updating\n"
2430 my $error = $cust_pkg->replace( $old_cust_pkg,
2431 'options' => { $cust_pkg->options },
2433 return "Error modifying pkgnum ". $cust_pkg->pkgnum. ": $error"
2434 if $error; #just in case
2437 $setup = sprintf( "%.2f", $setup );
2438 $recur = sprintf( "%.2f", $recur );
2439 if ( $setup < 0 && ! $conf->exists('allow_negative_charges') ) {
2440 return "negative setup $setup for pkgnum ". $cust_pkg->pkgnum;
2442 if ( $recur < 0 && ! $conf->exists('allow_negative_charges') ) {
2443 return "negative recur $recur for pkgnum ". $cust_pkg->pkgnum;
2446 if ( $setup != 0 || $recur != 0 ) {
2448 warn " charges (setup=$setup, recur=$recur); adding line items\n"
2450 my $cust_bill_pkg = new FS::cust_bill_pkg {
2451 'pkgnum' => $cust_pkg->pkgnum,
2453 'unitsetup' => $unitsetup,
2455 'unitrecur' => $unitrecur,
2456 'quantity' => $cust_pkg->quantity,
2458 'edate' => $cust_pkg->bill,
2459 'details' => \@details,
2461 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2462 unless $part_pkg->pkgpart == $real_pkgpart;
2463 push @$cust_bill_pkgs, $cust_bill_pkg;
2465 $$total_setup += $setup;
2466 $$total_recur += $recur;
2472 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2474 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2476 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2478 } #if $setup != 0 || $recur != 0
2482 if ( $part_pkg->can('append_cust_bill_pkgs') ) {
2483 my %param = ( 'precommit_hooks' => $precommit_hooks, );
2484 my ($more_cust_bill_pkgs) =
2485 eval { $part_pkg->append_cust_bill_pkgs( $cust_pkg, \$sdate, \%param ) };
2487 return "$@ running append_cust_bill_pkgs for $cust_pkg\n"
2489 return "$more_cust_bill_pkgs"
2490 unless ( ref($more_cust_bill_pkgs) );
2492 foreach my $cust_bill_pkg ( @{$more_cust_bill_pkgs} ) {
2494 $cust_bill_pkg->pkgpart_override($part_pkg->pkgpart)
2495 unless $part_pkg->pkgpart == $real_pkgpart;
2496 push @$appended_cust_bill_pkg, $cust_bill_pkg;
2498 unless ($cust_bill_pkg->duplicate) {
2499 $$total_setup += $cust_bill_pkg->setup;
2500 $$total_recur += $cust_bill_pkg->recur;
2506 unless ( $self->tax =~ /Y/i || $self->payby eq 'COMP' ) {
2508 $self->_handle_taxes($part_pkg, $taxlisthash, $cust_bill_pkg);
2510 } #unless $self->tax =~ /Y/i || $self->payby eq 'COMP'
2519 my $part_pkg = shift;
2520 my $taxlisthash = shift;
2521 my $cust_bill_pkg = shift;
2524 my @taxoverrides = $part_pkg->part_pkg_taxoverride;
2527 ( $conf->exists('tax-ship_address') && length($self->ship_last) )
2531 if ( $conf->exists('enable_taxproducts')
2532 && (scalar(@taxoverrides) || $part_pkg->taxproductnum )
2536 my @taxclassnums = ();
2537 my $geocode = $self->geocode('cch');
2539 if ( scalar( @taxoverrides ) ) {
2540 @taxclassnums = map { $_->taxclassnum } @taxoverrides;
2541 }elsif ( $part_pkg->taxproductnum ) {
2542 @taxclassnums = map { $_->taxclassnum }
2543 $part_pkg->part_pkg_taxrate('cch', $geocode);
2548 join(' OR ', map { "taxclassnum = $_" } @taxclassnums ). ")";
2550 @taxes = qsearch({ 'table' => 'tax_rate',
2551 'hashref' => { 'geocode' => $geocode, },
2552 'extra_sql' => $extra_sql,
2554 if scalar(@taxclassnums);
2559 my %taxhash = map { $_ => $self->get("$prefix$_") }
2560 qw( state county country );
2562 $taxhash{'taxclass'} = $part_pkg->taxclass;
2564 @taxes = qsearch( 'cust_main_county', \%taxhash );
2567 $taxhash{'taxclass'} = '';
2568 @taxes = qsearch( 'cust_main_county', \%taxhash );
2571 #one more try at a whole-country tax rate
2573 $taxhash{$_} = '' foreach qw( state county );
2574 @taxes = qsearch( 'cust_main_county', \%taxhash );
2577 } #if $conf->exists('enable_taxproducts')
2579 # maybe eliminate this entirely, along with all the 0% records
2582 if ( $conf->exists('enable_taxproducts') ) {
2584 "fatal: can't find tax rate for zip/taxproduct/pkgpart ".
2585 join('/', ( map $self->get("$prefix$_"),
2588 $part_pkg->taxproduct_description,
2589 $part_pkg->pkgpart ). "\n";
2592 "fatal: can't find tax rate for state/county/country/taxclass ".
2593 join('/', ( map $self->get("$prefix$_"),
2594 qw(state county country)
2596 $part_pkg->taxclass ). "\n";
2601 foreach my $tax ( @taxes ) {
2602 my $taxname = ref( $tax ). ' '. $tax->taxnum;
2603 if ( exists( $taxlisthash->{ $taxname } ) ) {
2604 push @{ $taxlisthash->{ $taxname } }, $cust_bill_pkg;
2606 $taxlisthash->{ $taxname } = [ $tax, $cust_bill_pkg ];
2612 =item collect OPTIONS
2614 (Attempt to) collect money for this customer's outstanding invoices (see
2615 L<FS::cust_bill>). Usually used after the bill method.
2617 Actions are now triggered by billing events; see L<FS::part_event> and the
2618 billing events web interface. Old-style invoice events (see
2619 L<FS::part_bill_event>) have been deprecated.
2621 If there is an error, returns the error, otherwise returns false.
2623 Options are passed as name-value pairs.
2625 Currently available options are:
2631 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.
2635 Retry card/echeck/LEC transactions even when not scheduled by invoice events.
2639 set true to surpress email card/ACH decline notices.
2643 "1d" for the traditional, daily events (the default), or "1m" for the new monthly events (part_event.check_freq)
2647 allows for one time override of normal customer billing method
2651 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)
2659 my( $self, %options ) = @_;
2660 my $invoice_time = $options{'invoice_time'} || time;
2663 local $SIG{HUP} = 'IGNORE';
2664 local $SIG{INT} = 'IGNORE';
2665 local $SIG{QUIT} = 'IGNORE';
2666 local $SIG{TERM} = 'IGNORE';
2667 local $SIG{TSTP} = 'IGNORE';
2668 local $SIG{PIPE} = 'IGNORE';
2670 my $oldAutoCommit = $FS::UID::AutoCommit;
2671 local $FS::UID::AutoCommit = 0;
2674 $self->select_for_update; #mutex
2677 my $balance = $self->balance;
2678 warn "$me collect customer ". $self->custnum. ": balance $balance\n"
2681 if ( exists($options{'retry_card'}) ) {
2682 carp 'retry_card option passed to collect is deprecated; use retry';
2683 $options{'retry'} ||= $options{'retry_card'};
2685 if ( exists($options{'retry'}) && $options{'retry'} ) {
2686 my $error = $self->retry_realtime;
2688 $dbh->rollback if $oldAutoCommit;
2693 # false laziness w/pay_batch::import_results
2695 my $due_cust_event = $self->due_cust_event(
2696 'debug' => ( $options{'debug'} || 0 ),
2697 'time' => $invoice_time,
2698 'check_freq' => $options{'check_freq'},
2700 unless( ref($due_cust_event) ) {
2701 $dbh->rollback if $oldAutoCommit;
2702 return $due_cust_event;
2705 foreach my $cust_event ( @$due_cust_event ) {
2709 #re-eval event conditions (a previous event could have changed things)
2710 unless ( $cust_event->test_conditions( 'time' => $invoice_time ) ) {
2711 #don't leave stray "new/locked" records around
2712 my $error = $cust_event->delete;
2714 #gah, even with transactions
2715 $dbh->commit if $oldAutoCommit; #well.
2722 local $realtime_bop_decline_quiet = 1 if $options{'quiet'};
2723 warn " running cust_event ". $cust_event->eventnum. "\n"
2727 #if ( my $error = $cust_event->do_event(%options) ) { #XXX %options?
2728 if ( my $error = $cust_event->do_event() ) {
2729 #XXX wtf is this? figure out a proper dealio with return value
2731 # gah, even with transactions.
2732 $dbh->commit if $oldAutoCommit; #well.
2739 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2744 =item due_cust_event [ HASHREF | OPTION => VALUE ... ]
2746 Inserts database records for and returns an ordered listref of new events due
2747 for this customer, as FS::cust_event objects (see L<FS::cust_event>). If no
2748 events are due, an empty listref is returned. If there is an error, returns a
2749 scalar error message.
2751 To actually run the events, call each event's test_condition method, and if
2752 still true, call the event's do_event method.
2754 Options are passed as a hashref or as a list of name-value pairs. Available
2761 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.
2765 "Current time" for the events.
2769 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)
2773 Only return events for the specified eventtable (by default, events of all eventtables are returned)
2777 Explicitly pass the objects to be tested (typically used with eventtable).
2783 sub due_cust_event {
2785 my %opt = ref($_[0]) ? %{ $_[0] } : @_;
2788 #my $DEBUG = $opt{'debug'}
2789 local($DEBUG) = $opt{'debug'}
2790 if defined($opt{'debug'}) && $opt{'debug'} > $DEBUG;
2792 warn "$me due_cust_event called with options ".
2793 join(', ', map { "$_: $opt{$_}" } keys %opt). "\n"
2796 $opt{'time'} ||= time;
2798 local $SIG{HUP} = 'IGNORE';
2799 local $SIG{INT} = 'IGNORE';
2800 local $SIG{QUIT} = 'IGNORE';
2801 local $SIG{TERM} = 'IGNORE';
2802 local $SIG{TSTP} = 'IGNORE';
2803 local $SIG{PIPE} = 'IGNORE';
2805 my $oldAutoCommit = $FS::UID::AutoCommit;
2806 local $FS::UID::AutoCommit = 0;
2809 $self->select_for_update; #mutex
2812 # 1: find possible events (initial search)
2815 my @cust_event = ();
2817 my @eventtable = $opt{'eventtable'}
2818 ? ( $opt{'eventtable'} )
2819 : FS::part_event->eventtables_runorder;
2821 foreach my $eventtable ( @eventtable ) {
2824 if ( $opt{'objects'} ) {
2826 @objects = @{ $opt{'objects'} };
2830 #my @objects = $self->eventtable(); # sub cust_main { @{ [ $self ] }; }
2831 @objects = ( $eventtable eq 'cust_main' )
2833 : ( $self->$eventtable() );
2837 my @e_cust_event = ();
2839 my $cross = "CROSS JOIN $eventtable";
2840 $cross .= ' LEFT JOIN cust_main USING ( custnum )'
2841 unless $eventtable eq 'cust_main';
2843 foreach my $object ( @objects ) {
2845 #this first search uses the condition_sql magic for optimization.
2846 #the more possible events we can eliminate in this step the better
2848 my $cross_where = '';
2849 my $pkey = $object->primary_key;
2850 $cross_where = "$eventtable.$pkey = ". $object->$pkey();
2852 my $join = FS::part_event_condition->join_conditions_sql( $eventtable );
2854 FS::part_event_condition->where_conditions_sql( $eventtable,
2855 'time'=>$opt{'time'}
2857 my $order = FS::part_event_condition->order_conditions_sql( $eventtable );
2859 $extra_sql = "AND $extra_sql" if $extra_sql;
2861 #here is the agent virtualization
2862 $extra_sql .= " AND ( part_event.agentnum IS NULL
2863 OR part_event.agentnum = ". $self->agentnum. ' )';
2865 $extra_sql .= " $order";
2867 warn "searching for events for $eventtable ". $object->$pkey. "\n"
2868 if $opt{'debug'} > 2;
2869 my @part_event = qsearch( {
2870 'debug' => ( $opt{'debug'} > 3 ? 1 : 0 ),
2871 'select' => 'part_event.*',
2872 'table' => 'part_event',
2873 'addl_from' => "$cross $join",
2874 'hashref' => { 'check_freq' => ( $opt{'check_freq'} || '1d' ),
2875 'eventtable' => $eventtable,
2878 'extra_sql' => "AND $cross_where $extra_sql",
2882 my $pkey = $object->primary_key;
2883 warn " ". scalar(@part_event).
2884 " possible events found for $eventtable ". $object->$pkey(). "\n";
2887 push @e_cust_event, map { $_->new_cust_event($object) } @part_event;
2891 warn " ". scalar(@e_cust_event).
2892 " subtotal possible cust events found for $eventtable\n"
2895 push @cust_event, @e_cust_event;
2899 warn " ". scalar(@cust_event).
2900 " total possible cust events found in initial search\n"
2904 # 2: test conditions
2909 @cust_event = grep $_->test_conditions( 'time' => $opt{'time'},
2910 'stats_hashref' => \%unsat ),
2913 warn " ". scalar(@cust_event). " cust events left satisfying conditions\n"
2916 warn " invalid conditions not eliminated with condition_sql:\n".
2917 join('', map " $_: ".$unsat{$_}."\n", keys %unsat )
2924 foreach my $cust_event ( @cust_event ) {
2926 my $error = $cust_event->insert();
2928 $dbh->rollback if $oldAutoCommit;
2934 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2940 warn " returning events: ". Dumper(@cust_event). "\n"
2947 =item retry_realtime
2949 Schedules realtime / batch credit card / electronic check / LEC billing
2950 events for for retry. Useful if card information has changed or manual
2951 retry is desired. The 'collect' method must be called to actually retry
2954 Implementation details: For either this customer, or for each of this
2955 customer's open invoices, changes the status of the first "done" (with
2956 statustext error) realtime processing event to "failed".
2960 sub retry_realtime {
2963 local $SIG{HUP} = 'IGNORE';
2964 local $SIG{INT} = 'IGNORE';
2965 local $SIG{QUIT} = 'IGNORE';
2966 local $SIG{TERM} = 'IGNORE';
2967 local $SIG{TSTP} = 'IGNORE';
2968 local $SIG{PIPE} = 'IGNORE';
2970 my $oldAutoCommit = $FS::UID::AutoCommit;
2971 local $FS::UID::AutoCommit = 0;
2974 #a little false laziness w/due_cust_event (not too bad, really)
2976 my $join = FS::part_event_condition->join_conditions_sql;
2977 my $order = FS::part_event_condition->order_conditions_sql;
2980 . join ( ' OR ' , map {
2981 "( part_event.eventtable = " . dbh->quote($_)
2982 . " AND tablenum IN( SELECT " . dbdef->table($_)->primary_key . " from $_ where custnum = " . dbh->quote( $self->custnum ) . "))" ;
2983 } FS::part_event->eventtables)
2986 #here is the agent virtualization
2987 my $agent_virt = " ( part_event.agentnum IS NULL
2988 OR part_event.agentnum = ". $self->agentnum. ' )';
2990 #XXX this shouldn't be hardcoded, actions should declare it...
2991 my @realtime_events = qw(
2992 cust_bill_realtime_card
2993 cust_bill_realtime_check
2994 cust_bill_realtime_lec
2998 my $is_realtime_event = ' ( '. join(' OR ', map "part_event.action = '$_'",
3003 my @cust_event = qsearchs({
3004 'table' => 'cust_event',
3005 'select' => 'cust_event.*',
3006 'addl_from' => "LEFT JOIN part_event USING ( eventpart ) $join",
3007 'hashref' => { 'status' => 'done' },
3008 'extra_sql' => " AND statustext IS NOT NULL AND statustext != '' ".
3009 " AND $mine AND $is_realtime_event AND $agent_virt $order" # LIMIT 1"
3012 my %seen_invnum = ();
3013 foreach my $cust_event (@cust_event) {
3015 #max one for the customer, one for each open invoice
3016 my $cust_X = $cust_event->cust_X;
3017 next if $seen_invnum{ $cust_event->part_event->eventtable eq 'cust_bill'
3021 or $cust_event->part_event->eventtable eq 'cust_bill'
3024 my $error = $cust_event->retry;
3026 $dbh->rollback if $oldAutoCommit;
3027 return "error scheduling event for retry: $error";
3032 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3037 =item realtime_bop METHOD AMOUNT [ OPTION => VALUE ... ]
3039 Runs a realtime credit card, ACH (electronic check) or phone bill transaction
3040 via a Business::OnlinePayment realtime gateway. See
3041 L<http://420.am/business-onlinepayment> for supported gateways.
3043 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3045 Available options are: I<description>, I<invnum>, I<quiet>, I<paynum_ref>, I<payunique>
3047 The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3048 I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3049 if set, will override the value from the customer record.
3051 I<description> is a free-text field passed to the gateway. It defaults to
3052 "Internet services".
3054 If an I<invnum> is specified, this payment (if successful) is applied to the
3055 specified invoice. If you don't specify an I<invnum> you might want to
3056 call the B<apply_payments> method.
3058 I<quiet> can be set true to surpress email decline notices.
3060 I<paynum_ref> can be set to a scalar reference. It will be filled in with the
3061 resulting paynum, if any.
3063 I<payunique> is a unique identifier for this payment.
3065 (moved from cust_bill) (probably should get realtime_{card,ach,lec} here too)
3070 my( $self, $method, $amount, %options ) = @_;
3072 warn "$me realtime_bop: $method $amount\n";
3073 warn " $_ => $options{$_}\n" foreach keys %options;
3076 $options{'description'} ||= 'Internet services';
3078 return $self->fake_bop($method, $amount, %options) if $options{'fake'};
3080 eval "use Business::OnlinePayment";
3083 my $payinfo = exists($options{'payinfo'})
3084 ? $options{'payinfo'}
3087 my %method2payby = (
3094 # check for banned credit card/ACH
3097 my $ban = qsearchs('banned_pay', {
3098 'payby' => $method2payby{$method},
3099 'payinfo' => md5_base64($payinfo),
3101 return "Banned credit card" if $ban;
3108 if ( $options{'invnum'} ) {
3109 my $cust_bill = qsearchs('cust_bill', { 'invnum' => $options{'invnum'} } );
3110 die "invnum ". $options{'invnum'}. " not found" unless $cust_bill;
3112 map { $_->part_pkg->taxclass }
3114 map { $_->cust_pkg }
3115 $cust_bill->cust_bill_pkg;
3116 unless ( grep { $taxclasses[0] ne $_ } @taxclasses ) { #unless there are
3117 #different taxclasses
3118 $taxclass = $taxclasses[0];
3122 #look for an agent gateway override first
3124 if ( $method eq 'CC' ) {
3125 $cardtype = cardtype($payinfo);
3126 } elsif ( $method eq 'ECHECK' ) {
3129 $cardtype = $method;
3133 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3134 cardtype => $cardtype,
3135 taxclass => $taxclass, } )
3136 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3138 taxclass => $taxclass, } )
3139 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3140 cardtype => $cardtype,
3142 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3144 taxclass => '', } );
3146 my $payment_gateway = '';
3147 my( $processor, $login, $password, $action, @bop_options );
3148 if ( $override ) { #use a payment gateway override
3150 $payment_gateway = $override->payment_gateway;
3152 $processor = $payment_gateway->gateway_module;
3153 $login = $payment_gateway->gateway_username;
3154 $password = $payment_gateway->gateway_password;
3155 $action = $payment_gateway->gateway_action;
3156 @bop_options = $payment_gateway->options;
3158 } else { #use the standard settings from the config
3160 ( $processor, $login, $password, $action, @bop_options ) =
3161 $self->default_payment_gateway($method);
3169 my $address = exists($options{'address1'})
3170 ? $options{'address1'}
3172 my $address2 = exists($options{'address2'})
3173 ? $options{'address2'}
3175 $address .= ", ". $address2 if length($address2);
3177 my $o_payname = exists($options{'payname'})
3178 ? $options{'payname'}
3180 my($payname, $payfirst, $paylast);
3181 if ( $o_payname && $method ne 'ECHECK' ) {
3182 ($payname = $o_payname) =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3183 or return "Illegal payname $payname";
3184 ($payfirst, $paylast) = ($1, $2);
3186 $payfirst = $self->getfield('first');
3187 $paylast = $self->getfield('last');
3188 $payname = "$payfirst $paylast";
3191 my @invoicing_list = $self->invoicing_list_emailonly;
3192 if ( $conf->exists('emailinvoiceautoalways')
3193 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3194 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3195 push @invoicing_list, $self->all_emails;
3198 my $email = ($conf->exists('business-onlinepayment-email-override'))
3199 ? $conf->config('business-onlinepayment-email-override')
3200 : $invoicing_list[0];
3204 my $payip = exists($options{'payip'})
3207 $content{customer_ip} = $payip
3210 $content{invoice_number} = $options{'invnum'}
3211 if exists($options{'invnum'}) && length($options{'invnum'});
3213 $content{email_customer} =
3214 ( $conf->exists('business-onlinepayment-email_customer')
3215 || $conf->exists('business-onlinepayment-email-override') );
3218 if ( $method eq 'CC' ) {
3220 $content{card_number} = $payinfo;
3221 $paydate = exists($options{'paydate'})
3222 ? $options{'paydate'}
3224 $paydate =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3225 $content{expiration} = "$2/$1";
3227 my $paycvv = exists($options{'paycvv'})
3228 ? $options{'paycvv'}
3230 $content{cvv2} = $paycvv
3233 my $paystart_month = exists($options{'paystart_month'})
3234 ? $options{'paystart_month'}
3235 : $self->paystart_month;
3237 my $paystart_year = exists($options{'paystart_year'})
3238 ? $options{'paystart_year'}
3239 : $self->paystart_year;
3241 $content{card_start} = "$paystart_month/$paystart_year"
3242 if $paystart_month && $paystart_year;
3244 my $payissue = exists($options{'payissue'})
3245 ? $options{'payissue'}
3247 $content{issue_number} = $payissue if $payissue;
3249 $content{recurring_billing} = 'YES'
3250 if qsearch('cust_pay', { 'custnum' => $self->custnum,
3252 'payinfo' => $payinfo,
3254 || qsearch('cust_pay', { 'custnum' => $self->custnum,
3256 'paymask' => $self->mask_payinfo('CARD', $payinfo),
3260 } elsif ( $method eq 'ECHECK' ) {
3261 ( $content{account_number}, $content{routing_code} ) =
3262 split('@', $payinfo);
3263 $content{bank_name} = $o_payname;
3264 $content{bank_state} = exists($options{'paystate'})
3265 ? $options{'paystate'}
3266 : $self->getfield('paystate');
3267 $content{account_type} = exists($options{'paytype'})
3268 ? uc($options{'paytype'}) || 'CHECKING'
3269 : uc($self->getfield('paytype')) || 'CHECKING';
3270 $content{account_name} = $payname;
3271 $content{customer_org} = $self->company ? 'B' : 'I';
3272 $content{state_id} = exists($options{'stateid'})
3273 ? $options{'stateid'}
3274 : $self->getfield('stateid');
3275 $content{state_id_state} = exists($options{'stateid_state'})
3276 ? $options{'stateid_state'}
3277 : $self->getfield('stateid_state');
3278 $content{customer_ssn} = exists($options{'ss'})
3281 } elsif ( $method eq 'LEC' ) {
3282 $content{phone} = $payinfo;
3286 # run transaction(s)
3289 my $balance = exists( $options{'balance'} )
3290 ? $options{'balance'}
3293 $self->select_for_update; #mutex ... just until we get our pending record in
3295 #the checks here are intended to catch concurrent payments
3296 #double-form-submission prevention is taken care of in cust_pay_pending::check
3299 return "The customer's balance has changed; $method transaction aborted."
3300 if $self->balance < $balance;
3301 #&& $self->balance < $amount; #might as well anyway?
3303 #also check and make sure there aren't *other* pending payments for this cust
3305 my @pending = qsearch('cust_pay_pending', {
3306 'custnum' => $self->custnum,
3307 'status' => { op=>'!=', value=>'done' }
3309 return "A payment is already being processed for this customer (".
3310 join(', ', map 'paypendingnum '. $_->paypendingnum, @pending ).
3311 "); $method transaction aborted."
3312 if scalar(@pending);
3314 #okay, good to go, if we're a duplicate, cust_pay_pending will kick us out
3316 my $cust_pay_pending = new FS::cust_pay_pending {
3317 'custnum' => $self->custnum,
3318 #'invnum' => $options{'invnum'},
3321 'payby' => $method2payby{$method},
3322 'payinfo' => $payinfo,
3323 'paydate' => $paydate,
3325 'gatewaynum' => ( $payment_gateway ? $payment_gateway->gatewaynum : '' ),
3327 $cust_pay_pending->payunique( $options{payunique} )
3328 if defined($options{payunique}) && length($options{payunique});
3329 my $cpp_new_err = $cust_pay_pending->insert; #mutex lost when this is inserted
3330 return $cpp_new_err if $cpp_new_err;
3332 my( $action1, $action2 ) = split(/\s*\,\s*/, $action );
3334 my $transaction = new Business::OnlinePayment( $processor, @bop_options );
3335 $transaction->content(
3338 'password' => $password,
3339 'action' => $action1,
3340 'description' => $options{'description'},
3341 'amount' => $amount,
3342 #'invoice_number' => $options{'invnum'},
3343 'customer_id' => $self->custnum,
3344 'last_name' => $paylast,
3345 'first_name' => $payfirst,
3347 'address' => $address,
3348 'city' => ( exists($options{'city'})
3351 'state' => ( exists($options{'state'})
3354 'zip' => ( exists($options{'zip'})
3357 'country' => ( exists($options{'country'})
3358 ? $options{'country'}
3360 'referer' => 'http://cleanwhisker.420.am/',
3362 'phone' => $self->daytime || $self->night,
3366 $cust_pay_pending->status('pending');
3367 my $cpp_pending_err = $cust_pay_pending->replace;
3368 return $cpp_pending_err if $cpp_pending_err;
3371 my $BOP_TESTING = 0;
3372 my $BOP_TESTING_SUCCESS = 1;
3374 unless ( $BOP_TESTING ) {
3375 $transaction->submit();
3377 if ( $BOP_TESTING_SUCCESS ) {
3378 $transaction->is_success(1);
3379 $transaction->authorization('fake auth');
3381 $transaction->is_success(0);
3382 $transaction->error_message('fake failure');
3386 if ( $transaction->is_success() && $action2 ) {
3388 $cust_pay_pending->status('authorized');
3389 my $cpp_authorized_err = $cust_pay_pending->replace;
3390 return $cpp_authorized_err if $cpp_authorized_err;
3392 my $auth = $transaction->authorization;
3393 my $ordernum = $transaction->can('order_number')
3394 ? $transaction->order_number
3398 new Business::OnlinePayment( $processor, @bop_options );
3405 password => $password,
3406 order_number => $ordernum,
3408 authorization => $auth,
3409 description => $options{'description'},
3412 foreach my $field (qw( authorization_source_code returned_ACI
3413 transaction_identifier validation_code
3414 transaction_sequence_num local_transaction_date
3415 local_transaction_time AVS_result_code )) {
3416 $capture{$field} = $transaction->$field() if $transaction->can($field);
3419 $capture->content( %capture );
3423 unless ( $capture->is_success ) {
3424 my $e = "Authorization successful but capture failed, custnum #".
3425 $self->custnum. ': '. $capture->result_code.
3426 ": ". $capture->error_message;
3433 $cust_pay_pending->status($transaction->is_success() ? 'captured' : 'declined');
3434 my $cpp_captured_err = $cust_pay_pending->replace;
3435 return $cpp_captured_err if $cpp_captured_err;
3438 # remove paycvv after initial transaction
3441 #false laziness w/misc/process/payment.cgi - check both to make sure working
3443 if ( defined $self->dbdef_table->column('paycvv')
3444 && length($self->paycvv)
3445 && ! grep { $_ eq cardtype($payinfo) } $conf->config('cvv-save')
3447 my $error = $self->remove_cvv;
3449 warn "WARNING: error removing cvv: $error\n";
3457 if ( $transaction->is_success() ) {
3460 if ( $payment_gateway ) { # agent override
3461 $paybatch = $payment_gateway->gatewaynum. '-';
3464 $paybatch .= "$processor:". $transaction->authorization;
3466 $paybatch .= ':'. $transaction->order_number
3467 if $transaction->can('order_number')
3468 && length($transaction->order_number);
3470 my $cust_pay = new FS::cust_pay ( {
3471 'custnum' => $self->custnum,
3472 'invnum' => $options{'invnum'},
3475 'payby' => $method2payby{$method},
3476 'payinfo' => $payinfo,
3477 'paybatch' => $paybatch,
3478 'paydate' => $paydate,
3480 #doesn't hurt to know, even though the dup check is in cust_pay_pending now
3481 $cust_pay->payunique( $options{payunique} )
3482 if defined($options{payunique}) && length($options{payunique});
3484 my $oldAutoCommit = $FS::UID::AutoCommit;
3485 local $FS::UID::AutoCommit = 0;
3488 #start a transaction, insert the cust_pay and set cust_pay_pending.status to done in a single transction
3490 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3493 $cust_pay->invnum(''); #try again with no specific invnum
3494 my $error2 = $cust_pay->insert( $options{'manual'} ?
3495 ( 'manual' => 1 ) : ()
3498 # gah. but at least we have a record of the state we had to abort in
3499 # from cust_pay_pending now.
3500 my $e = "WARNING: $method captured but payment not recorded - ".
3501 "error inserting payment ($processor): $error2".
3502 " (previously tried insert with invnum #$options{'invnum'}" .
3503 ": $error ) - pending payment saved as paypendingnum ".
3504 $cust_pay_pending->paypendingnum. "\n";
3510 if ( $options{'paynum_ref'} ) {
3511 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3514 $cust_pay_pending->status('done');
3515 $cust_pay_pending->statustext('captured');
3516 my $cpp_done_err = $cust_pay_pending->replace;
3518 if ( $cpp_done_err ) {
3520 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
3521 my $e = "WARNING: $method captured but payment not recorded - ".
3522 "error updating status for paypendingnum ".
3523 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3529 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
3530 return ''; #no error
3536 my $perror = "$processor error: ". $transaction->error_message;
3538 unless ( $transaction->error_message ) {
3541 if ( $transaction->can('response_page') ) {
3543 'page' => ( $transaction->can('response_page')
3544 ? $transaction->response_page
3547 'code' => ( $transaction->can('response_code')
3548 ? $transaction->response_code
3551 'headers' => ( $transaction->can('response_headers')
3552 ? $transaction->response_headers
3558 "No additional debugging information available for $processor";
3561 $perror .= "No error_message returned from $processor -- ".
3562 ( ref($t_response) ? Dumper($t_response) : $t_response );
3566 if ( !$options{'quiet'} && !$realtime_bop_decline_quiet
3567 && $conf->exists('emaildecline')
3568 && grep { $_ ne 'POST' } $self->invoicing_list
3569 && ! grep { $transaction->error_message =~ /$_/ }
3570 $conf->config('emaildecline-exclude')
3572 my @templ = $conf->config('declinetemplate');
3573 my $template = new Text::Template (
3575 SOURCE => [ map "$_\n", @templ ],
3576 ) or return "($perror) can't create template: $Text::Template::ERROR";
3577 $template->compile()
3578 or return "($perror) can't compile template: $Text::Template::ERROR";
3580 my $templ_hash = { error => $transaction->error_message };
3582 my $error = send_email(
3583 'from' => $conf->config('invoice_from'),
3584 'to' => [ grep { $_ ne 'POST' } $self->invoicing_list ],
3585 'subject' => 'Your payment could not be processed',
3586 'body' => [ $template->fill_in(HASH => $templ_hash) ],
3589 $perror .= " (also received error sending decline notification: $error)"
3594 $cust_pay_pending->status('done');
3595 $cust_pay_pending->statustext("declined: $perror");
3596 my $cpp_done_err = $cust_pay_pending->replace;
3597 if ( $cpp_done_err ) {
3598 my $e = "WARNING: $method declined but pending payment not resolved - ".
3599 "error updating status for paypendingnum ".
3600 $cust_pay_pending->paypendingnum. ": $cpp_done_err \n";
3602 $perror = "$e ($perror)";
3615 my( $self, $method, $amount, %options ) = @_;
3617 if ( $options{'fake_failure'} ) {
3618 return "Error: No error; test failure requested with fake_failure";
3621 my %method2payby = (
3628 #if ( $payment_gateway ) { # agent override
3629 # $paybatch = $payment_gateway->gatewaynum. '-';
3632 #$paybatch .= "$processor:". $transaction->authorization;
3634 #$paybatch .= ':'. $transaction->order_number
3635 # if $transaction->can('order_number')
3636 # && length($transaction->order_number);
3638 my $paybatch = 'FakeProcessor:54:32';
3640 my $cust_pay = new FS::cust_pay ( {
3641 'custnum' => $self->custnum,
3642 'invnum' => $options{'invnum'},
3645 'payby' => $method2payby{$method},
3646 #'payinfo' => $payinfo,
3647 'payinfo' => '4111111111111111',
3648 'paybatch' => $paybatch,
3649 #'paydate' => $paydate,
3650 'paydate' => '2012-05-01',
3652 $cust_pay->payunique( $options{payunique} ) if length($options{payunique});
3654 my $error = $cust_pay->insert($options{'manual'} ? ( 'manual' => 1 ) : () );
3657 $cust_pay->invnum(''); #try again with no specific invnum
3658 my $error2 = $cust_pay->insert( $options{'manual'} ?
3659 ( 'manual' => 1 ) : ()
3662 # gah, even with transactions.
3663 my $e = 'WARNING: Card/ACH debited but database not updated - '.
3664 "error inserting (fake!) payment: $error2".
3665 " (previously tried insert with invnum #$options{'invnum'}" .
3672 if ( $options{'paynum_ref'} ) {
3673 ${ $options{'paynum_ref'} } = $cust_pay->paynum;
3676 return ''; #no error
3680 =item default_payment_gateway
3684 sub default_payment_gateway {
3685 my( $self, $method ) = @_;
3687 die "Real-time processing not enabled\n"
3688 unless $conf->exists('business-onlinepayment');
3691 my $bop_config = 'business-onlinepayment';
3692 $bop_config .= '-ach'
3693 if $method =~ /^(ECHECK|CHEK)$/ && $conf->exists($bop_config. '-ach');
3694 my ( $processor, $login, $password, $action, @bop_options ) =
3695 $conf->config($bop_config);
3696 $action ||= 'normal authorization';
3697 pop @bop_options if scalar(@bop_options) % 2 && $bop_options[-1] =~ /^\s*$/;
3698 die "No real-time processor is enabled - ".
3699 "did you set the business-onlinepayment configuration value?\n"
3702 ( $processor, $login, $password, $action, @bop_options )
3707 Removes the I<paycvv> field from the database directly.
3709 If there is an error, returns the error, otherwise returns false.
3715 my $sth = dbh->prepare("UPDATE cust_main SET paycvv = '' WHERE custnum = ?")
3716 or return dbh->errstr;
3717 $sth->execute($self->custnum)
3718 or return $sth->errstr;
3723 =item realtime_refund_bop METHOD [ OPTION => VALUE ... ]
3725 Refunds a realtime credit card, ACH (electronic check) or phone bill transaction
3726 via a Business::OnlinePayment realtime gateway. See
3727 L<http://420.am/business-onlinepayment> for supported gateways.
3729 Available methods are: I<CC>, I<ECHECK> and I<LEC>
3731 Available options are: I<amount>, I<reason>, I<paynum>, I<paydate>
3733 Most gateways require a reference to an original payment transaction to refund,
3734 so you probably need to specify a I<paynum>.
3736 I<amount> defaults to the original amount of the payment if not specified.
3738 I<reason> specifies a reason for the refund.
3740 I<paydate> specifies the expiration date for a credit card overriding the
3741 value from the customer record or the payment record. Specified as yyyy-mm-dd
3743 Implementation note: If I<amount> is unspecified or equal to the amount of the
3744 orignal payment, first an attempt is made to "void" the transaction via
3745 the gateway (to cancel a not-yet settled transaction) and then if that fails,
3746 the normal attempt is made to "refund" ("credit") the transaction via the
3747 gateway is attempted.
3749 #The additional options I<payname>, I<address1>, I<address2>, I<city>, I<state>,
3750 #I<zip>, I<payinfo> and I<paydate> are also available. Any of these options,
3751 #if set, will override the value from the customer record.
3753 #If an I<invnum> is specified, this payment (if successful) is applied to the
3754 #specified invoice. If you don't specify an I<invnum> you might want to
3755 #call the B<apply_payments> method.
3759 #some false laziness w/realtime_bop, not enough to make it worth merging
3760 #but some useful small subs should be pulled out
3761 sub realtime_refund_bop {
3762 my( $self, $method, %options ) = @_;
3764 warn "$me realtime_refund_bop: $method refund\n";
3765 warn " $_ => $options{$_}\n" foreach keys %options;
3768 eval "use Business::OnlinePayment";
3772 # look up the original payment and optionally a gateway for that payment
3776 my $amount = $options{'amount'};
3778 my( $processor, $login, $password, @bop_options ) ;
3779 my( $auth, $order_number ) = ( '', '', '' );
3781 if ( $options{'paynum'} ) {
3783 warn " paynum: $options{paynum}\n" if $DEBUG > 1;
3784 $cust_pay = qsearchs('cust_pay', { paynum=>$options{'paynum'} } )
3785 or return "Unknown paynum $options{'paynum'}";
3786 $amount ||= $cust_pay->paid;
3788 $cust_pay->paybatch =~ /^((\d+)\-)?(\w+):\s*([\w\-\/ ]*)(:([\w\-]+))?$/
3789 or return "Can't parse paybatch for paynum $options{'paynum'}: ".
3790 $cust_pay->paybatch;
3791 my $gatewaynum = '';
3792 ( $gatewaynum, $processor, $auth, $order_number ) = ( $2, $3, $4, $6 );
3794 if ( $gatewaynum ) { #gateway for the payment to be refunded
3796 my $payment_gateway =
3797 qsearchs('payment_gateway', { 'gatewaynum' => $gatewaynum } );
3798 die "payment gateway $gatewaynum not found"
3799 unless $payment_gateway;
3801 $processor = $payment_gateway->gateway_module;
3802 $login = $payment_gateway->gateway_username;
3803 $password = $payment_gateway->gateway_password;
3804 @bop_options = $payment_gateway->options;
3806 } else { #try the default gateway
3808 my( $conf_processor, $unused_action );
3809 ( $conf_processor, $login, $password, $unused_action, @bop_options ) =
3810 $self->default_payment_gateway($method);
3812 return "processor of payment $options{'paynum'} $processor does not".
3813 " match default processor $conf_processor"
3814 unless $processor eq $conf_processor;
3819 } else { # didn't specify a paynum, so look for agent gateway overrides
3820 # like a normal transaction
3823 if ( $method eq 'CC' ) {
3824 $cardtype = cardtype($self->payinfo);
3825 } elsif ( $method eq 'ECHECK' ) {
3828 $cardtype = $method;
3831 qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3832 cardtype => $cardtype,
3834 || qsearchs('agent_payment_gateway', { agentnum => $self->agentnum,
3836 taxclass => '', } );
3838 if ( $override ) { #use a payment gateway override
3840 my $payment_gateway = $override->payment_gateway;
3842 $processor = $payment_gateway->gateway_module;
3843 $login = $payment_gateway->gateway_username;
3844 $password = $payment_gateway->gateway_password;
3845 #$action = $payment_gateway->gateway_action;
3846 @bop_options = $payment_gateway->options;
3848 } else { #use the standard settings from the config
3851 ( $processor, $login, $password, $unused_action, @bop_options ) =
3852 $self->default_payment_gateway($method);
3857 return "neither amount nor paynum specified" unless $amount;
3862 'password' => $password,
3863 'order_number' => $order_number,
3864 'amount' => $amount,
3865 'referer' => 'http://cleanwhisker.420.am/',
3867 $content{authorization} = $auth
3868 if length($auth); #echeck/ACH transactions have an order # but no auth
3869 #(at least with authorize.net)
3871 my $disable_void_after;
3872 if ($conf->exists('disable_void_after')
3873 && $conf->config('disable_void_after') =~ /^(\d+)$/) {
3874 $disable_void_after = $1;
3877 #first try void if applicable
3878 if ( $cust_pay && $cust_pay->paid == $amount
3880 ( not defined($disable_void_after) )
3881 || ( time < ($cust_pay->_date + $disable_void_after ) )
3884 warn " attempting void\n" if $DEBUG > 1;
3885 my $void = new Business::OnlinePayment( $processor, @bop_options );
3886 $void->content( 'action' => 'void', %content );
3888 if ( $void->is_success ) {
3889 my $error = $cust_pay->void($options{'reason'});
3891 # gah, even with transactions.
3892 my $e = 'WARNING: Card/ACH voided but database not updated - '.
3893 "error voiding payment: $error";
3897 warn " void successful\n" if $DEBUG > 1;
3902 warn " void unsuccessful, trying refund\n"
3906 my $address = $self->address1;
3907 $address .= ", ". $self->address2 if $self->address2;
3909 my($payname, $payfirst, $paylast);
3910 if ( $self->payname && $method ne 'ECHECK' ) {
3911 $payname = $self->payname;
3912 $payname =~ /^\s*([\w \,\.\-\']*)?\s+([\w\,\.\-\']+)\s*$/
3913 or return "Illegal payname $payname";
3914 ($payfirst, $paylast) = ($1, $2);
3916 $payfirst = $self->getfield('first');
3917 $paylast = $self->getfield('last');
3918 $payname = "$payfirst $paylast";
3921 my @invoicing_list = $self->invoicing_list_emailonly;
3922 if ( $conf->exists('emailinvoiceautoalways')
3923 || $conf->exists('emailinvoiceauto') && ! @invoicing_list
3924 || ( $conf->exists('emailinvoiceonly') && ! @invoicing_list ) ) {
3925 push @invoicing_list, $self->all_emails;
3928 my $email = ($conf->exists('business-onlinepayment-email-override'))
3929 ? $conf->config('business-onlinepayment-email-override')
3930 : $invoicing_list[0];
3932 my $payip = exists($options{'payip'})
3935 $content{customer_ip} = $payip
3939 if ( $method eq 'CC' ) {
3942 $content{card_number} = $payinfo = $cust_pay->payinfo;
3943 (exists($options{'paydate'}) ? $options{'paydate'} : $cust_pay->paydate)
3944 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/ &&
3945 ($content{expiration} = "$2/$1"); # where available
3947 $content{card_number} = $payinfo = $self->payinfo;
3948 (exists($options{'paydate'}) ? $options{'paydate'} : $self->paydate)
3949 =~ /^\d{2}(\d{2})[\/\-](\d+)[\/\-]\d+$/;
3950 $content{expiration} = "$2/$1";
3953 } elsif ( $method eq 'ECHECK' ) {
3956 $payinfo = $cust_pay->payinfo;
3958 $payinfo = $self->payinfo;
3960 ( $content{account_number}, $content{routing_code} )= split('@', $payinfo );
3961 $content{bank_name} = $self->payname;
3962 $content{account_type} = 'CHECKING';
3963 $content{account_name} = $payname;
3964 $content{customer_org} = $self->company ? 'B' : 'I';
3965 $content{customer_ssn} = $self->ss;
3966 } elsif ( $method eq 'LEC' ) {
3967 $content{phone} = $payinfo = $self->payinfo;
3971 my $refund = new Business::OnlinePayment( $processor, @bop_options );
3972 my %sub_content = $refund->content(
3973 'action' => 'credit',
3974 'customer_id' => $self->custnum,
3975 'last_name' => $paylast,
3976 'first_name' => $payfirst,
3978 'address' => $address,
3979 'city' => $self->city,
3980 'state' => $self->state,
3981 'zip' => $self->zip,
3982 'country' => $self->country,
3984 'phone' => $self->daytime || $self->night,
3987 warn join('', map { " $_ => $sub_content{$_}\n" } keys %sub_content )
3991 return "$processor error: ". $refund->error_message
3992 unless $refund->is_success();
3994 my %method2payby = (
4000 my $paybatch = "$processor:". $refund->authorization;
4001 $paybatch .= ':'. $refund->order_number
4002 if $refund->can('order_number') && $refund->order_number;
4004 while ( $cust_pay && $cust_pay->unapplied < $amount ) {
4005 my @cust_bill_pay = $cust_pay->cust_bill_pay;
4006 last unless @cust_bill_pay;
4007 my $cust_bill_pay = pop @cust_bill_pay;
4008 my $error = $cust_bill_pay->delete;
4012 my $cust_refund = new FS::cust_refund ( {
4013 'custnum' => $self->custnum,
4014 'paynum' => $options{'paynum'},
4015 'refund' => $amount,
4017 'payby' => $method2payby{$method},
4018 'payinfo' => $payinfo,
4019 'paybatch' => $paybatch,
4020 'reason' => $options{'reason'} || 'card or ACH refund',
4022 my $error = $cust_refund->insert;
4024 $cust_refund->paynum(''); #try again with no specific paynum
4025 my $error2 = $cust_refund->insert;
4027 # gah, even with transactions.
4028 my $e = 'WARNING: Card/ACH refunded but database not updated - '.
4029 "error inserting refund ($processor): $error2".
4030 " (previously tried insert with paynum #$options{'paynum'}" .
4041 =item batch_card OPTION => VALUE...
4043 Adds a payment for this invoice to the pending credit card batch (see
4044 L<FS::cust_pay_batch>), or, if the B<realtime> option is set to a true value,
4045 runs the payment using a realtime gateway.
4050 my ($self, %options) = @_;
4053 if (exists($options{amount})) {
4054 $amount = $options{amount};
4056 $amount = sprintf("%.2f", $self->balance - $self->in_transit_payments);
4058 return '' unless $amount > 0;
4060 my $invnum = delete $options{invnum};
4061 my $payby = $options{invnum} || $self->payby; #dubious
4063 if ($options{'realtime'}) {
4064 return $self->realtime_bop( FS::payby->payby2bop($self->payby),
4070 my $oldAutoCommit = $FS::UID::AutoCommit;
4071 local $FS::UID::AutoCommit = 0;
4074 #this needs to handle mysql as well as Pg, like svc_acct.pm
4075 #(make it into a common function if folks need to do batching with mysql)
4076 $dbh->do("LOCK TABLE pay_batch IN SHARE ROW EXCLUSIVE MODE")
4077 or return "Cannot lock pay_batch: " . $dbh->errstr;
4081 'payby' => FS::payby->payby2payment($payby),
4084 my $pay_batch = qsearchs( 'pay_batch', \%pay_batch );
4086 unless ( $pay_batch ) {
4087 $pay_batch = new FS::pay_batch \%pay_batch;
4088 my $error = $pay_batch->insert;
4090 $dbh->rollback if $oldAutoCommit;
4091 die "error creating new batch: $error\n";
4095 my $old_cust_pay_batch = qsearchs('cust_pay_batch', {
4096 'batchnum' => $pay_batch->batchnum,
4097 'custnum' => $self->custnum,
4100 foreach (qw( address1 address2 city state zip country payby payinfo paydate
4102 $options{$_} = '' unless exists($options{$_});
4105 my $cust_pay_batch = new FS::cust_pay_batch ( {
4106 'batchnum' => $pay_batch->batchnum,
4107 'invnum' => $invnum || 0, # is there a better value?
4108 # this field should be
4110 # cust_bill_pay_batch now
4111 'custnum' => $self->custnum,
4112 'last' => $self->getfield('last'),
4113 'first' => $self->getfield('first'),
4114 'address1' => $options{address1} || $self->address1,
4115 'address2' => $options{address2} || $self->address2,
4116 'city' => $options{city} || $self->city,
4117 'state' => $options{state} || $self->state,
4118 'zip' => $options{zip} || $self->zip,
4119 'country' => $options{country} || $self->country,
4120 'payby' => $options{payby} || $self->payby,
4121 'payinfo' => $options{payinfo} || $self->payinfo,
4122 'exp' => $options{paydate} || $self->paydate,
4123 'payname' => $options{payname} || $self->payname,
4124 'amount' => $amount, # consolidating
4127 $cust_pay_batch->paybatchnum($old_cust_pay_batch->paybatchnum)
4128 if $old_cust_pay_batch;
4131 if ($old_cust_pay_batch) {
4132 $error = $cust_pay_batch->replace($old_cust_pay_batch)
4134 $error = $cust_pay_batch->insert;
4138 $dbh->rollback if $oldAutoCommit;
4142 my $unapplied = $self->total_credited + $self->total_unapplied_payments + $self->in_transit_payments;
4143 foreach my $cust_bill ($self->open_cust_bill) {
4144 #$dbh->commit or die $dbh->errstr if $oldAutoCommit;
4145 my $cust_bill_pay_batch = new FS::cust_bill_pay_batch {
4146 'invnum' => $cust_bill->invnum,
4147 'paybatchnum' => $cust_pay_batch->paybatchnum,
4148 'amount' => $cust_bill->owed,
4151 if ($unapplied >= $cust_bill_pay_batch->amount){
4152 $unapplied -= $cust_bill_pay_batch->amount;
4155 $cust_bill_pay_batch->amount(sprintf ( "%.2f",
4156 $cust_bill_pay_batch->amount - $unapplied )); $unapplied = 0;
4158 $error = $cust_bill_pay_batch->insert;
4160 $dbh->rollback if $oldAutoCommit;
4165 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4171 Returns the total owed for this customer on all invoices
4172 (see L<FS::cust_bill/owed>).
4178 $self->total_owed_date(2145859200); #12/31/2037
4181 =item total_owed_date TIME
4183 Returns the total owed for this customer on all invoices with date earlier than
4184 TIME. TIME is specified as a UNIX timestamp; see L<perlfunc/"time">). Also
4185 see L<Time::Local> and L<Date::Parse> for conversion functions.
4189 sub total_owed_date {
4193 foreach my $cust_bill (
4194 grep { $_->_date <= $time }
4195 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4197 $total_bill += $cust_bill->owed;
4199 sprintf( "%.2f", $total_bill );
4202 =item apply_payments_and_credits
4204 Applies unapplied payments and credits.
4206 In most cases, this new method should be used in place of sequential
4207 apply_payments and apply_credits methods.
4209 If there is an error, returns the error, otherwise returns false.
4213 sub apply_payments_and_credits {
4216 local $SIG{HUP} = 'IGNORE';
4217 local $SIG{INT} = 'IGNORE';
4218 local $SIG{QUIT} = 'IGNORE';
4219 local $SIG{TERM} = 'IGNORE';
4220 local $SIG{TSTP} = 'IGNORE';
4221 local $SIG{PIPE} = 'IGNORE';
4223 my $oldAutoCommit = $FS::UID::AutoCommit;
4224 local $FS::UID::AutoCommit = 0;
4227 $self->select_for_update; #mutex
4229 foreach my $cust_bill ( $self->open_cust_bill ) {
4230 my $error = $cust_bill->apply_payments_and_credits;
4232 $dbh->rollback if $oldAutoCommit;
4233 return "Error applying: $error";
4237 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4242 =item apply_credits OPTION => VALUE ...
4244 Applies (see L<FS::cust_credit_bill>) unapplied credits (see L<FS::cust_credit>)
4245 to outstanding invoice balances in chronological order (or reverse
4246 chronological order if the I<order> option is set to B<newest>) and returns the
4247 value of any remaining unapplied credits available for refund (see
4248 L<FS::cust_refund>).
4250 Dies if there is an error.
4258 local $SIG{HUP} = 'IGNORE';
4259 local $SIG{INT} = 'IGNORE';
4260 local $SIG{QUIT} = 'IGNORE';
4261 local $SIG{TERM} = 'IGNORE';
4262 local $SIG{TSTP} = 'IGNORE';
4263 local $SIG{PIPE} = 'IGNORE';
4265 my $oldAutoCommit = $FS::UID::AutoCommit;
4266 local $FS::UID::AutoCommit = 0;
4269 $self->select_for_update; #mutex
4271 unless ( $self->total_credited ) {
4272 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4276 my @credits = sort { $b->_date <=> $a->_date} (grep { $_->credited > 0 }
4277 qsearch('cust_credit', { 'custnum' => $self->custnum } ) );
4279 my @invoices = $self->open_cust_bill;
4280 @invoices = sort { $b->_date <=> $a->_date } @invoices
4281 if defined($opt{'order'}) && $opt{'order'} eq 'newest';
4284 foreach my $cust_bill ( @invoices ) {
4287 if ( !defined($credit) || $credit->credited == 0) {
4288 $credit = pop @credits or last;
4291 if ($cust_bill->owed >= $credit->credited) {
4292 $amount=$credit->credited;
4294 $amount=$cust_bill->owed;
4297 my $cust_credit_bill = new FS::cust_credit_bill ( {
4298 'crednum' => $credit->crednum,
4299 'invnum' => $cust_bill->invnum,
4300 'amount' => $amount,
4302 my $error = $cust_credit_bill->insert;
4304 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4308 redo if ($cust_bill->owed > 0);
4312 my $total_credited = $self->total_credited;
4314 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4316 return $total_credited;
4319 =item apply_payments
4321 Applies (see L<FS::cust_bill_pay>) unapplied payments (see L<FS::cust_pay>)
4322 to outstanding invoice balances in chronological order.
4324 #and returns the value of any remaining unapplied payments.
4326 Dies if there is an error.
4330 sub apply_payments {
4333 local $SIG{HUP} = 'IGNORE';
4334 local $SIG{INT} = 'IGNORE';
4335 local $SIG{QUIT} = 'IGNORE';
4336 local $SIG{TERM} = 'IGNORE';
4337 local $SIG{TSTP} = 'IGNORE';
4338 local $SIG{PIPE} = 'IGNORE';
4340 my $oldAutoCommit = $FS::UID::AutoCommit;
4341 local $FS::UID::AutoCommit = 0;
4344 $self->select_for_update; #mutex
4348 my @payments = sort { $b->_date <=> $a->_date } ( grep { $_->unapplied > 0 }
4349 qsearch('cust_pay', { 'custnum' => $self->custnum } ) );
4351 my @invoices = sort { $a->_date <=> $b->_date} (grep { $_->owed > 0 }
4352 qsearch('cust_bill', { 'custnum' => $self->custnum } ) );
4356 foreach my $cust_bill ( @invoices ) {
4359 if ( !defined($payment) || $payment->unapplied == 0 ) {
4360 $payment = pop @payments or last;
4363 if ( $cust_bill->owed >= $payment->unapplied ) {
4364 $amount = $payment->unapplied;
4366 $amount = $cust_bill->owed;
4369 my $cust_bill_pay = new FS::cust_bill_pay ( {
4370 'paynum' => $payment->paynum,
4371 'invnum' => $cust_bill->invnum,
4372 'amount' => $amount,
4374 my $error = $cust_bill_pay->insert;
4376 $dbh->rollback or die $dbh->errstr if $oldAutoCommit;
4380 redo if ( $cust_bill->owed > 0);
4384 my $total_unapplied_payments = $self->total_unapplied_payments;
4386 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4388 return $total_unapplied_payments;
4391 =item total_credited
4393 Returns the total outstanding credit (see L<FS::cust_credit>) for this
4394 customer. See L<FS::cust_credit/credited>.
4398 sub total_credited {
4400 my $total_credit = 0;
4401 foreach my $cust_credit ( qsearch('cust_credit', {
4402 'custnum' => $self->custnum,
4404 $total_credit += $cust_credit->credited;
4406 sprintf( "%.2f", $total_credit );
4409 =item total_unapplied_payments
4411 Returns the total unapplied payments (see L<FS::cust_pay>) for this customer.
4412 See L<FS::cust_pay/unapplied>.
4416 sub total_unapplied_payments {
4418 my $total_unapplied = 0;
4419 foreach my $cust_pay ( qsearch('cust_pay', {
4420 'custnum' => $self->custnum,
4422 $total_unapplied += $cust_pay->unapplied;
4424 sprintf( "%.2f", $total_unapplied );
4427 =item total_unapplied_refunds
4429 Returns the total unrefunded refunds (see L<FS::cust_refund>) for this
4430 customer. See L<FS::cust_refund/unapplied>.
4434 sub total_unapplied_refunds {
4436 my $total_unapplied = 0;
4437 foreach my $cust_refund ( qsearch('cust_refund', {
4438 'custnum' => $self->custnum,
4440 $total_unapplied += $cust_refund->unapplied;
4442 sprintf( "%.2f", $total_unapplied );
4447 Returns the balance for this customer (total_owed plus total_unrefunded, minus
4448 total_credited minus total_unapplied_payments).
4456 + $self->total_unapplied_refunds
4457 - $self->total_credited
4458 - $self->total_unapplied_payments
4462 =item balance_date TIME
4464 Returns the balance for this customer, only considering invoices with date
4465 earlier than TIME (total_owed_date minus total_credited minus
4466 total_unapplied_payments). TIME is specified as a UNIX timestamp; see
4467 L<perlfunc/"time">). Also see L<Time::Local> and L<Date::Parse> for conversion
4476 $self->total_owed_date($time)
4477 + $self->total_unapplied_refunds
4478 - $self->total_credited
4479 - $self->total_unapplied_payments
4483 =item in_transit_payments
4485 Returns the total of requests for payments for this customer pending in
4486 batches in transit to the bank. See L<FS::pay_batch> and L<FS::cust_pay_batch>
4490 sub in_transit_payments {
4492 my $in_transit_payments = 0;
4493 foreach my $pay_batch ( qsearch('pay_batch', {
4496 foreach my $cust_pay_batch ( qsearch('cust_pay_batch', {
4497 'batchnum' => $pay_batch->batchnum,
4498 'custnum' => $self->custnum,
4500 $in_transit_payments += $cust_pay_batch->amount;
4503 sprintf( "%.2f", $in_transit_payments );
4506 =item paydate_monthyear
4508 Returns a two-element list consisting of the month and year of this customer's
4509 paydate (credit card expiration date for CARD customers)
4513 sub paydate_monthyear {
4515 if ( $self->paydate =~ /^(\d{4})-(\d{1,2})-\d{1,2}$/ ) { #Pg date format
4517 } elsif ( $self->paydate =~ /^(\d{1,2})-(\d{1,2}-)?(\d{4}$)/ ) {
4524 =item invoicing_list [ ARRAYREF ]
4526 If an arguement is given, sets these email addresses as invoice recipients
4527 (see L<FS::cust_main_invoice>). Errors are not fatal and are not reported
4528 (except as warnings), so use check_invoicing_list first.
4530 Returns a list of email addresses (with svcnum entries expanded).
4532 Note: You can clear the invoicing list by passing an empty ARRAYREF. You can
4533 check it without disturbing anything by passing nothing.
4535 This interface may change in the future.
4539 sub invoicing_list {
4540 my( $self, $arrayref ) = @_;
4543 my @cust_main_invoice;
4544 if ( $self->custnum ) {
4545 @cust_main_invoice =
4546 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4548 @cust_main_invoice = ();
4550 foreach my $cust_main_invoice ( @cust_main_invoice ) {
4551 #warn $cust_main_invoice->destnum;
4552 unless ( grep { $cust_main_invoice->address eq $_ } @{$arrayref} ) {
4553 #warn $cust_main_invoice->destnum;
4554 my $error = $cust_main_invoice->delete;
4555 warn $error if $error;
4558 if ( $self->custnum ) {
4559 @cust_main_invoice =
4560 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4562 @cust_main_invoice = ();
4564 my %seen = map { $_->address => 1 } @cust_main_invoice;
4565 foreach my $address ( @{$arrayref} ) {
4566 next if exists $seen{$address} && $seen{$address};
4567 $seen{$address} = 1;
4568 my $cust_main_invoice = new FS::cust_main_invoice ( {
4569 'custnum' => $self->custnum,
4572 my $error = $cust_main_invoice->insert;
4573 warn $error if $error;
4577 if ( $self->custnum ) {
4579 qsearch( 'cust_main_invoice', { 'custnum' => $self->custnum } );
4586 =item check_invoicing_list ARRAYREF
4588 Checks these arguements as valid input for the invoicing_list method. If there
4589 is an error, returns the error, otherwise returns false.
4593 sub check_invoicing_list {
4594 my( $self, $arrayref ) = @_;
4596 foreach my $address ( @$arrayref ) {
4598 if ($address eq 'FAX' and $self->getfield('fax') eq '') {
4599 return 'Can\'t add FAX invoice destination with a blank FAX number.';
4602 my $cust_main_invoice = new FS::cust_main_invoice ( {
4603 'custnum' => $self->custnum,
4606 my $error = $self->custnum
4607 ? $cust_main_invoice->check
4608 : $cust_main_invoice->checkdest
4610 return $error if $error;
4614 return "Email address required"
4615 if $conf->exists('cust_main-require_invoicing_list_email')
4616 && ! grep { $_ !~ /^([A-Z]+)$/ } @$arrayref;
4621 =item set_default_invoicing_list
4623 Sets the invoicing list to all accounts associated with this customer,
4624 overwriting any previous invoicing list.
4628 sub set_default_invoicing_list {
4630 $self->invoicing_list($self->all_emails);
4635 Returns the email addresses of all accounts provisioned for this customer.
4642 foreach my $cust_pkg ( $self->all_pkgs ) {
4643 my @cust_svc = qsearch('cust_svc', { 'pkgnum' => $cust_pkg->pkgnum } );
4645 map { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4646 grep { qsearchs('svc_acct', { 'svcnum' => $_->svcnum } ) }
4648 $list{$_}=1 foreach map { $_->email } @svc_acct;
4653 =item invoicing_list_addpost
4655 Adds postal invoicing to this customer. If this customer is already configured
4656 to receive postal invoices, does nothing.
4660 sub invoicing_list_addpost {
4662 return if grep { $_ eq 'POST' } $self->invoicing_list;
4663 my @invoicing_list = $self->invoicing_list;
4664 push @invoicing_list, 'POST';
4665 $self->invoicing_list(\@invoicing_list);
4668 =item invoicing_list_emailonly
4670 Returns the list of email invoice recipients (invoicing_list without non-email
4671 destinations such as POST and FAX).
4675 sub invoicing_list_emailonly {
4677 warn "$me invoicing_list_emailonly called"
4679 grep { $_ !~ /^([A-Z]+)$/ } $self->invoicing_list;
4682 =item invoicing_list_emailonly_scalar
4684 Returns the list of email invoice recipients (invoicing_list without non-email
4685 destinations such as POST and FAX) as a comma-separated scalar.
4689 sub invoicing_list_emailonly_scalar {
4691 warn "$me invoicing_list_emailonly_scalar called"
4693 join(', ', $self->invoicing_list_emailonly);
4696 =item referral_cust_main [ DEPTH [ EXCLUDE_HASHREF ] ]
4698 Returns an array of customers referred by this customer (referral_custnum set
4699 to this custnum). If DEPTH is given, recurses up to the given depth, returning
4700 customers referred by customers referred by this customer and so on, inclusive.
4701 The default behavior is DEPTH 1 (no recursion).
4705 sub referral_cust_main {
4707 my $depth = @_ ? shift : 1;
4708 my $exclude = @_ ? shift : {};
4711 map { $exclude->{$_->custnum}++; $_; }
4712 grep { ! $exclude->{ $_->custnum } }
4713 qsearch( 'cust_main', { 'referral_custnum' => $self->custnum } );
4717 map { $_->referral_cust_main($depth-1, $exclude) }
4724 =item referral_cust_main_ncancelled
4726 Same as referral_cust_main, except only returns customers with uncancelled
4731 sub referral_cust_main_ncancelled {
4733 grep { scalar($_->ncancelled_pkgs) } $self->referral_cust_main;
4736 =item referral_cust_pkg [ DEPTH ]
4738 Like referral_cust_main, except returns a flat list of all unsuspended (and
4739 uncancelled) packages for each customer. The number of items in this list may
4740 be useful for comission calculations (perhaps after a C<grep { my $pkgpart = $_->pkgpart; grep { $_ == $pkgpart } @commission_worthy_pkgparts> } $cust_main-> ).
4744 sub referral_cust_pkg {
4746 my $depth = @_ ? shift : 1;
4748 map { $_->unsuspended_pkgs }
4749 grep { $_->unsuspended_pkgs }
4750 $self->referral_cust_main($depth);
4753 =item referring_cust_main
4755 Returns the single cust_main record for the customer who referred this customer
4756 (referral_custnum), or false.
4760 sub referring_cust_main {
4762 return '' unless $self->referral_custnum;
4763 qsearchs('cust_main', { 'custnum' => $self->referral_custnum } );
4766 =item credit AMOUNT, REASON
4768 Applies a credit to this customer. If there is an error, returns the error,
4769 otherwise returns false.
4774 my( $self, $amount, $reason, %options ) = @_;
4775 my $cust_credit = new FS::cust_credit {
4776 'custnum' => $self->custnum,
4777 'amount' => $amount,
4778 'reason' => $reason,
4780 $cust_credit->insert(%options);
4783 =item charge AMOUNT [ PKG [ COMMENT [ TAXCLASS ] ] ]
4785 Creates a one-time charge for this customer. If there is an error, returns
4786 the error, otherwise returns false.
4792 my ( $amount, $quantity, $pkg, $comment, $taxclass, $additional, $classnum );
4793 if ( ref( $_[0] ) ) {
4794 $amount = $_[0]->{amount};
4795 $quantity = exists($_[0]->{quantity}) ? $_[0]->{quantity} : 1;
4796 $pkg = exists($_[0]->{pkg}) ? $_[0]->{pkg} : 'One-time charge';
4797 $comment = exists($_[0]->{comment}) ? $_[0]->{comment}
4798 : '$'. sprintf("%.2f",$amount);
4799 $taxclass = exists($_[0]->{taxclass}) ? $_[0]->{taxclass} : '';
4800 $classnum = exists($_[0]->{classnum}) ? $_[0]->{classnum} : '';
4801 $additional = $_[0]->{additional};
4805 $pkg = @_ ? shift : 'One-time charge';
4806 $comment = @_ ? shift : '$'. sprintf("%.2f",$amount);
4807 $taxclass = @_ ? shift : '';
4811 local $SIG{HUP} = 'IGNORE';
4812 local $SIG{INT} = 'IGNORE';
4813 local $SIG{QUIT} = 'IGNORE';
4814 local $SIG{TERM} = 'IGNORE';
4815 local $SIG{TSTP} = 'IGNORE';
4816 local $SIG{PIPE} = 'IGNORE';
4818 my $oldAutoCommit = $FS::UID::AutoCommit;
4819 local $FS::UID::AutoCommit = 0;
4822 my $part_pkg = new FS::part_pkg ( {
4824 'comment' => $comment,
4828 'classnum' => $classnum ? $classnum : '',
4829 'taxclass' => $taxclass,
4832 my %options = ( ( map { ("additional_info$_" => $additional->[$_] ) }
4833 ( 0 .. @$additional - 1 )
4835 'additional_count' => scalar(@$additional),
4836 'setup_fee' => $amount,
4839 my $error = $part_pkg->insert( options => \%options );
4841 $dbh->rollback if $oldAutoCommit;
4845 my $pkgpart = $part_pkg->pkgpart;
4846 my %type_pkgs = ( 'typenum' => $self->agent->typenum, 'pkgpart' => $pkgpart );
4847 unless ( qsearchs('type_pkgs', \%type_pkgs ) ) {
4848 my $type_pkgs = new FS::type_pkgs \%type_pkgs;
4849 $error = $type_pkgs->insert;
4851 $dbh->rollback if $oldAutoCommit;
4856 my $cust_pkg = new FS::cust_pkg ( {
4857 'custnum' => $self->custnum,
4858 'pkgpart' => $pkgpart,
4859 'quantity' => $quantity,
4862 $error = $cust_pkg->insert;
4864 $dbh->rollback if $oldAutoCommit;
4868 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
4873 #=item charge_postal_fee
4875 #Applies a one time charge this customer. If there is an error,
4876 #returns the error, returns the cust_pkg charge object or false
4877 #if there was no charge.
4881 # This should be a customer event. For that to work requires that bill
4882 # also be a customer event.
4884 sub charge_postal_fee {
4887 my $pkgpart = $conf->config('postal_invoice-fee_pkgpart');
4888 return '' unless ($pkgpart && grep { $_ eq 'POST' } $self->invoicing_list);
4890 my $cust_pkg = new FS::cust_pkg ( {
4891 'custnum' => $self->custnum,
4892 'pkgpart' => $pkgpart,
4896 my $error = $cust_pkg->insert;
4897 $error ? $error : $cust_pkg;
4902 Returns all the invoices (see L<FS::cust_bill>) for this customer.
4908 sort { $a->_date <=> $b->_date }
4909 qsearch('cust_bill', { 'custnum' => $self->custnum, } )
4912 =item open_cust_bill
4914 Returns all the open (owed > 0) invoices (see L<FS::cust_bill>) for this
4919 sub open_cust_bill {
4921 grep { $_->owed > 0 } $self->cust_bill;
4926 Returns all the credits (see L<FS::cust_credit>) for this customer.
4932 sort { $a->_date <=> $b->_date }
4933 qsearch( 'cust_credit', { 'custnum' => $self->custnum } )
4938 Returns all the payments (see L<FS::cust_pay>) for this customer.
4944 sort { $a->_date <=> $b->_date }
4945 qsearch( 'cust_pay', { 'custnum' => $self->custnum } )
4950 Returns all voided payments (see L<FS::cust_pay_void>) for this customer.
4956 sort { $a->_date <=> $b->_date }
4957 qsearch( 'cust_pay_void', { 'custnum' => $self->custnum } )
4960 =item cust_pay_batch
4962 Returns all batched payments (see L<FS::cust_pay_void>) for this customer.
4966 sub cust_pay_batch {
4968 sort { $a->_date <=> $b->_date }
4969 qsearch( 'cust_pay_batch', { 'custnum' => $self->custnum } )
4974 Returns all the refunds (see L<FS::cust_refund>) for this customer.
4980 sort { $a->_date <=> $b->_date }
4981 qsearch( 'cust_refund', { 'custnum' => $self->custnum } )
4986 Returns a name string for this customer, either "Company (Last, First)" or
4993 my $name = $self->contact;
4994 $name = $self->company. " ($name)" if $self->company;
5000 Returns a name string for this (service/shipping) contact, either
5001 "Company (Last, First)" or "Last, First".
5007 if ( $self->get('ship_last') ) {
5008 my $name = $self->ship_contact;
5009 $name = $self->ship_company. " ($name)" if $self->ship_company;
5018 Returns this customer's full (billing) contact name only, "Last, First"
5024 $self->get('last'). ', '. $self->first;
5029 Returns this customer's full (shipping) contact name only, "Last, First"
5035 $self->get('ship_last')
5036 ? $self->get('ship_last'). ', '. $self->ship_first
5042 Returns this customer's full country name
5048 code2country($self->country);
5051 =item geocode DATA_VENDOR
5053 Returns a value for the customer location as encoded by DATA_VENDOR.
5054 Currently this only makes sense for "CCH" as DATA_VENDOR.
5059 my ($self, $data_vendor) = (shift, shift); #always cch for now
5061 my $prefix = ( $conf->exists('tax-ship_address') && length($self->ship_last) )
5065 my ($zip,$plus4) = split /-/, $self->get("${prefix}zip")
5066 if $self->country eq 'US';
5068 #CCH specific location stuff
5069 my $extra_sql = "AND plus4lo <= '$plus4' AND plus4hi >= '$plus4'";
5072 my $cust_tax_location =
5074 'table' => 'cust_tax_location',
5075 'hashref' => { 'zip' => $zip, 'data_vendor' => $data_vendor },
5076 'extra_sql' => $extra_sql,
5079 $geocode = $cust_tax_location->geocode
5080 if $cust_tax_location;
5089 Returns a status string for this customer, currently:
5093 =item prospect - No packages have ever been ordered
5095 =item active - One or more recurring packages is active
5097 =item inactive - No active recurring packages, but otherwise unsuspended/uncancelled (the inactive status is new - previously inactive customers were mis-identified as cancelled)
5099 =item suspended - All non-cancelled recurring packages are suspended
5101 =item cancelled - All recurring packages are cancelled
5107 sub status { shift->cust_status(@_); }
5111 for my $status (qw( prospect active inactive suspended cancelled )) {
5112 my $method = $status.'_sql';
5113 my $numnum = ( my $sql = $self->$method() ) =~ s/cust_main\.custnum/?/g;
5114 my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
5115 $sth->execute( ($self->custnum) x $numnum )
5116 or die "Error executing 'SELECT $sql': ". $sth->errstr;
5117 return $status if $sth->fetchrow_arrayref->[0];
5121 =item ucfirst_cust_status
5123 =item ucfirst_status
5125 Returns the status with the first character capitalized.
5129 sub ucfirst_status { shift->ucfirst_cust_status(@_); }
5131 sub ucfirst_cust_status {
5133 ucfirst($self->cust_status);
5138 Returns a hex triplet color string for this customer's status.
5142 use vars qw(%statuscolor);
5143 tie %statuscolor, 'Tie::IxHash',
5144 'prospect' => '7e0079', #'000000', #black? naw, purple
5145 'active' => '00CC00', #green
5146 'inactive' => '0000CC', #blue
5147 'suspended' => 'FF9900', #yellow
5148 'cancelled' => 'FF0000', #red
5151 sub statuscolor { shift->cust_statuscolor(@_); }
5153 sub cust_statuscolor {
5155 $statuscolor{$self->cust_status};
5160 Returns an array of hashes representing the customer's RT tickets.
5167 my $num = $conf->config('cust_main-max_tickets') || 10;
5170 unless ( $conf->config('ticket_system-custom_priority_field') ) {
5172 @tickets = @{ FS::TicketSystem->customer_tickets($self->custnum, $num) };
5176 foreach my $priority (
5177 $conf->config('ticket_system-custom_priority_field-values'), ''
5179 last if scalar(@tickets) >= $num;
5181 @{ FS::TicketSystem->customer_tickets( $self->custnum,
5182 $num - scalar(@tickets),
5191 # Return services representing svc_accts in customer support packages
5192 sub support_services {
5194 my %packages = map { $_ => 1 } $conf->config('support_packages');
5196 grep { $_->pkg_svc && $_->pkg_svc->primary_svc eq 'Y' }
5197 grep { $_->part_svc->svcdb eq 'svc_acct' }
5198 map { $_->cust_svc }
5199 grep { exists $packages{ $_->pkgpart } }
5200 $self->ncancelled_pkgs;
5206 =head1 CLASS METHODS
5212 Class method that returns the list of possible status strings for customers
5213 (see L<the status method|/status>). For example:
5215 @statuses = FS::cust_main->statuses();
5220 #my $self = shift; #could be class...
5226 Returns an SQL expression identifying prospective cust_main records (customers
5227 with no packages ever ordered)
5231 use vars qw($select_count_pkgs);
5232 $select_count_pkgs =
5233 "SELECT COUNT(*) FROM cust_pkg
5234 WHERE cust_pkg.custnum = cust_main.custnum";
5236 sub select_count_pkgs_sql {
5240 sub prospect_sql { "
5241 0 = ( $select_count_pkgs )
5246 Returns an SQL expression identifying active cust_main records (customers with
5247 active recurring packages).
5252 0 < ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. "
5258 Returns an SQL expression identifying inactive cust_main records (customers with
5259 no active recurring packages, but otherwise unsuspended/uncancelled).
5263 sub inactive_sql { "
5264 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5266 0 < ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5272 Returns an SQL expression identifying suspended cust_main records.
5277 sub suspended_sql { susp_sql(@_); }
5279 0 < ( $select_count_pkgs AND ". FS::cust_pkg->suspended_sql. " )
5281 0 = ( $select_count_pkgs AND ". FS::cust_pkg->active_sql. " )
5287 Returns an SQL expression identifying cancelled cust_main records.
5291 sub cancelled_sql { cancel_sql(@_); }
5294 my $recurring_sql = FS::cust_pkg->recurring_sql;
5295 my $cancelled_sql = FS::cust_pkg->cancelled_sql;
5298 0 < ( $select_count_pkgs )
5299 AND 0 < ( $select_count_pkgs AND $recurring_sql AND $cancelled_sql )
5300 AND 0 = ( $select_count_pkgs AND $recurring_sql
5301 AND ( cust_pkg.cancel IS NULL OR cust_pkg.cancel = 0 )
5303 AND 0 = ( $select_count_pkgs AND ". FS::cust_pkg->inactive_sql. " )
5309 =item uncancelled_sql
5311 Returns an SQL expression identifying un-cancelled cust_main records.
5315 sub uncancelled_sql { uncancel_sql(@_); }
5316 sub uncancel_sql { "
5317 ( 0 < ( $select_count_pkgs
5318 AND ( cust_pkg.cancel IS NULL
5319 OR cust_pkg.cancel = 0
5322 OR 0 = ( $select_count_pkgs )
5328 Returns an SQL fragment to retreive the balance.
5333 ( SELECT COALESCE( SUM(charged), 0 ) FROM cust_bill
5334 WHERE cust_bill.custnum = cust_main.custnum )
5335 - ( SELECT COALESCE( SUM(paid), 0 ) FROM cust_pay
5336 WHERE cust_pay.custnum = cust_main.custnum )
5337 - ( SELECT COALESCE( SUM(amount), 0 ) FROM cust_credit
5338 WHERE cust_credit.custnum = cust_main.custnum )
5339 + ( SELECT COALESCE( SUM(refund), 0 ) FROM cust_refund
5340 WHERE cust_refund.custnum = cust_main.custnum )
5343 =item balance_date_sql START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5345 Returns an SQL fragment to retreive the balance for this customer, only
5346 considering invoices with date earlier than START_TIME, and optionally not
5347 later than END_TIME (total_owed_date minus total_credited minus
5348 total_unapplied_payments).
5350 Times are specified as SQL fragments or numeric
5351 UNIX timestamps; see L<perlfunc/"time">). Also see L<Time::Local> and
5352 L<Date::Parse> for conversion functions. The empty string can be passed
5353 to disable that time constraint completely.
5355 Available options are:
5359 =item unapplied_date
5361 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)
5366 set to true to remove all customer comparison clauses, for totals
5371 WHERE clause hashref (elements "AND"ed together) (typically used with the total option)
5376 JOIN clause (typically used with the total option)
5382 sub balance_date_sql {
5383 my( $class, $start, $end, %opt ) = @_;
5385 my $owed = FS::cust_bill->owed_sql;
5386 my $unapp_refund = FS::cust_refund->unapplied_sql;
5387 my $unapp_credit = FS::cust_credit->unapplied_sql;
5388 my $unapp_pay = FS::cust_pay->unapplied_sql;
5390 my $j = $opt{'join'} || '';
5392 my $owed_wh = $class->_money_table_where( 'cust_bill', $start,$end,%opt );
5393 my $refund_wh = $class->_money_table_where( 'cust_refund', $start,$end,%opt );
5394 my $credit_wh = $class->_money_table_where( 'cust_credit', $start,$end,%opt );
5395 my $pay_wh = $class->_money_table_where( 'cust_pay', $start,$end,%opt );
5397 " ( SELECT COALESCE(SUM($owed), 0) FROM cust_bill $j $owed_wh )
5398 + ( SELECT COALESCE(SUM($unapp_refund), 0) FROM cust_refund $j $refund_wh )
5399 - ( SELECT COALESCE(SUM($unapp_credit), 0) FROM cust_credit $j $credit_wh )
5400 - ( SELECT COALESCE(SUM($unapp_pay), 0) FROM cust_pay $j $pay_wh )
5405 =item _money_table_where TABLE START_TIME [ END_TIME [ OPTION => VALUE ... ] ]
5407 Helper method for balance_date_sql; name (and usage) subject to change
5408 (suggestions welcome).
5410 Returns a WHERE clause for the specified monetary TABLE (cust_bill,
5411 cust_refund, cust_credit or cust_pay).
5413 If TABLE is "cust_bill" or the unapplied_date option is true, only
5414 considers records with date earlier than START_TIME, and optionally not
5415 later than END_TIME .
5419 sub _money_table_where {
5420 my( $class, $table, $start, $end, %opt ) = @_;
5423 push @where, "cust_main.custnum = $table.custnum" unless $opt{'total'};
5424 if ( $table eq 'cust_bill' || $opt{'unapplied_date'} ) {
5425 push @where, "$table._date <= $start" if defined($start) && length($start);
5426 push @where, "$table._date > $end" if defined($end) && length($end);
5428 push @where, @{$opt{'where'}} if $opt{'where'};
5429 my $where = scalar(@where) ? 'WHERE '. join(' AND ', @where ) : '';
5435 =item search_sql HASHREF
5439 Returns a qsearch hash expression to search for parameters specified in HREF.
5440 Valid parameters are
5448 =item cancelled_pkgs
5454 listref of start date, end date
5460 =item current_balance
5462 listref (list returned by FS::UI::Web::parse_lt_gt($cgi, 'current_balance'))
5466 =item flattened_pkgs
5475 my ($class, $params) = @_;
5486 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
5488 "cust_main.agentnum = $1";
5495 #prospect active inactive suspended cancelled
5496 if ( grep { $params->{'status'} eq $_ } FS::cust_main->statuses() ) {
5497 my $method = $params->{'status'}. '_sql';
5498 #push @where, $class->$method();
5499 push @where, FS::cust_main->$method();
5503 # parse cancelled package checkbox
5508 $pkgwhere .= "AND (cancel = 0 or cancel is null)"
5509 unless $params->{'cancelled_pkgs'};
5515 foreach my $field (qw( signupdate )) {
5517 next unless exists($params->{$field});
5519 my($beginning, $ending) = @{$params->{$field}};
5522 "cust_main.$field IS NOT NULL",
5523 "cust_main.$field >= $beginning",
5524 "cust_main.$field <= $ending";
5526 $orderby ||= "ORDER BY cust_main.$field";
5534 my @payby = grep /^([A-Z]{4})$/, @{ $params->{'payby'} };
5536 push @where, '( '. join(' OR ', map "cust_main.payby = '$_'", @payby). ' )';
5543 #my $balance_sql = $class->balance_sql();
5544 my $balance_sql = FS::cust_main->balance_sql();
5546 push @where, map { s/current_balance/$balance_sql/; $_ }
5547 @{ $params->{'current_balance'} };
5553 if ( $params->{'custbatch'} =~ /^([\w\/\-\:\.]+)$/ and $1 ) {
5555 "cust_main.custbatch = '$1'";
5559 # setup queries, subs, etc. for the search
5562 $orderby ||= 'ORDER BY custnum';
5564 # here is the agent virtualization
5565 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql;
5567 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
5569 my $addl_from = 'LEFT JOIN cust_pkg USING ( custnum ) ';
5571 my $count_query = "SELECT COUNT(*) FROM cust_main $extra_sql";
5573 my $select = join(', ',
5574 'cust_main.custnum',
5575 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
5578 my(@extra_headers) = ();
5579 my(@extra_fields) = ();
5581 if ($params->{'flattened_pkgs'}) {
5583 if ($dbh->{Driver}->{Name} eq 'Pg') {
5585 $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";
5587 }elsif ($dbh->{Driver}->{Name} =~ /^mysql/i) {
5588 $select .= ", GROUP_CONCAT(pkg SEPARATOR '|') as magic";
5589 $addl_from .= " LEFT JOIN part_pkg using ( pkgpart )";
5591 warn "warning: unknown database type ". $dbh->{Driver}->{Name}.
5592 "omitting packing information from report.";
5595 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";
5597 my $sth = dbh->prepare($header_query) or die dbh->errstr;
5598 $sth->execute() or die $sth->errstr;
5599 my $headerrow = $sth->fetchrow_arrayref;
5600 my $headercount = $headerrow ? $headerrow->[0] : 0;
5601 while($headercount) {
5602 unshift @extra_headers, "Package ". $headercount;
5603 unshift @extra_fields, eval q!sub {my $c = shift;
5604 my @a = split '\|', $c->magic;
5605 my $p = $a[!.--$headercount. q!];
5613 'table' => 'cust_main',
5614 'select' => $select,
5616 'extra_sql' => $extra_sql,
5617 'order_by' => $orderby,
5618 'count_query' => $count_query,
5619 'extra_headers' => \@extra_headers,
5620 'extra_fields' => \@extra_fields,
5625 =item email_search_sql HASHREF
5629 Emails a notice to the specified customers.
5631 Valid parameters are those of the L<search_sql> method, plus the following:
5653 Optional job queue job for status updates.
5657 Returns an error message, or false for success.
5659 If an error occurs during any email, stops the enture send and returns that
5660 error. Presumably if you're getting SMTP errors aborting is better than
5661 retrying everything.
5665 sub email_search_sql {
5666 my($class, $params) = @_;
5668 my $from = delete $params->{from};
5669 my $subject = delete $params->{subject};
5670 my $html_body = delete $params->{html_body};
5671 my $text_body = delete $params->{text_body};
5673 my $job = delete $params->{'job'};
5675 my $sql_query = $class->search_sql($params);
5677 my $count_query = delete($sql_query->{'count_query'});
5678 my $count_sth = dbh->prepare($count_query)
5679 or die "Error preparing $count_query: ". dbh->errstr;
5681 or die "Error executing $count_query: ". $count_sth->errstr;
5682 my $count_arrayref = $count_sth->fetchrow_arrayref;
5683 my $num_cust = $count_arrayref->[0];
5685 #my @extra_headers = @{ delete($sql_query->{'extra_headers'}) };
5686 #my @extra_fields = @{ delete($sql_query->{'extra_fields'}) };
5689 my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
5691 #eventually order+limit magic to reduce memory use?
5692 foreach my $cust_main ( qsearch($sql_query) ) {
5694 my $to = $cust_main->invoicing_list_emailonly_scalar;
5697 my $error = send_email(
5701 'subject' => $subject,
5702 'html_body' => $html_body,
5703 'text_body' => $text_body,
5706 return $error if $error;
5708 if ( $job ) { #progressbar foo
5710 if ( time - $min_sec > $last ) {
5711 my $error = $job->update_statustext(
5712 int( 100 * $num / $num_cust )
5714 die $error if $error;
5724 use Storable qw(thaw);
5727 sub process_email_search_sql {
5729 #warn "$me process_re_X $method for job $job\n" if $DEBUG;
5731 my $param = thaw(decode_base64(shift));
5732 warn Dumper($param) if $DEBUG;
5734 $param->{'job'} = $job;
5736 my $error = FS::cust_main->email_search_sql( $param );
5737 die $error if $error;
5741 =item fuzzy_search FUZZY_HASHREF [ HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ ]
5743 Performs a fuzzy (approximate) search and returns the matching FS::cust_main
5744 records. Currently, I<first>, I<last> and/or I<company> may be specified (the
5745 appropriate ship_ field is also searched).
5747 Additional options are the same as FS::Record::qsearch
5752 my( $self, $fuzzy, $hash, @opt) = @_;
5757 check_and_rebuild_fuzzyfiles();
5758 foreach my $field ( keys %$fuzzy ) {
5760 my $all = $self->all_X($field);
5761 next unless scalar(@$all);
5764 $match{$_}=1 foreach ( amatch( $fuzzy->{$field}, ['i'], @$all ) );
5767 foreach ( keys %match ) {
5768 push @fcust, qsearch('cust_main', { %$hash, $field=>$_}, @opt);
5769 push @fcust, qsearch('cust_main', { %$hash, "ship_$field"=>$_}, @opt);
5772 push @cust_main, grep { ! $fsaw{$_->custnum}++ } @fcust;
5775 # we want the components of $fuzzy ANDed, not ORed, but still don't want dupes
5777 @cust_main = grep { ++$saw{$_->custnum} == scalar(keys %$fuzzy) } @cust_main;
5785 Returns a masked version of the named field
5790 my ($self,$field) = @_;
5794 'x'x(length($self->getfield($field))-4).
5795 substr($self->getfield($field), (length($self->getfield($field))-4));
5805 =item smart_search OPTION => VALUE ...
5807 Accepts the following options: I<search>, the string to search for. The string
5808 will be searched for as a customer number, phone number, name or company name,
5809 as an exact, or, in some cases, a substring or fuzzy match (see the source code
5810 for the exact heuristics used); I<no_fuzzy_on_exact>, causes smart_search to
5811 skip fuzzy matching when an exact match is found.
5813 Any additional options are treated as an additional qualifier on the search
5816 Returns a (possibly empty) array of FS::cust_main objects.
5823 #here is the agent virtualization
5824 my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
5828 my $skip_fuzzy = delete $options{'no_fuzzy_on_exact'};
5829 my $search = delete $options{'search'};
5830 ( my $alphanum_search = $search ) =~ s/\W//g;
5832 if ( $alphanum_search =~ /^1?(\d{3})(\d{3})(\d{4})(\d*)$/ ) { #phone# search
5834 #false laziness w/Record::ut_phone
5835 my $phonen = "$1-$2-$3";
5836 $phonen .= " x$4" if $4;
5838 push @cust_main, qsearch( {
5839 'table' => 'cust_main',
5840 'hashref' => { %options },
5841 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5843 join(' OR ', map "$_ = '$phonen'",
5844 qw( daytime night fax
5845 ship_daytime ship_night ship_fax )
5848 " AND $agentnums_sql", #agent virtualization
5851 unless ( @cust_main || $phonen =~ /x\d+$/ ) { #no exact match
5852 #try looking for matches with extensions unless one was specified
5854 push @cust_main, qsearch( {
5855 'table' => 'cust_main',
5856 'hashref' => { %options },
5857 'extra_sql' => ( scalar(keys %options) ? ' AND ' : ' WHERE ' ).
5859 join(' OR ', map "$_ LIKE '$phonen\%'",
5861 ship_daytime ship_night )
5864 " AND $agentnums_sql", #agent virtualization
5869 # custnum search (also try agent_custid), with some tweaking options if your
5870 # legacy cust "numbers" have letters
5871 } elsif ( $search =~ /^\s*(\d+)\s*$/
5872 || ( $conf->config('cust_main-agent_custid-format') eq 'ww?d+'
5873 && $search =~ /^\s*(\w\w?\d+)\s*$/
5878 push @cust_main, qsearch( {
5879 'table' => 'cust_main',
5880 'hashref' => { 'custnum' => $1, %options },
5881 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5884 push @cust_main, qsearch( {
5885 'table' => 'cust_main',
5886 'hashref' => { 'agent_custid' => $1, %options },
5887 'extra_sql' => " AND $agentnums_sql", #agent virtualization
5890 } elsif ( $search =~ /^\s*(\S.*\S)\s+\((.+), ([^,]+)\)\s*$/ ) {
5892 my($company, $last, $first) = ( $1, $2, $3 );
5894 # "Company (Last, First)"
5895 #this is probably something a browser remembered,
5896 #so just do an exact search
5898 foreach my $prefix ( '', 'ship_' ) {
5899 push @cust_main, qsearch( {
5900 'table' => 'cust_main',
5901 'hashref' => { $prefix.'first' => $first,
5902 $prefix.'last' => $last,
5903 $prefix.'company' => $company,
5906 'extra_sql' => " AND $agentnums_sql",
5910 } elsif ( $search =~ /^\s*(\S.*\S)\s*$/ ) { # value search
5911 # try (ship_){last,company}
5915 # # remove "(Last, First)" in "Company (Last, First)", otherwise the
5916 # # full strings the browser remembers won't work
5917 # $value =~ s/\([\w \,\.\-\']*\)$//; #false laziness w/Record::ut_name
5919 use Lingua::EN::NameParse;
5920 my $NameParse = new Lingua::EN::NameParse(
5922 allow_reversed => 1,
5925 my($last, $first) = ( '', '' );
5926 #maybe disable this too and just rely on NameParse?
5927 if ( $value =~ /^(.+),\s*([^,]+)$/ ) { # Last, First
5929 ($last, $first) = ( $1, $2 );
5931 #} elsif ( $value =~ /^(.+)\s+(.+)$/ ) {
5932 } elsif ( ! $NameParse->parse($value) ) {
5934 my %name = $NameParse->components;
5935 $first = $name{'given_name_1'};
5936 $last = $name{'surname_1'};
5940 if ( $first && $last ) {
5942 my($q_last, $q_first) = ( dbh->quote($last), dbh->quote($first) );
5945 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5947 ( ( LOWER(last) = $q_last AND LOWER(first) = $q_first )
5948 OR ( LOWER(ship_last) = $q_last AND LOWER(ship_first) = $q_first )
5951 push @cust_main, qsearch( {
5952 'table' => 'cust_main',
5953 'hashref' => \%options,
5954 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5957 # or it just be something that was typed in... (try that in a sec)
5961 my $q_value = dbh->quote($value);
5964 my $sql = scalar(keys %options) ? ' AND ' : ' WHERE ';
5965 $sql .= " ( LOWER(last) = $q_value
5966 OR LOWER(company) = $q_value
5967 OR LOWER(ship_last) = $q_value
5968 OR LOWER(ship_company) = $q_value
5971 push @cust_main, qsearch( {
5972 'table' => 'cust_main',
5973 'hashref' => \%options,
5974 'extra_sql' => "$sql AND $agentnums_sql", #agent virtualization
5977 #no exact match, trying substring/fuzzy
5978 #always do substring & fuzzy (unless they're explicity config'ed off)
5979 #getting complaints searches are not returning enough
5980 unless ( @cust_main && $skip_fuzzy || $conf->exists('disable-fuzzy') ) {
5982 #still some false laziness w/search_sql (was search/cust_main.cgi)
5987 { 'company' => { op=>'ILIKE', value=>"%$value%" }, },
5988 { 'ship_company' => { op=>'ILIKE', value=>"%$value%" }, },
5991 if ( $first && $last ) {
5994 { 'first' => { op=>'ILIKE', value=>"%$first%" },
5995 'last' => { op=>'ILIKE', value=>"%$last%" },
5997 { 'ship_first' => { op=>'ILIKE', value=>"%$first%" },
5998 'ship_last' => { op=>'ILIKE', value=>"%$last%" },
6005 { 'last' => { op=>'ILIKE', value=>"%$value%" }, },
6006 { 'ship_last' => { op=>'ILIKE', value=>"%$value%" }, },
6010 foreach my $hashref ( @hashrefs ) {
6012 push @cust_main, qsearch( {
6013 'table' => 'cust_main',
6014 'hashref' => { %$hashref,
6017 'extra_sql' => " AND $agentnums_sql", #agent virtualizaiton
6026 " AND $agentnums_sql", #extra_sql #agent virtualization
6029 if ( $first && $last ) {
6030 push @cust_main, FS::cust_main->fuzzy_search(
6031 { 'last' => $last, #fuzzy hashref
6032 'first' => $first }, #
6036 foreach my $field ( 'last', 'company' ) {
6038 FS::cust_main->fuzzy_search( { $field => $value }, @fuzopts );
6043 #eliminate duplicates
6045 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6055 Accepts the following options: I<email>, the email address to search for. The
6056 email address will be searched for as an email invoice destination and as an
6059 #Any additional options are treated as an additional qualifier on the search
6060 #(i.e. I<agentnum>).
6062 Returns a (possibly empty) array of FS::cust_main objects (but usually just
6072 my $email = delete $options{'email'};
6074 #we're only being used by RT at the moment... no agent virtualization yet
6075 #my $agentnums_sql = $FS::CurrentUser::CurrentUser->agentnums_sql;
6079 if ( $email =~ /([^@]+)\@([^@]+)/ ) {
6081 my ( $user, $domain ) = ( $1, $2 );
6083 warn "$me smart_search: searching for $user in domain $domain"
6089 'table' => 'cust_main_invoice',
6090 'hashref' => { 'dest' => $email },
6097 map $_->cust_svc->cust_pkg,
6099 'table' => 'svc_acct',
6100 'hashref' => { 'username' => $user, },
6102 'AND ( SELECT domain FROM svc_domain
6103 WHERE svc_acct.domsvc = svc_domain.svcnum
6104 ) = '. dbh->quote($domain),
6110 @cust_main = grep { !$saw{$_->custnum}++ } @cust_main;
6112 warn "$me smart_search: found ". scalar(@cust_main). " unique customers"
6119 =item check_and_rebuild_fuzzyfiles
6123 use vars qw(@fuzzyfields);
6124 @fuzzyfields = ( 'last', 'first', 'company' );
6126 sub check_and_rebuild_fuzzyfiles {
6127 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6128 rebuild_fuzzyfiles() if grep { ! -e "$dir/cust_main.$_" } @fuzzyfields
6131 =item rebuild_fuzzyfiles
6135 sub rebuild_fuzzyfiles {
6137 use Fcntl qw(:flock);
6139 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6140 mkdir $dir, 0700 unless -d $dir;
6142 foreach my $fuzzy ( @fuzzyfields ) {
6144 open(LOCK,">>$dir/cust_main.$fuzzy")
6145 or die "can't open $dir/cust_main.$fuzzy: $!";
6147 or die "can't lock $dir/cust_main.$fuzzy: $!";
6149 open (CACHE,">$dir/cust_main.$fuzzy.tmp")
6150 or die "can't open $dir/cust_main.$fuzzy.tmp: $!";
6152 foreach my $field ( $fuzzy, "ship_$fuzzy" ) {
6153 my $sth = dbh->prepare("SELECT $field FROM cust_main".
6154 " WHERE $field != '' AND $field IS NOT NULL");
6155 $sth->execute or die $sth->errstr;
6157 while ( my $row = $sth->fetchrow_arrayref ) {
6158 print CACHE $row->[0]. "\n";
6163 close CACHE or die "can't close $dir/cust_main.$fuzzy.tmp: $!";
6165 rename "$dir/cust_main.$fuzzy.tmp", "$dir/cust_main.$fuzzy";
6176 my( $self, $field ) = @_;
6177 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6178 open(CACHE,"<$dir/cust_main.$field")
6179 or die "can't open $dir/cust_main.$field: $!";
6180 my @array = map { chomp; $_; } <CACHE>;
6185 =item append_fuzzyfiles LASTNAME COMPANY
6189 sub append_fuzzyfiles {
6190 #my( $first, $last, $company ) = @_;
6192 &check_and_rebuild_fuzzyfiles;
6194 use Fcntl qw(:flock);
6196 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
6198 foreach my $field (qw( first last company )) {
6203 open(CACHE,">>$dir/cust_main.$field")
6204 or die "can't open $dir/cust_main.$field: $!";
6205 flock(CACHE,LOCK_EX)
6206 or die "can't lock $dir/cust_main.$field: $!";
6208 print CACHE "$value\n";
6210 flock(CACHE,LOCK_UN)
6211 or die "can't unlock $dir/cust_main.$field: $!";
6220 =item process_batch_import
6222 Load a batch import as a queued JSRPC job
6226 use Storable qw(thaw);
6229 sub process_batch_import {
6232 my $param = thaw(decode_base64(shift));
6233 warn Dumper($param) if $DEBUG;
6235 my $files = $param->{'uploaded_files'}
6236 or die "No files provided.\n";
6238 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
6240 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
6241 my $file = $dir. $files{'file'};
6244 if ( $file =~ /\.(\w+)$/i ) {
6248 warn "can't parse file type from filename $file; defaulting to CSV";
6253 FS::cust_main::batch_import( {
6257 custbatch => $param->{custbatch},
6258 agentnum => $param->{'agentnum'},
6259 refnum => $param->{'refnum'},
6260 pkgpart => $param->{'pkgpart'},
6261 #'fields' => [qw( cust_pkg.setup dayphone first last address1 address2
6262 # city state zip comments )],
6263 'format' => $param->{'format'},
6268 die "$error\n" if $error;
6276 #some false laziness w/cdr.pm now
6280 my $job = $param->{job};
6282 my $filename = $param->{file};
6283 my $type = $param->{type} || 'csv';
6285 my $custbatch = $param->{custbatch};
6287 my $agentnum = $param->{agentnum};
6288 my $refnum = $param->{refnum};
6289 my $pkgpart = $param->{pkgpart};
6291 my $format = $param->{'format'};
6295 if ( $format eq 'simple' ) {
6296 @fields = qw( cust_pkg.setup dayphone first last
6297 address1 address2 city state zip comments );
6299 } elsif ( $format eq 'extended' ) {
6300 @fields = qw( agent_custid refnum
6301 last first address1 address2 city state zip country
6303 ship_last ship_first ship_address1 ship_address2
6304 ship_city ship_state ship_zip ship_country
6305 payinfo paycvv paydate
6308 svc_acct.username svc_acct._password
6311 } elsif ( $format eq 'extended-plus_company' ) {
6312 @fields = qw( agent_custid refnum
6313 last first company address1 address2 city state zip country
6315 ship_last ship_first ship_company ship_address1 ship_address2
6316 ship_city ship_state ship_zip ship_country
6317 payinfo paycvv paydate
6320 svc_acct.username svc_acct._password
6324 die "unknown format $format";
6330 if ( $type eq 'csv' ) {
6332 eval "use Text::CSV_XS;";
6335 $parser = new Text::CSV_XS;
6337 @buffer = split(/\r?\n/, slurp($filename) );
6338 $count = scalar(@buffer);
6340 } elsif ( $type eq 'xls' ) {
6342 eval "use Spreadsheet::ParseExcel;";
6345 my $excel = new Spreadsheet::ParseExcel::Workbook->Parse($filename);
6346 $parser = $excel->{Worksheet}[0]; #first sheet
6348 $count = $parser->{MaxRow} || $parser->{MinRow};
6352 die "Unknown file type $type\n";
6357 local $SIG{HUP} = 'IGNORE';
6358 local $SIG{INT} = 'IGNORE';
6359 local $SIG{QUIT} = 'IGNORE';
6360 local $SIG{TERM} = 'IGNORE';
6361 local $SIG{TSTP} = 'IGNORE';
6362 local $SIG{PIPE} = 'IGNORE';
6364 my $oldAutoCommit = $FS::UID::AutoCommit;
6365 local $FS::UID::AutoCommit = 0;
6370 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
6374 if ( $type eq 'csv' ) {
6376 last unless scalar(@buffer);
6377 $line = shift(@buffer);
6379 $parser->parse($line) or do {
6380 $dbh->rollback if $oldAutoCommit;
6381 return "can't parse: ". $parser->error_input();
6383 @columns = $parser->fields();
6385 } elsif ( $type eq 'xls' ) {
6387 last if $row > ($parser->{MaxRow} || $parser->{MinRow});
6389 my @row = @{ $parser->{Cells}[$row] };
6390 @columns = map $_->{Val}, @row;
6393 #warn $z++. ": $_\n" for @columns;
6396 die "Unknown file type $type\n";
6399 #warn join('-',@columns);
6402 custbatch => $custbatch,
6403 agentnum => $agentnum,
6405 country => $conf->config('countrydefault') || 'US',
6406 payby => $payby, #default
6407 paydate => '12/2037', #default
6409 my $billtime = time;
6410 my %cust_pkg = ( pkgpart => $pkgpart );
6412 foreach my $field ( @fields ) {
6414 if ( $field =~ /^cust_pkg\.(pkgpart|setup|bill|susp|adjourn|expire|cancel)$/ ) {
6416 #$cust_pkg{$1} = str2time( shift @$columns );
6417 if ( $1 eq 'pkgpart' ) {
6418 $cust_pkg{$1} = shift @columns;
6419 } elsif ( $1 eq 'setup' ) {
6420 $billtime = str2time(shift @columns);
6422 $cust_pkg{$1} = str2time( shift @columns );
6425 } elsif ( $field =~ /^svc_acct\.(username|_password)$/ ) {
6427 $svc_acct{$1} = shift @columns;
6431 #refnum interception
6432 if ( $field eq 'refnum' && $columns[0] !~ /^\s*(\d+)\s*$/ ) {
6434 my $referral = $columns[0];
6435 my %hash = ( 'referral' => $referral,
6436 'agentnum' => $agentnum,
6440 my $part_referral = qsearchs('part_referral', \%hash )
6441 || new FS::part_referral \%hash;
6443 unless ( $part_referral->refnum ) {
6444 my $error = $part_referral->insert;
6446 $dbh->rollback if $oldAutoCommit;
6447 return "can't auto-insert advertising source: $referral: $error";
6451 $columns[0] = $part_referral->refnum;
6454 #$cust_main{$field} = shift @$columns;
6455 $cust_main{$field} = shift @columns;
6459 $cust_main{'payby'} = 'CARD'
6460 if defined $cust_main{'payinfo'}
6461 && length $cust_main{'payinfo'};
6463 my $invoicing_list = $cust_main{'invoicing_list'}
6464 ? [ delete $cust_main{'invoicing_list'} ]
6467 my $cust_main = new FS::cust_main ( \%cust_main );
6470 tie my %hash, 'Tie::RefHash'; #this part is important
6472 if ( $cust_pkg{'pkgpart'} ) {
6473 my $cust_pkg = new FS::cust_pkg ( \%cust_pkg );
6476 if ( $svc_acct{'username'} ) {
6477 my $part_pkg = $cust_pkg->part_pkg;
6478 unless ( $part_pkg ) {
6479 $dbh->rollback if $oldAutoCommit;
6480 return "unknown pkgpart: ". $cust_pkg{'pkgpart'};
6482 $svc_acct{svcpart} = $part_pkg->svcpart( 'svc_acct' );
6483 push @svc_acct, new FS::svc_acct ( \%svc_acct )
6486 $hash{$cust_pkg} = \@svc_acct;
6489 my $error = $cust_main->insert( \%hash, $invoicing_list );
6492 $dbh->rollback if $oldAutoCommit;
6493 return "can't insert customer". ( $line ? " for $line" : '' ). ": $error";
6496 if ( $format eq 'simple' ) {
6498 #false laziness w/bill.cgi
6499 $error = $cust_main->bill( 'time' => $billtime );
6501 $dbh->rollback if $oldAutoCommit;
6502 return "can't bill customer for $line: $error";
6505 $error = $cust_main->apply_payments_and_credits;
6507 $dbh->rollback if $oldAutoCommit;
6508 return "can't bill customer for $line: $error";
6511 $error = $cust_main->collect();
6513 $dbh->rollback if $oldAutoCommit;
6514 return "can't collect customer for $line: $error";
6521 if ( $job && time - $min_sec > $last ) { #progress bar
6522 $job->update_statustext( int(100 * $row / $count) );
6528 $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
6530 return "Empty file!" unless $row;
6542 #warn join('-',keys %$param);
6543 my $fh = $param->{filehandle};
6544 my @fields = @{$param->{fields}};
6546 eval "use Text::CSV_XS;";
6549 my $csv = new Text::CSV_XS;
6556 local $SIG{HUP} = 'IGNORE';
6557 local $SIG{INT} = 'IGNORE';
6558 local $SIG{QUIT} = 'IGNORE';
6559 local $SIG{TERM} = 'IGNORE';
6560 local $SIG{TSTP} = 'IGNORE';
6561 local $SIG{PIPE} = 'IGNORE';
6563 my $oldAutoCommit = $FS::UID::AutoCommit;
6564 local $FS::UID::AutoCommit = 0;
6567 #while ( $columns = $csv->getline($fh) ) {
6569 while ( defined($line=<$fh>) ) {
6571 $csv->parse($line) or do {
6572 $dbh->rollback if $oldAutoCommit;
6573 return "can't parse: ". $csv->error_input();
6576 my @columns = $csv->fields();
6577 #warn join('-',@columns);
6580 foreach my $field ( @fields ) {
6581 $row{$field} = shift @columns;
6584 my $cust_main = qsearchs('cust_main', { 'custnum' => $row{'custnum'} } );
6585 unless ( $cust_main ) {
6586 $dbh->rollback if $oldAutoCommit;
6587 return "unknown custnum $row{'custnum'}";
6590 if ( $row{'amount'} > 0 ) {
6591 my $error = $cust_main->charge($row{'amount'}, $row{'pkg'});
6593 $dbh->rollback if $oldAutoCommit;
6597 } elsif ( $row{'amount'} < 0 ) {
6598 my $error = $cust_main->credit( sprintf( "%.2f", 0-$row{'amount'} ),
6601 $dbh->rollback if $oldAutoCommit;
6611 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
6613 return "Empty file!" unless $imported;
6619 =item notify CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6621 Sends a templated email notification to the customer (see L<Text::Template>).
6623 OPTIONS is a hash and may include
6625 I<from> - the email sender (default is invoice_from)
6627 I<to> - comma-separated scalar or arrayref of recipients
6628 (default is invoicing_list)
6630 I<subject> - The subject line of the sent email notification
6631 (default is "Notice from company_name")
6633 I<extra_fields> - a hashref of name/value pairs which will be substituted
6636 The following variables are vavailable in the template.
6638 I<$first> - the customer first name
6639 I<$last> - the customer last name
6640 I<$company> - the customer company
6641 I<$payby> - a description of the method of payment for the customer
6642 # would be nice to use FS::payby::shortname
6643 I<$payinfo> - the account information used to collect for this customer
6644 I<$expdate> - the expiration of the customer payment in seconds from epoch
6649 my ($customer, $template, %options) = @_;
6651 return unless $conf->exists($template);
6653 my $from = $conf->config('invoice_from') if $conf->exists('invoice_from');
6654 $from = $options{from} if exists($options{from});
6656 my $to = join(',', $customer->invoicing_list_emailonly);
6657 $to = $options{to} if exists($options{to});
6659 my $subject = "Notice from " . $conf->config('company_name')
6660 if $conf->exists('company_name');
6661 $subject = $options{subject} if exists($options{subject});
6663 my $notify_template = new Text::Template (TYPE => 'ARRAY',
6664 SOURCE => [ map "$_\n",
6665 $conf->config($template)]
6667 or die "can't create new Text::Template object: Text::Template::ERROR";
6668 $notify_template->compile()
6669 or die "can't compile template: Text::Template::ERROR";
6671 $FS::notify_template::_template::company_name = $conf->config('company_name');
6672 $FS::notify_template::_template::company_address =
6673 join("\n", $conf->config('company_address') ). "\n";
6675 my $paydate = $customer->paydate || '2037-12-31';
6676 $FS::notify_template::_template::first = $customer->first;
6677 $FS::notify_template::_template::last = $customer->last;
6678 $FS::notify_template::_template::company = $customer->company;
6679 $FS::notify_template::_template::payinfo = $customer->mask_payinfo;
6680 my $payby = $customer->payby;
6681 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6682 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6684 #credit cards expire at the end of the month/year of their exp date
6685 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6686 $FS::notify_template::_template::payby = 'credit card';
6687 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6688 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6690 }elsif ($payby eq 'COMP') {
6691 $FS::notify_template::_template::payby = 'complimentary account';
6693 $FS::notify_template::_template::payby = 'current method';
6695 $FS::notify_template::_template::expdate = $expire_time;
6697 for (keys %{$options{extra_fields}}){
6699 ${"FS::notify_template::_template::$_"} = $options{extra_fields}->{$_};
6702 send_email(from => $from,
6704 subject => $subject,
6705 body => $notify_template->fill_in( PACKAGE =>
6706 'FS::notify_template::_template' ),
6711 =item generate_letter CUSTOMER_OBJECT TEMPLATE_NAME OPTIONS
6713 Generates a templated notification to the customer (see L<Text::Template>).
6715 OPTIONS is a hash and may include
6717 I<extra_fields> - a hashref of name/value pairs which will be substituted
6718 into the template. These values may override values mentioned below
6719 and those from the customer record.
6721 The following variables are available in the template instead of or in addition
6722 to the fields of the customer record.
6724 I<$payby> - a description of the method of payment for the customer
6725 # would be nice to use FS::payby::shortname
6726 I<$payinfo> - the masked account information used to collect for this customer
6727 I<$expdate> - the expiration of the customer payment method in seconds from epoch
6728 I<$returnaddress> - the return address defaults to invoice_latexreturnaddress or company_address
6732 sub generate_letter {
6733 my ($self, $template, %options) = @_;
6735 return unless $conf->exists($template);
6737 my $letter_template = new Text::Template
6739 SOURCE => [ map "$_\n", $conf->config($template)],
6740 DELIMITERS => [ '[@--', '--@]' ],
6742 or die "can't create new Text::Template object: Text::Template::ERROR";
6744 $letter_template->compile()
6745 or die "can't compile template: Text::Template::ERROR";
6747 my %letter_data = map { $_ => $self->$_ } $self->fields;
6748 $letter_data{payinfo} = $self->mask_payinfo;
6750 #my $paydate = $self->paydate || '2037-12-31';
6751 my $paydate = $self->paydate =~ /^\S+$/ ? $self->paydate : '2037-12-31';
6753 my $payby = $self->payby;
6754 my ($payyear,$paymonth,$payday) = split (/-/,$paydate);
6755 my $expire_time = timelocal(0,0,0,$payday,--$paymonth,$payyear);
6757 #credit cards expire at the end of the month/year of their exp date
6758 if ($payby eq 'CARD' || $payby eq 'DCRD') {
6759 $letter_data{payby} = 'credit card';
6760 ($paymonth < 11) ? $paymonth++ : ($paymonth=0, $payyear++);
6761 $expire_time = timelocal(0,0,0,$payday,$paymonth,$payyear);
6763 }elsif ($payby eq 'COMP') {
6764 $letter_data{payby} = 'complimentary account';
6766 $letter_data{payby} = 'current method';
6768 $letter_data{expdate} = $expire_time;
6770 for (keys %{$options{extra_fields}}){
6771 $letter_data{$_} = $options{extra_fields}->{$_};
6774 unless(exists($letter_data{returnaddress})){
6775 my $retadd = join("\n", $conf->config_orbase( 'invoice_latexreturnaddress',
6776 $self->agent_template)
6778 if ( length($retadd) ) {
6779 $letter_data{returnaddress} = $retadd;
6780 } elsif ( grep /\S/, $conf->config('company_address') ) {
6781 $letter_data{returnaddress} =
6782 join( '\\*'."\n", map s/( {2,})/'~' x length($1)/eg,
6783 $conf->config('company_address')
6786 $letter_data{returnaddress} = '~';
6790 $letter_data{conf_dir} = "$FS::UID::conf_dir/conf.$FS::UID::datasrc";
6792 $letter_data{company_name} = $conf->config('company_name');
6794 my $dir = $FS::UID::conf_dir."cache.". $FS::UID::datasrc;
6795 my $fh = new File::Temp( TEMPLATE => 'letter.'. $self->custnum. '.XXXXXXXX',
6799 ) or die "can't open temp file: $!\n";
6801 $letter_template->fill_in( OUTPUT => $fh, HASH => \%letter_data );
6803 $fh->filename =~ /^(.*).tex$/ or die "unparsable filename: ". $fh->filename;
6807 =item print_ps TEMPLATE
6809 Returns an postscript letter filled in from TEMPLATE, as a scalar.
6815 my $file = $self->generate_letter(@_);
6816 FS::Misc::generate_ps($file);
6819 =item print TEMPLATE
6821 Prints the filled in template.
6823 TEMPLATE is the name of a L<Text::Template> to fill in and print.
6827 sub queueable_print {
6830 my $self = qsearchs('cust_main', { 'custnum' => $opt{custnum} } )
6831 or die "invalid customer number: " . $opt{custvnum};
6833 my $error = $self->print( $opt{template} );
6834 die $error if $error;
6838 my ($self, $template) = (shift, shift);
6839 do_print [ $self->print_ps($template) ];
6842 sub agent_template {
6844 $self->_agent_plandata('agent_templatename');
6847 sub agent_invoice_from {
6849 $self->_agent_plandata('agent_invoice_from');
6852 sub _agent_plandata {
6853 my( $self, $option ) = @_;
6855 #yuck. this whole thing needs to be reconciled better with 1.9's idea of
6856 #agent-specific Conf
6858 use FS::part_event::Condition;
6860 my $agentnum = $self->agentnum;
6863 if ( driver_name =~ /^Pg/i ) {
6865 } elsif ( driver_name =~ /^mysql/i ) {
6868 die "don't know how to use regular expressions in ". driver_name. " databases";
6871 my $part_event_option =
6873 'select' => 'part_event_option.*',
6874 'table' => 'part_event_option',
6876 LEFT JOIN part_event USING ( eventpart )
6877 LEFT JOIN part_event_option AS peo_agentnum
6878 ON ( part_event.eventpart = peo_agentnum.eventpart
6879 AND peo_agentnum.optionname = 'agentnum'
6880 AND peo_agentnum.optionvalue }. $regexp. q{ '(^|,)}. $agentnum. q{(,|$)'
6882 LEFT JOIN part_event_option AS peo_cust_bill_age
6883 ON ( part_event.eventpart = peo_cust_bill_age.eventpart
6884 AND peo_cust_bill_age.optionname = 'cust_bill_age'
6887 #'hashref' => { 'optionname' => $option },
6888 #'hashref' => { 'part_event_option.optionname' => $option },
6890 " WHERE part_event_option.optionname = ". dbh->quote($option).
6891 " AND action = 'cust_bill_send_agent' ".
6892 " AND ( disabled IS NULL OR disabled != 'Y' ) ".
6893 " AND peo_agentnum.optionname = 'agentnum' ".
6894 " AND agentnum IS NULL OR agentnum = $agentnum ".
6896 CASE WHEN peo_cust_bill_age.optionname != 'cust_bill_age'
6898 ELSE ". FS::part_event::Condition->age2seconds_sql('peo_cust_bill_age.optionvalue').
6900 , part_event.weight".
6904 unless ( $part_event_option ) {
6905 return $self->agent->invoice_template || ''
6906 if $option eq 'agent_templatename';
6910 $part_event_option->optionvalue;
6915 ## actual sub, not a method, designed to be called from the queue.
6916 ## sets up the customer, and calls the bill_and_collect
6917 my (%args) = @_; #, ($time, $invoice_time, $check_freq, $resetup) = @_;
6918 my $cust_main = qsearchs( 'cust_main', { custnum => $args{'custnum'} } );
6919 $cust_main->bill_and_collect(
6930 The delete method should possibly take an FS::cust_main object reference
6931 instead of a scalar customer number.
6933 Bill and collect options should probably be passed as references instead of a
6936 There should probably be a configuration file with a list of allowed credit
6939 No multiple currency support (probably a larger project than just this module).
6941 payinfo_masked false laziness with cust_pay.pm and cust_refund.pm
6943 Birthdates rely on negative epoch values.
6945 The payby for card/check batches is broken. With mixed batching, bad
6948 B<collect> I<invoice_time> should be renamed I<time>, like B<bill>.
6952 L<FS::Record>, L<FS::cust_pkg>, L<FS::cust_bill>, L<FS::cust_credit>
6953 L<FS::agent>, L<FS::part_referral>, L<FS::cust_main_county>,
6954 L<FS::cust_main_invoice>, L<FS::UID>, schema.html from the base documentation.