3bbad5bb91b666e0fdd8d99034ecf0d049fed7c2
[freeside.git] / FS / FS / Misc.pm
1 package FS::Misc;
2
3 use strict;
4 use vars qw ( @ISA @EXPORT_OK $DEBUG );
5 use Exporter;
6 use Carp;
7 use Data::Dumper;
8 use IPC::Run qw( run timeout );   # for _pslatex
9 use IPC::Run3; # for do_print... should just use IPC::Run i guess
10 use File::Temp;
11 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
12 #until on client machine) dependancy loops.  put them in FS::Misc::Something
13 #instead
14
15 @ISA = qw( Exporter );
16 @EXPORT_OK = qw( generate_email send_email send_fax
17                  states_hash counties state_label
18                  card_types
19                  generate_ps generate_pdf do_print
20                  csv_from_fixed
21                );
22
23 $DEBUG = 0;
24
25 =head1 NAME
26
27 FS::Misc - Miscellaneous subroutines
28
29 =head1 SYNOPSIS
30
31   use FS::Misc qw(send_email);
32
33   send_email();
34
35 =head1 DESCRIPTION
36
37 Miscellaneous subroutines.  This module contains miscellaneous subroutines
38 called from multiple other modules.  These are not OO or necessarily related,
39 but are collected here to elimiate code duplication.
40
41 =head1 SUBROUTINES
42
43 =over 4
44
45 =item generate_email OPTION => VALUE ...
46
47 Options:
48
49 =over 4
50
51 =item from
52
53 Sender address, required
54
55 =item to
56
57 Recipient address, required
58
59 =item subject
60
61 email subject, required
62
63 =item html_body
64
65 Email body (HTML alternative).  Arrayref of lines, or scalar.
66
67 Will be placed inside an HTML <BODY> tag.
68
69 =item text_body
70
71 Email body (Text alternative).  Arrayref of lines, or scalar.
72
73 =back
74
75 Returns an argument list to be passsed to L<send_email>.
76
77 =cut
78
79 #false laziness w/FS::cust_bill::generate_email
80
81 use MIME::Entity;
82 use HTML::Entities;
83
84 sub generate_email {
85   my %args = @_;
86
87   my $me = '[FS::Misc::generate_email]';
88
89   my %return = (
90     'from'    => $args{'from'},
91     'to'      => $args{'to'},
92     'subject' => $args{'subject'},
93   );
94
95   #if (ref($args{'to'}) eq 'ARRAY') {
96   #  $return{'to'} = $args{'to'};
97   #} else {
98   #  $return{'to'} = [ grep { $_ !~ /^(POST|FAX)$/ }
99   #                         $self->cust_main->invoicing_list
100   #                  ];
101   #}
102
103   warn "$me creating HTML/text multipart message"
104     if $DEBUG;
105
106   $return{'nobody'} = 1;
107
108   my $alternative = build MIME::Entity
109     'Type'        => 'multipart/alternative',
110     'Encoding'    => '7bit',
111     'Disposition' => 'inline'
112   ;
113
114   my $data;
115   if ( ref($args{'text_body'}) eq 'ARRAY' ) {
116     $data = $args{'text_body'};
117   } else {
118     $data = [ split(/\n/, $args{'text_body'}) ];
119   }
120
121   $alternative->attach(
122     'Type'        => 'text/plain',
123     #'Encoding'    => 'quoted-printable',
124     'Encoding'    => '7bit',
125     'Data'        => $data,
126     'Disposition' => 'inline',
127   );
128
129   my @html_data;
130   if ( ref($args{'html_body'}) eq 'ARRAY' ) {
131     @html_data = @{ $args{'html_body'} };
132   } else {
133     @html_data = split(/\n/, $args{'html_body'});
134   }
135
136   $alternative->attach(
137     'Type'        => 'text/html',
138     'Encoding'    => 'quoted-printable',
139     'Data'        => [ '<html>',
140                        '  <head>',
141                        '    <title>',
142                        '      '. encode_entities($return{'subject'}), 
143                        '    </title>',
144                        '  </head>',
145                        '  <body bgcolor="#e8e8e8">',
146                        @html_data,
147                        '  </body>',
148                        '</html>',
149                      ],
150     'Disposition' => 'inline',
151     #'Filename'    => 'invoice.pdf',
152   );
153
154   #no other attachment:
155   # multipart/related
156   #   multipart/alternative
157   #     text/plain
158   #     text/html
159
160   $return{'content-type'} = 'multipart/related';
161   $return{'mimeparts'} = [ $alternative ];
162   $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
163   #$return{'disposition'} = 'inline';
164
165   %return;
166
167 }
168
169 =item send_email OPTION => VALUE ...
170
171 Options:
172
173 =over 4
174
175 =item from
176
177 (required)
178
179 =item to
180
181 (required) comma-separated scalar or arrayref of recipients
182
183 =item subject
184
185 (required)
186
187 =item content-type
188
189 (optional) MIME type for the body
190
191 =item body
192
193 (required unless I<nobody> is true) arrayref of body text lines
194
195 =item mimeparts
196
197 (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().
198
199 =item nobody
200
201 (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,
202 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
203
204 =item content-encoding
205
206 (optional) when using nobody, optional top-level MIME
207 encoding which, if specified, overrides the default "7bit".
208
209 =item type
210
211 (optional) type parameter for multipart/related messages
212
213 =back
214
215 =cut
216
217 use vars qw( $conf );
218 use Date::Format;
219 use MIME::Entity;
220 use Email::Sender::Simple qw(sendmail);
221 use Email::Sender::Transport::SMTP;
222 use Email::Sender::Transport::SMTP::TLS;
223 use FS::UID;
224
225 FS::UID->install_callback( sub {
226   $conf = new FS::Conf;
227 } );
228
229 sub send_email {
230   my(%options) = @_;
231   if ( $DEBUG ) {
232     my %doptions = %options;
233     $doptions{'body'} = '(full body not shown in debug)';
234     warn "FS::Misc::send_email called with options:\n  ". Dumper(\%doptions);
235 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
236   }
237
238   my $to = ref($options{to}) ? join(', ', @{ $options{to} } ) : $options{to};
239
240   my @mimeargs = ();
241   my @mimeparts = ();
242   if ( $options{'nobody'} ) {
243
244     croak "'mimeparts' option required when 'nobody' option given\n"
245       unless $options{'mimeparts'};
246
247     @mimeparts = @{$options{'mimeparts'}};
248
249     @mimeargs = (
250       'Type'         => ( $options{'content-type'} || 'multipart/mixed' ),
251       'Encoding'     => ( $options{'content-encoding'} || '7bit' ),
252     );
253
254   } else {
255
256     @mimeparts = @{$options{'mimeparts'}}
257       if ref($options{'mimeparts'}) eq 'ARRAY';
258
259     if (scalar(@mimeparts)) {
260
261       @mimeargs = (
262         'Type'     => 'multipart/mixed',
263         'Encoding' => '7bit',
264       );
265   
266       unshift @mimeparts, { 
267         'Type'        => ( $options{'content-type'} || 'text/plain' ),
268         'Data'        => $options{'body'},
269         'Encoding'    => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
270         'Disposition' => 'inline',
271       };
272
273     } else {
274     
275       @mimeargs = (
276         'Type'     => ( $options{'content-type'} || 'text/plain' ),
277         'Data'     => $options{'body'},
278         'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
279       );
280
281     }
282
283   }
284
285   my $domain;
286   if ( $options{'from'} =~ /\@([\w\.\-]+)/ ) {
287     $domain = $1;
288   } else {
289     warn 'no domain found in invoice from address '. $options{'from'}.
290          '; constructing Message-ID (and saying HELO) @example.com'; 
291     $domain = 'example.com';
292   }
293   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
294
295   my $message = MIME::Entity->build(
296     'From'       => $options{'from'},
297     'To'         => $to,
298     'Sender'     => $options{'from'},
299     'Reply-To'   => $options{'from'},
300     'Date'       => time2str("%a, %d %b %Y %X %z", time),
301     'Subject'    => $options{'subject'},
302     'Message-ID' => "<$message_id>",
303     @mimeargs,
304   );
305
306   if ( $options{'type'} ) {
307     #false laziness w/cust_bill::generate_email
308     $message->head->replace('Content-type',
309       $message->mime_type.
310       '; boundary="'. $message->head->multipart_boundary. '"'.
311       '; type='. $options{'type'}
312     );
313   }
314
315   foreach my $part (@mimeparts) {
316
317     if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
318
319       warn "attaching MIME part from MIME::Entity object\n"
320         if $DEBUG;
321       $message->add_part($part);
322
323     } elsif ( ref($part) eq 'HASH' ) {
324
325       warn "attaching MIME part from hashref:\n".
326            join("\n", map "  $_: ".$part->{$_}, keys %$part ). "\n"
327         if $DEBUG;
328       $message->attach(%$part);
329
330     } else {
331       croak "mimepart $part isn't a hashref or MIME::Entity object!";
332     }
333
334   }
335
336   #send the email
337
338   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
339                    'helo' => $domain,
340                  );
341
342   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
343   $smtp_opt{'port'} = $port;
344
345   my $transport;
346   if ( defined($enc) && $enc eq 'starttls' ) {
347     $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
348     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
349   } else {
350     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
351       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
352     }
353     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
354     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
355   }
356   
357   local $@; # just in case
358   eval { sendmail($message, { transport => $transport }) };
359  
360   if(ref($@) and $@->isa('Email::Sender::Failure')) {
361     return ($@->code ? $@->code.' ' : '').$@->message
362   }
363   else {
364     return $@;
365   }
366 }
367
368 =item send_fax OPTION => VALUE ...
369
370 Options:
371
372 I<dialstring> - (required) 10-digit phone number w/ area code
373
374 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
375
376 -or-
377
378 I<docfile> - (required) Filename of PostScript TIFF Class F document
379
380 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
381
382
383 =cut
384
385 sub send_fax {
386
387   my %options = @_;
388
389   die 'HylaFAX support has not been configured.'
390     unless $conf->exists('hylafax');
391
392   eval {
393     require Fax::Hylafax::Client;
394   };
395
396   if ($@) {
397     if ($@ =~ /^Can't locate Fax.*/) {
398       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
399     } else {
400       die $@;
401     }
402   }
403
404   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
405
406   die 'Called send_fax without a \'dialstring\'.'
407     unless exists($options{'dialstring'});
408
409   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
410       my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
411       my $fh = new File::Temp(
412         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
413         DIR      => $dir,
414         UNLINK   => 0,
415       ) or die "can't open temp file: $!\n";
416
417       $options{docfile} = $fh->filename;
418
419       print $fh @{$options{'docdata'}};
420       close $fh;
421
422       delete $options{'docdata'};
423   }
424
425   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
426     unless exists($options{'docfile'});
427
428   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
429   #       works in the US.
430
431   $options{'dialstring'} =~ s/[^\d\+]//g;
432   if ($options{'dialstring'} =~ /^\d{10}$/) {
433     $options{dialstring} = '+1' . $options{'dialstring'};
434   } else {
435     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
436   }
437
438   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
439
440   if ($faxjob->success) {
441     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
442            $faxjob->jobid
443       if $DEBUG;
444     return '';
445   } else {
446     return 'Error while sending FAX: ' . $faxjob->trace;
447   }
448
449 }
450
451 =item states_hash COUNTRY
452
453 Returns a list of key/value pairs containing state (or other sub-country
454 division) abbriviations and names.
455
456 =cut
457
458 use FS::Record qw(qsearch);
459 use Locale::SubCountry;
460
461 sub states_hash {
462   my($country) = @_;
463
464   my @states = 
465 #     sort
466      map { s/[\n\r]//g; $_; }
467      map { $_->state; }
468          qsearch({ 
469                    'select'    => 'state',
470                    'table'     => 'cust_main_county',
471                    'hashref'   => { 'country' => $country },
472                    'extra_sql' => 'GROUP BY state',
473                 });
474
475   #it could throw a fatal "Invalid country code" error (for example "AX")
476   my $subcountry = eval { new Locale::SubCountry($country) }
477     or return ( '', '(n/a)' );
478
479   #"i see your schwartz is as big as mine!"
480   map  { ( $_->[0] => $_->[1] ) }
481   sort { $a->[1] cmp $b->[1] }
482   map  { [ $_ => state_label($_, $subcountry) ] }
483        @states;
484 }
485
486 =item counties STATE COUNTRY
487
488 Returns a list of counties for this state and country.
489
490 =cut
491
492 sub counties {
493   my( $state, $country ) = @_;
494
495   sort map { s/[\n\r]//g; $_; }
496        map { $_->county }
497            qsearch({
498              'select'  => 'DISTINCT county',
499              'table'   => 'cust_main_county',
500              'hashref' => { 'state'   => $state,
501                             'country' => $country,
502                           },
503            });
504 }
505
506 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
507
508 =cut
509
510 sub state_label {
511   my( $state, $country ) = @_;
512
513   unless ( ref($country) ) {
514     $country = eval { new Locale::SubCountry($country) }
515       or return'(n/a)';
516
517   }
518
519   # US kludge to avoid changing existing behaviour 
520   # also we actually *use* the abbriviations...
521   my $full_name = $country->country_code eq 'US'
522                     ? ''
523                     : $country->full_name($state);
524
525   $full_name = '' if $full_name eq 'unknown';
526   $full_name =~ s/\(see also.*\)\s*$//;
527   $full_name .= " ($state)" if $full_name;
528
529   $full_name || $state || '(n/a)';
530
531 }
532
533 =item card_types
534
535 Returns a hash reference of the accepted credit card types.  Keys are shorter
536 identifiers and values are the longer strings used by the system (see
537 L<Business::CreditCard>).
538
539 =cut
540
541 #$conf from above
542
543 sub card_types {
544   my $conf = new FS::Conf;
545
546   my %card_types = (
547     #displayname                    #value (Business::CreditCard)
548     "VISA"                       => "VISA card",
549     "MasterCard"                 => "MasterCard",
550     "Discover"                   => "Discover card",
551     "American Express"           => "American Express card",
552     "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
553     "enRoute"                    => "enRoute",
554     "JCB"                        => "JCB",
555     "BankCard"                   => "BankCard",
556     "Switch"                     => "Switch",
557     "Solo"                       => "Solo",
558   );
559   my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
560   if ( @conf_card_types ) {
561     #perhaps the hash is backwards for this, but this way works better for
562     #usage in selfservice
563     %card_types = map  { $_ => $card_types{$_} }
564                   grep {
565                          my $d = $_;
566                            grep { $card_types{$d} eq $_ } @conf_card_types
567                        }
568                     keys %card_types;
569   }
570
571   \%card_types;
572 }
573
574 =item generate_ps FILENAME
575
576 Returns an postscript rendition of the LaTex file, as a scalar.
577 FILENAME does not contain the .tex suffix and is unlinked by this function.
578
579 =cut
580
581 use String::ShellQuote;
582
583 sub generate_ps {
584   my $file = shift;
585
586   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
587   chdir($dir);
588
589   _pslatex($file);
590
591   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
592     or die "dvips failed";
593
594   open(POSTSCRIPT, "<$file.ps")
595     or die "can't open $file.ps: $! (error in LaTeX template?)\n";
596
597   unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex");
598
599   my $ps = '';
600
601   if ( $conf->exists('lpr-postscript_prefix') ) {
602     my $prefix = $conf->config('lpr-postscript_prefix');
603     $ps .= eval qq("$prefix");
604   }
605
606   while (<POSTSCRIPT>) {
607     $ps .= $_;
608   }
609
610   close POSTSCRIPT;
611
612   if ( $conf->exists('lpr-postscript_suffix') ) {
613     my $suffix = $conf->config('lpr-postscript_suffix');
614     $ps .= eval qq("$suffix");
615   }
616
617   return $ps;
618
619 }
620
621 =item generate_pdf FILENAME
622
623 Returns an PDF rendition of the LaTex file, as a scalar.  FILENAME does not
624 contain the .tex suffix and is unlinked by this function.
625
626 =cut
627
628 use String::ShellQuote;
629
630 sub generate_pdf {
631   my $file = shift;
632
633   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
634   chdir($dir);
635
636   #system('pdflatex', "$file.tex");
637   #system('pdflatex', "$file.tex");
638   #! LaTeX Error: Unknown graphics extension: .eps.
639
640   _pslatex($file);
641
642   my $sfile = shell_quote $file;
643
644   #system('dvipdf', "$file.dvi", "$file.pdf" );
645   system(
646     "dvips -q -t letter -f $sfile.dvi ".
647     "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
648     "     -c save pop -"
649   ) == 0
650     or die "dvips | gs failed: $!";
651
652   open(PDF, "<$file.pdf")
653     or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
654
655   unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex");
656
657   my $pdf = '';
658   while (<PDF>) {
659     $pdf .= $_;
660   }
661
662   close PDF;
663
664   return $pdf;
665
666 }
667
668 sub _pslatex {
669   my $file = shift;
670
671   #my $sfile = shell_quote $file;
672
673   my @cmd = (
674     'latex',
675     '-interaction=batchmode',
676     '\AtBeginDocument{\RequirePackage{pslatex}}',
677     '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
678     '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
679     '\PSLATEXTMP',
680     "$file.tex"
681   );
682
683   my $timeout = 30; #? should be more than enough
684
685   for ( 1, 2 ) {
686
687     local($SIG{CHLD}) = sub {};
688     run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
689       or die "pslatex $file.tex failed; see $file.log for details?\n";
690
691   }
692
693 }
694
695 =item print ARRAYREF
696
697 Sends the lines in ARRAYREF to the printer.
698
699 =cut
700
701 sub do_print {
702   my $data = shift;
703
704   my $lpr = $conf->config('lpr');
705
706   my $outerr = '';
707   run3 $lpr, $data, \$outerr, \$outerr;
708   if ( $? ) {
709     $outerr = ": $outerr" if length($outerr);
710     die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
711   }
712
713 }
714
715 =item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
716
717 Converts the filehandle referenced by FILEREF from fixed length record
718 lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
719 The CALLBACKS_LISTREF refers to a correpsonding list of coderefs.  Each
720 should return the value to be substituted in place of its single argument.
721
722 Returns false on success or an error if one occurs.
723
724 =cut
725
726 sub csv_from_fixed {
727   my( $fhref, $countref, $lengths, $callbacks) = @_;
728
729   eval { require Text::CSV_XS; };
730   return $@ if $@;
731
732   my $ofh = $$fhref;
733   my $unpacker = new Text::CSV_XS;
734   my $total = 0;
735   my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
736
737   my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
738   my $fh = new File::Temp( TEMPLATE => "FILE.csv.XXXXXXXX",
739                            DIR      => $dir,
740                            UNLINK   => 0,
741                          ) or return "can't open temp file: $!\n"
742     if $template;
743
744   while ( defined(my $line=<$ofh>) ) {
745     $$countref++;
746     if ( $template ) {
747       my $column = 0;
748
749       chomp $line;
750       return "unexpected input at line $$countref: $line".
751              " -- expected $total but received ". length($line)
752         unless length($line) == $total;
753
754       $unpacker->combine( map { my $i = $column++;
755                                 defined( $callbacks->[$i] )
756                                   ? &{ $callbacks->[$i] }( $_ )
757                                   : $_
758                               } unpack( $template, $line )
759                         )
760         or return "invalid data for CSV: ". $unpacker->error_input;
761
762       print $fh $unpacker->string(), "\n"
763         or return "can't write temp file: $!\n";
764     }
765   }
766
767   if ( $template ) { close $$fhref; $$fhref = $fh }
768
769   seek $$fhref, 0, 0;
770   '';
771 }
772
773
774 =back
775
776 =head1 BUGS
777
778 This package exists.
779
780 =head1 SEE ALSO
781
782 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
783
784 L<Fax::Hylafax::Client>
785
786 =cut
787
788 1;