/extras/perl/site_perl/LWP/Protocol/mailto.pm

  1package LWP::Protocol::mailto;
  2
  3# This module implements the mailto protocol.  It is just a simple
  4# frontend to the Unix sendmail program except on MacOS, where it uses
  5# Mail::Internet.
  6
  7require LWP::Protocol;
  8require HTTP::Request;
  9require HTTP::Response;
 10require HTTP::Status;
 11
 12use Carp;
 13use strict;
 14use vars qw(@ISA $SENDMAIL);
 15
 16@ISA = qw(LWP::Protocol);
 17
 18unless ($SENDMAIL = $ENV{SENDMAIL}) {
 19    for my $sm (qw(/usr/sbin/sendmail
 20		   /usr/lib/sendmail
 21		   /usr/ucblib/sendmail
 22		  ))
 23    {
 24	if (-x $sm) {
 25	    $SENDMAIL = $sm;
 26	    last;
 27	}
 28    }
 29    die "Can't find the 'sendmail' program" unless $SENDMAIL;
 30}
 31
 32sub request
 33{
 34    my($self, $request, $proxy, $arg, $size) = @_;
 35
 36    my ($mail, $addr) if $^O eq "MacOS";
 37    my @text = () if $^O eq "MacOS";
 38
 39    # check proxy
 40    if (defined $proxy)
 41    {
 42	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
 43				  'You can not proxy with mail';
 44    }
 45
 46    # check method
 47    my $method = $request->method;
 48
 49    if ($method ne 'POST') {
 50	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
 51				  'Library does not allow method ' .
 52				  "$method for 'mailto:' URLs";
 53    }
 54
 55    # check url
 56    my $url = $request->uri;
 57
 58    my $scheme = $url->scheme;
 59    if ($scheme ne 'mailto') {
 60	return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 61			 "LWP::Protocol::mailto::request called for '$scheme'";
 62    }
 63    if ($^O eq "MacOS") {
 64	eval {
 65	    require Mail::Internet;
 66	};
 67	if($@) {
 68	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 69	               "You don't have MailTools installed";
 70	}
 71	unless ($ENV{SMTPHOSTS}) {
 72	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 73	               "You don't have SMTPHOSTS defined";
 74	}
 75    }
 76    else {
 77	unless (-x $SENDMAIL) {
 78	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 79	               "You don't have $SENDMAIL";
 80    }
 81    }
 82    if ($^O eq "MacOS") {
 83	    $mail = Mail::Internet->new or
 84	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 85	    "Can't get a Mail::Internet object";
 86    }
 87    else {
 88	open(SENDMAIL, "| $SENDMAIL -oi -t") or
 89	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
 90	               "Can't run $SENDMAIL: $!";
 91    }
 92    if ($^O eq "MacOS") {
 93	$addr = $url->encoded822addr;
 94    }
 95    else {
 96	$request = $request->clone;  # we modify a copy
 97	my @h = $url->headers;  # URL headers override those in the request
 98	while (@h) {
 99	    my $k = shift @h;
100	    my $v = shift @h;
101	    next unless defined $v;
102	    if (lc($k) eq "body") {
103		$request->content($v);
104	    }
105	    else {
106		$request->push_header($k => $v);
107	    }
108	}
109    }
110    if ($^O eq "MacOS") {
111	$mail->add(To => $addr);
112	$mail->add(split(/[:\n]/,$request->headers_as_string));
113    }
114    else {
115	print SENDMAIL $request->headers_as_string;
116	print SENDMAIL "\n";
117    }
118    my $content = $request->content;
119    if (defined $content) {
120	my $contRef = ref($content) ? $content : \$content;
121	if (ref($contRef) eq 'SCALAR') {
122	    if ($^O eq "MacOS") {
123		@text = split("\n",$$contRef);
124		foreach (@text) {
125		    $_ .= "\n";
126		}
127	    }
128	    else {
129	    print SENDMAIL $$contRef;
130	    }
131
132	}
133	elsif (ref($contRef) eq 'CODE') {
134	    # Callback provides data
135	    my $d;
136	    if ($^O eq "MacOS") {
137		my $stuff = "";
138		while (length($d = &$contRef)) {
139		    $stuff .= $d;
140		}
141		@text = split("\n",$stuff);
142		foreach (@text) {
143		    $_ .= "\n";
144		}
145	    }
146	    else {
147		print SENDMAIL $d;
148	    }
149	}
150    }
151    if ($^O eq "MacOS") {
152	$mail->body(\@text);
153	unless ($mail->smtpsend) {
154	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
155				       "Mail::Internet->smtpsend unable to send message to <$addr>");
156	}
157    }
158    else {
159	unless (close(SENDMAIL)) {
160	    my $err = $! ? "$!" : "Exit status $?";
161	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
162				       "$SENDMAIL: $err");
163	}
164    }
165
166
167    my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
168				       "Mail accepted");
169    $response->header('Content-Type', 'text/plain');
170    if ($^O eq "MacOS") {
171	$response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
172	$response->content("Message sent to <$addr>\n");
173    }
174    else {
175	$response->header('Server' => $SENDMAIL);
176	my $to = $request->header("To");
177	$response->content("Message sent to <$to>\n");
178    }
179
180    return $response;
181}
182
1831;