X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=dev%2Farm%2Flibwww-perl%2Flibwww-perl-5.813%2Flib%2FLWP%2FProtocol%2Fmailto.pm;fp=dev%2Farm%2Flibwww-perl%2Flibwww-perl-5.813%2Flib%2FLWP%2FProtocol%2Fmailto.pm;h=73a8885fe404d463717257d360ad099f20085d80;hb=f477fa73365d491991707e7ed9217b48d6994551;hp=0000000000000000000000000000000000000000;hpb=da95c414033799c3a62606f299c3c00b5c77ca11;p=dh-make-perl

diff --git a/dev/arm/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/mailto.pm b/dev/arm/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/mailto.pm
new file mode 100644
index 0000000..73a8885
--- /dev/null
+++ b/dev/arm/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/mailto.pm
@@ -0,0 +1,183 @@
+package LWP::Protocol::mailto;
+
+# This module implements the mailto protocol.  It is just a simple
+# frontend to the Unix sendmail program except on MacOS, where it uses
+# Mail::Internet.
+
+require LWP::Protocol;
+require HTTP::Request;
+require HTTP::Response;
+require HTTP::Status;
+
+use Carp;
+use strict;
+use vars qw(@ISA $SENDMAIL);
+
+@ISA = qw(LWP::Protocol);
+
+unless ($SENDMAIL = $ENV{SENDMAIL}) {
+    for my $sm (qw(/usr/sbin/sendmail
+		   /usr/lib/sendmail
+		   /usr/ucblib/sendmail
+		  ))
+    {
+	if (-x $sm) {
+	    $SENDMAIL = $sm;
+	    last;
+	}
+    }
+    die "Can't find the 'sendmail' program" unless $SENDMAIL;
+}
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size) = @_;
+
+    my ($mail, $addr) if $^O eq "MacOS";
+    my @text = () if $^O eq "MacOS";
+
+    # check proxy
+    if (defined $proxy)
+    {
+	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
+				  'You can not proxy with mail';
+    }
+
+    # check method
+    my $method = $request->method;
+
+    if ($method ne 'POST') {
+	return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
+				  'Library does not allow method ' .
+				  "$method for 'mailto:' URLs";
+    }
+
+    # check url
+    my $url = $request->url;
+
+    my $scheme = $url->scheme;
+    if ($scheme ne 'mailto') {
+	return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+			 "LWP::Protocol::mailto::request called for '$scheme'";
+    }
+    if ($^O eq "MacOS") {
+	eval {
+	    require Mail::Internet;
+	};
+	if($@) {
+	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have MailTools installed";
+	}
+	unless ($ENV{SMTPHOSTS}) {
+	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have SMTPHOSTS defined";
+	}
+    }
+    else {
+	unless (-x $SENDMAIL) {
+	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "You don't have $SENDMAIL";
+    }
+    }
+    if ($^O eq "MacOS") {
+	    $mail = Mail::Internet->new or
+	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	    "Can't get a Mail::Internet object";
+    }
+    else {
+	open(SENDMAIL, "| $SENDMAIL -oi -t") or
+	    return new HTTP::Response &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+	               "Can't run $SENDMAIL: $!";
+    }
+    if ($^O eq "MacOS") {
+	$addr = $url->encoded822addr;
+    }
+    else {
+	$request = $request->clone;  # we modify a copy
+	my @h = $url->headers;  # URL headers override those in the request
+	while (@h) {
+	    my $k = shift @h;
+	    my $v = shift @h;
+	    next unless defined $v;
+	    if (lc($k) eq "body") {
+		$request->content($v);
+	    }
+	    else {
+		$request->push_header($k => $v);
+	    }
+	}
+    }
+    if ($^O eq "MacOS") {
+	$mail->add(To => $addr);
+	$mail->add(split(/[:\n]/,$request->headers_as_string));
+    }
+    else {
+	print SENDMAIL $request->headers_as_string;
+	print SENDMAIL "\n";
+    }
+    my $content = $request->content;
+    if (defined $content) {
+	my $contRef = ref($content) ? $content : \$content;
+	if (ref($contRef) eq 'SCALAR') {
+	    if ($^O eq "MacOS") {
+		@text = split("\n",$$contRef);
+		foreach (@text) {
+		    $_ .= "\n";
+		}
+	    }
+	    else {
+	    print SENDMAIL $$contRef;
+	    }
+
+	}
+	elsif (ref($contRef) eq 'CODE') {
+	    # Callback provides data
+	    my $d;
+	    if ($^O eq "MacOS") {
+		my $stuff = "";
+		while (length($d = &$contRef)) {
+		    $stuff .= $d;
+		}
+		@text = split("\n",$stuff);
+		foreach (@text) {
+		    $_ .= "\n";
+		}
+	    }
+	    else {
+		print SENDMAIL $d;
+	    }
+	}
+    }
+    if ($^O eq "MacOS") {
+	$mail->body(\@text);
+	unless ($mail->smtpsend) {
+	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				       "Mail::Internet->smtpsend unable to send message to <$addr>");
+	}
+    }
+    else {
+	unless (close(SENDMAIL)) {
+	    my $err = $! ? "$!" : "Exit status $?";
+	    return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				       "$SENDMAIL: $err");
+	}
+    }
+
+
+    my $response = HTTP::Response->new(&HTTP::Status::RC_ACCEPTED,
+				       "Mail accepted");
+    $response->header('Content-Type', 'text/plain');
+    if ($^O eq "MacOS") {
+	$response->header('Server' => "Mail::Internet $Mail::Internet::VERSION");
+	$response->content("Message sent to <$addr>\n");
+    }
+    else {
+	$response->header('Server' => $SENDMAIL);
+	my $to = $request->header("To");
+	$response->content("Message sent to <$to>\n");
+    }
+
+    return $response;
+}
+
+1;