File Coverage

lib/Sisimai/Message.pm

Criterion	Covered	Total	%
statement	199	206	96.6
branch	82	106	77.3
condition	24	32	75.0
subroutine	15	15	100.0
pod	1	5	20.0
total	321	364	88.1

package Sisimai::Message;
use feature ':5.10';
use strict;
use warnings;
use Sisimai::RFC5322;
use Sisimai::Address;
use Sisimai::String;
use Sisimai::Order;
use Sisimai::Lhost;
use Sisimai::MIME;
use Class::Accessor::Lite (
    'new' => 0,
    'rw'  => [
        'from',     # [String] UNIX From line
        'header',   # [Hash]   Header part of an email
        'ds',       # [Array]  Parsed data by Sisimai::Lhost
        'rfc822',   # [Hash]   Header part of the original message
        'catch'     # [Any]    The results returned by hook method
    ]
);

my $ToBeLoaded = [];
my $TryOnFirst = [];

sub new {
    # Constructor of Sisimai::Message
    # @param         [Hash] argvs       Email text data
    # @options argvs [String] data      Entire email message
    # @options argvs [Array]  load      User defined MTA module list
    # @options argvs [Array]  order     The order of MTA modules
    # @options argvs [Code]   hook      Reference to callback method
    # @return        [Sisimai::Message] Structured email data or Undef if each
    #                                   value of the arguments are missing
    my $class = shift;
    my $argvs = { @_ };
    my $param = {};
    my $email = $argvs->{'data'} || return undef;
    my $thing = { 'from' => '', 'header' => {}, 'rfc822' => '', 'ds' => [], 'catch' => undef };

    # 1. Load specified MTA modules
    for my $e ('load', 'order') {
        # Order of MTA modules
        next unless exists $argvs->{ $e };
        next unless ref $argvs->{ $e } eq 'ARRAY';
        next unless scalar @{ $argvs->{ $e } };
        $param->{ $e } = $argvs->{ $e };
    }
    $ToBeLoaded = __PACKAGE__->load(%$param);

    # 2. Split email data to headers and a body part.
    return undef unless my $aftersplit = __PACKAGE__->divideup(\$email);

    # 3. Convert email headers from text to hash reference
    $thing->{'from'}   = $aftersplit->[0];
    $thing->{'header'} = __PACKAGE__->makemap(\$aftersplit->[1]);

    # 4. Decode and rewrite the "Subject:" header
    if( $thing->{'header'}->{'subject'} ) {
        # Decode MIME-Encoded "Subject:" header
        my $s = $thing->{'header'}->{'subject'};
        my $q = Sisimai::MIME->is_mimeencoded(\$s) ? Sisimai::MIME->mimedecode([split(/[ ]/, $s)]) : $s;

        # Remove "Fwd:" string from the "Subject:" header
        if( lc($q) =~ /\A[ \t]*fwd?:[ ]*(.*)\z/ ) {
            # Delete quoted strings, quote symbols(>)
            $q = $1;
            $aftersplit->[2] =~ s/^[>]+[ ]//gm;
            $aftersplit->[2] =~ s/^[>]$//gm;
        }
        $thing->{'header'}->{'subject'} = $q;
    }

    # 5. Rewrite message body for detecting the bounce reason
    $TryOnFirst = Sisimai::Order->make($thing->{'header'}->{'subject'});
    $param = { 'hook' => $argvs->{'hook'} || undef, 'mail' => $thing, 'body' => \$aftersplit->[2] };
    return undef unless my $bouncedata = __PACKAGE__->parse(%$param);
    return undef unless keys %$bouncedata;

    # 6. Rewrite headers of the original message in the body part
    $thing->{ $_ } = $bouncedata->{ $_ } for ('ds', 'catch', 'rfc822');
    my $r = $bouncedata->{'rfc822'} || $aftersplit->[2];
    $thing->{'rfc822'} = ref $r ? $r : __PACKAGE__->makemap(\$r, 1);

    return bless($thing, $class);
}

sub load {
    # Load MTA modules which specified at 'order' and 'load' in the argument
    # @param         [Hash] argvs       Module information to be loaded
    # @options argvs [Array]  load      User defined MTA module list
    # @options argvs [Array]  order     The order of MTA modules
    # @return        [Array]            Module list
    # @since v4.20.0
    my $class = shift;
    my $argvs = { @_ };

    my @modulelist;
    my $tobeloaded = [];

    for my $e ('load', 'order') {
        # The order of MTA modules specified by user
        next unless exists $argvs->{ $e };
        next unless ref $argvs->{ $e } eq 'ARRAY';
        next unless scalar @{ $argvs->{ $e } };

        push @modulelist, @{ $argvs->{'order'} } if $e eq 'order';
        next unless $e eq 'load';

        # Load user defined MTA module
        for my $v ( @{ $argvs->{'load'} } ) {
            # Load user defined MTA module
            eval {
                (my $modulepath = $v) =~ s|::|/|g;
                require $modulepath.'.pm';
            };
            next if $@;
            push @$tobeloaded, $v;
        }
    }

    for my $e ( @modulelist ) {
        # Append the custom order of MTA modules
        next if grep { $e eq $_ } @$tobeloaded;
        push @$tobeloaded, $e;
    }
    return $tobeloaded;
}

sub divideup {
    # Divide email data up headers and a body part.
    # @param         [String] email  Email data
    # @return        [Array]         Email data after split
    # @since v4.14.0
    my $class = shift;
    my $email = shift // return undef;
    my $block = ['', '', ''];   # 0:From, 1:Header, 2:Body

    $$email =~ s/\r\n/\n/gm  if rindex($$email, "\r\n") > -1;
    $$email =~ s/[ \t]+$//gm if $$email =~ /[ \t]+$/;

    ($block->[1], $block->[2]) = split(/\n\n/, $$email, 2);
    return undef unless $block->[1];
    return undef unless $block->[2];

    if( substr($block->[1], 0, 5) eq 'From ' ) {
        # From MAILER-DAEMON Tue Feb 11 00:00:00 2014
        $block->[0] =  [split(/\n/, $block->[1], 2)]->[0];
        $block->[0] =~ y/\r\n//d;
    } else {
        # Set pseudo UNIX From line
        $block->[0] =  'MAILER-DAEMON Tue Feb 11 00:00:00 2014';
    }
    $block->[1] .= "\n" unless $block->[1] =~ /\n\z/;

    for my $e ('image/', 'application/', 'text/html') {
        # https://github.com/sisimai/p5-sisimai/issues/492, Reduce email size
        my $p0 = 0;
        my $p1 = 0;
        my $ep = $e eq 'text/html' ? '' : "--\n";
        while(1) {
            # Remove each part from "Content-Type: image/..." to "--\n" (the end of each boundary)
            $p0 = index($block->[2], 'Content-Type: '.$e, $p0); last if $p0 < 0;
            $p1 = index($block->[2], $ep, $p0 + 32);            last if $p1 < 0;
            substr($block->[2], $p0, $p1 - $p0, '');
        }
    }
    $block->[2] .= "\n";
    return $block;
}

sub makemap {
    # Convert a text including email headers to a hash reference
    # @param    [String] argv0  Email header data
    # @param    [Bool]   argv1  Decode "Subject:" header
    # @return   [Hash]          Structured email header data
    # @since    v4.25.6
    my $class = shift;
    my $argv0 = shift || return {};
    my $argv1 = shift || 0;

    $$argv0 =~ s/^[>]+[ ]//mg;  # Remove '>' indent symbol of forwarded message

    # Select and convert all the headers in $argv0. The following regular expression
    # is based on https://gist.github.com/xtetsuji/b080e1f5551d17242f6415aba8a00239
    my $firstpairs = { $$argv0 =~ /^([\w-]+):[ ]*(.*?)\n(?![\s\t])/gms };
    my $headermaps = { 'subject' => '' };
    my $recvheader = [];


    $headermaps->{ lc $_ } = $firstpairs->{ $_ } for keys %$firstpairs;
    for my $e ( values %$headermaps ) { $e =~ s/\n\s+/ /; $e =~ y/\t / /s }

    if( $$argv0 =~ /^Received:/m ) {
        # Capture values of each Received: header
        $recvheader = [$$argv0 =~ /^Received:[ ]*(.*?)\n(?![\s\t])/gms];
        for my $e ( @$recvheader ) { $e =~ s/\n\s+/ /; $e =~ y/\n\t / /s }
    }
    $headermaps->{'received'} = $recvheader;

    return $headermaps unless $argv1;
    return $headermaps unless length $headermaps->{'subject'};

    # Convert MIME-Encoded subject
    if( Sisimai::String->is_8bit(\$headermaps->{'subject'}) ) {
        # The value of ``Subject'' header is including multibyte character,
        # is not MIME-Encoded text.
        eval {
            # Remove invalid byte sequence
            Encode::decode_utf8($headermaps->{'subject'});
            Encode::encode_utf8($headermaps->{'subject'});
        };
        $headermaps->{'subject'} = 'MULTIBYTE CHARACTERS HAVE BEEN REMOVED' if $@;

    } else {
        # MIME-Encoded subject field or ASCII characters only
        my $r = [];
        if( Sisimai::MIME->is_mimeencoded(\$headermaps->{'subject'}) ) {
            # split the value of Subject by $borderline
            for my $v ( split(/ /, $headermaps->{'subject'}) ) {
                # Insert value to the array if the string is MIME encoded text
                push @$r, $v if Sisimai::MIME->is_mimeencoded(\$v);
            }
        } else {
            # Subject line is not MIME encoded
            $r = [$headermaps->{'subject'}];
        }
        $headermaps->{'subject'} = Sisimai::MIME->mimedecode($r);
    }
    return $headermaps;
}

sub parse {
    # Parse bounce mail with each MTA module
    # @param               [Hash] argvs    Processing message entity.
    # @param options argvs [Hash] mail     Email message entity
    # @param options mail  [String] from   From line of mbox
    # @param options mail  [Hash]   header Email header data
    # @param options mail  [String] rfc822 Original message part
    # @param options mail  [Array]  ds     Delivery status list(parsed data)
    # @param options argvs [String] body   Email message body
    # @param options argvs [Code]   hook   Hook method to be called
    # @return              [Hash]          Parsed and structured bounce mails
    my $class = shift;
    my $argvs = { @_ };

    my $mailheader = $argvs->{'mail'}->{'header'} || return '';
    my $bodystring = $argvs->{'body'} || return '';
    my $hookmethod = $argvs->{'hook'} || undef;
    my $havecaught = undef;

    state $defaultset = Sisimai::Order->another;
    state $lhosttable = Sisimai::Lhost->path;

    $mailheader->{'from'}         //= '';
    $mailheader->{'subject'}      //= '';
    $mailheader->{'content-type'} //= '';

    # Decode BASE64 Encoded message body
    my $mesgformat = lc($mailheader->{'content-type'} || '');
    my $ctencoding = lc($mailheader->{'content-transfer-encoding'} || '');
    if( index($mesgformat, 'text/') == 0 ) {
        # Content-Type: text/plain; charset=UTF-8
        if( $ctencoding eq 'base64' ) {
            # Content-Transfer-Encoding: base64
            $bodystring = Sisimai::MIME->base64d($bodystring);

        } elsif( $ctencoding eq 'quoted-printable' ) {
            # Content-Transfer-Encoding: quoted-printable
            $bodystring = Sisimai::MIME->qprintd($bodystring);
        }

        # Content-Type: text/html;...
        $bodystring = Sisimai::String->to_plain($bodystring, 1) if $mesgformat =~ m|text/html;?|;
    } else {
        # NOT text/plain
        if( index($mesgformat, 'multipart/') == 0 ) {
            # In case of Content-Type: multipart/*
            my $p = Sisimai::MIME->makeflat($mailheader->{'content-type'}, $bodystring);
            $bodystring = $p if length $$p;
        }
    }
    $$bodystring =~ tr/\r//d;

    if( ref $hookmethod eq 'CODE' ) {
        # Call hook method
        my $p = { 'headers' => $mailheader, 'message' => $$bodystring };
        eval { $havecaught = $hookmethod->($p) };
        warn sprintf(" ***warning: Something is wrong in hook method:%s", $@) if $@;
    }

    my $haveloaded = {};
    my $parseddata = undef;
    my $modulename = '';
    PARSER: while(1) {
        # 1. User-Defined Module
        # 2. MTA Module Candidates to be tried on first
        # 3. Sisimai::Lhost::*
        # 4. Sisimai::RFC3464
        # 5. Sisimai::ARF
        # 6. Sisimai::RFC3834
        USER_DEFINED: for my $r ( @$ToBeLoaded ) {
            # Call user defined MTA modules
            next if exists $haveloaded->{ $r };
            $parseddata = $r->make($mailheader, $bodystring);
            $haveloaded->{ $r } = 1;
            $modulename = $r;
            last(PARSER) if $parseddata;
        }

        TRY_ON_FIRST_AND_DEFAULTS: for my $r ( @$TryOnFirst, @$defaultset ) {
            # Try MTA module candidates
            next if exists $haveloaded->{ $r };
            require $lhosttable->{ $r };
            $parseddata = $r->make($mailheader, $bodystring);
            $haveloaded->{ $r } = 1;
            $modulename = $r;
            last(PARSER) if $parseddata;
        }

        unless( $haveloaded->{'Sisimai::RFC3464'} ) {
            # When the all of Sisimai::Lhost::* modules did not return bounce
            # data, call Sisimai::RFC3464;
            require Sisimai::RFC3464;
            $parseddata = Sisimai::RFC3464->make($mailheader, $bodystring);
            $modulename = 'RFC3464';
            last(PARSER) if $parseddata;
        }

        unless( $haveloaded->{'Sisimai::ARF'} ) {
            # Feedback Loop message
            require Sisimai::ARF;
            $parseddata = Sisimai::ARF->make($mailheader, $bodystring) if Sisimai::ARF->is_arf($mailheader);
            last(PARSER) if $parseddata;
        }

        unless( $haveloaded->{'Sisimai::RFC3834'} ) {
            # Try to parse the message as auto reply message defined in RFC3834
            require Sisimai::RFC3834;
            $parseddata = Sisimai::RFC3834->make($mailheader, $bodystring);
            $modulename = 'RFC3834';
            last(PARSER) if $parseddata;
        }

        last; # as of now, we have no sample email for coding this block
    } # End of while(PARSER)
    return undef unless $parseddata;

    $parseddata->{'catch'} = $havecaught;
    $modulename =~ s/\A.+:://;
    $_->{'agent'} ||= $modulename for @{ $parseddata->{'ds'} };
    return $parseddata;
}

1;
__END__