auto-responder.pl

#!/usr/bin/perl

=head1 NAME

auto-responder - 受信したメールに自動返信する

=head1 SYNOPSIS

C<.forward> の中で

    |"auto-responder -t message -b realuser@example.com"

と指定する．

=head1 DESCRIPTION

受信したメールに自動返信するスクリプト．

=cut
use 5.8.0;
use Getopt::Long;
use File::Temp qw/ tempdir /;
use Mail::Address;
use MIME::Parser;
use MIME::Entity;
use Net::SMTP;
use strict;
use open IO => ':bytes';
use constant LOOPDETECTFIELD => 'X-Auto-Responder-Recipient';
use constant IGNORE_FURTHER_DELIVERY => 0;
use constant TEMPORARY_FAILURE => 75;

=head1 OPTIONS

=over 4

=item --host HOST

メールの返信に利用する SMTP サーバを指定する．無指定の場合は，
C<localhost> を使用する．

=item --txtfile FILE

自動返信するメッセージのファイルを指定する．UTF-8 のテキストファイルの
み指定できる．

=item --backup ADDRESS

=item --debug

=back

=cut
our $HOST = 'localhost';
our $TXTFILE;
our $BACKUP;
our $DEBUG;
&GetOptions( 'host=s'    => \$HOST,
	     'txtfile=s' => \$TXTFILE,
	     'backup=s'  => \$BACKUP,
	     'debug!'    => \$DEBUG );

&main();

sub main {
    my $message = &read_message();
    exit &IGNORE_FURTHER_DELIVERY if $message->head->get(&LOOPDETECTFIELD);

    if( $BACKUP ){
	my $smtp = Net::SMTP->new( $HOST );
	my $ok = ( $smtp->mail( &extract_recipient_address($message) ) &&
		   $smtp->to( $BACKUP ) &&
		   $smtp->data( $message->as_string ) );
	exit &TEMPORARY_FAILURE unless $ok;
    }

    my $response = &make_response($message);
    exit &TEMPORARY_FAILURE unless $response;
    if( $DEBUG ){
	$response->print( \*STDOUT );
    } else {
	$response->smtpsend( Host => $HOST );
    }
    exit 0;
}

sub make_response {
    my( $message ) = @_;

    my $text;
    if( open( my $fh, '<:bytes', $TXTFILE ) ){
	$text = join( '', <$fh> );
    } else {
	return undef;
    }

    my $subject = $message->head->get('Subject');
    $subject =~ s/\A\s*(re:\s+)*/Re: /i;
    my $messageid = &extract_messageid($message);
    my $ref = $message->head->get('References');
    if( $ref ){
	$ref = join( ' ', $ref, $messageid );
    } else {
	$ref = $messageid;
    }

    my $recipient = &extract_recipient_address($message);
    my $response = MIME::Entity->build( From => $recipient,
					To => &extract_sender_address($message),
					Subject => $subject,
					References => $ref,
					Type => 'text/plain; charset=utf-8',
					Encoding => 'base64',
					Data => $text );
    # ADHOC FIX:
    # Because In-Reply-To header is not registered in MIME::Entity::KnownField,
    # its specification for MIME::Entity::build function is ignored.
    $response->head->set( 'In-Reply-To' => $messageid );
    $response->head->set( &LOOPDETECTFIELD, $recipient );
    $response;
}

sub extract_address {
    my( $head ) = @_;
    for my $x ( Mail::Address->parse( $head ) ){
	return $x->address;
    }
    $head;
}

sub extract_sender_address {
    my( $m ) = @_;
    &extract_address($m->head->get('sender') || $m->head->get('return-path') || $m->head->get('from'));
}

sub extract_recipient_address {
    my( $m ) = @_;
    &extract_address($m->head->get('to'));
}

sub extract_messageid {
    my( $m ) = @_;
    my $x = $m->head->get('message-id');
    if( $x ){
	$x =~ s/\A\s+//;
	$x =~ s/\s+\Z//;
    }
    $x;
}

sub read_message {
    my $parser = MIME::Parser->new();
    $parser->output_under( &tempdir( CLEANUP => 1 ) );
    $parser->parse( \*STDIN );
}

=head1 AUTHOR

TSUCHIYA Masatoshi <tsuchm@gmail.com>

=head1 COPYRIGHT

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.

=cut