From 5e53fd5a8df3855918e8153d4979b9d8862dfc5f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 26 Aug 2026 18:45:21 +0200 Subject: [PATCH] fix: autoload RFC 2047 MIME header codec Register Encode::MIME::Header when MIME-Header is requested so Email::MIME can decode encoded display names without explicitly loading the codec. Closes #1141 Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- docs/about/changelog.md | 1 + src/main/perl/lib/Encode.pm | 7 ++ src/main/perl/lib/Encode/MIME/Header.pm | 87 +++++++++++++++++++ .../unit/encode_mime_header_autoload.t | 22 +++++ 4 files changed, 117 insertions(+) create mode 100644 src/main/perl/lib/Encode/MIME/Header.pm create mode 100644 src/test/resources/unit/encode_mime_header_autoload.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index feb86a0b50..aa3560c24d 100644 --- a/docs/about/changelog.md +++ b/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`. diff --git a/src/main/perl/lib/Encode.pm b/src/main/perl/lib/Encode.pm index 1558fee88c..5cb6173294 100644 --- a/src/main/perl/lib/Encode.pm +++ b/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; diff --git a/src/main/perl/lib/Encode/MIME/Header.pm b/src/main/perl/lib/Encode/MIME/Header.pm new file mode 100644 index 0000000000..875c6f752d --- /dev/null +++ b/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; diff --git a/src/test/resources/unit/encode_mime_header_autoload.t b/src/test/resources/unit/encode_mime_header_autoload.t new file mode 100644 index 0000000000..690f9a5810 --- /dev/null +++ b/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==?= '), + 'Döy ', + '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;