Skip to content

Commit

Permalink
Bug fix, tiny code improvements #407
Browse files Browse the repository at this point in the history
  • Loading branch information
@azumakuniyuki
azumakuniyuki committed Aug 25, 2020
1 parent c7982df commit 223b35e
Show file tree
Hide file tree
Showing 2 changed files with 35 additions and 64 deletions.
56 changes: 26 additions & 30 deletions lib/Sisimai/RFC2047.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@ sub is_mimeencoded {

# Multiple MIME-Encoded strings in a line
@piece = split(' ', $text1) if rindex($text1, ' ') > -1;
for my $e ( @piece ) {
while( my $e = shift @piece ) {
# Check all the string in the array
next unless $e =~ /[ \t]*=[?][-_0-9A-Za-z]+[?][BbQq][?].+[?]=?[ \t]*/;
$mime1 = 1;
Expand All @@ -39,7 +39,7 @@ sub mimedecode {
my $qbencoding = '';
my @textblocks;

for my $e ( @$argvs ) {
while( my $e = shift @$argvs ) {
# Check and decode each element
$e =~ s/\A[ \t]+//g;
$e =~ s/[ \t]+\z//g;
Expand Down Expand Up @@ -88,21 +88,20 @@ sub ctvalue {
my $argv0 = shift || return undef;
my $argv1 = shift || '';

my $foundtoken = '';
my $parameterq = length $argv1 > 0 ? lc $argv1.'=' : '';
my $paramindex = length $argv1 > 0 ? index($argv0, $parameterq): 0;
return $foundtoken if $paramindex == -1;
my $paramindex = length $argv1 > 0 ? index($argv0, $parameterq) : 0;
return '' if $paramindex == -1;

# Find the value of the parameter name specified in $argv1
$foundtoken = [split(';', substr($argv0, $paramindex + length($parameterq)), 2)]->[0];
$foundtoken = lc $foundtoken unless $argv1 eq 'boundary';
$foundtoken =~ y/"'//d;
my $foundtoken = [split(';', substr($argv0, $paramindex + length($parameterq)), 2)]->[0];
$foundtoken = lc $foundtoken unless $argv1 eq 'boundary';
$foundtoken =~ y/"'//d;
return $foundtoken;
}

sub boundary {
# Get a boundary string
# @param [String] argv1 The value of Content-Type header
# @param [String] argv0 The value of Content-Type header
# @param [Integer] start -1: boundary string itself
# 0: Start of boundary
# 1: End of boundary
Expand Down Expand Up @@ -139,7 +138,6 @@ sub base64d {
my $class = shift;
my $argv0 = shift // return undef;

# Decode BASE64
my $p = $$argv0 =~ m|([+/=0-9A-Za-z\r\n]+)| ? MIME::Base64::decode($1) : '';
return \$p;
}
Expand All @@ -154,14 +152,12 @@ sub haircut {
my $block = shift // return undef;
my $heads = shift // undef;

my($upperchunk, $lowerchunk) = split("\n\n", $$block, 2);
return ['', ''] unless $upperchunk;
return ['', ''] unless index($upperchunk, 'Content-Type:') > -1;

my $headerpart = ['', '']; # ["text/plain; charset=iso-2022-jp; ...", "quoted-printable"]
my $multipart1 = []; # [@$headerpart, "body"]
my $upperchunk = ''; # Uppper chunk of the part: Headers of multipart/* block
my $lowerchunk = ''; # Lower chunk of the part: Body part of multipart/* block

($upperchunk, $lowerchunk) = split("\n\n", $$block, 2);
return $headerpart unless $upperchunk;
return $headerpart unless index($upperchunk, 'Content-Type:') > -1;

for my $e ( split("\n", $upperchunk) ) {
# Remove fields except Content-Type:, and Content-Transfer-Encoding: in each part
Expand All @@ -181,7 +177,7 @@ sub haircut {
$headerpart->[1] = lc [split(' ', $e, 2)]->[-1];

} elsif( index($e, 'boundary=') > -1 || index($e, 'charset=') > -1 ) {
# Parameters of "Content-Type" field: boundary="...", charset="utf-8"
# "Content-Type" field has boundary="..." or charset="utf-8"
next unless length $headerpart->[0];
$headerpart->[0] .= " ".$e;
$headerpart->[0] =~ s/\s\s+/ /g;
Expand Down Expand Up @@ -233,8 +229,8 @@ sub levelout {
return [] unless length $$argv1;

my $boundary00 = __PACKAGE__->ctvalue($argv0, 'boundary') || return [];
my $boundary01 = sprintf("--%s\n", $boundary00);
my $multiparts = [split(/\Q$boundary01\E/, $$argv1)];
my $boundary01 = sprintf("--%s", $boundary00);
my $multiparts = [split(/\Q$boundary01\E\n/, $$argv1)];
my $partstable = [];

# Remove empty or useless preamble and epilogue of multipart/* block
Expand Down Expand Up @@ -279,27 +275,27 @@ sub makeflat {
# Make flat multipart/* part blocks and decode
# @param [String] argv0 The value of Content-Type header
# @param [String] argv1 A pointer to multipart/* message blocks
# @return [String] Decoded message body
# @return [String] Message body
my $class = shift;
my $argv0 = shift // return undef;
my $argv1 = shift // return undef;

return \'' unless index($argv0, 'multipart/') > -1;
return \'' unless index($argv0, 'boundary=') > -1;

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

my $iso2022set = qr/charset=["']?(iso-2022-[-a-z0-9]+)['"]?\b/;
my $multiparts = __PACKAGE__->levelout($argv0, $argv1);
my $flattenout = '';

for my $e ( @$multiparts ) {
while( my $e = shift @$multiparts ) {
# Pick only the following parts Sisimai::Lhost will use, and decode each part
# - text/plain, text/rfc822-headers
# - message/delivery-status, message/rfc822, message/partial, message/feedback-report
Expand All @@ -310,7 +306,7 @@ sub makeflat {
if( $ctypevalue eq 'text/html' ) {
# Skip text/html part when the value of Content-Type: header in an internal part of
# multipart/* includes multipart/alternative;
next if index($e, 'multipart/alternative') > -1;
next if index($argv1, 'multipart/alternative') > -1;
$istexthtml = 1;
}
my $ctencoding = $e->{'head'}->{'content-transfer-encoding'} || '';
Expand Down Expand Up @@ -361,7 +357,7 @@ sub makeflat {
$bodystring = sprintf("Content-Type: %s\n%s", $ctypevalue, $bodystring);
}
# Append "\n" when the last character of $bodystring is not LF
$bodystring .= "\n\n" unless substr($bodystring, -1, 2) eq "\n\n";
$bodystring .= "\n\n" unless substr($bodystring, -2, 2) eq "\n\n";
$flattenout .= $bodystring;
}
return \$flattenout;
Expand Down
43 changes: 9 additions & 34 deletions t/011-rfc2047.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,43 +79,18 @@ MAKE_TEST: {

QPRINTD: {
# Part of Quoted-Printable
my $q7 = '
--971a94f0830fce8d511b5f45b46e17c7
Content-Type: text/plain; charset="UTF-8"
Content-Transfer-Encoding: quoted-printable
This is the mail delivery agent at messagelabs.com.
I was unable to deliver your message to the following addresses:
maria@dest.example.net
Reason: 550 maria@dest.example.net... No such user
The message subject was: Re: BOAS FESTAS!
The message date was: Tue, 23 Dec 2014 20:39:24 +0000
The message identifier was: DB/3F-17375-60D39495
The message reference was: server-5.tower-143.messagelabs.com!1419367172!32=
691968!1
Please do not reply to this email as it is sent from an unattended mailbox.
Please visit www.messagelabs.com/support for more details
about this error message and instructions to resolve this issue.
my $q7 = 'I will be traveling for work on July 10-31. During that time I will have i=
ntermittent access to email and phone, and I will respond to your message a=
s promptly as possible.
--971a94f0830fce8d511b5f45b46e17c7
Content-Type: message/delivery-status
Reporting-MTA: dns; server-15.bemta-3.messagelabs.com
Arrival-Date: Tue, 23 Dec 2014 20:39:34 +0000
--971a94f0830fce8d511b5f45b46e17c7--
';
Please contact our Client Service Support Team (information below) if you n=
eed immediate assistance on regular account matters, or contact my colleagu=
e Neko Nyaan (neko@example.org; +0-000-000-0000) for all other needs.
';
my $v7 = ${ $PackageName->qprintd(\$q7) };
ok length $v7, '->qprintd($a)';
ok length($q7) > length($v7), '->qprintd($a)';
like $v7, qr|\Q--971a94f0830fce8d511b5f45b46e17c7\E|m, '->qprintd(boundary)';
unlike $v7, qr|32=$|m, '->qprintd() does not match 32=';
unlike $v7, qr|a=$|m, '->qprintd() does not match a=';

my $q8 = 'neko';
is $q8, ${ $PackageName->qprintd(\$q8) };
Expand Down Expand Up @@ -202,7 +177,7 @@ Content-Type: message/delivery-status
Reporting-MTA: dns; server-15.bemta-3.messagelabs.com
Arrival-Date: Tue, 23 Dec 2014 20:39:34 +0000
';
';
my $v1 = $PackageName->levelout($ct, \$mp);
isa_ok $v1, 'ARRAY';
is scalar @$v1, 2;
Expand Down

0 comments on commit 223b35e

Please sign in to comment.