# ------------------------------------------------------------------------
#   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}               優先度（1〜5）
    $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フラグをON
    $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フラグをON
    $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フラグをON
    $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;
# ------------------------------------------------------------------------