Commit | Line | Data |
3fea05b9 |
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 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 | |
183 | 1; |