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