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 2.00;
  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 #now updated for MailTools v2!
 197 package Mail::Internet;
 198
 199 use Mail::Address;
 200 use Net::SMTP;
 201 use Net::Domain;
 202
 203 sub Mail::Internet::mysmtpsend($@) {
 204     my ($self, %opt) = @_;
 205
 206     my $host     = $opt{Host};
 207     my $envelope = $opt{MailFrom}; # || mailaddress();
 208     my $quit     = 1;
 209
 210     my ($smtp, @hello);
 211
 212     push @hello, Hello => $opt{Hello}
 213         if defined $opt{Hello};
 214
 215     push @hello, Port => $opt{Port}
 216         if exists $opt{Port};
 217
 218     push @hello, Debug => $opt{Debug}
 219         if exists $opt{Debug};
 220
 221 #    if(!defined $host)
 222 #    {   local $SIG{__DIE__};
 223 #        my @hosts = qw(mailhost localhost);
 224 #        unshift @hosts, split /\:/, $ENV{SMTPHOSTS}
 225 #            if defined $ENV{SMTPHOSTS};
 226 #
 227 #        foreach $host (@hosts)
 228 #        {   $smtp = eval { Net::SMTP->new($host, @hello) };
 229 #            last if defined $smtp;
 230 #        }
 231 #    }
 232 #    elsif(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 233     if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP'))
 234     {   $smtp = $host;
 235         $quit = 0;
 236     }
 237     else
 238     {   #local $SIG{__DIE__};
 239         #$smtp = eval { Net::SMTP->new($host, @hello) };
 240         $smtp = Net::SMTP->new($host, @hello);
 241     }
 242
 243     unless ( defined($smtp) ) {
 244       my $err = $!;
 245       $err =~ s/Invalid argument/Unknown host/;
 246       return "can't connect to $host: $err"
 247     }
 248
 249     my $head = $self->cleaned_header_dup;
 250
 251     $head->delete('Bcc');
 252
 253     # Who is it to
 254
 255     my @rcpt = map { ref $_ ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
 256     @rcpt    = map { $head->get($_) } qw(To Cc Bcc)
 257         unless @rcpt;
 258
 259     my @addr = map {$_->address} Mail::Address->parse(@rcpt);
 260     #@addr or return ();
 261     return 'No valid destination addresses found!'
 262         unless(@addr);
 263
 264     # Send it
 265
 266     my $ok = $smtp->mail($envelope)
 267           && $smtp->to(@addr)
 268           && $smtp->data(join("", @{$head->header}, "\n", @{$self->body}));
 269
 270     #$quit && $smtp->quit;
 271     #$ok ? @addr : ();
 272     if ( $ok ) {
 273       $quit && $smtp->quit;
 274       return '';
 275     } else {
 276       return $smtp->code. ' '. $smtp->message;
 277     }
 278 }
 279 package FS::Misc;
 280 #eokludge
 281
 282 =item send_fax OPTION => VALUE ...
 283
 284 Options:
 285
 286 I<dialstring> - (required) 10-digit phone number w/ area code
 287
 288 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
 289
 290 -or-
 291
 292 I<docfile> - (required) Filename of PostScript TIFF Class F document
 293
 294 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
 295
 296
 297 =cut
 298
 299 sub send_fax {
 300
 301   my %options = @_;
 302
 303   die 'HylaFAX support has not been configured.'
 304     unless $conf->exists('hylafax');
 305
 306   eval {
 307     require Fax::Hylafax::Client;
 308   };
 309
 310   if ($@) {
 311     if ($@ =~ /^Can't locate Fax.*/) {
 312       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
 313     } else {
 314       die $@;
 315     }
 316   }
 317
 318   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
 319
 320   die 'Called send_fax without a \'dialstring\'.'
 321     unless exists($options{'dialstring'});
 322
 323   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
 324       my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 325       my $fh = new File::Temp(
 326         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
 327         DIR      => $dir,
 328         UNLINK   => 0,
 329       ) or die "can't open temp file: $!\n";
 330
 331       $options{docfile} = $fh->filename;
 332
 333       print $fh @{$options{'docdata'}};
 334       close $fh;
 335
 336       delete $options{'docdata'};
 337   }
 338
 339   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
 340     unless exists($options{'docfile'});
 341
 342   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
 343   #       works in the US.
 344
 345   $options{'dialstring'} =~ s/[^\d\+]//g;
 346   if ($options{'dialstring'} =~ /^\d{10}$/) {
 347     $options{dialstring} = '+1' . $options{'dialstring'};
 348   } else {
 349     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
 350   }
 351
 352   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
 353
 354   if ($faxjob->success) {
 355     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
 356            $faxjob->jobid
 357       if $DEBUG;
 358     return '';
 359   } else {
 360     return 'Error while sending FAX: ' . $faxjob->trace;
 361   }
 362
 363 }
 364
 365 =item states_hash COUNTRY
 366
 367 Returns a list of key/value pairs containing state (or other sub-country
 368 division) abbriviations and names.
 369
 370 =cut
 371
 372 use FS::Record qw(qsearch);
 373 use Locale::SubCountry;
 374
 375 sub states_hash {
 376   my($country) = @_;
 377
 378   my @states =
 379 #     sort
 380      map { s/[\n\r]//g; $_; }
 381      map { $_->state; }
 382          qsearch({
 383                    'select'    => 'state',
 384                    'table'     => 'cust_main_county',
 385                    'hashref'   => { 'country' => $country },
 386                    'extra_sql' => 'GROUP BY state',
 387                 });
 388
 389   #it could throw a fatal "Invalid country code" error (for example "AX")
 390   my $subcountry = eval { new Locale::SubCountry($country) }
 391     or return ( '', '(n/a)' );
 392
 393   #"i see your schwartz is as big as mine!"
 394   map  { ( $_->[0] => $_->[1] ) }
 395   sort { $a->[1] cmp $b->[1] }
 396   map  { [ $_ => state_label($_, $subcountry) ] }
 397        @states;
 398 }
 399
 400 =item counties STATE COUNTRY
 401
 402 Returns a list of counties for this state and country.
 403
 404 =cut
 405
 406 sub counties {
 407   my( $state, $country ) = @_;
 408
 409   sort map { s/[\n\r]//g; $_; }
 410        map { $_->county }
 411            qsearch({
 412              'select'  => 'DISTINCT county',
 413              'table'   => 'cust_main_county',
 414              'hashref' => { 'state'   => $state,
 415                             'country' => $country,
 416                           },
 417            });
 418 }
 419
 420 =item state_label STATE COUNTRY_OR_LOCALE_SUBCOUNRY_OBJECT
 421
 422 =cut
 423
 424 sub state_label {
 425   my( $state, $country ) = @_;
 426
 427   unless ( ref($country) ) {
 428     $country = eval { new Locale::SubCountry($country) }
 429       or return'(n/a)';
 430
 431   }
 432
 433   # US kludge to avoid changing existing behaviour
 434   # also we actually *use* the abbriviations...
 435   my $full_name = $country->country_code eq 'US'
 436                     ? ''
 437                     : $country->full_name($state);
 438
 439   $full_name = '' if $full_name eq 'unknown';
 440   $full_name =~ s/\(see also.*\)\s*$//;
 441   $full_name .= " ($state)" if $full_name;
 442
 443   $full_name || $state || '(n/a)';
 444
 445 }
 446
 447 =item card_types
 448
 449 Returns a hash reference of the accepted credit card types.  Keys are shorter
 450 identifiers and values are the longer strings used by the system (see
 451 L<Business::CreditCard>).
 452
 453 =cut
 454
 455 #$conf from above
 456
 457 sub card_types {
 458   my $conf = new FS::Conf;
 459
 460   my %card_types = (
 461     #displayname                    #value (Business::CreditCard)
 462     "VISA"                       => "VISA card",
 463     "MasterCard"                 => "MasterCard",
 464     "Discover"                   => "Discover card",
 465     "American Express"           => "American Express card",
 466     "Diner's Club/Carte Blanche" => "Diner's Club/Carte Blanche",
 467     "enRoute"                    => "enRoute",
 468     "JCB"                        => "JCB",
 469     "BankCard"                   => "BankCard",
 470     "Switch"                     => "Switch",
 471     "Solo"                       => "Solo",
 472   );
 473   my @conf_card_types = grep { ! /^\s*$/ } $conf->config('card-types');
 474   if ( @conf_card_types ) {
 475     #perhaps the hash is backwards for this, but this way works better for
 476     #usage in selfservice
 477     %card_types = map  { $_ => $card_types{$_} }
 478                   grep {
 479                          my $d = $_;
 480                            grep { $card_types{$d} eq $_ } @conf_card_types
 481                        }
 482                     keys %card_types;
 483   }
 484
 485   \%card_types;
 486 }
 487
 488 =item generate_ps FILENAME
 489
 490 Returns an postscript rendition of the LaTex file, as a scalar.
 491 FILENAME does not contain the .tex suffix and is unlinked by this function.
 492
 493 =cut
 494
 495 use String::ShellQuote;
 496
 497 sub generate_ps {
 498   my $file = shift;
 499
 500   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
 501   chdir($dir);
 502
 503   my $sfile = shell_quote $file;
 504
 505   system("pslatex $sfile.tex >/dev/null 2>&1") == 0
 506     or die "pslatex $file.tex failed; see $file.log for details?\n";
 507   system("pslatex $sfile.tex >/dev/null 2>&1") == 0
 508     or die "pslatex $file.tex failed; see $file.log for details?\n";
 509
 510   system('dvips', '-q', '-t', 'letter', "$file.dvi", '-o', "$file.ps" ) == 0
 511     or die "dvips failed";
 512
 513   open(POSTSCRIPT, "<$file.ps")
 514     or die "can't open $file.ps: $! (error in LaTeX template?)\n";
 515
 516   unlink("$file.dvi", "$file.log", "$file.aux", "$file.ps", "$file.tex");
 517
 518   my $ps = '';
 519
 520   if ( $conf->exists('lpr-postscript_prefix') ) {
 521     my $prefix = $conf->config('lpr-postscript_prefix');
 522     $ps .= eval qq("$prefix");
 523   }
 524
 525   while (<POSTSCRIPT>) {
 526     $ps .= $_;
 527   }
 528
 529   close POSTSCRIPT;
 530
 531   if ( $conf->exists('lpr-postscript_suffix') ) {
 532     my $suffix = $conf->config('lpr-postscript_suffix');
 533     $ps .= eval qq("$suffix");
 534   }
 535
 536   return $ps;
 537
 538 }
 539
 540 =item print ARRAYREF
 541
 542 Sends the lines in ARRAYREF to the printer.
 543
 544 =cut
 545
 546 use IPC::Run3;
 547
 548 sub do_print {
 549   my $data = shift;
 550
 551   my $lpr = $conf->config('lpr');
 552
 553   my $outerr = '';
 554   run3 $lpr, $data, \$outerr, \$outerr;
 555   if ( $? ) {
 556     $outerr = ": $outerr" if length($outerr);
 557     die "Error from $lpr (exit status ". ($?>>8). ")$outerr\n";
 558   }
 559
 560 }
 561
 562 =back
 563
 564 =head1 BUGS
 565
 566 This package exists.
 567
 568 =head1 SEE ALSO
 569
 570 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
 571
 572 L<Fax::Hylafax::Client>
 573
 574 =cut
 575
 576 1;