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
33 FS::Misc - Miscellaneous subroutines
37 use FS::Misc qw(send_email);
43 Miscellaneous subroutines. This module contains miscellaneous subroutines
44 called from multiple other modules. These are not OO or necessarily related,
45 but are collected here to eliminate code duplication.
51 =item send_email OPTION => VALUE ...
63 (required) comma-separated scalar or arrayref of recipients
71 (optional) MIME type for the body
75 (required unless I<nobody> is true) arrayref of body text lines
79 (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().
83 (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,
84 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
86 =item content-encoding
88 (optional) when using nobody, optional top-level MIME
89 encoding which, if specified, overrides the default "7bit".
93 (optional) type parameter for multipart/related messages
97 (optional) L<FS::cust_main> key; if passed, the message will be logged
98 (if logging is enabled) with this custnum.
102 (optional) L<FS::msg_template> key, for logging.
108 use vars qw( $conf );
111 use Email::Sender::Simple qw(sendmail);
112 use Email::Sender::Transport::SMTP;
113 use Email::Sender::Transport::SMTP::TLS 0.11;
116 FS::UID->install_callback( sub {
117 $conf = new FS::Conf;
123 my %doptions = %options;
124 $doptions{'body'} = '(full body not shown in debug)';
125 warn "FS::Misc::send_email called with options:\n ". Dumper(\%doptions);
126 # join("\n", map { " $_: ". $options{$_} } keys %options ). "\n"
129 my @to = ref($options{to}) ? @{ $options{to} } : ( $options{to} );
133 if ( $options{'nobody'} ) {
135 croak "'mimeparts' option required when 'nobody' option given\n"
136 unless $options{'mimeparts'};
138 @mimeparts = @{$options{'mimeparts'}};
141 'Type' => ( $options{'content-type'} || 'multipart/mixed' ),
142 'Encoding' => ( $options{'content-encoding'} || '7bit' ),
147 @mimeparts = @{$options{'mimeparts'}}
148 if ref($options{'mimeparts'}) eq 'ARRAY';
150 if (scalar(@mimeparts)) {
153 'Type' => 'multipart/mixed',
154 'Encoding' => '7bit',
157 unshift @mimeparts, {
158 'Type' => ( $options{'content-type'} || 'text/plain' ),
159 'Data' => $options{'body'},
160 'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
161 'Disposition' => 'inline',
167 'Type' => ( $options{'content-type'} || 'text/plain' ),
168 'Data' => $options{'body'},
169 'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
176 my $from = $options{from};
177 $from =~ s/^\s*//; $from =~ s/\s*$//;
178 if ( $from =~ /^(.*)\s*<(.*@.*)>$/ ) {
184 if ( $from =~ /\@([\w\.\-]+)/ ) {
187 warn 'no domain found in invoice from address '. $options{'from'}.
188 '; constructing Message-ID (and saying HELO) @example.com';
189 $domain = 'example.com';
191 my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
194 my $message = MIME::Entity->build(
195 'From' => $options{'from'},
196 'To' => join(', ', @to),
197 'Sender' => $options{'from'},
198 'Reply-To' => $options{'from'},
199 'Date' => time2str("%a, %d %b %Y %X %z", $time),
200 'Subject' => Encode::encode('MIME-Header', $options{'subject'}),
201 'Message-ID' => "<$message_id>",
205 if ( $options{'type'} ) {
206 #false laziness w/cust_bill::generate_email
207 $message->head->replace('Content-type',
209 '; boundary="'. $message->head->multipart_boundary. '"'.
210 '; type='. $options{'type'}
214 foreach my $part (@mimeparts) {
216 if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
218 warn "attaching MIME part from MIME::Entity object\n"
220 $message->add_part($part);
222 } elsif ( ref($part) eq 'HASH' ) {
224 warn "attaching MIME part from hashref:\n".
225 join("\n", map " $_: ".$part->{$_}, keys %$part ). "\n"
227 $message->attach(%$part);
230 croak "mimepart $part isn't a hashref or MIME::Entity object!";
237 my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
241 my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
242 $smtp_opt{'port'} = $port;
245 if ( defined($enc) && $enc eq 'starttls' ) {
246 $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
247 $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
249 if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
250 $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
252 $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
253 $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
256 push @to, $options{bcc} if defined($options{bcc});
258 my @env_to = split(/\s*,\s*/, join(', ', @to));
259 # strip display-name from envelope addresses
263 s/^(.*)\s*<(.*@.*)>$/$2/;
266 local $@; # just in case
267 eval { sendmail($message, { transport => $transport,
272 if(ref($@) and $@->isa('Email::Sender::Failure')) {
273 $error = $@->code.' ' if $@->code;
274 $error .= $@->message;
281 if ( $conf->exists('log_sent_mail') ) {
282 my $cust_msg = FS::cust_msg->new({
283 'env_from' => $options{'from'},
284 'env_to' => join(', ', @to),
285 'header' => $message->header_as_string,
286 'body' => $message->body_as_string,
289 'custnum' => $options{'custnum'},
290 'msgnum' => $options{'msgnum'},
291 'status' => ($error ? 'failed' : 'sent'),
292 'msgtype' => $options{'msgtype'},
294 $cust_msg->insert; # ignore errors
300 =item generate_email OPTION => VALUE ...
308 Sender address, required
312 Recipient address, required
316 Blind copy address, optional
320 email subject, required
324 Email body (HTML alternative). Arrayref of lines, or scalar.
326 Will be placed inside an HTML <BODY> tag.
330 Email body (Text alternative). Arrayref of lines, or scalar.
332 =item custnum, msgnum (optional)
334 Customer and template numbers, passed through to send_email for logging.
338 Constructs a multipart message from text_body and html_body.
342 #false laziness w/FS::cust_bill::generate_email
350 my $me = '[FS::Misc::generate_email]';
352 my @fields = qw(from to bcc subject custnum msgnum msgtype);
354 @return{@fields} = @args{@fields};
356 warn "$me creating HTML/text multipart message"
359 $return{'nobody'} = 1;
361 my $alternative = build MIME::Entity
362 'Type' => 'multipart/alternative',
363 'Encoding' => '7bit',
364 'Disposition' => 'inline'
368 if ( ref($args{'text_body'}) eq 'ARRAY' ) {
369 $data = join("\n", @{ $args{'text_body'} });
371 $data = $args{'text_body'};
374 $alternative->attach(
375 'Type' => 'text/plain',
376 'Encoding' => 'quoted-printable',
377 #'Encoding' => '7bit',
379 'Disposition' => 'inline',
383 if ( ref($args{'html_body'}) eq 'ARRAY' ) {
384 @html_data = @{ $args{'html_body'} };
386 @html_data = split(/\n/, $args{'html_body'});
389 $alternative->attach(
390 'Type' => 'text/html',
391 'Encoding' => 'quoted-printable',
392 'Data' => [ '<html>',
395 ' '. encode_entities($return{'subject'}),
398 ' <body bgcolor="#ffffff">',
403 'Disposition' => 'inline',
404 #'Filename' => 'invoice.pdf',
407 #no other attachment:
409 # multipart/alternative
413 $return{'content-type'} = 'multipart/related';
414 $return{'mimeparts'} = [ $alternative ];
415 $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
416 #$return{'disposition'} = 'inline';
422 =item process_send_email OPTION => VALUE ...
424 Takes arguments as per generate_email() and sends the message. This
425 will die on any error and can be used in the job queue.
429 sub process_send_email {
431 my $error = send_email(generate_email(%message));
432 die "$error\n" if $error;
436 =item process_send_generated_email OPTION => VALUE ...
438 Takes arguments as per send_email() and sends the message. This
439 will die on any error and can be used in the job queue.
443 sub process_send_generated_email {
445 my $error = send_email(%args);
446 die "$error\n" if $error;
450 =item send_fax OPTION => VALUE ...
454 I<dialstring> - (required) 10-digit phone number w/ area code
456 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
460 I<docfile> - (required) Filename of PostScript TIFF Class F document
462 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
471 die 'HylaFAX support has not been configured.'
472 unless $conf->exists('hylafax');
475 require Fax::Hylafax::Client;
479 if ($@ =~ /^Can't locate Fax.*/) {
480 die "You must have Fax::Hylafax::Client installed to use invoice faxing."
486 my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
488 die 'Called send_fax without a \'dialstring\'.'
489 unless exists($options{'dialstring'});
491 if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
492 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
493 my $fh = new File::Temp(
494 TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
497 ) or die "can't open temp file: $!\n";
499 $options{docfile} = $fh->filename;
501 print $fh @{$options{'docdata'}};
504 delete $options{'docdata'};
507 die 'Called send_fax without a \'docfile\' or \'docdata\'.'
508 unless exists($options{'docfile'});
510 #FIXME: Need to send canonical dialstring to HylaFAX, but this only
513 $options{'dialstring'} =~ s/[^\d\+]//g;
514 if ($options{'dialstring'} =~ /^\d{10}$/) {
515 $options{dialstring} = '+1' . $options{'dialstring'};
517 return 'Invalid dialstring ' . $options{'dialstring'} . '.';
520 my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
522 if ($faxjob->success) {
523 warn "Successfully queued fax to '$options{dialstring}' with jobid " .
528 return 'Error while sending FAX: ' . $faxjob->trace;
533 =item states_hash COUNTRY
535 Returns a list of key/value pairs containing state (or other sub-country
536 division) abbriviations and names.
540 use FS::Record qw(qsearch);
541 use Locale::SubCountry;
546 #a hash? not expecting an explosion of business from unrecognized countries..
547 return states_hash_nosubcountry($country) if $country eq 'XC';
551 map { s/[\n\r]//g; $_; }
555 'table' => 'cust_main_county',
556 'hashref' => { 'country' => $country },
557 'extra_sql' => 'GROUP BY state',
560 #it could throw a fatal "Invalid country code" error (for example "AX")
561 my $subcountry = eval { new Locale::SubCountry($country) }
562 or return (); # ( '', '(n/a)' );
564 #"i see your schwartz is as big as mine!"
565 map { ( $_->[0] => $_->[1] ) }
566 sort { $a->[1] cmp $b->[1] }
567 map { [ $_ => state_label($_, $subcountry) ] }
571 sub states_hash_nosubcountry {
576 map { s/[\n\r]//g; $_; }
580 'table' => 'cust_main_county',
581 'hashref' => { 'country' => $country },
582 'extra_sql' => 'GROUP BY state',
585 #"i see your schwartz is as big as mine!"
586 map { ( $_->[0] => $_->[1] ) }
587 sort { $a->[1] cmp $b->[1] }
592 =item counties STATE COUNTRY
594 Returns a list of counties for this state and country.
599 my( $state, $country ) = @_;
601 map { $_ } #return num_counties($state, $country) unless wantarray;
602 sort map { s/[\n\r]//g; $_; }
605 'select' => 'DISTINCT county',
606 'table' => 'cust_main_county',
607 'hashref' => { 'state' => $state,
608 'country' => $country,
613 =item cities COUNTY STATE COUNTRY
615 Returns a list of cities for this county, state and country.
620 my( $county, $state, $country ) = @_;
622 map { $_ } #return num_cities($county, $state, $country) unless wantarray;
623 sort map { s/[\n\r]//g; $_; }
626 'select' => 'DISTINCT city',
627 'table' => 'cust_main_county',
628 'hashref' => { 'county' => $county,
630 'country' => $country,
635 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
640 my( $state, $country ) = @_;
642 unless ( ref($country) ) {
643 $country = eval { new Locale::SubCountry($country) }
648 # US kludge to avoid changing existing behaviour
649 # also we actually *use* the abbriviations...
650 my $full_name = $country->country_code eq 'US'
652 : $country->full_name($state);
654 $full_name = '' if $full_name eq 'unknown';
655 $full_name =~ s/\(see also.*\)\s*$//;
656 $full_name .= " ($state)" if $full_name;
658 $full_name || $state || '(n/a)';
664 Returns a hash reference of the accepted credit card types. Keys are shorter
665 identifiers and values are the longer strings used by the system (see
666 L<Business::CreditCard>).
673 my $conf = new FS::Conf;
676 #displayname #value (Business::CreditCard)
677 "VISA" => "VISA card",
678 "MasterCard" => "MasterCard",
679 "Discover" => "Discover card",
680 "American Express" => "American Express card",
681 "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
682 "enRoute" => "enRoute",
684 "BankCard" => "BankCard",
685 "Switch" => "Switch",
688 my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
689 if ( @conf_card_types ) {
690 #perhaps the hash is backwards for this, but this way works better for
691 #usage in selfservice
692 %card_types = map { $_ => $card_types{$_} }
695 grep { $card_types{$d} eq $_ } @conf_card_types
705 Returns a hash reference of allowed package billing frequencies.
710 tie my %freq, 'Tie::IxHash', (
711 '0' => '(no recurring fee)',
714 '2d' => 'every two days',
715 '3d' => 'every three days',
717 '2w' => 'biweekly (every 2 weeks)',
719 '45d' => 'every 45 days',
720 '2' => 'bimonthly (every 2 months)',
721 '3' => 'quarterly (every 3 months)',
722 '4' => 'every 4 months',
723 '137d' => 'every 4 1/2 months (137 days)',
724 '6' => 'semiannually (every 6 months)',
726 '13' => 'every 13 months (annually +1 month)',
727 '24' => 'biannually (every 2 years)',
728 '36' => 'triannually (every 3 years)',
729 '48' => '(every 4 years)',
730 '60' => '(every 5 years)',
731 '120' => '(every 10 years)',
736 =item generate_ps FILENAME
738 Returns an postscript rendition of the LaTex file, as a scalar.
739 FILENAME does not contain the .tex suffix and is unlinked by this function.
743 use String::ShellQuote;
748 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
753 my $papersize = $conf->config('papersize') || 'letter';
755 system('dvips', '-q', '-t', $papersize, "$file.dvi", '-o', "$file.ps" ) == 0
756 or die "dvips failed";
758 open(POSTSCRIPT, "<$file.ps")
759 or die "can't open $file.ps: $! (error in LaTeX template?)\n";
761 unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex")
762 unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
766 if ( $conf->exists('lpr-postscript_prefix') ) {
767 my $prefix = $conf->config('lpr-postscript_prefix');
768 $ps .= eval qq("$prefix");
771 while (<POSTSCRIPT>) {
777 if ( $conf->exists('lpr-postscript_suffix') ) {
778 my $suffix = $conf->config('lpr-postscript_suffix');
779 $ps .= eval qq("$suffix");
786 =item generate_pdf FILENAME
788 Returns an PDF rendition of the LaTex file, as a scalar. FILENAME does not
789 contain the .tex suffix and is unlinked by this function.
793 use String::ShellQuote;
798 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
801 #system('pdflatex', "$file.tex");
802 #system('pdflatex', "$file.tex");
803 #! LaTeX Error: Unknown graphics extension: .eps.
807 my $sfile = shell_quote $file;
809 #system('dvipdf', "$file.dvi", "$file.pdf" );
810 my $papersize = $conf->config('papersize') || 'letter';
813 "dvips -q -f $sfile.dvi -t $papersize ".
814 "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
817 or die "dvips | gs failed: $!";
819 open(PDF, "<$file.pdf")
820 or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
822 unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex")
823 unless $FS::CurrentUser::CurrentUser->option('save_tmp_typesetting');
839 #my $sfile = shell_quote $file;
843 '-interaction=batchmode',
844 '\AtBeginDocument{\RequirePackage{pslatex}}',
845 '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
846 '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
851 my $timeout = 30; #? should be more than enough
855 local($SIG{CHLD}) = sub {};
856 run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
857 or warn "bad exit status from pslatex pass $_\n";
861 return if -e "$file.dvi" && -s "$file.dvi";
862 die "pslatex $file.tex failed, see $file.log for details?\n";
866 =item do_print ARRAYREF [, OPTION => VALUE ... ]
868 Sends the lines in ARRAYREF to the printer.
870 Options available are:
876 Uses this agent's 'lpr' configuration setting override instead of the global
881 Uses this command instead of the configured lpr command (overrides both the
882 global value and agentnum).
887 my( $data, %opt ) = @_;
889 my $lpr = ( exists($opt{'lpr'}) && $opt{'lpr'} )
891 : $conf->config('lpr', $opt{'agentnum'} );
894 run3 $lpr, $data, \$outerr, \$outerr;
896 $outerr = ": $outerr" if length($outerr);
897 die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
902 =item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
904 Converts the filehandle referenced by FILEREF from fixed length record
905 lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
906 The CALLBACKS_LISTREF refers to a correpsonding list of coderefs. Each
907 should return the value to be substituted in place of its single argument.
909 Returns false on success or an error if one occurs.
914 my( $fhref, $countref, $lengths, $callbacks) = @_;
916 eval { require Text::CSV_XS; };
920 my $unpacker = new Text::CSV_XS;
922 my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
924 my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
925 my $fh = new File::Temp( TEMPLATE => "FILE.csv.XXXXXXXX",
928 ) or return "can't open temp file: $!\n"
931 while ( defined(my $line=<$ofh>) ) {
937 return "unexpected input at line $$countref: $line".
938 " -- expected $total but received ". length($line)
939 unless length($line) == $total;
941 $unpacker->combine( map { my $i = $column++;
942 defined( $callbacks->[$i] )
943 ? &{ $callbacks->[$i] }( $_ )
945 } unpack( $template, $line )
947 or return "invalid data for CSV: ". $unpacker->error_input;
949 print $fh $unpacker->string(), "\n"
950 or return "can't write temp file: $!\n";
954 if ( $template ) { close $$fhref; $$fhref = $fh }
960 =item ocr_image IMAGE_SCALAR
962 Runs OCR on the provided image data and returns a list of text lines.
967 my $logo_data = shift;
969 #XXX use conf dir location from Makefile
970 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
971 my $fh = new File::Temp(
972 TEMPLATE => 'bizcard.XXXXXXXX',
973 SUFFIX => '.png', #XXX assuming, but should handle jpg, gif, etc. too
976 ) or die "can't open temp file: $!\n";
978 my $filename = $fh->filename;
980 print $fh $logo_data;
983 run( [qw(ocroscript recognize), $filename], '>'=>"$filename.hocr" )
984 or die "ocroscript recognize failed\n";
986 run( [qw(ocroscript hocr-to-text), "$filename.hocr"], '>pipe'=>\*OUT )
987 or die "ocroscript hocr-to-text failed\n";
989 my @lines = split(/\n/, <OUT> );
991 foreach (@lines) { s/\.c0m\s*$/.com/; }
996 =item bytes_substr STRING, OFFSET[, LENGTH[, REPLACEMENT] ]
998 A replacement for "substr" that counts raw bytes rather than logical
999 characters. Unlike "bytes::substr", will suppress fragmented UTF-8 characters
1000 rather than output them. Unlike real "substr", is not an lvalue.
1005 my ($string, $offset, $length, $repl) = @_;
1007 Encode::encode('utf8', $string),
1010 Encode::encode('utf8', $repl)
1012 my $chk = $DEBUG ? Encode::FB_WARN : Encode::FB_QUIET;
1013 return Encode::decode('utf8', $bytes, $chk);
1018 Accepts a postive or negative numerical value.
1019 Returns amount formatted for display,
1020 including money character.
1026 my $money_char = $conf->{'money_char'} || '$';
1027 $amount = sprintf("%0.2f",$amount);
1028 $amount =~ s/^(-?)/$1$money_char/;
1036 This package exists.
1040 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
1042 L<Fax::Hylafax::Client>