#30616 Fix AU toll-free
[freeside.git] / FS / FS / cust_main_Mixin.pm
1 package FS::cust_main_Mixin;
2
3 use strict;
4 use vars qw( $DEBUG $me );
5 use Carp qw( confess carp cluck );
6 use FS::UID qw(dbh);
7 use FS::cust_main;
8 use FS::Record qw( qsearch qsearchs );
9 use FS::Misc qw( send_email generate_email );
10 use HTML::Entities;
11
12 $DEBUG = 0;
13 $me = '[FS::cust_main_Mixin]';
14
15 =head1 NAME
16
17 FS::cust_main_Mixin - Mixin class for records that contain fields from cust_main
18
19 =head1 SYNOPSIS
20
21 package FS::some_table;
22 use vars qw(@ISA);
23 @ISA = qw( FS::cust_main_Mixin FS::Record );
24
25 =head1 DESCRIPTION
26
27 This is a mixin class for records that contain fields from the cust_main table,
28 for example, from a JOINed search.  See httemplate/search/ for examples.
29
30 =head1 METHODS
31
32 =over 4
33
34 =cut
35
36 sub cust_unlinked_msg { '(unlinked)'; }
37 sub cust_linked { $_[0]->custnum; }
38
39 sub cust_main { 
40   my $self = shift;
41   cluck ref($self). '->cust_main called' if $DEBUG;
42   $self->cust_linked ? qsearchs('cust_main', {custnum => $self->custnum}) : '';
43 }
44
45 =item display_custnum
46
47 Given an object that contains fields from cust_main (say, from a JOINed
48 search; see httemplate/search/ for examples), returns the equivalent of the
49 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
50 a customer.
51
52 =cut
53
54 sub display_custnum {
55   my $self = shift;
56   $self->cust_linked
57     ? FS::cust_main::display_custnum($self)
58     : $self->cust_unlinked_msg;
59 }
60
61 =item name
62
63 Given an object that contains fields from cust_main (say, from a JOINed
64 search; see httemplate/search/ for examples), returns the equivalent of the
65 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
66 a customer.
67
68 =cut
69
70 sub name {
71   my $self = shift;
72   $self->cust_linked
73     ? FS::cust_main::name($self)
74     : $self->cust_unlinked_msg;
75 }
76
77 =item ship_name
78
79 Given an object that contains fields from cust_main (say, from a JOINed
80 search; see httemplate/search/ for examples), returns the equivalent of the
81 FS::cust_main I<ship_name> method, or "(unlinked)" if this object is not
82 linked to a customer.
83
84 =cut
85
86 sub ship_name {
87   my $self = shift;
88   $self->cust_linked
89     ? FS::cust_main::ship_name($self)
90     : $self->cust_unlinked_msg;
91 }
92
93 =item contact
94
95 Given an object that contains fields from cust_main (say, from a JOINed
96 search; see httemplate/search/ for examples), returns the equivalent of the
97 FS::cust_main I<contact> method, or "(unlinked)" if this object is not linked
98 to a customer.
99
100 =cut
101
102 sub contact {
103   my $self = shift;
104   $self->cust_linked
105     ? FS::cust_main::contact($self)
106     : $self->cust_unlinked_msg;
107 }
108
109 =item ship_contact
110
111 Given an object that contains fields from cust_main (say, from a JOINed
112 search; see httemplate/search/ for examples), returns the equivalent of the
113 FS::cust_main I<ship_contact> method, or "(unlinked)" if this object is not
114 linked to a customer.
115
116 =cut
117
118 sub ship_contact {
119   my $self = shift;
120   $self->cust_linked
121     ? FS::cust_main::ship_contact($self)
122     : $self->cust_unlinked_msg;
123 }
124
125 =item country_full
126
127 Given an object that contains fields from cust_main (say, from a JOINed
128 search; see httemplate/search/ for examples), returns the equivalent of the
129 FS::cust_main I<country_full> method, or "(unlinked)" if this object is not
130 linked to a customer.
131
132 =cut
133
134 sub country_full {
135   my $self = shift;
136   if ( $self->locationnum ) {  # cust_pkg has this
137     my $location = FS::cust_location->by_key($self->locationnum);
138     $location ? $location->country_full : '';
139   } elsif ( $self->cust_linked ) {
140     $self->cust_main->bill_country_full;
141   }
142 }
143
144 =item invoicing_list_emailonly
145
146 Given an object that contains fields from cust_main (say, from a JOINed
147 search; see httemplate/search/ for examples), returns the equivalent of the
148 FS::cust_main I<invoicing_list_emailonly> method, or "(unlinked)" if this
149 object is not linked to a customer.
150
151 =cut
152
153 sub invoicing_list_emailonly {
154   my $self = shift;
155   warn "invoicing_list_email only called on $self, ".
156        "custnum ". $self->custnum. "\n"
157     if $DEBUG;
158   $self->cust_linked
159     ? FS::cust_main::invoicing_list_emailonly($self)
160     : $self->cust_unlinked_msg;
161 }
162
163 =item invoicing_list_emailonly_scalar
164
165 Given an object that contains fields from cust_main (say, from a JOINed
166 search; see httemplate/search/ for examples), returns the equivalent of the
167 FS::cust_main I<invoicing_list_emailonly_scalar> method, or "(unlinked)" if
168 this object is not linked to a customer.
169
170 =cut
171
172 sub invoicing_list_emailonly_scalar {
173   my $self = shift;
174   warn "invoicing_list_emailonly called on $self, ".
175        "custnum ". $self->custnum. "\n"
176     if $DEBUG;
177   $self->cust_linked
178     ? FS::cust_main::invoicing_list_emailonly_scalar($self)
179     : $self->cust_unlinked_msg;
180 }
181
182 =item invoicing_list
183
184 Given an object that contains fields from cust_main (say, from a JOINed
185 search; see httemplate/search/ for examples), returns the equivalent of the
186 FS::cust_main I<invoicing_list> method, or "(unlinked)" if this object is not
187 linked to a customer.
188
189 Note: this method is read-only.
190
191 =cut
192
193 #read-only
194 sub invoicing_list {
195   my $self = shift;
196   $self->cust_linked
197     ? FS::cust_main::invoicing_list($self)
198     : ();
199 }
200
201 =item status
202
203 Given an object that contains fields from cust_main (say, from a JOINed
204 search; see httemplate/search/ for examples), returns the equivalent of the
205 FS::cust_main I<status> method, or "(unlinked)" if this object is not linked to
206 a customer.
207
208 =cut
209
210 sub cust_status {
211   my $self = shift;
212   return $self->cust_unlinked_msg unless $self->cust_linked;
213
214   #FS::cust_main::status($self)
215   #false laziness w/actual cust_main::status
216   # (make sure FS::cust_main methods are called)
217   for my $status (qw( prospect active inactive suspended cancelled )) {
218     my $method = $status.'_sql';
219     my $sql = FS::cust_main->$method();;
220     my $numnum = ( $sql =~ s/cust_main\.custnum/?/g );
221     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
222     $sth->execute( ($self->custnum) x $numnum )
223       or die "Error executing 'SELECT $sql': ". $sth->errstr;
224     return $status if $sth->fetchrow_arrayref->[0];
225   }
226 }
227
228 =item ucfirst_cust_status
229
230 Given an object that contains fields from cust_main (say, from a JOINed
231 search; see httemplate/search/ for examples), returns the equivalent of the
232 FS::cust_main I<ucfirst_status> method, or "(unlinked)" if this object is not
233 linked to a customer.
234
235 =cut
236
237 sub ucfirst_cust_status {
238   my $self = shift;
239   $self->cust_linked
240     ? ucfirst( $self->cust_status(@_) ) 
241     : $self->cust_unlinked_msg;
242 }
243
244 =item cust_statuscolor
245
246 Given an object that contains fields from cust_main (say, from a JOINed
247 search; see httemplate/search/ for examples), returns the equivalent of the
248 FS::cust_main I<statuscol> method, or "000000" if this object is not linked to
249 a customer.
250
251 =cut
252
253 sub cust_statuscolor {
254   my $self = shift;
255
256   $self->cust_linked
257     ? FS::cust_main::cust_statuscolor($self)
258     : '000000';
259 }
260
261 =item prospect_sql
262
263 =item active_sql
264
265 =item inactive_sql
266
267 =item suspended_sql
268
269 =item cancelled_sql
270
271 Class methods that return SQL framents, equivalent to the corresponding
272 FS::cust_main method.
273
274 =cut
275
276 #      my \$self = shift;
277 #      \$self->cust_linked
278 #        ? FS::cust_main::${sub}_sql(\$self)
279 #        : '0';
280
281 foreach my $sub (qw( prospect active inactive suspended cancelled )) {
282   eval "
283     sub ${sub}_sql {
284       confess 'cust_main_Mixin ${sub}_sql called with object' if ref(\$_[0]);
285       'cust_main.custnum IS NOT NULL AND '. FS::cust_main->${sub}_sql();
286     }
287   ";
288   die $@ if $@;
289 }
290
291 =item cust_search_sql
292
293 Returns a list of SQL WHERE fragments to search for parameters specified
294 in HASHREF.  Valid parameters are:
295
296 =over 4
297
298 =item agentnum
299
300 =item status
301
302 =item payby
303
304 =back
305
306 =cut
307
308 sub cust_search_sql {
309   my($class, $param) = @_;
310
311   if ( $DEBUG ) {
312     warn "$me cust_search_sql called with params: \n".
313          join("\n", map { "  $_: ". $param->{$_} } keys %$param ). "\n";
314   }
315
316   my @search = ();
317
318   if ( $param->{'agentnum'} && $param->{'agentnum'} =~ /^(\d+)$/ ) {
319     push @search, "cust_main.agentnum = $1";
320   }
321
322   #status (prospect active inactive suspended cancelled)
323   if ( grep { $param->{'status'} eq $_ } FS::cust_main->statuses() ) {
324     my $method = $param->{'status'}. '_sql';
325     push @search, $class->$method();
326   }
327
328   #payby
329   my @payby = ref($param->{'payby'})
330                 ? @{ $param->{'payby'} }
331                 : split(',', $param->{'payby'});
332   @payby = grep /^([A-Z]{4})$/, @payby;
333   if ( @payby ) {
334     push @search, 'cust_main.payby IN ('. join(',', map "'$_'", @payby). ')';
335   }
336
337   #here is the agent virtualization
338   push @search,
339     $FS::CurrentUser::CurrentUser->agentnums_sql( 'table' => 'cust_main' );
340   
341   return @search;
342
343 }
344
345 =item email_search_result HASHREF
346
347 Emails a notice to the specified customers.  Customers without 
348 invoice email destinations will be skipped.
349
350 Parameters: 
351
352 =over 4
353
354 =item job
355
356 Queue job for status updates.  Required.
357
358 =item search
359
360 Hashref of params to the L<search()> method.  Required.
361
362 =item msgnum
363
364 Message template number (see L<FS::msg_template>).  Overrides all 
365 of the following options.
366
367 =item from
368
369 From: address
370
371 =item subject
372
373 Email Subject:
374
375 =item html_body
376
377 HTML body
378
379 =item text_body
380
381 Text body
382
383 =back
384
385 Returns an error message, or false for success.
386
387 If any messages fail to send, they will be queued as individual 
388 jobs which can be manually retried.  If the first ten messages 
389 in the job fail, the entire job will abort and return an error.
390
391 =cut
392
393 use Storable qw(thaw);
394 use MIME::Base64;
395 use Data::Dumper qw(Dumper);
396 use Digest::SHA qw(sha1); # for duplicate checking
397
398 sub email_search_result {
399   my($class, $param) = @_;
400
401   my $msgnum = $param->{msgnum};
402   my $from = delete $param->{from};
403   my $subject = delete $param->{subject};
404   my $html_body = delete $param->{html_body};
405   my $text_body = delete $param->{text_body};
406   my $error = '';
407
408   my $job = delete $param->{'job'}
409     or die "email_search_result must run from the job queue.\n";
410   
411   my $msg_template;
412   if ( $msgnum ) {
413     $msg_template = qsearchs('msg_template', { msgnum => $msgnum } )
414       or die "msgnum $msgnum not found\n";
415   }
416
417   my $sql_query = $class->search($param->{'search'});
418   $sql_query->{'select'} = $sql_query->{'table'} . '.*';
419
420   my $count_query   = delete($sql_query->{'count_query'});
421   my $count_sth = dbh->prepare($count_query)
422     or die "Error preparing $count_query: ". dbh->errstr;
423   $count_sth->execute
424     or die "Error executing $count_query: ". $count_sth->errstr;
425   my $count_arrayref = $count_sth->fetchrow_arrayref;
426   my $num_cust = $count_arrayref->[0];
427
428   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
429   my @retry_jobs = ();
430   my $dups = 0;
431   my $success = 0;
432   my %sent_to = ();
433
434   #eventually order+limit magic to reduce memory use?
435   foreach my $obj ( qsearch($sql_query) ) {
436
437     #progressbar first, so that the count is right
438     $num++;
439     if ( time - $min_sec > $last ) {
440       my $error = $job->update_statustext(
441         int( 100 * $num / $num_cust )
442       );
443       die $error if $error;
444       $last = time;
445     }
446
447     my $cust_main = $obj->cust_main;
448     tie my %message, 'Tie::IxHash';
449     if ( !$cust_main ) { 
450       next; # unlinked object; nothing else we can do
451     }
452
453     if ( $msg_template ) {
454       # Now supports other context objects.
455       %message = $msg_template->prepare(
456         'cust_main' => $cust_main,
457         'object'    => $obj,
458       );
459     }
460     else {
461       my @to = $cust_main->invoicing_list_emailonly;
462       next if !@to;
463
464       %message = (
465         'from'      => $from,
466         'to'        => \@to,
467         'subject'   => $subject,
468         'html_body' => $html_body,
469         'text_body' => $text_body,
470         'custnum'   => $cust_main->custnum,
471       );
472     } #if $msg_template
473
474     # For non-cust_main searches, we avoid duplicates based on message
475     # body text.  
476     my $unique = $cust_main->custnum;
477     $unique .= sha1($message{'text_body'}) if $class ne 'FS::cust_main';
478     if( $sent_to{$unique} ) {
479       # avoid duplicates
480       $dups++;
481       next;
482     }
483
484     $sent_to{$unique} = 1;
485     
486     $error = send_email( generate_email( %message ) );
487
488     if($error) {
489       # queue the sending of this message so that the user can see what we
490       # tried to do, and retry if desired
491       my $queue = new FS::queue {
492         'job'        => 'FS::Misc::process_send_email',
493         'custnum'    => $cust_main->custnum,
494         'status'     => 'failed',
495         'statustext' => $error,
496       };
497       $queue->insert(%message);
498       push @retry_jobs, $queue;
499     }
500     else {
501       $success++;
502     }
503
504     if($success == 0 and
505         (scalar(@retry_jobs) > 10 or $num == $num_cust)
506       ) {
507       # 10 is arbitrary, but if we have enough failures, that's
508       # probably a configuration or network problem, and we
509       # abort the batch and run away screaming.
510       # We NEVER do this if anything was successfully sent.
511       $_->delete foreach (@retry_jobs);
512       return "multiple failures: '$error'\n";
513     }
514   } # foreach $obj
515
516   if(@retry_jobs) {
517     # fail the job, but with a status message that makes it clear
518     # something was sent.
519     return "Sent $success, skipped $dups duplicate(s), failed ".scalar(@retry_jobs).". Failed attempts placed in job queue.\n";
520   }
521
522   return '';
523 }
524
525 sub process_email_search_result {
526   my $job = shift;
527   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
528
529   my $param = thaw(decode_base64(shift));
530   warn Dumper($param) if $DEBUG;
531
532   $param->{'job'} = $job;
533
534   $param->{'search'} = thaw(decode_base64($param->{'search'}))
535     or die "process_email_search_result requires search params.\n";
536
537 #  $param->{'payby'} = [ split(/\0/, $param->{'payby'}) ]
538 #    unless ref($param->{'payby'});
539
540   my $table = $param->{'table'} 
541     or die "process_email_search_result requires table.\n";
542
543   eval "use FS::$table;";
544   die "error loading FS::$table: $@\n" if $@;
545
546   my $error = "FS::$table"->email_search_result( $param );
547   dbh->commit; # save failed jobs before rethrowing the error
548   die $error if $error;
549
550 }
551
552 =item conf
553
554 Returns a configuration handle (L<FS::Conf>) set to the customer's locale, 
555 if they have one.  If not, returns an FS::Conf with no locale.
556
557 =cut
558
559 sub conf {
560   my $self = shift;
561   return $self->{_conf} if (ref $self and $self->{_conf});
562   my $cust_main = $self->cust_main;
563   my $conf = new FS::Conf { 
564     'locale' => ($cust_main ? $cust_main->locale : '')
565   };
566   $self->{_conf} = $conf if ref $self;
567   return $conf;
568 }
569
570 =item mt TEXT [, ARGS ]
571
572 Localizes a text string (see L<Locale::Maketext>) for the customer's locale,
573 if they have one.
574
575 =cut
576
577 sub mt {
578   my $self = shift;
579   return $self->{_lh}->maketext(@_) if (ref $self and $self->{_lh});
580   my $cust_main = $self->cust_main;
581   my $locale = $cust_main ? $cust_main->locale : '';
582   my $lh = FS::L10N->get_handle($locale);
583   $self->{_lh} = $lh if ref $self;
584   return $lh->maketext(@_);
585 }
586
587 =item time2str_local FORMAT, TIME[, ESCAPE]
588
589 Localizes a date (see L<Date::Language>) for the customer's locale.
590
591 FORMAT can be a L<Date::Format> string, or one of these special words:
592
593 - "short": the value of the "date_format" config setting for the customer's 
594   locale, defaulting to "%x".
595 - "rdate": the same as "short" except that the default has a four-digit year.
596 - "long": the value of the "date_format_long" config setting for the 
597   customer's locale, defaulting to "%b %o, %Y".
598
599 ESCAPE, if specified, is one of "latex" or "html", and will escape non-ASCII
600 characters and convert spaces to nonbreaking spaces.
601
602 =cut
603
604 sub time2str_local {
605   # renamed so that we don't have to change every single reference to 
606   # time2str everywhere
607   my $self = shift;
608   my ($format, $time, $escape) = @_;
609   return '' unless $time > 0; # work around time2str's traditional stupidity
610
611   $self->{_date_format} ||= {};
612   if (!exists($self->{_dh})) {
613     my $cust_main = $self->cust_main;
614     my $locale = $cust_main->locale  if $cust_main;
615     $locale ||= 'en_US';
616     my %info = FS::Locales->locale_info($locale);
617     my $dh = eval { Date::Language->new($info{'name'}) } ||
618              Date::Language->new(); # fall back to English
619     $self->{_dh} = $dh;
620   }
621
622   if ($format eq 'short') {
623     $format = $self->{_date_format}->{short}
624             ||= $self->conf->config('date_format') || '%x';
625   } elsif ($format eq 'rdate') {
626     $format = $self->{_date_format}->{rdate}
627             ||= $self->conf->config('date_format') || '%m/%d/%Y';
628   } elsif ($format eq 'long') {
629     $format = $self->{_date_format}->{long}
630             ||= $self->conf->config('date_format_long') || '%b %o, %Y';
631   }
632
633   # actually render the date
634   my $string = $self->{_dh}->time2str($format, $time);
635
636   if ($escape) {
637     if ($escape eq 'html') {
638       $string = encode_entities($string);
639       $string =~ s/ +/&nbsp;/g;
640     } elsif ($escape eq 'latex') { # just do nbsp's here
641       $string =~ s/ +/~/g;
642     }
643   }
644   
645   $string;
646 }
647
648 =back
649
650 =head1 BUGS
651
652 =head1 SEE ALSO
653
654 L<FS::cust_main>, L<FS::Record>
655
656 =cut
657
658 1;
659