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