Mercurial > pub > Impl
annotate Lib/Mailer.pm @ 151:e36ffd8c29db
Fixed major bug in conversion from a POST request to the DOM document (when instanceId == 0)
minor fixes
| author | wizard |
|---|---|
| date | Fri, 20 Aug 2010 16:33:37 +0400 |
| parents | 06a34c197b05 |
| children |
| rev | line source |
|---|---|
|
130
06a34c197b05
Added support for utf-8 and old versions of CGI module
wizard
parents:
49
diff
changeset
|
1 package IMPL::Mailer; |
| 49 | 2 use strict; |
| 3 | |
| 4 use Encode qw (encode); | |
| 5 use Encode::MIME::Header; | |
| 6 use MIME::Base64 qw(encode_base64); | |
| 7 use Email::Simple; | |
| 8 | |
| 9 our $SENDMAIL; | |
| 10 | |
| 11 sub DeliverMessage { | |
| 12 my $message = shift; | |
| 13 | |
| 14 $message = shift if $message eq __PACKAGE__ or ref $message eq __PACKAGE__; | |
| 15 | |
| 16 my $email = new Email::Simple($message); | |
| 17 | |
| 18 $email->header_set('Content-Transfer-Encoding' => 'base64'); | |
| 19 $email->header_set('MIME-Version' => '1.0') if !$email->header('MIME-Version'); | |
| 20 $email->header_set('Content-Type' => 'text/plain; charset="utf-8"'); | |
| 21 my $raw = $email->body(); | |
| 22 utf8::encode($raw) if utf8::is_utf8($raw); | |
| 23 $email->body_set(encode_base64($raw)); | |
| 24 | |
| 25 foreach my $field ($email->header_names()) { | |
| 26 $email->header_set($field, map { encode('MIME-Header', utf8::is_utf8($_) ? $_ : Encode::decode('utf-8',$_) ) } $email->header($field) ); | |
| 27 } | |
| 28 | |
| 29 return SendMail($email,@_); | |
| 30 } | |
| 31 | |
| 32 sub _find_sendmail { | |
| 33 return $SENDMAIL if defined $SENDMAIL; | |
| 34 | |
| 35 my @path = split /:/, $ENV{PATH}; | |
| 36 my $sendmail; | |
| 37 for (@path) { | |
| 38 if ( -x "$_/sendmail" ) { | |
| 39 $sendmail = "$_/sendmail"; | |
| 40 last; | |
| 41 } | |
| 42 } | |
| 43 return $sendmail; | |
| 44 } | |
| 45 | |
| 46 sub SendMail { | |
| 47 my ($message, %args) = @_; | |
| 48 my $mailer = _find_sendmail; | |
| 49 | |
| 50 local *SENDMAIL; | |
| 51 if( $args{'TestFile'} ) { | |
| 52 open SENDMAIL, '>', $args{TestFile} or die "Failed to open $args{TestFile}: $!"; | |
| 53 binmode(SENDMAIL); | |
| 54 print SENDMAIL "X-SendMail-Cmd: sendmail ",join(' ',%args),"\n"; | |
| 55 } else { | |
| 56 my @args = %args; | |
| 57 die "sendmail not found" unless $mailer; | |
| 58 die "Found $mailer but cannot execute it" | |
| 59 unless -x $mailer; | |
| 60 open SENDMAIL, "| $mailer -t -oi @args" | |
| 61 or die "Error executing $mailer: $!"; | |
| 62 } | |
| 63 print SENDMAIL $message->as_string | |
| 64 or die "Error printing via pipe to $mailer: $!"; | |
| 65 close SENDMAIL; | |
| 66 return 1; | |
| 67 } | |
| 68 | |
| 69 1; |