ホーム » ブログ » yasさんのブログ

Perl で、メールサーバに送られてきたメールを処理する

Procmail を利用すればサーバに送られてきたメールが標準入力から Perl スクリプトに渡すことができる。ここでは Procmail の詳細は割愛するが、以下は標準入力に入っているメールを処理する関数。 使用するクラス 
use MIME::Parser;
use MIME::Base64;
use Mail::Address;
use MIME::Parser;
use MIME::Base64;
use Mail::Address;
use Unicode::Japanese;

my ($mail) = &parse;
print "From: " . $mail->{sender} . "\n";
print "To: " . $mail->{recipient} . "\n";
print "Subject: " . $mail->{subject} . "\n";

sub parse {

    my ($mail);

    # Parser Setting
    my $parser = new MIME::Parser;
    $parser->output_to_core(1);    # Keeps body analyzed internally
    $parser->tmp_recycling (1);    # Recycles the temporary stuff

    my $entity = $parser->parse(\*STDIN) or die "Parse Error in __FILE__\n";

    # Headers
    $mail->{sender   } =  $entity->head->get('from'   );
    $mail->{subject  } =  $entity->head->get('subject');
    $mail->{recipient} =  $entity->head->get('to'     );
    $mail->{recipient} =~ s/\n//g;

    # From
    @addrs = Mail::Address->parse($mail->{sender});
    foreach $addr (@addrs) {
        $mail->{sender} = $addr->address if $addr->address; # USE CAUTION, for the multiple address
    }

    # Subject
    my $subject = $mail->{subject};
    $lws      = '(?:(?:\x0D\x0A|\x0D|\x0A)?[ \t])+';
    $ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?=';
    $subject  =~ s/\n//g;
    $subject  =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio;
    $subject  =~ s/$lws/ /go;
    $subject  =~ s/$ew_regex/decode_base64($1)/egio;
    $subject  = Unicode::Japanese->new($subject, 'auto')->sjis_imode;
    $mail->{subject} = $subject;

    # Get MIME
    ($mail->{body}, $mail->{filename}, $mail->{mimetype}, $mail->{object}) = &getEntities($entity);
    $mail->{body   } =  Unicode::Japanese->new($mail->{body}, 'auto')->sjis_imode;
    $mail->{body   } =~ s/[ 　\n\r]+$//g;    # Delete the white spaces in the end of the line
    $mail->{subject} =~ s/[ 　\n\r]+$//g;    # Delete the white spaces in the end of the line

    return $mail;
}

sub getEntities {

    my $entity = shift;
    my $body, $filename, $mimetype, $object;

    # BODY
    my @parts = $entity->parts;
    if (@parts) {                   # multipart...

        my $i;
        foreach $i (0 .. $#parts) { # dump each part...

            &getEntities($parts[$i]);
        }
    } else {                        # single part...

        # Get MIME type, and display accordingly...
        my ($type, $subtype) = split('/', $entity->head->mime_type);
        my $bodyhandle = $entity->bodyhandle;

        if ($type =~ /^(text|message)$/) {      # text

            $body .= $bodyhandle->as_string;

        } else {                                # binary

            $filename= $entity->head->recommended_filename;
            $mimetype = $entity->head->mime_type;
            $object = $bodyhandle->as_string;
            binmode($object);
            # if we want to store it as BASE64, you can continue the processs here
        }
    }

    return ($body, $filename, $mimetype, $object);
}

1;
トラックバック URL: https://perltips.twinkle.cc/trackback/35
Posted on 2005-12-06 by yas |
ケータイサイト構築のポイント
Trackback from Perl Tips: 以下に、ケータイのサイトを開発する上で、ケータイならではの考慮すべきポイントを......
Posted by Perl Tips (未認証ユーザ) on 2006/03/21(火) 23:57
Perl で、メールのサブジェクト (Subject) を文字化けしないで送信するには？
Trackback from Perl Tips: メール送信時に日本語をサブジェクトに書いて送るには、この部分は Base64 ......
Posted by Perl Tips (未認証ユーザ) on 2006/07/12(水) 22:24