import torrus 1.0.9
[freeside.git] / FS / FS / Misc.pm
index 54467a1..fe8ac60 100644 (file)
@@ -5,15 +5,22 @@ use vars qw ( @ISA @EXPORT_OK $DEBUG );
 use Exporter;
 use Carp;
 use Data::Dumper;
 use Exporter;
 use Carp;
 use Data::Dumper;
+use IPC::Run qw( run timeout );   # for _pslatex
+use IPC::Run3; # for do_print... should just use IPC::Run i guess
+use File::Temp;
+use Tie::IxHash;
 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
 #until on client machine) dependancy loops.  put them in FS::Misc::Something
 #instead
 
 @ISA = qw( Exporter );
 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
 #until on client machine) dependancy loops.  put them in FS::Misc::Something
 #instead
 
 @ISA = qw( Exporter );
-@EXPORT_OK = qw( send_email send_fax
-                 states_hash counties state_label
+@EXPORT_OK = qw( send_email generate_email send_fax
+                 states_hash counties cities state_label
                  card_types
                  card_types
-                 generate_ps do_print
+                 pkg_freqs
+                 generate_ps generate_pdf do_print
+                 csv_from_fixed
+                 ocr_image
                );
 
 $DEBUG = 0;
                );
 
 $DEBUG = 0;
@@ -32,7 +39,7 @@ FS::Misc - Miscellaneous subroutines
 
 Miscellaneous subroutines.  This module contains miscellaneous subroutines
 called from multiple other modules.  These are not OO or necessarily related,
 
 Miscellaneous subroutines.  This module contains miscellaneous subroutines
 called from multiple other modules.  These are not OO or necessarily related,
-but are collected here to elimiate code duplication.
+but are collected here to eliminate code duplication.
 
 =head1 SUBROUTINES
 
 
 =head1 SUBROUTINES
 
@@ -42,33 +49,56 @@ but are collected here to elimiate code duplication.
 
 Options:
 
 
 Options:
 
-I<from> - (required)
+=over 4
+
+=item from
+
+(required)
+
+=item to
+
+(required) comma-separated scalar or arrayref of recipients
 
 
-I<to> - (required) comma-separated scalar or arrayref of recipients
+=item subject
 
 
-I<subject> - (required)
+(required)
 
 
-I<content-type> - (optional) MIME type for the body
+=item content-type
 
 
-I<body> - (required unless I<nobody> is true) arrayref of body text lines
+(optional) MIME type for the body
 
 
-I<mimeparts> - (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().
+=item body
 
 
-I<nobody> - (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,
+(required unless I<nobody> is true) arrayref of body text lines
+
+=item mimeparts
+
+(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().
+
+=item nobody
+
+(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,
 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
 
 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
 
-I<content-encoding> - (optional) when using nobody, optional top-level MIME
+=item content-encoding
+
+(optional) when using nobody, optional top-level MIME
 encoding which, if specified, overrides the default "7bit".
 
 encoding which, if specified, overrides the default "7bit".
 
-I<type> - (optional) type parameter for multipart/related messages
+=item type
+
+(optional) type parameter for multipart/related messages
+
+=back
 
 =cut
 
 use vars qw( $conf );
 use Date::Format;
 
 =cut
 
 use vars qw( $conf );
 use Date::Format;
-use Mail::Header;
-use Mail::Internet 2.00;
 use MIME::Entity;
 use MIME::Entity;
+use Email::Sender::Simple qw(sendmail);
+use Email::Sender::Transport::SMTP;
+use Email::Sender::Transport::SMTP::TLS;
 use FS::UID;
 
 FS::UID->install_callback( sub {
 use FS::UID;
 
 FS::UID->install_callback( sub {
@@ -84,8 +114,7 @@ sub send_email {
 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
   }
 
 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
   }
 
-  $ENV{MAILADDRESS} = $options{'from'};
-  my $to = ref($options{to}) ? join(', ', @{ $options{to} } ) : $options{to};
+  my @to = ref($options{to}) ? @{ $options{to} } : ( $options{to} );
 
   my @mimeargs = ();
   my @mimeparts = ();
 
   my @mimeargs = ();
   my @mimeparts = ();
@@ -137,14 +166,14 @@ sub send_email {
     $domain = $1;
   } else {
     warn 'no domain found in invoice from address '. $options{'from'}.
     $domain = $1;
   } else {
     warn 'no domain found in invoice from address '. $options{'from'}.
-         '; constructing Message-ID @example.com'; 
+         '; constructing Message-ID (and saying HELO) @example.com'; 
     $domain = 'example.com';
   }
   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 
   my $message = MIME::Entity->build(
     'From'       => $options{'from'},
     $domain = 'example.com';
   }
   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 
   my $message = MIME::Entity->build(
     'From'       => $options{'from'},
-    'To'         => $to,
+    'To'         => join(', ', @to),
     'Sender'     => $options{'from'},
     'Reply-To'   => $options{'from'},
     'Date'       => time2str("%a, %d %b %Y %X %z", time),
     'Sender'     => $options{'from'},
     'Reply-To'   => $options{'from'},
     'Date'       => time2str("%a, %d %b %Y %X %z", time),
@@ -183,101 +212,183 @@ sub send_email {
 
   }
 
 
   }
 
-  my $smtpmachine = $conf->config('smtpmachine');
-  $!=0;
+  #send the email
 
 
-  $message->mysmtpsend( 'Host'     => $smtpmachine,
-                        'MailFrom' => $options{'from'},
-                      );
+  my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
+                   'helo' => $domain,
+                 );
 
 
-}
+  my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
+  $smtp_opt{'port'} = $port;
 
 
-#this kludges a "mysmtpsend" method into Mail::Internet for send_email above
-#now updated for MailTools v2!
-package Mail::Internet;
-
-use Mail::Address;
-use Net::SMTP;
-use Net::Domain;
-
-sub Mail::Internet::mysmtpsend($@) {
-    my ($self, %opt) = @_;
-
-    my $host     = $opt{Host};
-    my $envelope = $opt{MailFrom}; # || mailaddress();
-    my $quit     = 1;
-
-    my ($smtp, @hello);
-
-    push @hello, Hello => $opt{Hello}
-        if defined $opt{Hello};
-
-    push @hello, Port => $opt{Port}
-        if exists $opt{Port};
-
-    push @hello, Debug => $opt{Debug}
-        if exists $opt{Debug};
-
-#    if(!defined $host)
-#    {   local $SIG{__DIE__};
-#        my @hosts = qw(mailhost localhost);
-#        unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
-#            if defined $ENV{SMTPHOSTS};
-#
-#        foreach $host (@hosts)
-#        {   $smtp = eval { Net::SMTP->new($host, @hello) };
-#            last if defined $smtp;
-#        }
-#    }
-#    elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
-    if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
-    {   $smtp = $host;
-        $quit = 0;
-    }
-    else
-    {   #local $SIG{__DIE__};
-        #$smtp = eval { Net::SMTP->new($host, @hello) };
-        $smtp = Net::SMTP->new($host, @hello);
+  my $transport;
+  if ( defined($enc) && $enc eq 'starttls' ) {
+    $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
+    $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
+  } else {
+    if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
+      $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
     }
     }
+    $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
+    $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
+  }
+  
+  push @to, $options{bcc} if defined($options{bcc});
+  local $@; # just in case
+  eval { sendmail($message, { transport => $transport,
+                              from      => $options{from},
+                              to        => \@to }) };
+  if(ref($@) and $@->isa('Email::Sender::Failure')) {
+    return ($@->code ? $@->code.' ' : '').$@->message
+  }
+  else {
+    return $@;
+  }
+}
 
 
-    unless ( defined($smtp) ) {
-      my $err = $!;
-      $err =~ s/Invalid argument/Unknown host/;
-      return "can't connect to $host: $err"
-    }
+=item generate_email OPTION => VALUE ...
 
 
-    my $head = $self->cleaned_header_dup;
+Options:
 
 
-    $head->delete('Bcc');
+=over 4
 
 
-    # Who is it to
+=item from
 
 
-    my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
-    @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
-        unless @rcpt;
+Sender address, required
 
 
-    my @addr = map {$_->address} Mail::Address->parse(@rcpt);
-    #@addr or return ();
-    return 'No valid destination addresses found!'
-       unless(@addr);
+=item to
 
 
-    # Send it
+Recipient address, required
 
 
-    my $ok = $smtp->mail($envelope)
-          && $smtp->to(@addr)
-          && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
+=item bcc
+
+Blind copy address, optional
+
+=item subject
+
+email subject, required
+
+=item html_body
+
+Email body (HTML alternative).  Arrayref of lines, or scalar.
+
+Will be placed inside an HTML <BODY> tag.
+
+=item text_body
+
+Email body (Text alternative).  Arrayref of lines, or scalar.
+
+=back
+
+Constructs a multipart message from text_body and html_body.
+
+=cut
+
+#false laziness w/FS::cust_bill::generate_email
+
+use MIME::Entity;
+use HTML::Entities;
+
+sub generate_email {
+  my %args = @_;
+
+  my $me = '[FS::Misc::generate_email]';
+
+  my %return = (
+    'from'    => $args{'from'},
+    'to'      => $args{'to'},
+    'bcc'     => $args{'bcc'},
+    'subject' => $args{'subject'},
+  );
+
+  #if (ref($args{'to'}) eq 'ARRAY') {
+  #  $return{'to'} = $args{'to'};
+  #} else {
+  #  $return{'to'} = [ grep { $_ !~ /^(POST|FAX)$/ }
+  #                         $self->cust_main->invoicing_list
+  #                  ];
+  #}
+
+  warn "$me creating HTML/text multipart message"
+    if $DEBUG;
+
+  $return{'nobody'} = 1;
+
+  my $alternative = build MIME::Entity
+    'Type'        => 'multipart/alternative',
+    'Encoding'    => '7bit',
+    'Disposition' => 'inline'
+  ;
+
+  my $data;
+  if ( ref($args{'text_body'}) eq 'ARRAY' ) {
+    $data = $args{'text_body'};
+  } else {
+    $data = [ split(/\n/, $args{'text_body'}) ];
+  }
+
+  $alternative->attach(
+    'Type'        => 'text/plain',
+    #'Encoding'    => 'quoted-printable',
+    'Encoding'    => '7bit',
+    'Data'        => $data,
+    'Disposition' => 'inline',
+  );
+
+  my @html_data;
+  if ( ref($args{'html_body'}) eq 'ARRAY' ) {
+    @html_data = @{ $args{'html_body'} };
+  } else {
+    @html_data = split(/\n/, $args{'html_body'});
+  }
+
+  $alternative->attach(
+    'Type'        => 'text/html',
+    'Encoding'    => 'quoted-printable',
+    'Data'        => [ '<html>',
+                       '  <head>',
+                       '    <title>',
+                       '      '. encode_entities($return{'subject'}), 
+                       '    </title>',
+                       '  </head>',
+                       '  <body bgcolor="#e8e8e8">',
+                       @html_data,
+                       '  </body>',
+                       '</html>',
+                     ],
+    'Disposition' => 'inline',
+    #'Filename'    => 'invoice.pdf',
+  );
+
+  #no other attachment:
+  # multipart/related
+  #   multipart/alternative
+  #     text/plain
+  #     text/html
+
+  $return{'content-type'} = 'multipart/related';
+  $return{'mimeparts'} = [ $alternative ];
+  $return{'type'} = 'multipart/alternative'; #Content-Type of first part...
+  #$return{'disposition'} = 'inline';
+
+  %return;
 
 
-    #$quit && $smtp->quit;
-    #$ok ? @addr : ();
-    if ( $ok ) {
-      $quit && $smtp->quit;
-      return '';
-    } else {
-      return $smtp->code. ' '. $smtp->message;
-    }
 }
 }
-package FS::Misc;
-#eokludge
+
+=item process_send_email OPTION => VALUE ...
+
+Takes arguments as per generate_email() and sends the message.  This 
+will die on any error and can be used in the job queue.
+
+=cut
+
+sub process_send_email {
+  my %message = @_;
+  my $error = send_email(generate_email(%message));
+  die "$error\n" if $error;
+  '';
+}
 
 =item send_fax OPTION => VALUE ...
 
 
 =item send_fax OPTION => VALUE ...
 
@@ -406,6 +517,7 @@ Returns a list of counties for this state and country.
 sub counties {
   my( $state, $country ) = @_;
 
 sub counties {
   my( $state, $country ) = @_;
 
+  map { $_ } #return num_counties($state, $country) unless wantarray;
   sort map { s/[\n\r]//g; $_; }
        map { $_->county }
            qsearch({
   sort map { s/[\n\r]//g; $_; }
        map { $_->county }
            qsearch({
@@ -417,6 +529,28 @@ sub counties {
            });
 }
 
            });
 }
 
+=item cities COUNTY STATE COUNTRY
+
+Returns a list of cities for this county, state and country.
+
+=cut
+
+sub cities {
+  my( $county, $state, $country ) = @_;
+
+  map { $_ } #return num_cities($county, $state, $country) unless wantarray;
+  sort map { s/[\n\r]//g; $_; }
+       map { $_->city }
+           qsearch({
+             'select'  => 'DISTINCT city',
+             'table'   => 'cust_main_county',
+             'hashref' => { 'county'  => $county,
+                            'state'   => $state,
+                            'country' => $country,
+                          },
+           });
+}
+
 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 
 =cut
 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 
 =cut
@@ -485,6 +619,39 @@ sub card_types {
   \%card_types;
 }
 
   \%card_types;
 }
 
+=item pkg_freqs
+
+Returns a hash reference of allowed package billing frequencies.
+
+=cut
+
+sub pkg_freqs {
+  tie my %freq, 'Tie::IxHash', (
+    '0'    => '(no recurring fee)',
+    '1h'   => 'hourly',
+    '1d'   => 'daily',
+    '2d'   => 'every two days',
+    '3d'   => 'every three days',
+    '1w'   => 'weekly',
+    '2w'   => 'biweekly (every 2 weeks)',
+    '1'    => 'monthly',
+    '45d'  => 'every 45 days',
+    '2'    => 'bimonthly (every 2 months)',
+    '3'    => 'quarterly (every 3 months)',
+    '4'    => 'every 4 months',
+    '137d' => 'every 4 1/2 months (137 days)',
+    '6'    => 'semiannually (every 6 months)',
+    '12'   => 'annually',
+    '13'   => 'every 13 months (annually +1 month)',
+    '24'   => 'biannually (every 2 years)',
+    '36'   => 'triannually (every 3 years)',
+    '48'   => '(every 4 years)',
+    '60'   => '(every 5 years)',
+    '120'  => '(every 10 years)',
+  ) ;
+  \%freq;
+}
+
 =item generate_ps FILENAME
 
 Returns an postscript rendition of the LaTex file, as a scalar.
 =item generate_ps FILENAME
 
 Returns an postscript rendition of the LaTex file, as a scalar.
@@ -500,12 +667,7 @@ sub generate_ps {
   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
   chdir($dir);
 
   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
   chdir($dir);
 
-  my $sfile = shell_quote $file;
-
-  system("pslatex $sfile.tex >/dev/null 2>&1") == 0
-    or die "pslatex $file.tex failed; see $file.log for details?\n";
-  system("pslatex $sfile.tex >/dev/null 2>&1") == 0
-    or die "pslatex $file.tex failed; see $file.log for details?\n";
+  _pslatex($file);
 
   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
     or die "dvips failed";
 
   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
     or die "dvips failed";
@@ -537,14 +699,86 @@ sub generate_ps {
 
 }
 
 
 }
 
+=item generate_pdf FILENAME
+
+Returns an PDF rendition of the LaTex file, as a scalar.  FILENAME does not
+contain the .tex suffix and is unlinked by this function.
+
+=cut
+
+use String::ShellQuote;
+
+sub generate_pdf {
+  my $file = shift;
+
+  my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
+  chdir($dir);
+
+  #system('pdflatex', "$file.tex");
+  #system('pdflatex', "$file.tex");
+  #! LaTeX Error: Unknown graphics extension: .eps.
+
+  _pslatex($file);
+
+  my $sfile = shell_quote $file;
+
+  #system('dvipdf', "$file.dvi", "$file.pdf" );
+  system(
+    "dvips -q -t letter -f $sfile.dvi ".
+    "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
+    "     -c save pop -"
+  ) == 0
+    or die "dvips | gs failed: $!";
+
+  open(PDF, "<$file.pdf")
+    or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
+
+  unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex");
+
+  my $pdf = '';
+  while (<PDF>) {
+    $pdf .= $_;
+  }
+
+  close PDF;
+
+  return $pdf;
+
+}
+
+sub _pslatex {
+  my $file = shift;
+
+  #my $sfile = shell_quote $file;
+
+  my @cmd = (
+    'latex',
+    '-interaction=batchmode',
+    '\AtBeginDocument{\RequirePackage{pslatex}}',
+    '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
+    '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
+    '\PSLATEXTMP',
+    "$file.tex"
+  );
+
+  my $timeout = 30; #? should be more than enough
+
+  for ( 1, 2 ) {
+
+    local($SIG{CHLD}) = sub {};
+    run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
+      or die "pslatex $file.tex failed; see $file.log for details?\n";
+
+  }
+
+}
+
 =item print ARRAYREF
 
 Sends the lines in ARRAYREF to the printer.
 
 =cut
 
 =item print ARRAYREF
 
 Sends the lines in ARRAYREF to the printer.
 
 =cut
 
-use IPC::Run3;
-
 sub do_print {
   my $data = shift;
 
 sub do_print {
   my $data = shift;
 
@@ -559,6 +793,100 @@ sub do_print {
 
 }
 
 
 }
 
+=item csv_from_fixed, FILEREF COUNTREF, [ LENGTH_LISTREF, [ CALLBACKS_LISTREF ] ]
+
+Converts the filehandle referenced by FILEREF from fixed length record
+lines to a CSV file according to the lengths specified in LENGTH_LISTREF.
+The CALLBACKS_LISTREF refers to a correpsonding list of coderefs.  Each
+should return the value to be substituted in place of its single argument.
+
+Returns false on success or an error if one occurs.
+
+=cut
+
+sub csv_from_fixed {
+  my( $fhref, $countref, $lengths, $callbacks) = @_;
+
+  eval { require Text::CSV_XS; };
+  return $@ if $@;
+
+  my $ofh = $$fhref;
+  my $unpacker = new Text::CSV_XS;
+  my $total = 0;
+  my $template = join('', map {$total += $_; "A$_"} @$lengths) if $lengths;
+
+  my $dir = "%%%FREESIDE_CACHE%%%/cache.$FS::UID::datasrc";
+  my $fh = new File::Temp( TEMPLATE => "FILE.csv.XXXXXXXX",
+                           DIR      => $dir,
+                           UNLINK   => 0,
+                         ) or return "can't open temp file: $!\n"
+    if $template;
+
+  while ( defined(my $line=<$ofh>) ) {
+    $$countref++;
+    if ( $template ) {
+      my $column = 0;
+
+      chomp $line;
+      return "unexpected input at line $$countref: $line".
+             " -- expected $total but received ". length($line)
+        unless length($line) == $total;
+
+      $unpacker->combine( map { my $i = $column++;
+                                defined( $callbacks->[$i] )
+                                  ? &{ $callbacks->[$i] }( $_ )
+                                  : $_
+                              } unpack( $template, $line )
+                        )
+        or return "invalid data for CSV: ". $unpacker->error_input;
+
+      print $fh $unpacker->string(), "\n"
+        or return "can't write temp file: $!\n";
+    }
+  }
+
+  if ( $template ) { close $$fhref; $$fhref = $fh }
+
+  seek $$fhref, 0, 0;
+  '';
+}
+
+=item ocr_image IMAGE_SCALAR
+
+Runs OCR on the provided image data and returns a list of text lines.
+
+=cut
+
+sub ocr_image {
+  my $logo_data = shift;
+
+  #XXX use conf dir location from Makefile
+  my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
+  my $fh = new File::Temp(
+    TEMPLATE => 'bizcard.XXXXXXXX',
+    SUFFIX   => '.png', #XXX assuming, but should handle jpg, gif, etc. too
+    DIR      => $dir,
+    UNLINK   => 0,
+  ) or die "can't open temp file: $!\n";
+
+  my $filename = $fh->filename;
+
+  print $fh $logo_data;
+  close $fh;
+
+  run( [qw(ocroscript recognize), $filename], '>'=>"$filename.hocr" )
+    or die "ocroscript recognize failed\n";
+
+  run( [qw(ocroscript hocr-to-text), "$filename.hocr"], '>pipe'=>\*OUT )
+    or die "ocroscript hocr-to-text failed\n";
+
+  my @lines = split(/\n/, <OUT> );
+
+  foreach (@lines) { s/\.c0m\s*$/.com/; }
+
+  @lines;
+}
+
 =back
 
 =head1 BUGS
 =back
 
 =head1 BUGS