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
  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 =item send_fax OPTION => VALUE ...
 189
 190 Options:
 191
 192 I<dialstring> - (required) 10-digit phone number w/ area code
 193
 194 I<docdata> - (required) Array ref containing PostScript or TIFF Class F document
 195
 196 -or-
 197
 198 I<docfile> - (required) Filename of PostScript TIFF Class F document
 199
 200 ...any other options will be passed to L<Fax::Hylafax::Client::sendfax>
 201
 202
 203 =cut
 204
 205 sub send_fax {
 206
 207   my %options = @_;
 208
 209   die 'HylaFAX support has not been configured.'
 210     unless $conf->exists('hylafax');
 211
 212   eval {
 213     require Fax::Hylafax::Client;
 214   };
 215
 216   if ($@) {
 217     if ($@ =~ /^Can't locate Fax.*/) {
 218       die "You must have Fax::Hylafax::Client installed to use invoice faxing."
 219     } else {
 220       die $@;
 221     }
 222   }
 223
 224   my %hylafax_opts = map { split /\s+/ } $conf->config('hylafax');
 225
 226   die 'Called send_fax without a \'dialstring\'.'
 227     unless exists($options{'dialstring'});
 228
 229   if (exists($options{'docdata'}) and ref($options{'docdata'}) eq 'ARRAY') {
 230       my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
 231       my $fh = new File::Temp(
 232         TEMPLATE => 'faxdoc.'. $options{'dialstring'} . '.XXXXXXXX',
 233         DIR      => $dir,
 234         UNLINK   => 0,
 235       ) or die "can't open temp file: $!\n";
 236
 237       $options{docfile} = $fh->filename;
 238
 239       print $fh @{$options{'docdata'}};
 240       close $fh;
 241
 242       delete $options{'docdata'};
 243   }
 244
 245   die 'Called send_fax without a \'docfile\' or \'docdata\'.'
 246     unless exists($options{'docfile'});
 247
 248   #FIXME: Need to send canonical dialstring to HylaFAX, but this only
 249   #       works in the US.
 250
 251   $options{'dialstring'} =~ s/[^\d\+]//g;
 252   if ($options{'dialstring'} =~ /^\d{10}$/) {
 253     $options{dialstring} = '+1' . $options{'dialstring'};
 254   } else {
 255     return 'Invalid dialstring ' . $options{'dialstring'} . '.';
 256   }
 257
 258   my $faxjob = &Fax::Hylafax::Client::sendfax(%options, %hylafax_opts);
 259
 260   if ($faxjob->success) {
 261     warn "Successfully queued fax to '$options{dialstring}' with jobid " .
 262            $faxjob->jobid
 263       if $DEBUG;
 264     return '';
 265   } else {
 266     return 'Error while sending FAX: ' . $faxjob->trace;
 267   }
 268
 269 }
 270
 271 package Mail::Internet;
 272
 273 use Mail::Address;
 274 use Net::SMTP;
 275
 276 sub Mail::Internet::mysmtpsend {
 277     my $src  = shift;
 278     my %opt = @_;
 279     my $host = $opt{Host};
 280     my $envelope = $opt{MailFrom};
 281     my $noquit = 0;
 282     my $smtp;
 283     my @hello = defined $opt{Hello} ? (Hello => $opt{Hello}) : ();
 284
 285     push(@hello, 'Port', $opt{'Port'})
 286         if exists $opt{'Port'};
 287
 288     push(@hello, 'Debug', $opt{'Debug'})
 289         if exists $opt{'Debug'};
 290
 291     if(ref($host) && UNIVERSAL::isa($host,'Net::SMTP')) {
 292         $smtp = $host;
 293         $noquit = 1;
 294     }
 295     else {
 296         #local $SIG{__DIE__};
 297         #$smtp = eval { Net::SMTP->new($host, @hello) };
 298         $smtp = new Net::SMTP $host, @hello;
 299     }
 300
 301     unless ( defined($smtp) ) {
 302       my $err = $!;
 303       $err =~ s/Invalid argument/Unknown host/;
 304       return "can't connect to $host: $err"
 305     }
 306
 307     my $hdr = $src->head->dup;
 308
 309     _prephdr($hdr);
 310
 311     # Who is it to
 312
 313     my @rcpt = map { ref($_) ? @$_ : $_ } grep { defined } @opt{'To','Cc','Bcc'};
 314     @rcpt = map { $hdr->get($_) } qw(To Cc Bcc)
 315         unless @rcpt;
 316     my @addr = map($_->address, Mail::Address->parse(@rcpt));
 317
 318     return 'No valid destination addresses found!'
 319         unless(@addr);
 320
 321     $hdr->delete('Bcc'); # Remove blind Cc's
 322
 323     # Send it
 324
 325     #warn "Headers: \n" . join('',@{$hdr->header});
 326     #warn "Body: \n" . join('',@{$src->body});
 327
 328     my $ok = $smtp->mail( $envelope ) &&
 329                 $smtp->to(@addr) &&
 330                 $smtp->data(join("", @{$hdr->header},"\n",@{$src->body}));
 331
 332     if ( $ok ) {
 333       $smtp->quit
 334           unless $noquit;
 335       return '';
 336     } else {
 337       return $smtp->code. ' '. $smtp->message;
 338     }
 339
 340 }
 341 package FS::Misc;
 342
 343 =back
 344
 345 =head1 BUGS
 346
 347 This package exists.
 348
 349 =head1 SEE ALSO
 350
 351 L<FS::UID>, L<FS::CGI>, L<FS::Record>, the base documentation.
 352
 353 L<Fax::Hylafax::Client>
 354
 355 =cut
 356
 357 1;