1 | package 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 |
|
---|
7 | require LWP::Protocol;
|
---|
8 | require HTTP::Request;
|
---|
9 | require HTTP::Response;
|
---|
10 | require HTTP::Status;
|
---|
11 |
|
---|
12 | use Carp;
|
---|
13 | use strict;
|
---|
14 | use vars qw(@ISA $SENDMAIL);
|
---|
15 |
|
---|
16 | @ISA = qw(LWP::Protocol);
|
---|
17 |
|
---|
18 | unless ($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 |
|
---|
32 | sub 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 HTTP::Response->new(&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 HTTP::Response->new( &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 HTTP::Response->new( &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 HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
---|
69 | "You don't have MailTools installed");
|
---|
70 | }
|
---|
71 | unless ($ENV{SMTPHOSTS}) {
|
---|
72 | return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
|
---|
73 | "You don't have SMTPHOSTS defined");
|
---|
74 | }
|
---|
75 | }
|
---|
76 | else {
|
---|
77 | unless (-x $SENDMAIL) {
|
---|
78 | return HTTP::Response->new( &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 HTTP::Response->new( &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 HTTP::Response->new( &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 |
|
---|
183 | 1;
|
---|