4 use vars qw ( @ISA @EXPORT_OK $DEBUG );
8 use IPC::Run qw( run timeout ); # for _pslatex
9 use IPC::Run3; # for do_print... should just use IPC::Run i guess
13 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
14 #until on client machine) dependancy loops. put them in FS::Misc::Something
17 @ISA = qw( Exporter );
18 @EXPORT_OK = qw( send_email generate_email send_fax
19 states_hash counties cities state_label
22 generate_ps generate_pdf do_print
32 FS::Misc - Miscellaneous subroutines
36 use FS::Misc qw(send_email);
42 Miscellaneous subroutines. This module contains miscellaneous subroutines
43 called from multiple other modules. These are not OO or necessarily related,
44 but are collected here to eliminate code duplication.
50 =item send_email OPTION => VALUE ...
62 (required) comma-separated scalar or arrayref of recipients
70 (optional) MIME type for the body
74 (required unless I<nobody> is true) arrayref of body text lines
78 (optional, but required if I<nobody> is true) arrayref of MIME::Entity->build PARAMHASH refs or MIME::Entity objects. These will be passed as arguments to MIME::Entity->attach().
82 (optional) when set true, send_email will ignore the I<body> option and simply construct a message with the given I<mimeparts>. In this case,
83 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
85 =item content-encoding
87 (optional) when using nobody, optional top-level MIME
88 encoding which, if specified, overrides the default "7bit".
92 (optional) type parameter for multipart/related messages
96 (optional) L<FS::cust_main> key; if passed, the message will be logged
97 (if logging is enabled) with this custnum.
101 (optional) L<FS::msg_template> key, for logging.
107 use vars qw( $conf );
110 use Email::Sender::Simple qw(sendmail);
111 use Email::Sender::Transport::SMTP;
112 use Email::Sender::Transport::SMTP::TLS 0.11;
115 FS::UID->install_callback( sub {
116 $conf = new FS::Conf;
122 my %doptions = %options;
123 $doptions{'body'} = '(full body not shown in debug)';
124 warn "FS::Misc::send_email called with options:\n ". Dumper(\%doptions);
125 # join("\n", map { " $_: ". $options{$_} } keys %options ). "\n"
128 my @to = ref($options{to}) ? @{ $options{to} } : ( $options{to} );
132 if ( $options{'nobody'} ) {
134 croak "'mimeparts' option required when 'nobody' option given\n"
135 unless $options{'mimeparts'};
137 @mimeparts = @{$options{'mimeparts'}};
140 'Type' => ( $options{'content-type'} || 'multipart/mixed' ),
141 'Encoding' => ( $options{'content-encoding'} || '7bit' ),
146 @mimeparts = @{$options{'mimeparts'}}
147 if ref($options{'mimeparts'}) eq 'ARRAY';
149 if (scalar(@mimeparts)) {
152 'Type' => 'multipart/mixed',
153 'Encoding' => '7bit',
156 unshift @mimeparts, {
157 'Type' => ( $options{'content-type'} || 'text/plain' ),
158 'Charset' => 'UTF-8',
159 'Data' => ( $options{'content-type'} =~ /^text\//
160 ? Encode::encode_utf8( $options{'body'} )
163 'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
164 'Disposition' => 'inline',
170 'Type' => ( $options{'content-type'} || 'text/plain' ),
171 'Data' => ( $options{'content-type'} =~ /^text\//
172 ? Encode::encode_utf8( $options{'body'} )
175 'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
176 'Charset' => 'UTF-8',
183 my $from = $options{from};
184 $from =~ s/^\s*//; $from =~ s/\s*$//;
185 if ( $from =~ /^(.*)\s*<(.*@.*)>$/ ) {
191 if ( $from =~ /\@([\w\.\-]+)/ ) {
194 warn 'no domain found in invoice from address '. $options{'from'}.
195 '; constructing Message-ID (and saying HELO) @example.com';
196 $domain = 'example.com';
198 my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
201 my $message = MIME::Entity->build(
202 'From' => $options{'from'},
203 'To' => join(', ', @to),
204 'Sender' => $options{'from'},
205 'Reply-To' => $options{'from'},
206 'Date' => time2str("%a, %d %b %Y %X %z", $time),
207 'Subject' => Encode::encode('MIME-Header', $options{'subject'}),
208 'Message-ID' => "<$message_id>",
212 if ( $options{'type'} ) {
213 #false laziness w/cust_bill::generate_email
214 $message->head->replace('Content-type',
216 '; boundary="'. $message->head->multipart_boundary. '"'.
217 '; type='. $options{'type'}
221 foreach my $part (@mimeparts) {
223 if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
225 warn "attaching MIME part from MIME::Entity object\n"
227 $message->add_part($part);
229 } elsif ( ref($part) eq 'HASH' ) {
231 warn "attaching MIME part from hashref:\n".
232 join("\n", map " $_: ".$part->{$_}, keys %$part ). "\n"
234 $message->attach(%$part);
237 croak "mimepart $part isn't a hashref or MIME::Entity object!";
244 my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
248 my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
249 $smtp_opt{'port'} = $port;
252 if ( defined($enc) && $enc eq 'starttls' ) {
253 $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
254 $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
256 if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
257 $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
259 $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
260 $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
263 push @to, $options{bcc} if defined($options{bcc});
264 # fully unpack all addresses found in @to (including Bcc) to make the
267 foreach my $dest (@to) {
268 push @env_to, map { $_->address } Email::Address->parse($dest);
271 local $@; # just in case
272 eval { sendmail($message, { transport => $transport,
277 if(ref($@) and $@->isa('Email::Sender::Failure')) {
278 $error = $@->code.' ' if $@->code;
279 $error .= $@->message;
286 if ( $conf->exists('log_sent_mail') ) {
287 my $cust_msg = FS::cust_msg->new({
288 'env_from' => $options{'from'},
289 'env_to' => join(', ', @env_to),
290 'header' => $message->header_as_string,
291 'body' => $message->body_as_string,
294 'custnum' => $options{'custnum'},
295 'msgnum' => $options{'msgnum'},
296 'status' => ($error ? 'failed' : 'sent'),
297 'msgtype' => $options{'msgtype'},
299 my $log_error = $cust_msg->insert;
300 warn "Error logging message: $log_error\n" if $log_error; # at least warn
306 =item generate_email OPTION => VALUE ...
314 Sender address, required
318 Recipient address, required
322 Blind copy address, optional
326 email subject, required
330 Email body (HTML alternative). Arrayref of lines, or scalar.
332 Will be placed inside an HTML <BODY> tag.
336 Email body (Text alternative). Arrayref of lines, or scalar.
338 =item custnum, msgnum (optional)
340 Customer and template numbers, passed through to send_email for logging.
344 Constructs a multipart message from text_body and html_body.
348 #false laziness w/FS::cust_bill::generate_email
356 my $me = '[FS::Misc::generate_email]';
358 my @fields = qw(from to bcc subject custnum msgnum msgtype);
360 @return{@fields} = @args{@fields};
362 warn "$me creating HTML/text multipart message"
365 $return{'nobody'} = 1;
367 my $alternative = build MIME::Entity
368 'Type' => 'multipart/alternative',
369 'Encoding' => '7bit',
370 'Disposition' => 'inline'
374 if ( ref($args{'text_body'}) eq 'ARRAY' ) {
375 $data = join("\n", @{ $args{'text_body'} });
377 $data = $args{'text_body'};
380 $alternative->attach(
381 'Type' => 'text/plain',
382 'Encoding' => 'quoted-printable',
383 'Charset' => 'UTF-8',
384 #'Encoding' => '7bit',
385 'Data' => Encode::encode_utf8($data),
386 'Disposition' => 'inline',
390 if ( ref($args{'html_body'}) eq 'ARRAY' ) {
391 @html_data = @{ $args{'html_body'} };
393 @html_data = split(/\n/, $args{'html_body'});
396 $alternative->attach(
397 'Type' => 'text/html',
398 'Encoding' => 'quoted-printable',
399 'Data' => [ '<html>',
402 ' '. encode_entities($return{'subject'}),
405 ' <body bgcolor="#ffffff">',
406 ( map Encode::encode_utf8($_), @html_data ),
410 'Disposition' => 'inline',
411 #'Filename' => 'invoice.pdf',
414 #no other attachment:
416 # multipart/alternative
420 $return{'content-type'} = 'multipart/related';
421 $return{'mimeparts'} = [ $alternative ];
422 $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
423 #$return{'disposition'} = 'inline';
429 =item send_fax OPTION => VALUE ...
433 I<dialstring> - (required) 10-digit phone number w/ area code
435 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
439 I<docfile> - (required) Filename of PostScript TIFF Class F document
441 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
450 die 'HylaFAX support has not been configured.'
451 unless $conf->exists('hylafax');
454 require Fax::Hylafax::Client;
458 if ($@ =~ /^Can't locate Fax.*/) {
459 die "You must have Fax::Hylafax::Client installed to use invoice faxing."
465 my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
467 die 'Called send_fax without a \'dialstring\'.'
468 unless exists($options{'dialstring'});
470 if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
471 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
472 my $fh = new File::Temp(
473 TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
476 ) or die "can't open temp file: $!\n";
478 $options{docfile} = $fh->filename;
480 print $fh @{$options{'docdata'}};
483 delete $options{'docdata'};
486 die 'Called send_fax without a \'docfile\' or \'docdata\'.'
487 unless exists($options{'docfile'});
489 #FIXME: Need to send canonical dialstring to HylaFAX, but this only
492 $options{'dialstring'} =~ s/[^\d\+]//g;
493 if ($options{'dialstring'} =~ /^\d{10}$/) {
494 $options{dialstring} = '+1' . $options{'dialstring'};
496 return 'Invalid dialstring ' . $options{'dialstring'} . '.';
499 my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
501 if ($faxjob->success) {
502 warn "Successfully queued fax to '$options{dialstring}' with jobid " .
507 return 'Error while sending FAX: ' . $faxjob->trace;
512 =item states_hash COUNTRY
514 Returns a list of key/value pairs containing state (or other sub-country
515 division) abbriviations and names.
519 use FS::Record qw(qsearch);
520 use Locale::SubCountry;
525 #a hash? not expecting an explosion of business from unrecognized countries..
526 return states_hash_nosubcountry($country) if $country eq 'XC';
530 map { s/[\n\r]//g; $_; }
534 'table' => 'cust_main_county',
535 'hashref' => { 'country' => $country },
536 'extra_sql' => 'GROUP BY state',
539 #it could throw a fatal "Invalid country code" error (for example "AX")
540 my $subcountry = eval { new Locale::SubCountry($country) }
541 or return (); # ( '', '(n/a)' );
543 #"i see your schwartz is as big as mine!"
544 map { ( $_->[0] => $_->[1] ) }
545 sort { $a->[1] cmp $b->[1] }
546 map { [ $_ => state_label($_, $subcountry) ] }
550 sub states_hash_nosubcountry {
555 map { s/[\n\r]//g; $_; }
559 'table' => 'cust_main_county',
560 'hashref' => { 'country' => $country },
561 'extra_sql' => 'GROUP BY state',
564 #"i see your schwartz is as big as mine!"
565 map { ( $_->[0] => $_->[1] ) }
566 sort { $a->[1] cmp $b->[1] }
571 =item counties STATE COUNTRY
573 Returns a list of counties for this state and country.
578 my( $state, $country ) = @_;
580 map { $_ } #return num_counties($state, $country) unless wantarray;
581 sort map { s/[\n\r]//g; $_; }
584 'select' => 'DISTINCT county',
585 'table' => 'cust_main_county',
586 'hashref' => { 'state' => $state,
587 'country' => $country,
592 =item cities COUNTY STATE COUNTRY
594 Returns a list of cities for this county, state and country.
599 my( $county, $state, $country ) = @_;
601 map { $_ } #return num_cities($county, $state, $country) unless wantarray;
602 sort map { s/[\n\r]//g; $_; }
605 'select' => 'DISTINCT city',
606 'table' => 'cust_main_county',
607 'hashref' => { 'county' => $county,
609 'country' => $country,
614 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
619 my( $state, $country ) = @_;
621 unless ( ref($country) ) {
622 $country = eval { new Locale::SubCountry($country) }
627 # US kludge to avoid changing existing behaviour
628 # also we actually *use* the abbriviations...
629 my $full_name = $country->country_code eq 'US'
631 : $country->full_name($state);
633 $full_name = '' if $full_name eq 'unknown';
634 $full_name =~ s/\(see also.*\)\s*$//;
635 $full_name .= " ($state)" if $full_name;
637 $full_name || $state || '(n/a)';
643 Returns a hash reference of the accepted credit card types. Keys are shorter
644 identifiers and values are the longer strings used by the system (see
645 L<Business::CreditCard>).
652 my $conf = new FS::Conf;
655 #displayname #value (Business::CreditCard)
656 "VISA" => "VISA card",
657 "MasterCard" => "MasterCard",
658 "Discover" => "Discover card",
659 "American Express" => "American Express card",
660 "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
661 "enRoute" => "enRoute",
663 "BankCard" => "BankCard",
664 "Switch" => "Switch",
667 my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
668 if ( @conf_card_types ) {
669 #perhaps the hash is backwards for this, but this way works better for
670 #usage in selfservice
671 %card_types = map { $_ => $card_types{$_} }
674 grep { $card_types{$d} eq $_ } @conf_card_types
684 Returns a hash reference of allowed package billing frequencies.
689 tie my %freq, 'Tie::IxHash', (
690 '0' => '(no recurring fee)',
693 '2d' => 'every two days',
694 '3d' => 'every three days',
696 '2w' => 'biweekly (every 2 weeks)',
698 '45d' => 'every 45 days',
699 '2' => 'bimonthly (every 2 months)',
700 '3' => 'quarterly (every 3 months)',
701 '4' => 'every 4 months',
702 '137d' => 'every 4 1/2 months (137 days)',
703 '6' => 'semiannually (every 6 months)',
705 '13' => 'every 13 months (annually +1 month)',
706 '24' => 'biannually (every 2 years)',
707 '36' => 'triannually (every 3 years)',
708 '48' => '(every 4 years)',
709 '60' => '(every 5 years)',
710 '120' => '(every 10 years)',
715 =item generate_ps FILENAME
717 Returns an postscript rendition of the LaTex file, as a scalar.
718 FILENAME does not contain the .tex suffix and is unlinked by this function.
722 use String::ShellQuote;
727 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
732 my $papersize = $conf->config('papersize') || 'letter';
734 local($SIG{CHLD}) = sub {};
736 system('dvips', '-q', '-t', $papersize, "$file.dvi", '-o', "$file.ps" ) == 0
737 or die "dvips failed";
739 open(POSTSCRIPT, "<$file.ps")
740 or die "can't open $file.ps: $! (error in LaTeX template?)\n";
742 unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex")
743 unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
747 if ( $conf->exists('lpr-postscript_prefix') ) {
748 my $prefix = $conf->config('lpr-postscript_prefix');
749 $ps .= eval qq("$prefix");
752 while (<POSTSCRIPT>) {
758 if ( $conf->exists('lpr-postscript_suffix') ) {
759 my $suffix = $conf->config('lpr-postscript_suffix');
760 $ps .= eval qq("$suffix");
767 =item generate_pdf FILENAME
769 Returns an PDF rendition of the LaTex file, as a scalar. FILENAME does not
770 contain the .tex suffix and is unlinked by this function.
774 use String::ShellQuote;
779 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
782 #system('pdflatex', "$file.tex");
783 #system('pdflatex', "$file.tex");
784 #! LaTeX Error: Unknown graphics extension: .eps.
788 my $sfile = shell_quote $file;
790 #system('dvipdf', "$file.dvi", "$file.pdf" );
791 my $papersize = $conf->config('papersize') || 'letter';
793 local($SIG{CHLD}) = sub {};
796 "dvips -q -f $sfile.dvi -t $papersize ".
797 "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
800 or die "dvips | gs failed: $!";
802 open(PDF, "<$file.pdf")
803 or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
805 unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex")
806 unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
822 #my $sfile = shell_quote $file;
826 '-interaction=batchmode',
827 '\AtBeginDocument{\RequirePackage{pslatex}}',
828 '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
829 '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
834 my $timeout = 30; #? should be more than enough
838 local($SIG{CHLD}) = sub {};
839 run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
840 or warn "bad exit status from pslatex pass $_\n";
844 return if -e "$file.dvi" && -s "$file.dvi";
845 die "pslatex $file.tex failed, see $file.log for details?\n";
849 =item do_print ARRAYREF [, OPTION => VALUE ... ]
851 Sends the lines in ARRAYREF to the printer.
853 Options available are:
859 Uses this agent's 'lpr' configuration setting override instead of the global
864 Uses this command instead of the configured lpr command (overrides both the
865 global value and agentnum).
870 my( $data, %opt ) = @_;
872 my $lpr = ( exists($opt{'lpr'}) && $opt{'lpr'} )
874 : $conf->config('lpr', $opt{'agentnum'} );
877 local($SIG{CHLD}) = sub {};
878 run3 $lpr, $data, \$outerr, \$outerr;
880 $outerr = ": $outerr" if length($outerr);
881 die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
886 =item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
888 Converts the filehandle referenced by FILEREF from fixed length record
889 lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
890 The CALLBACKS_LISTREF refers to a correpsonding list of coderefs. Each
891 should return the value to be substituted in place of its single argument.
893 Returns false on success or an error if one occurs.
898 my( $fhref, $countref, $lengths, $callbacks) = @_;
900 eval { require Text::CSV_XS; };
904 my $unpacker = new Text::CSV_XS;
906 my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
908 my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
909 my $fh = new File::Temp( TEMPLATE => "FILE.csv.XXXXXXXX",
912 ) or return "can't open temp file: $!\n"
915 while ( defined(my $line=<$ofh>) ) {
921 return "unexpected input at line $$countref: $line".
922 " -- expected $total but received ". length($line)
923 unless length($line) == $total;
925 $unpacker->combine( map { my $i = $column++;
926 defined( $callbacks->[$i] )
927 ? &{ $callbacks->[$i] }( $_ )
929 } unpack( $template, $line )
931 or return "invalid data for CSV: ". $unpacker->error_input;
933 print $fh $unpacker->string(), "\n"
934 or return "can't write temp file: $!\n";
938 if ( $template ) { close $$fhref; $$fhref = $fh }
944 =item ocr_image IMAGE_SCALAR
946 Runs OCR on the provided image data and returns a list of text lines.
951 my $logo_data = shift;
953 #XXX use conf dir location from Makefile
954 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
955 my $fh = new File::Temp(
956 TEMPLATE => 'bizcard.XXXXXXXX',
957 SUFFIX => '.png', #XXX assuming, but should handle jpg, gif, etc. too
960 ) or die "can't open temp file: $!\n";
962 my $filename = $fh->filename;
964 print $fh $logo_data;
967 local($SIG{CHLD}) = sub {};
969 run( [qw(ocroscript recognize), $filename], '>'=>"$filename.hocr" )
970 or die "ocroscript recognize failed\n";
972 run( [qw(ocroscript hocr-to-text), "$filename.hocr"], '>pipe'=>\*OUT )
973 or die "ocroscript hocr-to-text failed\n";
975 my @lines = split(/\n/, <OUT> );
977 foreach (@lines) { s/\.c0m\s*$/.com/; }
982 =item bytes_substr STRING, OFFSET[, LENGTH[, REPLACEMENT] ]
985 Use Unicode::Truncate truncate_egc instead
987 A replacement for "substr" that counts raw bytes rather than logical
988 characters. Unlike "bytes::substr", will suppress fragmented UTF-8 characters
989 rather than output them. Unlike real "substr", is not an lvalue.
994 # my ($string, $offset, $length, $repl) = @_;
995 # my $bytes = substr(
996 # Encode::encode('utf8', $string),
999 # Encode::encode('utf8', $repl)
1001 # my $chk = $DEBUG ? Encode::FB_WARN : Encode::FB_QUIET;
1002 # return Encode::decode('utf8', $bytes, $chk);
1007 Accepts a postive or negative numerical value.
1008 Returns amount formatted for display,
1009 including money character.
1015 my $money_char = $conf->{'money_char'} || '$';
1016 $amount = sprintf("%0.2f",$amount);
1017 $amount =~ s/^(-?)/$1$money_char/;
1025 This package exists.
1029 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
1031 L<Fax::Hylafax::Client>