File Coverage

blib/lib/Email/MIME/RFC2047/Decoder.pm

Criterion	Covered	Total	%
statement	58	62	93.5
branch	19	20	95.0
condition	3	3	100.0
subroutine	8	8	100.0
pod	3	3	100.0
total	91	96	94.7

package Email::MIME::RFC2047::Decoder;
$Email::MIME::RFC2047::Decoder::VERSION = '0.96';
use strict;
use warnings;

# ABSTRACT: Decoding of non-ASCII MIME headers

use Encode ();
use MIME::Base64 ();

# Don't include period "." to correctly handle obs-phrase.
my $rfc_specials = '()<>\[\]:;\@\\,"';
my $rfc_specials_no_quote = '()<>\[\]:;\@\\,';

# Regex for encoded words.
# This also checks the validity of base64 encoded data because MIME::Base64
# silently ignores invalid characters.
# Captures ($encoding, $content_b, $content_q)
my $encoded_word_text_re = qr/
    (?: ^ | (?<= [\r\n\t ] ) )
    = \? ( [A-Za-z0-9_-]++ ) \?
    (?:
        [Bb] \?
        (
            (?:
                [A-Za-z0-9+\/]{2}
                (?: == | [A-Za-z0-9+\/] [A-Za-z0-9+\/=] )
            )++
        ) |
        [Qq] \?
        ( [\x21-\x3E\x40-\x7E]++ )
    )
    \? =
    (?= \z | [\r\n\t ] )
/x;

# Same as $encoded_word_text_re but excluding RFC 2822 special chars
# Also matches after and before special chars (why?).
my $encoded_word_phrase_re = qr/
    (?: ^ | (?<= [\r\n\t $rfc_specials_no_quote] ) )
    = \? ( [A-Za-z0-9_-]++ ) \?
    (?:
        [Bb] \?
        (
            (?:
                [A-Za-z0-9+\/]{2}
                (?: == | [A-Za-z0-9+\/] [A-Za-z0-9+\/=] )
            )++
        ) |
        [Qq] \?
        ( [A-Za-z0-9!*+\/=_-]++ )
    )
    \? =
    (?= \z | [\r\n\t $rfc_specials_no_quote] )
/x;

# Same as $encoded_word_text_re but excluding parens and backslash.
# Also matches after and before parens.
#my $encoded_word_comment_re = qr/
#    (?<= [\r\n\t ()] )
#    = \? ( [A-Za-z0-9_-]++ ) \?
#    (?:
#        [Bb] \?
#        (
#            (?:
#                [A-Za-z0-9+\/]{2}
#                (?: == | [A-Za-z0-9+\/] [A-Za-z0-9+\/=] )
#            )++
#        ) |
#        [Qq] \?
#        ( [\x21-\x27\x2A-\x3E\x40-\x5B\x5D-\x7E]++ )
#    )
#    \? =
#    (?= [\r\n\t ()] )
#/x;

my $quoted_string_re = qr/
    "
    (
        (?:
            [^"\\]++ |
            \\ .
        )*+
    )
    "
/sx;

my $comment_re = qr/
    (
        \(
            (?:
                [^()\\]++ |
                \\ . |
                (?-1)
            )*+
        \)
    )
/sx;

sub new {
    my $package = shift;

    my $self = {};

    return bless($self, $package);
}

sub decode_text {
    my $self = shift;

    return $self->_decode('text', @_);
}

sub decode_phrase {
    my $self = shift;

    return $self->_decode('phrase', @_);
}

sub _decode {
    my ($self, $mode, $encoded) = @_;
    my $encoded_ref = ref($encoded) ? $encoded : \$encoded;

    my $result = '';
    my $enc_flag;
    # use shortest match on any characters we don't want to decode
    my $regex = $mode eq 'phrase' ?
        qr/([^$rfc_specials]*?)($encoded_word_phrase_re|$quoted_string_re|$comment_re)/ :
        qr/(.*?)($encoded_word_text_re)/s;

    while ($$encoded_ref =~ /\G$regex/cg) {
        my ($text, $match,
            $encoding, $b_content, $q_content,
            $qs_content) =
            ($1, $2, $3, $4, $5, $6, $7);

        if (defined($encoding)) {
            # encoded words shouldn't be longer than 75 chars but
            # let's allow up to 255 chars
            if (length($match) > 255) {
                $result .= $text;
                $result .= $match;
                $enc_flag = undef;
                next;
            }

            my $content;

            if (defined($b_content)) {
                # MIME B
                $content = MIME::Base64::decode_base64($b_content);
            }
            else {
                # MIME Q
                $content = $q_content;
                $content =~ tr/_/ /;
                $content =~ s/=([0-9A-Fa-f]{2})/chr(hex($1))/eg;
            }

            my $chunk;
            eval {
                $chunk = Encode::decode(
                    $encoding,
                    $content,
                    Encode::FB_CROAK
                );
            };

            if ($@) {
                warn($@);
                # display raw encoded word in case of errors
                $result .= $text;
                $result .= $match;
                $enc_flag = undef;
                next;
            }

            # ignore whitespace between encoded words
            $result .= $text if !$enc_flag || $text =~ /\S/;

            $result .= $chunk;

            $enc_flag = 1;
        }
        elsif (defined($qs_content)) {
            # quoted string

            $result .= $text;

            # unquote
            $qs_content =~ s/\\(.)/$1/gs;
            $result .= $qs_content;

            $enc_flag = undef;
        }
    }

    $regex = $mode eq 'phrase' ?
        qr/[^$rfc_specials]+/ :
        qr/.+/s;
    $result .= $& if $$encoded_ref =~ /\G$regex/cg;

    # normalize whitespace
    $result =~ s/^[\r\n\t ]+//;
    $result =~ s/[\r\n\t ]+\z//;
    $result =~ s/[\r\n\t ]+/ /g;

    # remove potentially dangerous ASCII control chars
    $result =~ s/[\x00-\x1f\x7f]//g;

    return $result;
}

1;

__END__