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 #do NOT depend on any FS:: modules here, causes weird (sometimes unreproducable
  11 #until on client machine) dependancy loops.  put them in FS::Misc::Something
  12 #instead
  13
  14 @ISA = qw( Exporter );
  15 @EXPORT_OK = qw( send_email send_fax
  16                  states_hash counties state_label
  17                  card_types
  18                  generate_ps generate_pdf do_print
  19                );
  20
  21 $DEBUG = 1;
  22
  23 =head1 NAME
  24
  25 FS::Misc - Miscellaneous subroutines
  26
  27 =head1 SYNOPSIS
  28
  29   use FS::Misc qw(send_email);
  30
  31   send_email();
  32
  33 =head1 DESCRIPTION
  34
  35 Miscellaneous subroutines.  This module contains miscellaneous subroutines
  36 called from multiple other modules.  These are not OO or necessarily related,
  37 but are collected here to elimiate code duplication.
  38
  39 =head1 SUBROUTINES
  40
  41 =over 4
  42
  43 =item send_email OPTION => VALUE ...
  44
  45 Options:
  46
  47 I<from> - (required)
  48
  49 I<to> - (required) comma-separated scalar or arrayref of recipients
  50
  51 I<subject> - (required)
  52
  53 I<content-type> - (optional) MIME type for the body
  54
  55 I<body> - (required unless I<nobody> is true) arrayref of body text lines
  56
  57 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().
  58
  59 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,
  60 I<content-type>, if specified, overrides the default "multipart/mixed" for the outermost MIME container.
  61
  62 I<content-encoding> - (optional) when using nobody, optional top-level MIME
  63 encoding which, if specified, overrides the default "7bit".
  64
  65 I<type> - (optional) type parameter for multipart/related messages
  66
  67 =cut
  68
  69 use vars qw( $conf );
  70 use Date::Format;
  71 use Mail::Header;
  72 use Mail::Internet 2.00;
  73 use MIME::Entity;
  74 use FS::UID;
  75
  76 FS::UID->install_callback( sub {
  77   $conf = new FS::Conf;
  78 } );
  79
  80 sub send_email {
  81   my(%options) = @_;
  82   if ( $DEBUG ) {
  83     my %doptions = %options;
  84     $doptions{'body'} = '(full body not shown in debug)';
  85     warn "FS::Misc::send_email called with options:\n  ". Dumper(\%doptions);
  86 #         join("\n", map { "  $_: ". $options{$_} } keys %options ). "\n"
  87   }
  88
  89   $ENV{MAILADDRESS} = $options{'from'};
  90   my $to = ref($options{to}) ? join(', ', @{ $options{to} } ) : $options{to};
  91
  92   my @mimeargs = ();
  93   my @mimeparts = ();
  94   if ( $options{'nobody'} ) {
  95
  96     croak "'mimeparts' option required when 'nobody' option given\n"
  97       unless $options{'mimeparts'};
  98
  99     @mimeparts = @{$options{'mimeparts'}};
 100
 101     @mimeargs = (
 102       'Type'         => ( $options{'content-type'} || 'multipart/mixed' ),
 103       'Encoding'     => ( $options{'content-encoding'} || '7bit' ),
 104     );
 105
 106   } else {
 107
 108     @mimeparts = @{$options{'mimeparts'}}
 109       if ref($options{'mimeparts'}) eq 'ARRAY';
 110
 111     if (scalar(@mimeparts)) {
 112
 113       @mimeargs = (
 114         'Type'     => 'multipart/mixed',
 115         'Encoding' => '7bit',
 116       );
 117
 118       unshift @mimeparts, {
 119         'Type'        => ( $options{'content-type'} || 'text/plain' ),
 120         'Data'        => $options{'body'},
 121         'Encoding'    => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 122         'Disposition' => 'inline',
 123       };
 124
 125     } else {
 126
 127       @mimeargs = (
 128         'Type'     => ( $options{'content-type'} || 'text/plain' ),
 129         'Data'     => $options{'body'},
 130         'Encoding' => ( $options{'content-type'} ? '-SUGGEST' : '7bit' ),
 131       );
 132
 133     }
 134
 135   }
 136
 137   my $domain;
 138   if ( $options{'from'} =~ /\@([\w\.\-]+)/ ) {
 139     $domain = $1;
 140   } else {
 141     warn 'no domain found in invoice from address '. $options{'from'}.
 142          '; constructing Message-ID @example.com';
 143     $domain = 'example.com';
 144   }
 145   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 146
 147   my $message = MIME::Entity->build(
 148     'From'       => $options{'from'},
 149     'To'         => $to,
 150     'Sender'     => $options{'from'},
 151     'Reply-To'   => $options{'from'},
 152     'Date'       => time2str("%a, %d %b %Y %X %z", time),
 153     'Subject'    => $options{'subject'},
 154     'Message-ID' => "<$message_id>",
 155     @mimeargs,
 156   );
 157
 158   if ( $options{'type'} ) {
 159     #false laziness w/cust_bill::generate_email
 160     $message->head->replace('Content-type',
 161       $message->mime_type.
 162       '; boundary="'. $message->head->multipart_boundary. '"'.
 163       '; type='. $options{'type'}
 164     );
 165   }
 166
 167   foreach my $part (@mimeparts) {
 168
 169     if ( UNIVERSAL::isa($part, 'MIME::Entity') ) {
 170
 171       warn "attaching MIME part from MIME::Entity object\n"
 172         if $DEBUG;
 173       $message->add_part($part);
 174
 175     } elsif ( ref($part) eq 'HASH' ) {
 176
 177       warn "attaching MIME part from hashref:\n".
 178            join("\n", map "  $_: ".$part->{$_}, keys %$part ). "\n"
 179         if $DEBUG;
 180       $message->attach(%$part);
 181
 182     } else {
 183       croak "mimepart $part isn't a hashref or MIME::Entity object!";
 184     }
 185
 186   }
 187
 188   my $smtpmachine = $conf->config('smtpmachine');
 189   $!=0;
 190
 191   $message->mysmtpsend( 'Host'     => $smtpmachine,
 192                         'MailFrom' => $options{'from'},
 193                       );
 194
 195 }
 196
 197 #this kludges a "mysmtpsend" method into Mail::Internet for send_email above
 198 #now updated for MailTools v2!
 199 package Mail::Internet;
 200
 201 use Mail::Address;
 202 use Net::SMTP;
 203 use Net::Domain;
 204
 205 sub Mail::Internet::mysmtpsend($@) {
 206     my ($self, %opt) = @_;
 207
 208     my $host     = $opt{Host};
 209     my $envelope = $opt{MailFrom}; # || mailaddress();
 210     my $quit     = 1;
 211
 212     my ($smtp, @hello);
 213
 214     push @hello, Hello => $opt{Hello}
 215         if defined $opt{Hello};
 216
 217     push @hello, Port => $opt{Port}
 218         if exists $opt{Port};
 219
 220     push @hello, Debug => $opt{Debug}
 221         if exists $opt{Debug};
 222
 223 #    if(!defined $host)
 224 #    {   local $SIG{__DIE__};
 225 #        my @hosts = qw(mailhost localhost);
 226 #        unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
 227 #            if defined $ENV{SMTPHOSTS};
 228 #
 229 #        foreach $host (@hosts)
 230 #        {   $smtp = eval { Net::SMTP->new($host, @hello) };
 231 #            last if defined $smtp;
 232 #        }
 233 #    }
 234 #    elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 235     if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 236     {   $smtp = $host;
 237         $quit = 0;
 238     }
 239     else
 240     {   #local $SIG{__DIE__};
 241         #$smtp = eval { Net::SMTP->new($host, @hello) };
 242         $smtp = Net::SMTP->new($host, @hello);
 243     }
 244
 245     unless ( defined($smtp) ) {
 246       my $err = $!;
 247       $err =~ s/Invalid argument/Unknown host/;
 248       return "can't connect to $host: $err"
 249     }
 250
 251     my $head = $self->cleaned_header_dup;
 252
 253     $head->delete('Bcc');
 254
 255     # Who is it to
 256
 257     my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
 258     @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
 259         unless @rcpt;
 260
 261     my @addr = map {$_->address} Mail::Address->parse(@rcpt);
 262     #@addr or return ();
 263     return 'No valid destination addresses found!'
 264         unless(@addr);
 265
 266     # Send it
 267
 268     my $ok = $smtp->mail($envelope)
 269           && $smtp->to(@addr)
 270           && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
 271
 272     #$quit && $smtp->quit;
 273     #$ok ? @addr : ();
 274     if ( $ok ) {
 275       $quit && $smtp->quit;
 276       return '';
 277     } else {
 278       return $smtp->code. ' '. $smtp->message;
 279     }
 280 }
 281 package FS::Misc;
 282 #eokludge
 283
 284 =item send_fax OPTION => VALUE ...
 285
 286 Options:
 287
 288 I<dialstring> - (required) 10-digit phone number w/ area code
 289
 290 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
 291
 292 -or-
 293
 294 I<docfile> - (required) Filename of PostScript TIFF Class F document
 295
 296 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
 297
 298
 299 =cut
 300
 301 sub send_fax {
 302
 303   my %options = @_;
 304
 305   die 'HylaFAX support has not been configured.'
 306     unless $conf->exists('hylafax');
 307
 308   eval {
 309     require Fax::Hylafax::Client;
 310   };
 311
 312   if ($@) {
 313     if ($@ =~ /^Can't locate Fax.*/) {
 314       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
 315     } else {
 316       die $@;
 317     }
 318   }
 319
 320   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
 321
 322   die 'Called send_fax without a \'dialstring\'.'
 323     unless exists($options{'dialstring'});
 324
 325   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
 326       my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 327       my $fh = new File::Temp(
 328         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
 329         DIR      => $dir,
 330         UNLINK   => 0,
 331       ) or die "can't open temp file: $!\n";
 332
 333       $options{docfile} = $fh->filename;
 334
 335       print $fh @{$options{'docdata'}};
 336       close $fh;
 337
 338       delete $options{'docdata'};
 339   }
 340
 341   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
 342     unless exists($options{'docfile'});
 343
 344   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
 345   #       works in the US.
 346
 347   $options{'dialstring'} =~ s/[^\d\+]//g;
 348   if ($options{'dialstring'} =~ /^\d{10}$/) {
 349     $options{dialstring} = '+1' . $options{'dialstring'};
 350   } else {
 351     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
 352   }
 353
 354   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
 355
 356   if ($faxjob->success) {
 357     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
 358            $faxjob->jobid
 359       if $DEBUG;
 360     return '';
 361   } else {
 362     return 'Error while sending FAX: ' . $faxjob->trace;
 363   }
 364
 365 }
 366
 367 =item states_hash COUNTRY
 368
 369 Returns a list of key/value pairs containing state (or other sub-country
 370 division) abbriviations and names.
 371
 372 =cut
 373
 374 use FS::Record qw(qsearch);
 375 use Locale::SubCountry;
 376
 377 sub states_hash {
 378   my($country) = @_;
 379
 380   my @states =
 381 #     sort
 382      map { s/[\n\r]//g; $_; }
 383      map { $_->state; }
 384          qsearch({
 385                    'select'    => 'state',
 386                    'table'     => 'cust_main_county',
 387                    'hashref'   => { 'country' => $country },
 388                    'extra_sql' => 'GROUP BY state',
 389                 });
 390
 391   #it could throw a fatal "Invalid country code" error (for example "AX")
 392   my $subcountry = eval { new Locale::SubCountry($country) }
 393     or return ( '', '(n/a)' );
 394
 395   #"i see your schwartz is as big as mine!"
 396   map  { ( $_->[0] => $_->[1] ) }
 397   sort { $a->[1] cmp $b->[1] }
 398   map  { [ $_ => state_label($_, $subcountry) ] }
 399        @states;
 400 }
 401
 402 =item counties STATE COUNTRY
 403
 404 Returns a list of counties for this state and country.
 405
 406 =cut
 407
 408 sub counties {
 409   my( $state, $country ) = @_;
 410
 411   sort map { s/[\n\r]//g; $_; }
 412        map { $_->county }
 413            qsearch({
 414              'select'  => 'DISTINCT county',
 415              'table'   => 'cust_main_county',
 416              'hashref' => { 'state'   => $state,
 417                             'country' => $country,
 418                           },
 419            });
 420 }
 421
 422 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 423
 424 =cut
 425
 426 sub state_label {
 427   my( $state, $country ) = @_;
 428
 429   unless ( ref($country) ) {
 430     $country = eval { new Locale::SubCountry($country) }
 431       or return'(n/a)';
 432
 433   }
 434
 435   # US kludge to avoid changing existing behaviour
 436   # also we actually *use* the abbriviations...
 437   my $full_name = $country->country_code eq 'US'
 438                     ? ''
 439                     : $country->full_name($state);
 440
 441   $full_name = '' if $full_name eq 'unknown';
 442   $full_name =~ s/\(see also.*\)\s*$//;
 443   $full_name .= " ($state)" if $full_name;
 444
 445   $full_name || $state || '(n/a)';
 446
 447 }
 448
 449 =item card_types
 450
 451 Returns a hash reference of the accepted credit card types.  Keys are shorter
 452 identifiers and values are the longer strings used by the system (see
 453 L<Business::CreditCard>).
 454
 455 =cut
 456
 457 #$conf from above
 458
 459 sub card_types {
 460   my $conf = new FS::Conf;
 461
 462   my %card_types = (
 463     #displayname                    #value (Business::CreditCard)
 464     "VISA"                       => "VISA card",
 465     "MasterCard"                 => "MasterCard",
 466     "Discover"                   => "Discover card",
 467     "American Express"           => "American Express card",
 468     "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
 469     "enRoute"                    => "enRoute",
 470     "JCB"                        => "JCB",
 471     "BankCard"                   => "BankCard",
 472     "Switch"                     => "Switch",
 473     "Solo"                       => "Solo",
 474   );
 475   my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
 476   if ( @conf_card_types ) {
 477     #perhaps the hash is backwards for this, but this way works better for
 478     #usage in selfservice
 479     %card_types = map  { $_ => $card_types{$_} }
 480                   grep {
 481                          my $d = $_;
 482                            grep { $card_types{$d} eq $_ } @conf_card_types
 483                        }
 484                     keys %card_types;
 485   }
 486
 487   \%card_types;
 488 }
 489
 490 =item generate_ps FILENAME
 491
 492 Returns an postscript rendition of the LaTex file, as a scalar.
 493 FILENAME does not contain the .tex suffix and is unlinked by this function.
 494
 495 =cut
 496
 497 use String::ShellQuote;
 498
 499 sub generate_ps {
 500   my $file = shift;
 501
 502   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 503   chdir($dir);
 504
 505   _pslatex($file);
 506
 507   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
 508     or die "dvips failed";
 509
 510   open(POSTSCRIPT, "<$file.ps")
 511     or die "can't open $file.ps: $! (error in LaTeX template?)\n";
 512
 513   unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex");
 514
 515   my $ps = '';
 516
 517   if ( $conf->exists('lpr-postscript_prefix') ) {
 518     my $prefix = $conf->config('lpr-postscript_prefix');
 519     $ps .= eval qq("$prefix");
 520   }
 521
 522   while (<POSTSCRIPT>) {
 523     $ps .= $_;
 524   }
 525
 526   close POSTSCRIPT;
 527
 528   if ( $conf->exists('lpr-postscript_suffix') ) {
 529     my $suffix = $conf->config('lpr-postscript_suffix');
 530     $ps .= eval qq("$suffix");
 531   }
 532
 533   return $ps;
 534
 535 }
 536
 537 =item generate_pdf FILENAME
 538
 539 Returns an PDF rendition of the LaTex file, as a scalar.  FILENAME does not
 540 contain the .tex suffix and is unlinked by this function.
 541
 542 =cut
 543
 544 use String::ShellQuote;
 545
 546 sub generate_pdf {
 547   my $file = shift;
 548
 549   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 550   chdir($dir);
 551
 552   #system('pdflatex', "$file.tex");
 553   #system('pdflatex', "$file.tex");
 554   #! LaTeX Error: Unknown graphics extension: .eps.
 555
 556   _pslatex($file);
 557
 558   my $sfile = shell_quote $file;
 559
 560   #system('dvipdf', "$file.dvi", "$file.pdf" );
 561   system(
 562     "dvips -q -t letter -f $sfile.dvi ".
 563     "| gs -q -dNOPAUSE -dBATCH -sDEVICE=pdfwrite -sOutputFile=$sfile.pdf ".
 564     "     -c save pop -"
 565   ) == 0
 566     or die "dvips | gs failed: $!";
 567
 568   open(PDF, "<$file.pdf")
 569     or die "can't open $file.pdf: $! (error in LaTeX template?)\n";
 570
 571   unlink("$file.dvi", "$file.log", "$file.aux", "$file.pdf", "$file.tex");
 572
 573   my $pdf = '';
 574   while (<PDF>) {
 575     $pdf .= $_;
 576   }
 577
 578   close PDF;
 579
 580   return $pdf;
 581
 582 }
 583
 584 sub _pslatex {
 585   my $file = shift;
 586
 587   #my $sfile = shell_quote $file;
 588
 589   my @cmd = (
 590     'latex',
 591     '-interaction=batchmode',
 592     '\AtBeginDocument{\RequirePackage{pslatex}}',
 593     '\def\PSLATEXTMP{\futurelet\PSLATEXTMP\PSLATEXTMPB}',
 594     '\def\PSLATEXTMPB{\ifx\PSLATEXTMP\nonstopmode\else\input\fi}',
 595     '\PSLATEXTMP',
 596     "$file.tex"
 597   );
 598
 599   my $timeout = 30; #? should be more than enough
 600
 601   for ( 1, 2 ) {
 602
 603     local($SIG{CHLD}) = sub {};
 604     #run( \@cmd, '>'=>'/dev/null', '2>'=>'/dev/null', timeout($timeout) )
 605     run( \@cmd, timeout($timeout) )
 606       or die "pslatex $file.tex failed; see $file.log for details?\n";
 607
 608   }
 609
 610 }
 611
 612 =item print ARRAYREF
 613
 614 Sends the lines in ARRAYREF to the printer.
 615
 616 =cut
 617
 618 sub do_print {
 619   my $data = shift;
 620
 621   my $lpr = $conf->config('lpr');
 622
 623   my $outerr = '';
 624   run3 $lpr, $data, \$outerr, \$outerr;
 625   if ( $? ) {
 626     $outerr = ": $outerr" if length($outerr);
 627     die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
 628   }
 629
 630 }
 631
 632 =back
 633
 634 =head1 BUGS
 635
 636 This package exists.
 637
 638 =head1 SEE ALSO
 639
 640 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
 641
 642 L<Fax::Hylafax::Client>
 643
 644 =cut
 645
 646 1;