root/lang/perl/misc/i18n-emoji/EmailParser.pm

# ------------------------------------------------------------------------
#   EmailParser.pm --- �ޥ��ѡ���б��᡼���߼��⥸�塼��   Copyright 1997-2005 Kawasaki Yusuke <u-suke@kawa.net>
# ------------------------------------------------------------------------
    package EmailParser;
    use strict;
    use vars qw( $DEBUG $VERSION );
    $VERSION = "0.01";
    $DEBUG = \*STDERR;
# ------------------------------------------------------------------------
    use MIME::Base64;
    use Encode;
    use DateTime::Format::Mail;
    use IO::File;
    use IO::Scalar;
    use IO::ScalarArray;
# ------------------------------------------------------------------------
=head1 NAME

    EmailParser.pm ---- Multipart email parser

=head1 USAGE

    use EmailParser;

    $ep = EmailParser->new( $file );
    # $ep = EmailParser->new()->fromHandle( $handle );
    # $ep = EmailParser->new()->fromFile( $file );
    # $ep = EmailParser->new()->fromArray( $array );
    # $ep = EmailParser->new()->fromString( $scalar );

    $ep->setInternalTimeZone( "Japan" );
    $ep->setInternalCharset( "utf8" );
    ( $part0, $part1, $part2, ... ) = $ep->parse();

    $string = $part0->toString();
    $array  = $part1->toArray();
    $file   = $part2->toFile( $file );
    $handle = $part3->toHandle( $handle );

=head1 PARSED PROPATIES

    �ڶ��������    $part->{format} mulitipart/��  multipart content
                    text/plain      text content
                    text/html       HTML content
                    image/��       image data content
                    message/rfc822  RFC822 content
    $part->{encoding}   base64      Base64
                        quoted      quoted-printable
    $part->{offset}                 offset to this part
    $part->{boundary}               boundary string of the part
    $part->{head_text}              raw header text
    $part->{raw}->{FROM}->[0]           From: line
    $part->{raw}->{SUBJECT}->[0]        Subject: line
    $part->{raw}->{CONTENT_TYPE}->[0]   Content-Type: line

    �ڥ᡼������Τߤ�����    $part->{addr_from}->[0]         ���пͥ᡼�륢�ɥ쥹
    $part->{addr_to}->[0]��        ����᡼�륢�ɥ쥹To:
    $part->{addr_cc}->[0]��        ����᡼�륢�ɥ쥹Cc:
    $part->{addr_bcc}->[0]��       ����᡼�륢�ɥ쥹Bcc:
    $part->{subject}                �᡼��̾
    $part->{epoch}                  ������(�)
    $part->{datetime}               ������(YYYY/MM/DD HH:MM:SS)
    $part->{priority}               ͥ��������    $part->{ml_name}                ML̾��
    �ڥޥ��ѡ��ȥ������Τߤ�����    $part->{child_boundary}         �ҥѡ��ȤΥХ������    �ڥƥ����ȥ������Τߤ�����    $part->{charset}                �����������
=head1 HISTORY

    1997/
    2005/04/21 EmailParser.pm
    2005/05/08 EmailParser::Part ���饹���

=head1 COPYRIGHT

    Kawasaki Yusuke <u-suke@kawa.net>
    http://www.kawa.net/

=cut
# ------------------------------------------------------------------------
    my $INTERNAL_TIMEZONE = "Japan";    # �ǥե����Υ����ॾ����  my $INTERNAL_CHARSET = "utf8";      # �����ʸ����# ------------------------------------------------------------------------
#   ���󥹥ȥ饯��
# ------------------------------------------------------------------------
sub new {
    my $pkg = shift;
    my $file = shift;
    ## $DEBUG and print $DEBUG "[EmailParser::new] $pkg $file\n";
    my $emp = {};
    bless $emp, $pkg;
    $emp->fromFile( $file ) if $file;
    $emp;
}
# ------------------------------------------------------------------------
#   �ǥ��󥹥ȥ饯��
# ------------------------------------------------------------------------
sub DESTROY {
    my $emp = shift or return;
    ## $DEBUG and print $DEBUG "[DESTROY] $emp\n";
    if ( $emp->{ihandle_opened} ) {
        # ï¿½ï¿½ï¿½Ï¥ï¿½ë¤¬ï¿½ï¿½ï¿½ï¿½ï¿½×¥ï¿½ß¤Î¾ï¿½ï¿½Ï¥ï¿½ï¿½í¡¼ï¿½ï¿½ï¿½ï¿½ï¿½ï¿½Â       eval {
            $emp->{ihandle}->close();
        };
    }
    $emp;
}
# ------------------------------------------------------------------------
#   �������ॾ�����ꤹ���᡼�������Υ����ॾ����Ϥʤ���# ------------------------------------------------------------------------
sub setInternalTimeZone {
    my $emp = shift;
    my $timezone = shift;
    # DateTime::TimeZone ����ȳ���Ǥ��뤫�⡩
    $emp->{timezone} = $timezone;
}
sub getInternalTimeZone {
    defined $_[0]->{timezone} ? $_[0]->{timezone} : $INTERNAL_TIMEZONE;
}
# ------------------------------------------------------------------------
#   ��ʸ���Ȥ�ꤹ���᡼��ʸ���ȤǤϤʤ���# ------------------------------------------------------------------------
sub setInternalCharset {
    my $emp = shift;
    my $charset = shift;
    EmailParser::Util::valid_charset( $charset ) or die "Invalid charset: $charset\n";
    $emp->{charset} = $charset;
}
sub getInternalCharset {
    defined $_[0]->{charset} ? $_[0]->{charset} : $INTERNAL_CHARSET;
}
# ------------------------------------------------------------------------
#   ��߹��ߥϥ����
# ------------------------------------------------------------------------
sub fromHandle {
    my $emp = shift;
    my $ifh = shift;
    ## $DEBUG and print $DEBUG "[fromHandle] ",ref($ifh),"\n";
    $emp->{ihandle} = $ifh;             # ��߹��ߥϥ���Ͽ
    $emp->{begin} = $emp->tell();       # ���ϰ�֤��
    $ifh;
}
# ------------------------------------------------------------------------
sub fromFile {
    my $emp = shift;
    my $file = shift;
    ## $DEBUG and print $DEBUG "[fromFile] $file\n";
    my $ifh = new IO::File( $file, "r" ) or die "$! - $file\n";
    $emp->{ihandle_opened} ++;          # OPEN�ե饰��    $emp->fromHandle( $ifh );
}
# ------------------------------------------------------------------------
sub fromArray {
    my $emp = shift;
    my $array = shift;
    ## $DEBUG and print $DEBUG "[fromArray] $array\n";
    my $ifh = new IO::ScalarArray( $array ) or die "IO::ScalarArray failed.\n";
    $emp->{ihandle_opened} ++;          # OPEN�ե饰��    $emp->fromHandle( $ifh );
}
# ------------------------------------------------------------------------
sub fromString {
    my $emp = shift;
    my $string = shift;
    ## $DEBUG and print $DEBUG "[fromString] \$string\n";
    my $ifh = new IO::Scalar( \$string ) or die "IO::Scalar failed.\n";
    $emp->{ihandle_opened} ++;          # OPEN�ե饰��    $emp->fromHandle( $ifh );
}
# ------------------------------------------------------------------------
#   ����ɤ߹��� ------------------------------------------------------------------------
sub getline {
    $_[0]->{ihandle}->getline() if $_[0]->{ihandle};
}
sub seek {
    my $emp = shift;
    my $pos = shift;
    ## $DEBUG and print $DEBUG "[seek] $pos\n";
    $emp->{ihandle}->seek($pos,0) if $emp->{ihandle};
}
sub tell {
    my $emp = shift;
    $emp->{ihandle}->tell() if $emp->{ihandle};
}
# ------------------------------------------------------------------------
#   �Ƭ�˴������
# ------------------------------------------------------------------------
sub rewind {
    my $emp = shift;
    my $begin = $emp->{begin};
    ## $DEBUG and print $DEBUG "[rewind] $begin\n";
    $emp->seek( $begin );
}
# ------------------------------------------------------------------------
#   �᡼���(�ޤ��ϥޥ��ѡ�����������ơ��ƥѡ��Ȥ��
# ------------------------------------------------------------------------
sub parse {
    my $emp = shift;
    my $selfbnd = shift;                    # ���ѡ��ȤΥХ����    my $epart = EmailParser::Part->new( $emp, $selfbnd );
    my $childbnd = $epart->{child_boundary};  # �ҥѡ��ȤΥХ����   my $is_multi = ( $childbnd && $epart->{format} =~ m#^multipart/# );
    my @parts = ();
    my $findchr = $epart->{charset};

    # ���Ȥ��ޥ��ѡ��Ȥξ��ϡ��ҥѡ��Ȥ�Ϥ���    if ( $is_multi ) {
        # �ǽ��ҥѡ��Ȥ��Ϥޤ��Ǥ����
        while( 1 ) {
            my $line = $emp->getline();
            last unless defined $line;
            $line =~ s/[\r\n]*$/\n/s;
            last if ( $line =~ /^--\Q$childbnd\E[\r\n]*$/ );
        }
        # �ƻҥѡ��Ȥ򷫤����ʺƵ��ƤӽФ���        my $partcnt;
        while ( 1 ) {
            $partcnt ++;
            ## $DEBUG and print $DEBUG "[parse] multipart #$partcnt\n";
            my @childlen = $emp->parse( $childbnd );
            my $partcnt = scalar @childlen or last; # �ޥ��ѡ��Ƚ�λ
            push( @parts, @childlen );              # ����¤٤Ƥ���
            my $lastchild = $childlen[$#childlen] or last;
            last unless $lastchild->{has_next};     # ³���Υѡ��Ȥ�����       }
        ## $DEBUG and print $DEBUG "[parse] multipart finish\n";

        # �Ƥ�����Ȥ���������Ҥ�����Ȥ�Ƚ�������
        # �Ҥ�����Ȥκǽ�ʸ���Ȥ򡢿Ƥ�����ȤȤߤʤ�
        if ( ! $findchr && scalar @parts ) {
            $findchr = ( map {$_->{charset}} 
                         grep {defined $_->{charset}} @parts )[0];
            ## $DEBUG and print $DEBUG "[parse] child charset=$findchr\n";
        }
    }

    # �ޥ��ѡ��ȤǤʤ���拾���ξ��ϡ��ʸ�����ɤ���
    # ������ʤ��顢�⤷����ʤ�����������⤹��    if ( ! $is_multi ) {
        my $notascii = ( $findchr ne "" );                          # 
        my $is_text = ( $epart->{format} =~ m#^text/# );            # 
        my $enc_qp = ( $epart->{encoding} eq "quoted-printable" );
        my $enc_b64 = ( $epart->{encoding} eq "base64" );
        my $prevtag;

        while( 1 ) {
            my $line = $emp->getline();
            last unless defined $line;
            if ( $selfbnd && $line =~ /^--\Q$selfbnd\E(--)?[\r\n]*$/ ) {
                $epart->{has_next} ++ unless $1;    # ³���Υѡ��Ȥ�����               last;
            }
            next if ( $line =~ /^$/ );

            if ( ! $findchr && $is_text ) {
                if ( $enc_qp ) {
                    $line =~ s/=([a-z0-9]{2})/pack(C=>hex($1))/gei;
                } elsif ( $enc_b64 ) {
                    $line =~ s/\s+$//s;
                    next unless ( length($line) % 4 == 0 );     # 4��ܿ�ʤ���̵��                   $line = MIME::Base64::decode_base64($line);
                }
                $line = $prevtag.$line if $prevtag;
                if ( $line =~ m#(?:^|\W)charset=["']?([\w\-\.]+)#i ) {
                    ## $DEBUG and print $DEBUG "[parse] html charset=$1\n";
                    $findchr = EmailParser::Util::valid_charset( $1 );
                } elsif ( $line =~ m#\e\$B# ) {
                    $findchr = "ISO-2022-JP";                   # ���������ץ�������                } elsif ( $line =~ m#https?://[\w\%\-\.]+\.(\w{2})/#i ) {
                    my $cntry = $1;
                    ## $DEBUG and print $DEBUG "[parse] country=$cntry\n";
                    $findchr = $EmailParser::COUNTRY2CHARSET->{$cntry};
                }
                $notascii ++ if ( ! $notascii && $line =~ /[^\000-\177]/ );
                $prevtag = ( $line =~ /(<[^<>]*)$/s )[0];       # �Ǹ�����
            }
        }

        # charset ���ǡ����ġ�� ASCII ʸ�����������ʤ��� us-ascii
        if ( ! $findchr && $is_text && ! $notascii  ) {
            $findchr = "us-ascii";
            ## $DEBUG and print $DEBUG "[parse] findchr=$findchr\n";
        }
    }

    # �ʸ�������ɤ����ޤ����ʤ顢MIME�إå���
    if ( ! $findchr ) {
        if ( $epart->{head_text} =~ /(\=\?([\w\-]+)\?[BQ]\?)([^\s\?]+)\?\=/i ) {
            $findchr = EmailParser::Util::valid_charset( $2 );
        } elsif ( $epart->{head_text} =~ /\e\$B/ ) {
            $findchr = "ISO-2022-JP";
        }
    }

    # ʸ���ɤ����ޤ����ʤ顢���пͥ᡼�륢�ɥ쥹���
    if ( ! $findchr && ref $epart->{raw}->{FROM} ) {
        my $from = $epart->{raw}->{FROM}->[0];                      # ���пͥ��ɥ쥹
        my $DOMAIN2CHARSET = EmailParser::Map::domain2charset();
        my $domain = ( $from =~ /\@(?:[\w\-]+\.)*([\w\-]+\.[\w\-]+)(\W|$)/ )[0];         # �ɥᥤ��        $findchr ||= $DOMAIN2CHARSET->{lc($domain)} if $domain;
        $DEBUG and print $DEBUG "[parse] domain=$domain [$findchr]\n";

        my $COUNTRY2CHARSET = EmailParser::Map::country2charset();
        my $cntry = ( $from =~ /\@[\w\-\.]+\.(\w{2})(\W|$)/)[0];    # ��ɥᥤ��      $findchr ||= $COUNTRY2CHARSET->{lc($cntry)} if $cntry;
        $DEBUG and print $DEBUG "[parse] country=$cntry [$findchr]\n";
    }

    # ʸ���ɤ򺣲󸡽Ф��Ƥ����ʤ顢�إå�������Ƥ���
    if ( ! $epart->{charset} && $findchr ) {
        $epart->{charset} = $findchr;
        my $convto = $emp->getInternalCharset();
        $epart->convertCharset( $convto ) if $convto;
    }

    # ������������ѡ��Ȥ�������
    unshift( @parts, $epart );

    # ��λ
    wantarray ? @parts : $epart;
}
# ------------------------------------------------------------------------
    package EmailParser::Part;
    use strict;
    use vars qw( $DEBUG );
    $DEBUG = \*STDERR;
# ------------------------------------------------------------------------
sub new {
    my $pkg = shift;
    my $emp = shift or return;  # MailParser object
    my $selfbnd = shift;
    ## $DEBUG and print $DEBUG "[EmailParser::Part::new] $pkg $emp $selfbnd\n";
    my $epart = {};
    bless $epart, $pkg;
    $epart->{email} = $emp;
    $epart->{offset} = $emp->tell();
    $epart->{boundary} = $selfbnd;
    $epart->readHeader();
    $epart;
}
# ------------------------------------------------------------------------
#   �إå��������� ------------------------------------------------------------------------
sub readHeader {
    my $epart = shift;

    my $emp = $epart->{email};
    my $selfbnd = $epart->{boundary};

    # �������ե��åȤ˰������    my $offset = $epart->{offset};
    $emp->seek( $offset ) if defined $offset;

    # �إå��߹���    my $harray = [];
    while( 1 ) {
        my $line = $emp->getline();
        last unless defined $line;
        last if ( $line =~ /^$/ );      # �إå��λ
        if ( $selfbnd && $line =~ /^--\Q$selfbnd\E(--)?[\r\n]$/ ){
            return;                     # �ѡ��Ƚ�λ���å�ʤ�
        }
        $line =~ s/[\r\n]+$//s;
        push( @$harray, $line );
    }
    $epart->{head_text} = join( "", @$harray );

    # �إå��å���Ÿ������    my $raw = {};
    my $key;
    foreach ( @$harray ) {
        if ( /^([\w\-]+)\:\s*(.*)$/ ) {
            $key = uc($1);
            my $val = $2;
            $key =~ s/\W/_/g;           
            $raw->{$key} ||= [];
            push( @{$raw->{$key}}, $val );
        } elsif ( $key ne "" && /^\s+(.*)/ ) {
            $raw->{$key}->[$#{$raw->{$key}}] .= $1; # ����ɲä��Ƥ���
        } else {
            $key = "";
        }
    }
    $epart->{raw} = $raw;

    # ʸ���ɤβ�
    my $contype;
    $contype = $raw->{CONTENT_TYPE}->[0] if ref $raw->{CONTENT_TYPE};
    $contype =~ s/\s+/ /sg;
    my $charset;
    if ( $contype =~ /\;\s*charset=["']?([\w\-\.]+)["']?/i ) {
        ## $DEBUG and print $DEBUG "[readHeader] charset=$1\n";
        $charset = EmailParser::Util::valid_charset( $1 );
    }
    $epart->{charset} = $charset;

    # �⤷ charset= ������ɤ�ʬ���äƤ�����������Ƥ���

    my $convto = $emp->getInternalCharset();
    $epart->convertCharset( $convto ) if $convto;

    # Content-Type: �Ԥβ�
    $contype = $raw->{CONTENT_TYPE}->[0] if ref $raw->{CONTENT_TYPE};
    $contype =~ s/\s+/ /sg;
    my $format = ( $contype =~ m#^([\w\-\.]+/[\w\-\.]+)# )[0];
    $format =~ tr/A-Z/a-z/;
    $epart->{format} = $format;
    ## $DEBUG and print $DEBUG "[readHeader] format=$format\n";

    # �ҥѡ��ȤΥХ����    my $childbnd = ( $contype =~ /\;\s*boundary=["']?([^\s"']+)/i )[0];
    $epart->{child_boundary} = $childbnd;
    ## $DEBUG and print $DEBUG "[readHeader] child_boundary=$childbnd\n";

    # Content-Transfer-Encoding: �Ԥβ�base64 quoted-pritable

    my $encoding = ( $raw->{CONTENT_TRANSFER_ENCODING}->[0] =~ /^([\w\-]+)/ )[0]
        if ref $raw->{CONTENT_TRANSFER_ENCODING};
    $encoding =~ tr/A-Z/a-z/;
    $epart->{encoding} = $encoding;
    ## $DEBUG and print $DEBUG "[readHeader] encoding=$encoding\n";

    # Date: �Ԥβ�
    my $srcdate;
    $srcdate = $raw->{DATE}->[0] if ref $raw->{DATE};
    $srcdate =~ s/[^\040-\176]+/ /g;            # ���߽�  $srcdate ||= ( $raw->{RECEIVED}->[$#{$raw->{RECEIVED}}] =~ /;\s*
                (\d+\s+[a-z]+\s+\d+\s+\d+:\d+:\d+\s+[\+\-]\d+(\:\d+)?)
                (\D|$)/xi )[0] if ref $raw->{RECEIVED};
    ## $DEBUG and print $DEBUG "[readHeader] Date: $srcdate\n";
    if ( $DateTime::Format::Mail::VERSION && $srcdate ) {
        my $dt;
        eval {
            my $dtfm = DateTime::Format::Mail->new()->loose();
            $dt = $dtfm->parse_datetime( $srcdate );
        };
        if ( ref $dt ) {
            my $tz = $emp->getInternalTimeZone();       # �����������ॾ����          $dt->set_time_zone( $tz ) if $tz;   # �����ॾ�����          $epart->{epoch} = $dt->epoch();
            my $datetime = $dt->ymd('/')." ".$dt->hms(':');
            $epart->{datetime} = $datetime;
            ## $DEBUG and print $DEBUG "[readHeader] datetime=$datetime\n";
        }
    }

    # �ե��������ե�����ĥ�Ҥ򸡽�    {
        my $filename = ( $contype =~ /\;\s*name=["']?([^\s"']+)/i )[0];
        $filename ||= ( $raw->{CONTENT_DISPOSITION}->[0] =~
            /\;\s*filename=["']?([^\s"']+)/i )[0]
            if ref $raw->{CONTENT_DISPOSITION};
        ## $DEBUG and print $DEBUG "[readHeader] filename=$filename\n";
        $epart->{filename} = $filename;

        my $ext = ( $filename =~ m#[^\/\:\.]\.(\w[\w\-]*)$# )[0];
        my $FORMAT2EXT = EmailParser::Map::format2ext();
        $ext ||= $FORMAT2EXT->{$format} if $format;
        ## $DEBUG and print $DEBUG "[readHeader] ext=$ext\n";
        $epart->{ext} = $ext;
    }

    # Subject: �Ԥ��    {
        my $subject;
        $subject = $raw->{SUBJECT}->[0] if ref $raw->{SUBJECT};
        ## $DEBUG and print $DEBUG "[readHeader] subject=$subject\n";
        $epart->{subject} = $subject;
    }

    # X-Priority: �Ԥ��    {
        my $priority;
        $priority = $raw->{PRIORITY}->[0] if ref $raw->{PRIORITY};
        $priority ||= $raw->{X_PRIORITY}->[0] if ref $raw->{X_PRIORITY};
        $priority = ( $priority =~ /(\d+)/ )[0];
        ## $DEBUG and print $DEBUG "[readHeader] priority=$priority\n";
        $epart->{priority} = $priority;
    }

    # X-ML-Name: �Ԥ��    {
        my $mlname;
        $mlname = $raw->{X_ML_NAME}->[0] if ref $raw->{X_ML_NAME};
        $mlname ||= $raw->{X_SEQUENCE}->[0] if ref $raw->{X_SEQUENCE};
        $mlname =~ s/\s.*$//s;
        ## $DEBUG and print $DEBUG "[readHeader] ml_name=$mlname\n";
        $epart->{ml_name} = $mlname if $mlname;
    }

    # �إå�����ɥ쥹�ϤιԤ��    my $addrkey = {
        "FROM"  =>  "addr_from",
        "TO"    =>  "addr_to",
        "CC"    =>  "addr_cc",
        "BCC"   =>  "addr_bcc",
        "REPLY_TO"      =>  "addr_reply",       # Reply-To:
        "RETURN_PATH"   =>  "addr_return",      # Return-Path:
        "DELIVERED_TO"  =>  "addr_deliv",       # Delivered-To: (qmail)
        "MESSAGE_ID"    =>  "message_id",       # Message-Id:
        "REFERENCES"    =>  "mess_refer",       # References:
        "IN_REPLY_TO"   =>  "mess_reply",       # In-Reply-To:
    };
    foreach my $ikey ( keys %$addrkey ) {
        next unless ref $raw->{$ikey};
        my $okey = $addrkey->{$ikey};
        my $list = [];
        foreach my $line ( @{$raw->{$ikey}} ) {
            my @pickup = EmailParser::Util::pickup_address( $line );
            push( @$list, @pickup ) if scalar @pickup;
        }
        $epart->{$okey} = $list if scalar $list;
    }

    # �إå���λ
    $epart;
}
# ------------------------------------------------------------------------
#   �ѡ��Ȥ��Ȥ˥ե������ؽ�Ϥ��� ------------------------------------------------------------------------
sub toFile {
    my $epart = shift;
    my $file = shift;
    ## $DEBUG and print $DEBUG "[toFile] $file\n";
    my $ofh = new IO::File( $file, "w" ) or die "$! - $file\n";
    $epart->toHandle( $ofh, @_ );
    $ofh->close();
    $file;
}
# ------------------------------------------------------------------------
sub toArray {
    my $epart = shift;
    ## $DEBUG and print $DEBUG "[toArray]\n";
    my $array = [];
    my $ofh = new IO::ScalarArray( $array ) or die "IO::ScalarArray failed.\n";
    $epart->toHandle( $ofh, @_ );
    $ofh->close();
    $array;
}
# ------------------------------------------------------------------------
sub toString {
    my $epart = shift;
    # $DEBUG and print $DEBUG "[toString]\n";
    my $string = "";
    my $ofh = new IO::Scalar( \$string ) or die "IO::Scalar failed.\n";
    $epart->toHandle( $ofh, @_ );
    $ofh->close();
    $string;
}
# ------------------------------------------------------------------------
sub toHandle {
    my $epart = shift;
    my $ofh = shift;        # �������   my $ocode = shift;      # ��Ϥ�������    # $DEBUG and print $DEBUG "[toHandle] ",ref($ofh)," $ocode\n";

    # ������ʸ���ɡʥƥ����ȥѡ��Ȥ��Ľ������ɻ���Τ�Ѵ���    my $icode;
    if ( $Encode::VERSION && $ocode && $epart->{type} =~ m#^text/#i ) {
        # $DEBUG and print $DEBUG "[toHandle] icode=$icode ocode=$ocode\n";
        $icode = $epart->{charset};
    }

    # �Х��������
    my $selfbnd = $epart->{boundary};           # ���ѡ��ȤΥХ����   my $childbnd = $epart->{child_boundary};    # �ҥѡ��ȤΥХ����   # $DEBUG and print $DEBUG "[toHandle] self_boundary=$selfbnd\n";
    # $DEBUG and print $DEBUG "[toHandle] child_boundary=$childbnd\n";

    # �������ե��åȤ˰������    my $emp = $epart->{email};
    my $offset = $epart->{offset};
    $emp->seek( $offset ) if defined $offset;

    # �إå�����

    while( 1 ) {
        my $line = $emp->getline();
        last unless defined $line;
        last if ( $line =~ /^$/ );      # �إå��λ
        return if ( $selfbnd && $line =~ /^--\Q$selfbnd\E(--)?[\r\n]$/ );
    }

    # �ޥ��ѡ��ȷ���ʤ鿿
    my $is_multi = ( $childbnd && $epart->{format} =~ m#^multipart/# );

    # ���󥳡��ǥ���    my $enc64 = ( $epart->{encoding} eq "base64" );
    my $encQT = ( $epart->{encoding} eq "quoted-printable" );

    # �ܥǥ���ƥϥ����Ϥ���   my $b64rest;
    my $multi_started;
    while( 1 ) {
        my $line = $emp->getline();
        last unless defined $line;
        next if $multi_started;
        if ( $is_multi && $line =~ /^--\Q$childbnd\E(--)?[\r\n]*$/ ) {
            $multi_started ++;
            next;
        }
        if ( $selfbnd && $line =~ /^--\Q$selfbnd\E(--)?[\r\n]*$/ ) {
            $epart->{has_next} ++ unless $1;    # ³���Υѡ��Ȥ�����           last;
        }
        $line =~ s/[\r\n]*$/\n/s;
        if ( $enc64 ) {
            chomp $line;
            if ( $b64rest ne "" ) {
                $line = $b64rest.$line;
                $b64rest = undef;
            }
            my $b64len = length($line);
            ## $DEBUG and print $DEBUG "[toHandle] base64_length=$b64len\n";
            if ( $b64len % 4 == 0 ) {         # 4��ܿ���
                $line = MIME::Base64::decode_base64($line);
            } else {
                $b64rest = $line;                   # ������
                next;
            }
        } elsif ( $encQT ) {
            $line =~ s/=[\r\n]*$//s;
            $line =~ s/=([0-9a-f]{2})/pack(C=>hex($1))/gei;
        }
        Encode::from_to( $line, $icode, $ocode ) if $icode;
        $ofh->print( $line );
    }
    if ( $b64rest ne "" ) {
        my $line = MIME::Base64::decode_base64($b64rest);
        Encode::from_to( $line, $icode, $ocode ) if $icode;
        $ofh->print( $line );    # �Ĥ꤬���ä�
    }

    $ofh;
}
# ------------------------------------------------------------------------
#   �ѡ��������إå�������ɤ������   �ʸ������ɤ�Ѵ����ޤ���------------------------------------------------------------------------
sub convertCharset {
    my $epart = shift;
    my $convto = shift or return;               # ����ʸ����    ## $DEBUG and print $DEBUG "[convertCharset] convto=$convto\n";
    return unless $Encode::VERSION;

    my $convfrom = $epart->{current_charset} || $epart->{charset};
    ## $DEBUG and print $DEBUG "[convertCharset] convfrom=$convfrom\n";
    return unless $convfrom;                    # ���ߤ�����ɤ���

#   return if ( lc($convto) eq lc($convfrom) ); # ���������ɤǤ�������    # $epart->{XXXX} �γ�ͤ�����ɤ������    foreach my $key ( keys %$epart ) {
        next if ref $epart->{$key};             # �ϥå��塦���Ͻ�      Encode::from_to( $epart->{$key}, $convfrom, $convto );
        EmailParser::Util::decode_mime_head( $convto, $epart->{$key} );
        $epart->{$key} =~ s/[\000-\040\177]/ /gs;
    }

    # $epart->{raw}->{XXXX} �γ�ͤ�����ɤ������    foreach my $key ( keys %{$epart->{raw}} ) {
        foreach my $val ( @{$epart->{raw}->{$key}} ) {
            Encode::from_to( $val, $convfrom, $convto );
            EmailParser::Util::decode_mime_head( $convto, $val );
            $val =~ s/[\000-\040\177]/ /gs;
        }
    }

    $epart->{current_charset} = $convto;
}
# ------------------------------------------------------------------------
    package EmailParser::Util;
    use strict;
    use vars qw( $DEBUG );
    $DEBUG = \*STDERR;
# ------------------------------------------------------------------------
#   ʸ���ɤλ�꤬�������������� ------------------------------------------------------------------------
sub valid_charset {
    my $charset = shift or return;

    # �̾���
    my $CHARSET_ALIAS = {
        "sjis"  =>  "Shift_JIS",
        "euc"   =>  "EUC-JP",
        "jis"   =>  "ISO-2022-JP",
        "utf-8" =>  "utf8",
    };
    if ( defined $CHARSET_ALIAS->{lc($charset)} ) {
        $charset = $CHARSET_ALIAS->{lc($charset)};
    }

    # Encode ��������ʾ��ϡ���������ɤ��������    if ( defined $Encode::VERSION ) {
        $charset = Encode::resolve_alias($charset) or return undef;
    }

    $charset;   # �����ɳ����λ
}
# ------------------------------------------------------------------------
#   �إå�����ɤ�ѹ�
# ------------------------------------------------------------------------
sub decode_mime_head {
    my $convto = shift or return;
    return unless defined $Encode::VERSION;
    foreach ( @_ ) {
        s{
            \=\?([\w\-]+)\?([BQ])\?([^\?]+?)\?\=
        }{
            my( $charset, $method, $str ) = ( $1, $2, $3 );
            my $convfrom = EmailParser::Util::valid_charset($charset);
            if ( $convfrom ) {
                if ( $method eq "Q" ) {
                    $str =~ s/=([a-z0-9]{2})/pack(C=>hex($1))/gei;
                } else {
                    $str = MIME::Base64::decode_base64($str);
                }
                if ( lc($convfrom) ne lc($convto) ) {
                    Encode::from_to( $str, $convfrom, $convto );
                }
            }
            $str;
        }iegx;
    }
}
# ------------------------------------------------------------------------
#   �᡼�륢�ɥ쥹��������� ------------------------------------------------------------------------
sub pickup_address {
    my $copy = "" . $_[0];
    my $list = [];
    while ( $copy =~ /\@/ ) {
        # �᡼�륢�ɥ쥹�κ�¦�Υ����Ȥ򳰤�
        $copy =~ s#^( \s*"([^"]|\")*"\s* | [^"][^\@]*\s+ )##xs;
        # �᡼�륢�ɥ쥹��Ф���       if ( $copy =~ s#(
            (?: " [\x21\x23-\x26\x2a\x2b\x2d-\x3b\x3d\x3f\x41-\x7e]+ " |
                  [\x21\x23-\x26\x2a\x2b\x2d-\x3b\x3d\x3f\x41-\x7e]+ ) \@
            (?: (?:[\w\-]+\.)+\w+ | \[\d+\.\d+\.\d+\.\d+\] ))##xs ) {
            push( @$list, $1 );
        } else {
            last;
        }
        # �᡼�륢�ɥ쥹�α�¦�Υ����Ȥ򳰤�
        $copy =~ s#^ [\<\>\s]* \(.*?\) \s* ##xs;
        $copy =~ s#^ [^,\@]* , \s* ##xs;
    }
    return unless scalar @$list;
    @$list;
}
# ------------------------------------------------------------------------
    package EmailParser::Map;
    use strict;
# ------------------------------------------------------------------------
#   �ɥᥤ�󤴤ȤΥǥե����Υ᡼�����ȡʼ�SPAM��# ------------------------------------------------------------------------
sub domain2charset {
    my $domain2charset = {
        "hanmail.net"   =>  "EUC-KR",
        "korea.com"     =>  "EUC-KR",
        "sinamail.com"  =>  "Big5",
        "hinet.net"     =>  "Big5",
    };
}
# ------------------------------------------------------------------------
#   �񤴤ȤΥǥե����Υ᡼������# ------------------------------------------------------------------------
sub country2charset {
    my $country2charset = {
        cn  =>  "GB2312",       # ���      hk  =>  "Big5",         # ��
        tw  =>  "Big5",         # ��
        kr  =>  "EUC-KR",       # �ڹ�      ru  =>  "koi8-r",       # ï¿½í¥·ï¿½ï¿½
        us  =>  "iso-8859-1",   # ������
    };
}
# ------------------------------------------------------------------------
#   ���������פȳ���Ҥ�б�
# ------------------------------------------------------------------------
sub format2ext {
    my $format2ext = {
        "text/plain"    =>  "txt",
        "text/html"     =>  "html",
        "image/jpeg"    =>  "jpg",
        "image/gif"     =>  "gif",
        "application/vnd.ms-excel"  =>  "xls",
    };
}
# ------------------------------------------------------------------------
;1;
# ------------------------------------------------------------------------