lib/LWP/Protocol/mailto.pm

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