/extras/perl/site_perl/LWP/Protocol/mailto.pm
Perl | 183 lines | 169 code | 10 blank | 4 comment | 21 complexity | 66ff19172bf66fa106a6602ec358b4a7 MD5 | raw file
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;