File Coverage

lib/Sisimai/MIME.pm

Criterion	Covered	Total	%
statement	201	208	96.6
branch	104	124	83.8
condition	33	48	68.7
subroutine	15	15	100.0
pod	7	7	100.0
total	360	402	89.5

package Sisimai::MIME;
use feature ':5.10';
use strict;
use warnings;
use Encode;
use MIME::Base64 ();
use MIME::QuotedPrint ();
use Sisimai::String;
use constant ReE => {
    '7bit-encoded' => qr/^content-transfer-encoding:[ ]*7bit/m,
    'quoted-print' => qr/^content-transfer-encoding:[ ]*quoted-printable/m,
    'some-iso2022' => qr/^content-type:[ ]*.+;[ ]*charset=["']?(iso-2022-[-a-z0-9]+)['"]?\b/m,
    'with-charset' => qr/^content[-]type:[ ]*.+[;][ ]*charset=['"]?([-0-9a-z]+)['"]?\b/,
    'only-charset' => qr/^[\s\t]+charset=['"]?([-0-9a-z]+)['"]?\b/,
    'html-message' => qr|^content-type:[ ]*text/html;|m,
};

sub is_mimeencoded {
    # Check that the argument is MIME-Encoded string or not
    # @param    [String] argv1  String to be checked
    # @return   [Integer]       0: Not MIME encoded string
    #                           1: MIME encoded string
    my $class = shift;
    my $argv1 = shift || return undef;
    return undef unless ref $argv1 eq 'SCALAR';

    my $text1 = $$argv1; $text1 =~ y/"//d;
    my $mime1 = 0;
    my @piece;

    if( rindex($text1, ' ') > -1 ) {
        # Multiple MIME-Encoded strings in a line
        @piece = split(' ', $text1);
    } else {
        push @piece, $text1;
    }

    for my $e ( @piece ) {
        # Check all the string in the array
        next unless $e =~ /[ \t]*=[?][-_0-9A-Za-z]+[?][BbQq][?].+[?]=?[ \t]*/;
        $mime1 = 1;
    }
    return $mime1;
}

sub mimedecode {
    # Decode MIME-Encoded string
    # @param    [Array] argvs   Reference to an array including MIME-Encoded text
    # @return   [String]        MIME-Decoded text
    my $class = shift;
    my $argvs = shift;
    return undef unless ref $argvs eq 'ARRAY';

    my $characterset = '';
    my $encodingname = '';
    my @decodedtext0;

    for my $e ( @$argvs ) {
        # Check and decode each element
        $e =~ s/\A[ \t]+//g;
        $e =~ s/[ \t]+\z//g;
        $e =~ y/"//d;

        if( __PACKAGE__->is_mimeencoded(\$e) ) {
            # =?utf-8?B?55m954yr44Gr44KD44KT44GT?=
            next unless $e =~ m{\A(.*)=[?]([-_0-9A-Za-z]+)[?]([BbQq])[?](.+)[?]=?(.*)\z};
            $characterset ||= lc $2;
            $encodingname ||= uc $3;

            push @decodedtext0, $1;
            push @decodedtext0, $encodingname eq 'B'
                ? MIME::Base64::decode($4)
                : MIME::QuotedPrint::decode($4);
            $decodedtext0[-1] =~ y/\r\n//d;
            push @decodedtext0, $5;

        } else {
            push @decodedtext0, scalar @decodedtext0 ? ' '.$e : $e;
        }
    }
    return '' unless scalar @decodedtext0;

    my $decodedtext1 = join('', @decodedtext0);
    if( $characterset && $encodingname ) {
        # utf-8 => utf8
        $characterset = 'utf8' if $characterset eq 'utf-8';

        if( $characterset ne 'utf8' ) {
            # Characterset is not UTF-8
            eval { Encode::from_to($decodedtext1, $characterset, 'utf8') };
            $decodedtext1 = 'FAILED TO CONVERT THE SUBJECT' if $@;
        }
    }
    return $decodedtext1;
}

sub qprintd {
    # Decode MIME Quoted-Printable Encoded string
    # @param    [String] argv1   MIME Encoded text
    # @param    [Hash]   heads   Email header
    # @return   [String]         MIME Decoded text
    my $class = shift;
    my $argv1 = shift // return undef;
    my $heads = shift // {};
    my $plain = '';
    return \'' unless ref $argv1 eq 'SCALAR';

    if( ! exists $heads->{'content-type'} || ! $heads->{'content-type'} ) {
        # There is no Content-Type: field
        $plain = MIME::QuotedPrint::decode($$argv1);
        return \$plain;
    }

    # Quoted-printable encoded part is the part of the text
    my $boundary00 = __PACKAGE__->boundary($heads->{'content-type'}, 0);
    if( ! $boundary00 || lc($$argv1) !~ ReE->{'quoted-print'} ) {
        # There is no boundary string or no
        # Content-Transfer-Encoding: quoted-printable field.
        $plain = MIME::QuotedPrint::decode($$argv1);
        return \$plain;
    }

    my $boundary01 = Sisimai::MIME->boundary($heads->{'content-type'}, 1);
    my $bodystring = '';
    my $notdecoded = '';

    my $encodename = undef;
    my $ctencoding = undef;
    my $mimeinside = 0;

    for my $e ( split("\n", $$argv1) ) {
        # This is a multi-part message in MIME format. Your mail reader does not
        # understand MIME message format.
        # --=_gy7C4Gpes0RP4V5Bs9cK4o2Us2ZT57b-3OLnRN+4klS8dTmQ
        # Content-Type: text/plain; charset=iso-8859-15
        # Content-Transfer-Encoding: quoted-printable
        if( $mimeinside ) {
            # Quoted-Printable encoded text block
            if( $e eq $boundary00 ) {
                # The next boundary string has appeared
                # --=_gy7C4Gpes0RP4V5Bs9cK4o2Us2ZT57b-3OLnRN+4klS8dTmQ
                my $hasdecoded = MIME::QuotedPrint::decode($notdecoded);
                   $hasdecoded = Sisimai::String->to_utf8(\$hasdecoded, $encodename);
                $bodystring .= $$hasdecoded;
                $bodystring .= $e . "\n";

                $notdecoded = '';
                $mimeinside = 0;
                $ctencoding = undef;
                $encodename = undef;
            } else {
                # Inside of Queoted printable encoded text
                $notdecoded .= $e . "\n";
            }
        } else {
            # NOT Quoted-Printable encoded text block
            if( (my $lowercased = lc $e) =~ /\A[-]{2}[^\s]+[^-]\z/ ) {
                # Start of the boundary block
                # --=_gy7C4Gpes0RP4V5Bs9cK4o2Us2ZT57b-3OLnRN+4klS8dTmQ
                unless( $e eq $boundary00 ) {
                    # New boundary string has appeared
                    $boundary00 = $e;
                    $boundary01 = $e . '--';
                }
            } elsif( $lowercased =~ ReE->{'with-charset'} || $lowercased =~ ReE->{'only-charset'} ) {
                # Content-Type: text/plain; charset=ISO-2022-JP
                $encodename = $1;
                $mimeinside = 1 if $ctencoding;

            } elsif( $lowercased =~ ReE->{'quoted-print'} ) {
                # Content-Transfer-Encoding: quoted-printable
                $ctencoding = $e;
                $mimeinside = 1 if $encodename;

            } elsif( $e eq $boundary01 ) {
                # The end of boundary block
                # --=_gy7C4Gpes0RP4V5Bs9cK4o2Us2ZT57b-3OLnRN+4klS8dTmQ--
                $mimeinside = 0;
            }
            $bodystring .= $e . "\n";
        }
    }

    $bodystring .= $notdecoded if length $notdecoded;
    return \$bodystring;
}

sub base64d {
    # Decode MIME BASE64 Encoded string
    # @param    [String] argv1   MIME Encoded text
    # @return   [String]         MIME-Decoded text
    my $class = shift;
    my $argv1 = shift // return undef;
    return \'' unless ref $argv1 eq 'SCALAR';

    # Decode BASE64
    my $plain = $$argv1 =~ m|([+/=0-9A-Za-z\r\n]+)| ? MIME::Base64::decode($1) : '';
    return \$plain;
}

sub boundary {
    # Get boundary string
    # @param    [String]  argv1 The value of Content-Type header
    # @param    [Integer] start -1: boundary string itself
    #                            0: Start of boundary
    #                            1: End of boundary
    # @return   [String] Boundary string
    my $class = shift;
    my $argv1 = shift || return undef;
    my $start = shift // -1;
    my $value = '';

    if( lc $argv1 =~ /\bboundary=([^ ]+)/ ) {
        # Content-Type: multipart/mixed; boundary=Apple-Mail-5--931376066
        # Content-Type: multipart/report; report-type=delivery-status;
        #    boundary="n6H9lKZh014511.1247824040/mx.example.jp"
        $value =  $1;
        $value =~ y/"';\\//d;
        $value =  '--'.$value if $start > -1;
        $value =  $value.'--' if $start >  0;
    }
    return $value;
}

sub breaksup {
    # Breaks up each multipart/* block
    # @param    [String] argv0 Text block of multipart/*
    # @param    [String] argv1 MIME type of the outside part
    # @return   [String] Decoded part as a plain text(text part only)
    my $class = shift;
    my $argv0 = shift || return undef;
    my $argv1 = shift || '';

    state $alsoappend = qr{\A(?:text/rfc822-headers|message/)};
    state $thisformat = qr/\A(?:Content-Transfer-Encoding:\s*.+\n)?Content-Type:\s*([^ ;\s]+)/;
    state $leavesonly = qr{\A(?>
         text/(?:plain|html|rfc822-headers)
        |message/(?:x?delivery-status|rfc822|partial|feedback-report)
        |multipart/(?:report|alternative|mixed|related|partial)
        )
    }x;

    my $mimeformat = $$argv0 =~ $thisformat ? lc($1) : '';
    my $alternates = index($argv1, 'multipart/alternative') == 0 ? 1 : 0;
    my $hasflatten = '';    # Message body including only text/plain and message/*

    # Sisimai require only MIME types defined in $leavesonly variable
    return \'' unless $mimeformat =~ $leavesonly;
    return \'' if $alternates && $mimeformat eq 'text/html';

    my ($upperchunk, $lowerchunk) = split(/^$/m, $$argv0, 2);
    $upperchunk =~ y/\n/ /;
    $upperchunk =~ y/ //s;

    # Content-Description: Undelivered Message
    # Content-Type: message/rfc822
    #
    $lowerchunk ||= '';

    if( index($mimeformat, 'multipart/') == 0 ) {
        # Content-Type: multipart/*
        my $mpboundary = __PACKAGE__->boundary($upperchunk, 0);
        my @innerparts = split(/\Q$mpboundary\E\n/, $lowerchunk);
        shift @innerparts unless length $innerparts[0];
        shift @innerparts if $innerparts[0] eq "\n";

        for my $e ( @innerparts ) {
            # Find internal multipart/* blocks and decode
            if( $e =~ $thisformat ) {
                # Found Content-Type field at the first or second line of this
                # split part
                my $nextformat = lc $1;
                next unless $nextformat =~ $leavesonly;
                next if $nextformat eq 'text/html';
                $hasflatten .= ${ __PACKAGE__->breaksup(\$e, $mimeformat) };

            } else {
                # The content of this part is almost '--': a part of boundary
                # string which is used for splitting multipart/* blocks.
                $hasflatten .= "\n";
            }
        }
    } else {
        # Is not "Content-Type: multipart/*"
        if( $upperchunk =~ /Content-Transfer-Encoding: ([^\s;]+)/ ) {
            # Content-Transfer-Encoding: quoted-printable|base64|7bit|...
            my $getdecoded = '';

            if( (my $ctencoding = lc $1) eq 'quoted-printable' ) {
                # Content-Transfer-Encoding: quoted-printable
                $getdecoded = ${ __PACKAGE__->qprintd(\$lowerchunk) };

            } elsif( $ctencoding eq 'base64' ) {
                # Content-Transfer-Encoding: base64
                $getdecoded = ${ __PACKAGE__->base64d(\$lowerchunk) };

            } elsif( $ctencoding eq '7bit' ) {
                # Content-Transfer-Encoding: 7bit
                if( lc($upperchunk) =~ ReE->{'some-iso2022'} ) {
                    # Content-Type: text/plain; charset=ISO-2022-JP
                    $getdecoded = ${ Sisimai::String->to_utf8(\$lowerchunk, $1) };

                } else {
                    # No "charset" parameter in Content-Type: field
                    $getdecoded = $lowerchunk;
                }
            } else {
                # Content-Transfer-Encoding: 8bit, binary, and so on
                $getdecoded = $lowerchunk;
            }
            $getdecoded =~ s|\r\n|\n|g if index($getdecoded, "\r\n") > -1; # Convert CRLF to LF

            if( $mimeformat =~ $alsoappend ) {
                # Append field when the value of Content-Type: begins with
                # message/ or equals text/rfc822-headers.
                $upperchunk =~ s/Content-Transfer-Encoding:\s*[^\s]+//;
                $upperchunk =~ s/\A[ ]//g if substr($upperchunk,  0, 1) eq ' ';
                $upperchunk =~ s/[ ]\z//g if substr($upperchunk, -1, 1) eq ' ';
                $hasflatten .= $upperchunk;

            } elsif( $mimeformat eq 'text/html' ) {
                # Delete HTML tags inside of text/html part whenever possible
                $getdecoded = ${ Sisimai::String->to_plain(\$getdecoded) };
            }
            $hasflatten .= $getdecoded."\n\n" if length $getdecoded;
        } else {
            # Content-Type: text/plain OR text/rfc822-headers OR message/*
            if( index($mimeformat, 'message/') == 0 || $mimeformat eq 'text/rfc822-headers' ) {
                # Append headers of multipart/* when the value of "Content-Type"
                # is inlucded in the following MIME types:
                #  - message/delivery-status
                #  - message/rfc822
                #  - text/rfc822-headers
                $hasflatten .= $upperchunk;
            }
            $lowerchunk =~ s/^--\z//m;
            $lowerchunk .= "\n" unless $lowerchunk =~ /\n\z/;
            $hasflatten .= $lowerchunk;
        }
    }
    return \$hasflatten;
}

sub makeflat {
    # MIME decode entire message body
    # @param    [String] argv0 Content-Type header
    # @param    [String] argv1 Entire message body
    # @return   [String] Decoded message body
    my $class = shift;
    my $argv0 = shift // return undef;
    my $argv1 = shift // return undef;

    my $ehboundary = __PACKAGE__->boundary($argv0, 0);
    my $mimeformat = $argv0 =~ qr|\A([0-9a-z]+/[^ ;]+)| ? $1 : '';
    my $bodystring = '';

    return \'' unless index($mimeformat, 'multipart/') > -1;
    return \'' unless $ehboundary;

    # Some bounce messages include lower-cased "content-type:" field such as
    #   content-type: message/delivery-status
    #   content-transfer-encoding: quoted-printable
    $$argv1 =~ s/[Cc]ontent-[Tt]ype:/Content-Type:/g;
    $$argv1 =~ s/[Cc]ontent-[Tt]ransfer-[Ee]ncodeing:/Content-Transfer-Encoding:/g;

    # 1. Some bounce messages include upper-cased "Content-Transfer-Encoding",
    #    and "Content-Type" value such as
    #      - Content-Type: multipart/RELATED;
    #      - Content-Transfer-Encoding: 7BIT
    # 2. Unused fields inside of mutipart/* block should be removed
    $$argv1 =~ s/(Content-[A-Za-z-]+?):[ ]*([^\s]+)/$1.': '.lc($2)/eg;
    $$argv1 =~ s/^Content-(?:Description|Disposition):.+?\n//gm;

    my @multiparts = split(/\Q$ehboundary\E\n?/, $$argv1);
    shift @multiparts unless length $multiparts[0];
    for my $e ( @multiparts ) {
        # Find internal multipart blocks and decode
        XCCT: {
            # Remove fields except Content-Type, Content-Transfer-Encoding in
            # each part such as the following:
            #   Date: Thu, 29 Apr 2018 22:22:22 +0900
            #   MIME-Version: 1.0
            #   Message-ID: ...
            #   Content-Transfer-Encoding: quoted-printable
            #   Content-Type: text/plain; charset=us-ascii
            #
            # Fields before "Content-Type:" in each part should have been removed
            # and "Content-Type:" should be exist at the first line of each part.
            # The field works as a delimiter to decode contents of each part.
            #
            last(XCCT) if $e =~ /\AContent-T[ry]/;  # The first field is "Content-Type:"
            my $p = $1 if $e =~ /\A(.+?)Content-Type:/s || last(XCCT);
            last(XCCT) if $p =~ /\n\n/m;            # There is no field before "Content-Type:"
            $e =~ s/\A.+?(Content-T[ry].+)\z/$1/s;  # Remove fields before "Content-Type:"
        }

        if( $e =~ /\A(?:Content-[A-Za-z-]+:.+?\r?\n)?Content-Type:[ ]*[^\s]+/ ) {
            # Content-Type: multipart/*
            $bodystring .= ${ __PACKAGE__->breaksup(\$e, $mimeformat) };

        } else {
            # Is not multipart/* block
            $e =~ s|^Content-Transfer-Encoding:.+?\n||sim;
            $e =~ s|^Content-Type:\s*text/plain.+?\n||sim;
            $bodystring .= $e;
        }
    }

    # Remove entire message body of the original message beginning from
    # Content-Type: message/rfc822 field so Sisimai does not read the message
    # body for detecting a bounce reason, for getting email header fields of
    # the original message.
    $bodystring =~ s{^(Content-Type:\s*message/(?:rfc822|delivery-status)).+$}{$1}gm;
    $bodystring =~ s|^\n{2,}|\n|gm;

    return \$bodystring;
}

1;
__END__