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