source: main/trunk/greenstone2/perllib/cpan/LWP/Protocol/mailto.pm@ 27183

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 HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
                  'You can not proxy with mail');
    }

    # check method
    my $method = $request->method;

    if ($method ne 'POST') {
    return HTTP::Response->new( &HTTP::Status::RC_BAD_REQUEST,
                  'Library does not allow method ' .
                  "$method for 'mailto:' URLs");
    }

    # check url
    my $url = $request->uri;

    my $scheme = $url->scheme;
    if ($scheme ne 'mailto') {
    return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
             "LWP::Protocol::mailto::request called for '$scheme'");
    }
    if ($^O eq "MacOS") {
    eval {
        require Mail::Internet;
    };
    if($@) {
        return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                   "You don't have MailTools installed");
    }
    unless ($ENV{SMTPHOSTS}) {
        return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                   "You don't have SMTPHOSTS defined");
    }
    }
    else {
    unless (-x $SENDMAIL) {
        return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
                   "You don't have $SENDMAIL");
    }
    }
    if ($^O eq "MacOS") {
        $mail = Mail::Internet->new or
        return HTTP::Response->new( &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
        "Can't get a Mail::Internet object");
    }
    else {
    open(SENDMAIL, "| $SENDMAIL -oi -t") or
        return HTTP::Response->new( &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;