diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm')
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm | 183 |
1 files changed, 183 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm new file mode 100755 index 00000000000..700beb729d5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/mailto.pm @@ -0,0 +1,183 @@ +package LWP::Protocol::mailto; + +# This module implements the mailto protocol. It is just a simple +# frontend to the Unix sendmail program except on MacOS, where it uses +# Mail::Internet. + +require LWP::Protocol; +require HTTP::Request; +require HTTP::Response; +require HTTP::Status; + +use Carp; +use strict; +use vars qw(@ISA $SENDMAIL); + +@ISA = qw(LWP::Protocol); + +unless ($SENDMAIL = $ENV{SENDMAIL}) { + for my $sm (qw(/usr/sbin/sendmail + /usr/lib/sendmail + /usr/ucblib/sendmail + )) + { + if (-x $sm) { + $SENDMAIL = $sm; + last; + } + } + die "Can't find the 'sendmail' program" unless $SENDMAIL; +} + +sub request +{ + my($self, $request, $proxy, $arg, $size) = @_; + + my ($mail, $addr) if $^O eq "MacOS"; + my @text = () if $^O eq "MacOS"; + + # check proxy + if (defined $proxy) + { + return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST, + 'You can not proxy with mail'; + } + + # check method + my $method = $request->method; + + if ($method ne 'POST') { + return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST, + 'Library does not allow method ' . + "$method for 'mailto:' URLs"; + } + + # check url + my $url = $request->uri; + + my $scheme = $url->scheme; + if ($scheme ne 'mailto') { + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "LWP::Protocol::mailto::request called for '$scheme'"; + } + if ($^O eq "MacOS") { + eval { + require Mail::Internet; + }; + if($@) { + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have MailTools installed"; + } + unless ($ENV{SMTPHOSTS}) { + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have SMTPHOSTS defined"; + } + } + else { + unless (-x $SENDMAIL) { + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "You don't have $SENDMAIL"; + } + } + if ($^O eq "MacOS") { + $mail = Mail::Internet->new or + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't get a Mail::Internet object"; + } + else { + open(SENDMAIL, "| $SENDMAIL -oi -t") or + return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Can't run $SENDMAIL: $!"; + } + if ($^O eq "MacOS") { + $addr = $url->encoded822addr; + } + else { + $request = $request->clone; # we modify a copy + my @h = $url->headers; # URL headers override those in the request + while (@h) { + my $k = shift @h; + my $v = shift @h; + next unless defined $v; + if (lc($k) eq "body") { + $request->content($v); + } + else { + $request->push_header($k => $v); + } + } + } + if ($^O eq "MacOS") { + $mail->add(To => $addr); + $mail->add(split(/[:\n]/,$request->headers_as_string)); + } + else { + print SENDMAIL $request->headers_as_string; + print SENDMAIL "\n"; + } + my $content = $request->content; + if (defined $content) { + my $contRef = ref($content) ? $content : \$content; + if (ref($contRef) eq 'SCALAR') { + if ($^O eq "MacOS") { + @text = split("\n",$$contRef); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $$contRef; + } + + } + elsif (ref($contRef) eq 'CODE') { + # Callback provides data + my $d; + if ($^O eq "MacOS") { + my $stuff = ""; + while (length($d = &$contRef)) { + $stuff .= $d; + } + @text = split("\n",$stuff); + foreach (@text) { + $_ .= "\n"; + } + } + else { + print SENDMAIL $d; + } + } + } + if ($^O eq "MacOS") { + $mail->body(\@text); + unless ($mail->smtpsend) { + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "Mail::Internet->smtpsend unable to send message to <$addr>"); + } + } + else { + unless (close(SENDMAIL)) { + my $err = $! ? "$!" : "Exit status $?"; + return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR, + "$SENDMAIL: $err"); + } + } + + + my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED, + "Mail accepted"); + $response->header('Content-Type', 'text/plain'); + if ($^O eq "MacOS") { + $response->header('Server' => "Mail::Internet $Mail::Internet::VERSION"); + $response->content("Message sent to <$addr>\n"); + } + else { + $response->header('Server' => $SENDMAIL); + my $to = $request->header("To"); + $response->content("Message sent to <$to>\n"); + } + + return $response; +} + +1; |