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