"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/lib/LWP/Protocol/mailto.pm" (26 Nov 2019, 4406 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "mailto.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.42_vs_6.43.

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