#!/v/guest/sw/bin/perl -w

use strict;
use vars qw( $MAX $SELF $UNIQ $ARCH $USER $PASS $CPAN $PORT $TIME $TEMP $MIME $MAIL $SERV $CLNT $FROM $TYPE $CODE $DISP @LIST @ERR $LOG );

use Net::FTP;
use Net::SMTP;
use MIME::Parser;
use MIME::Entity;

BEGIN
{
    $MAX  =  5; # Maximum number of files returned per request mail
    $SELF =  $0; $SELF =~ s!^.*[/\\]!!; $SELF =~ s!\.+[^\./\\]*$!!;
    $UNIQ =  sprintf("%03d%02d%02d%02d_%d", (localtime(time))[7,2,1,0], $$);
    $ARCH = "pindhart.muc.sdm.de";
    $USER = "anonymous";
    $PASS = "cpanserv\@muccpu1.muc.sdm.de";
    $CPAN = "/pub/mirrors/CPAN";
    $PORT =   21;
    $TIME =  120;
    $TEMP = "/tmp";
    $MIME = "mimepart_${UNIQ}_";
    $MAIL = "$TEMP/${SELF}_${UNIQ}.mail";
    $SERV = "muccpu1.muc.sdm.de";
    $CLNT = "muccpu1.muc.sdm.de";
    $FROM = "sb\@sdm.de (Automatic CPAN Mail Download Server)";
    $TYPE = "application/octet-stream";
    $CODE = "base64";
    $DISP = "attachment";
    @LIST =  ();
    @ERR  =  ();
    $LOG  =  $0; $LOG =~ s!\.+[^\./\\]*$!!; $LOG .= ".log";
}

END
{
    my($file,$item);

    foreach $file (@LIST)
    {
        unless (unlink($file))
        {
            warn "$SELF: unable to unlink file '$file': $!\n";
        }
    }
    unless (opendir(TEMP, $TEMP))
    {
        die "$SELF: couldn't read directory '$TEMP': $!\n";
    }
    while (defined ($item = readdir(TEMP)))
    {
        next if ($item =~ /^\.\.?$/);
        $file = "$TEMP/$item";
        next unless (-f $file);
        if ($item =~ /^$MIME/o)
        {
            unless (unlink($file))
            {
                warn "$SELF: unable to unlink file '$file': $!\n";
            }
        }
    }
    unless (closedir(TEMP))
    {
        warn "$SELF: couldn't close directory '$TEMP': $!\n";
    }
}

sub CloseFTP
{
    my($ftp) = @_;
    my($msg);

    unless ($ftp->quit())
    {
        $msg = $ftp->message();
        $msg =~ s!\s+$!!;
        push( @ERR,
            "Could not close the connection to '$ARCH'!",
            $msg );
    }
}

sub AbortFTP
{
    my($ftp) = shift;
    my($msg);

    $msg = $ftp->message();
    $msg =~ s!\s+$!!;
    push( @ERR, @_, $msg );
    &CloseFTP($ftp);
    return undef;
}

###############
##  M A I N  ##
###############

my($parser,$entity,$header,$body,$reply,$smtp,$item);
my($ftp,$line,$remote,$local,$file,$msg);

$parser = MIME::Parser->new();
$parser->output_dir( $TEMP );
$parser->output_prefix( $MIME );
eval { $entity = $parser->read( \*STDIN ); };
unless (($@ eq '') && (defined $entity) && (ref $entity))
{
    if ($@)
    {
        $@ =~ s!\s+$!!;
        die "$SELF: error while parsing mail: $@\n";
    }
    else
    {
        die "$SELF: MIME syntax error in mail!\n";
    }
}
eval { $header = $entity->head(); };
unless (($@ eq '') && (defined $header) && (ref $header))
{
    $@ =~ s!\s+$!!;
    $msg = "$SELF: unable to access mail header";
    if ($@) { $msg .= ": $@\n"; }
    else    { $msg .= "!\n";    }
    die $msg;
}
eval
{
    $header->decode(); # Decode Quoted-Printable etc. (RFC 1522)
#   $header->unfold(); # Join multiple lines
                       # (Commented out because of undesirable side effects)
};
if ($@)
{
    $@ =~ s!\s+$!!;
    die "$SELF: unable to decode mail header: $@\n";
}
eval
{
    $reply = $header->get( 'Reply-To', 0 );
    unless (defined $reply and $reply !~ /^\s*$/)
    {
        $reply = $header->get( 'From', 0 );
        unless (defined $reply and $reply !~ /^\s*$/)
        {
            $reply = $header->get( 'Sender', 0 );
            unless (defined $reply and $reply !~ /^\s*$/)
            {
                $reply = $header->get( 'X-Sender', 0 );
            }
        }
    }
};
unless (($@ eq '') and (defined $reply and $reply !~ /^\s*$/))
{
    $@ =~ s!\s+$!!;
    $msg = "$SELF: unable to determine sender";
    if ($@) { $msg .= ": $@\n"; }
    else    { $msg .= "!\n";    }
    die $msg;
}
$reply =~ s!^\s+!!;
$reply =~ s!\s+$!!;
eval { $body = $entity->body(); };
unless (($@ eq '') && (defined $body) && (ref $body))
{
    $@ =~ s!\s+$!!;
    $msg = "$SELF: unable to access mail body";
    if ($@) { $msg .= ": $@\n"; }
    else    { $msg .= "!\n";    }
    die $msg;
}
unless ($ftp = Net::FTP->new($ARCH, 'Port' => $PORT, 'Timeout' => $TIME))
{
    $@ =~ s!\s+$!!;
    push( @ERR,
        "Could not establish connection to '$ARCH'!",
        $@ );
    return undef;
}
unless ($ftp->login($USER, $PASS))
{
    return &AbortFTP($ftp,
        "Could not log into '$ARCH' as '$USER'!");
}
unless ($ftp->cwd($CPAN))
{
    return &AbortFTP($ftp,
        "Could not cd to '$CPAN'!");
}
unless ($ftp->binary())
{
    return &AbortFTP($ftp,
        "Could not set 'binary' mode!");
}
foreach $line (@{$body})
{
    next unless ($line =~ m!^\s*(/*(?:[a-zA-Z0-9_.,+-]+/+)*[a-zA-Z0-9_.,+-]+)\s*$!);
    $remote = $1;
    $local = $remote;
    $local =~ s!^.*/!!;
    $local = "$TEMP/$local";
    if (-e $local)
    {
        unless (unlink($local))
        {
            push( @ERR,
                "Could not overwrite '$local': $!" );
            next;
        }
    }
    if ($ftp->get($remote, $local))
    {
        push( @LIST, $local );
        last if (@LIST >= $MAX);
    }
    else
    {
        $msg = $ftp->message();
        $msg =~ s!\s+$!!;
        push( @ERR,
            "Could not fetch '$local'",
            "from '$remote'!",
            $msg );
    }
}
&CloseFTP($ftp);
#@ERR = map( $_ .= "\n", @ERR );
if (open(LOG, ">>$LOG"))
{
    print LOG '-' x 78, "\n";
    print LOG "TIMESTAMP: ", scalar(localtime), "\n";
    print LOG "ADDRESS: $reply\n";
    print LOG "ERRORS:\n";
    foreach $line (@ERR)
    {
        $line .= "\n";
        print LOG $line;
    }
    print LOG "FILES:\n";
    foreach $file (@LIST)
    {
        print LOG "$file\n";
    }
    print LOG '-' x 78, "\n";
    close(LOG);
}
eval
{
    $entity = MIME::Entity->build( 'From'    => $FROM,
                                   'To'      => $reply,
                                   'Subject' => "Re: Your requested CPAN file(s)",
                                   'Data'    => \@ERR );
};
unless (($@ eq '') && (defined $entity) && (ref $entity))
{
    $@ =~ s!\s+$!!;
    $msg = "$SELF: unable to create new mail";
    if ($@) { $msg .= ": $@\n"; }
    else    { $msg .= "!\n";    }
    die $msg;
}
eval { $entity->make_multipart(); };
if ($@)
{
    $@ =~ s!\s+$!!;
    die "$SELF: unable to create multipart mail header: $@\n";
}
foreach $file (@LIST)
{
    $item = $file;
    $item =~ s!^.*/!!;
    eval
    {
        $entity->attach( Path        => $file,
                         Filename    => $item,
                         Description => $item,
                         Type        => $TYPE,
                         Encoding    => $CODE,
                         Disposition => $DISP );
    };
    if ($@)
    {
        $@ =~ s!\s+$!!;
        warn "$SELF: unable to attach file '$file': $@\n";
    }
}
unless (open(MAIL, ">$MAIL"))
{
    die "$SELF: couldn't write mail file '$MAIL': $!\n";
}
unshift( @LIST, $MAIL );
eval { $entity->print( \*MAIL ); };
if ($@)
{
    $@ =~ s!\s+$!!;
    unless (close(MAIL))
    {
        warn "$SELF: couldn't close mail file '$MAIL': $!\n";
    }
    die "$SELF: couldn't write to mail file '$MAIL': $@\n";
}
unless (close(MAIL))
{
    die "$SELF: couldn't close mail file '$MAIL': $!\n";
}
unless ($smtp = Net::SMTP->new($SERV, 'Hello' => $CLNT, 'Timeout' => $TIME))
{
    die "$SELF: couldn't establish connection to '$SERV'!\n";
}
unless ($smtp->mail( $FROM ))
{
    $smtp->quit();
    die "$SELF: sender '$FROM' rejected by SMTP server!\n";
}
unless ($smtp->to( $reply ))
{
    $smtp->quit();
    die "$SELF: recipient '$reply' rejected by SMTP server!\n";
}
unless ($smtp->data())
{
    $smtp->quit();
    die "$SELF: SMTP server reports a 'data' error!\n";
}
unless (open(MAIL, "<$MAIL"))
{
    $smtp->quit();
    die "$SELF: couldn't read mail file '$MAIL': $!\n";
}
while (defined ($item = <MAIL>))
{
    unless ($smtp->datasend( $item ))
    {
        unless (close(MAIL))
        {
            warn "$SELF: couldn't close mail file '$MAIL': $!\n";
        }
        $smtp->quit();
        die "$SELF: SMTP server reports a 'datasend' error!\n";
    }
}
unless (close(MAIL))
{
    $smtp->quit();
    die "$SELF: couldn't close mail file '$MAIL': $!\n";
}
unless ($smtp->dataend())
{
    $smtp->quit();
    die "$SELF: SMTP server reports a 'dataend' error!\n";
}
unless ($smtp->quit())
{
    die "$SELF: SMTP server reports a 'quit' error!\n";
}

exit 0;

__END__