fix: decode RFC 2047 Email::MIME headers

docs/about/changelog.md

@@ -8,6 +8,7 @@ Release history of PerlOnJava. See [Roadmap](roadmap.md) for future plans.
 - Fix IO-handle type checks and uninitialized-value warning locations.
 - Fix numeric-zero results from failed `s///` substitutions.
 - Preserve references in `utf8::downgrade`.
+- Fix RFC 2047 header decoding for Email::MIME.
 - Bundle the complete CPAN `File::Path` 2.18 implementation, including modern
   `rmtree`/`remove_tree` options such as `keep_root`, `error`, `result`,
   `safe`, and `verbose`.

src/main/perl/lib/Encode.pm

@@ -72,6 +72,13 @@ XSLoader::load('Encode', $VERSION);
         my $key = lc $name;
         return $_encoding_cache{$key} if exists $_encoding_cache{$key};
 
+        # Perl's Encode lazily loads the RFC 2047 codecs when one of their
+        # registered names is requested.  Email::MIME relies on this through
+        # Encode::decode('MIME-Header', ...) without loading the codec itself.
+        if ($key =~ /\Amime-(?:header|b|q)\z/) {
+            return undef unless eval { require Encode::MIME::Header; 1 };
+        }
+
         if ($key eq 'locale') {
             my $enc = $_cached_java_find_encoding->('UTF-8');
             $_encoding_cache{$key} = $enc if defined $enc;

src/main/perl/lib/Encode/MIME/Header.pm

@@ -0,0 +1,87 @@
+package Encode::MIME::Header;
+use strict;
+use warnings;
+
+use Encode ();
+use MIME::Base64 ();
+
+our $VERSION = '2.28';
+our @ISA = qw(Encode::Encoding);
+
+my %defaults = (
+    decode_b => 1,
+    decode_q => 1,
+    encode   => 'B',
+    charset  => 'UTF-8',
+    bpl      => 75,
+);
+
+my @encodings = (
+    bless({ %defaults, Name => 'MIME-Header' }, __PACKAGE__),
+    bless({ %defaults, Name => 'MIME-B', decode_q => 0 }, __PACKAGE__),
+    bless({ %defaults, Name => 'MIME-Q', decode_b => 0, encode => 'Q' }, __PACKAGE__),
+);
+
+Encode::define_encoding($_, $_->{Name}) for @encodings;
+
+sub needs_lines { 1 }
+sub perlio_ok   { 0 }
+
+sub decode {
+    my ($self, $text, $check) = @_;
+    return undef unless defined $text;
+
+    # RFC 2047 says linear whitespace between adjacent encoded words is not
+    # displayed.  Normalize it before decoding the individual words.
+    $text =~ s{(=\?[^?\s]+\?[BbQq]\?[^?]*\?=)(?:[ \t\r\n]+)(?==\?)}{$1}g;
+
+    $text =~ s{
+        (=\?([^?\s]+)(?:\*[A-Za-z0-9-]+)?\?([BbQq])\?([^?]*)\?=)
+    }{
+        _decode_word($self, $1, $2, $3, $4, $check)
+    }egx;
+
+    return $text;
+}
+
+sub _decode_word {
+    my ($self, $original, $charset, $kind, $payload, $check) = @_;
+    return $original if uc($kind) eq 'B' && !$self->{decode_b};
+    return $original if uc($kind) eq 'Q' && !$self->{decode_q};
+
+    my $encoding = Encode::find_mime_encoding($charset)
+        || Encode::find_encoding($charset);
+    return $original unless defined $encoding;
+
+    my $octets;
+    if (uc($kind) eq 'B') {
+        $octets = MIME::Base64::decode($payload);
+    } else {
+        ($octets = $payload) =~ tr/_/ /;
+        $octets =~ s/=([0-9A-Fa-f]{2})/pack('C', hex($1))/eg;
+    }
+
+    my $decoded = eval { $encoding->decode($octets, $check || 0) };
+    return defined $decoded ? $decoded : $original;
+}
+
+sub encode {
+    my ($self, $text, $check) = @_;
+    return undef unless defined $text;
+
+    my $encoding = Encode::find_mime_encoding($self->{charset})
+        || Encode::find_encoding($self->{charset});
+    return $text unless defined $encoding;
+
+    my $octets = $encoding->encode($text, $check || 0);
+    if ($self->{encode} eq 'Q') {
+        $octets =~ s/([^A-Za-z0-9!*+\/-])/sprintf('=%02X', ord($1))/eg;
+        $octets =~ tr/ /_/;
+        return '=?' . $encoding->mime_name . '?Q?' . $octets . '?=';
+    }
+
+    return '=?' . $encoding->mime_name . '?B?'
+        . MIME::Base64::encode_base64($octets, '') . '?=';
+}
+
+1;

src/test/resources/unit/encode_mime_header_autoload.t

@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+use Test::More;
+use Encode qw(decode find_encoding);
+use utf8;
+
+my $codec = find_encoding('MIME-Header');
+ok(defined $codec, 'MIME-Header codec is autoloaded by find_encoding');
+
+is(
+    decode('MIME-Header', '=?UTF-8?B?RMO2eQ==?= <test@example.com>'),
+    'Döy <test@example.com>',
+    'decodes a UTF-8 base64 encoded display name',
+);
+
+is(
+    decode('MIME-Header', '=?ISO-8859-1?Q?Andr=E9?= =?UTF-8?B?IM6gzrXPgc6zzr8=?='),
+    'André Περγο',
+    'decodes adjacent quoted-printable and base64 encoded words',
+);
+
+done_testing;