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