vcs.maemo.org Git - dh-make-perl/blob - dev/arm/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/mailto.pm

   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->url;
  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;