From 9d5fea2e415bc9374d0152349a9ac6a0e1fca027 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Wed, 7 Mar 2012 18:56:40 -0600 Subject: initial implementation --- lib/Email/MIME/Header/Encode.pm | 136 ++++++++++++++++++++++++++++++++++++++++ t/basic.t | 53 ++++++++++++++++ 2 files changed, 189 insertions(+) create mode 100644 t/basic.t diff --git a/lib/Email/MIME/Header/Encode.pm b/lib/Email/MIME/Header/Encode.pm index e69de29..8349c66 100644 --- a/lib/Email/MIME/Header/Encode.pm +++ b/lib/Email/MIME/Header/Encode.pm @@ -0,0 +1,136 @@ +package Email::MIME::Header::Encode; +use strict; +use warnings; + +use Email::Address; +use Encode (); +use MIME::Base64(); + +use Sub::Exporter -setup => { + exports => [ 'mime_encode_header' ], +}; + +my %encoders = ( + 'Date' => \&_date_time_encode, + 'From' => \&_mailbox_list_encode, + 'Sender' => \&_mailbox_encode, + 'Reply-To' => \&_address_list_encode, + 'To' => \&_address_list_encode, + 'Cc' => \&_address_list_encode, + 'Bcc' => \&_address_list_encode, + 'Message-ID' => \&_msg_id_encode, + 'In-Reply-To' => \&_msg_id_encode, + 'References' => \&_msg_id_encode, + 'Subject' => \&_unstructured_encode, + 'Comments' => \&_unstructured_encode, +); + +sub mime_encode_header { + my ($header, $body, $charset, $encoding) = @_; + + return $body unless $body =~ /\P{ASCII}/ + || $body =~ /=\?/; + + $header =~ s/^Resent-//; + + return $encoders{$header}->($body, $charset, $encoding) + if exists $encoders{$header}; + + return _unstructured_encode($body, $charset, $encoding); +} + +sub _date_time_encode { + my ($val, $charset, $encoding) = @_; + return $val; +} + +sub _mailbox_encode { + my ($val, $charset, $encoding) = @_; + return _mailbox_list_encode($val, $charset); +} + +sub _mailbox_list_encode { + my ($val, $charset, $encoding) = @_; + my @addrs = Email::Address->parse($val); + + @addrs = map { + my $phrase = $_->phrase; + $_->phrase(_mime_encode($phrase, $charset, $encoding)) + if $phrase =~ /\P{ASCII}/; + my $comment = $_->comment; + $_->comment(_mime_encode($comment, $charset, $encoding)) + if $comment =~ /\P{ASCII}/; + $_; + } @addrs; + + return join(', ', map { $_->format } @addrs); +} + +sub _address_encode { + my ($val, $charset, $encoding) = @_; + return _address_list_encode($val, $charset, $encoding); +} + +sub _address_list_encode { + my ($val, $charset, $encoding) = @_; + return _mailbox_list_encode($val, $charset, $encoding); # XXX is this right? +} + +sub _msg_id_encode { + my ($val, $charset, $encoding) = @_; + return $val; +} + +sub _unstructured_encode { + my ($val, $charset, $encoding) = @_; + return _mime_encode($val, $charset, $encoding); +} + +sub _mime_encode { + my ($val, $charset, $encoding) = @_; + + $encoding = $encoding || 'base64'; + + if ($encoding eq 'base64') { + return _mime_encode_base64($val, $charset); + } + else { + # TODO: write an encoder for quoted-printable? the tricky part there is + # the folding whitespace + die "Encoding $encoding is not supported"; + } +} + +sub _mime_encode_base64 { + my $text = shift; + my $charset = Encode::find_encoding(shift)->mime_name(); + + my $head = '=?' . $charset . '?B?'; + my $tail = '?='; + + my $base_length = 75 - ( length($head) + length($tail) ); + + # This code is copied from Mail::Message::Field::Full in the Mail-Box + # distro. + my $real_length = int( $base_length / 4 ) * 3; + + my @result; + my $chunk = q{}; + while ( length( my $chr = substr( $text, 0, 1, '' ) ) ) { + my $chr = Encode::encode( $charset, $chr, 0 ); + + if ( length($chunk) + length($chr) > $real_length ) { + push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail; + $chunk = q{}; + } + + $chunk .= $chr; + } + + push @result, $head . MIME::Base64::encode_base64( $chunk, q{} ) . $tail + if length $chunk; + + return join q{ }, @result; +} + +1; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..5f28ffd --- /dev/null +++ b/t/basic.t @@ -0,0 +1,53 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use utf8; + +use Email::MIME::Header::Encode 'mime_encode_header'; + +is(mime_encode_header('Date', 'Wed, 7 Mar 2012 23:00:10 +0100', 'utf8'), + 'Wed, 7 Mar 2012 23:00:10 +0100', + "Date encoded correctly"); + +for my $header (qw(From Sender Reply-To To Cc Bcc)) { + is(mime_encode_header($header, 'Ævar Arnfjörð Bjarmason ', 'utf8'), + '=?UTF-8?B?w4Z2YXIgQXJuZmrDtnLDsCBCamFybWFzb24=?= ', + "$header encoded correctly"); + is(mime_encode_header($header, 'Ricardo Signes ', 'utf8'), + 'Ricardo Signes ', + "$header encoded correctly"); + is(mime_encode_header($header, 'Ævar Arnfjörð Bjarmason , "Ricardo Signes" ', 'utf8'), + '=?UTF-8?B?w4Z2YXIgQXJuZmrDtnLDsCBCamFybWFzb24=?= , "Ricardo Signes" ', + "$header encoded correctly"); +} + +for my $header (qw(Message-ID In-Reply-To References)) { + is(mime_encode_header($header, '', 'utf8'), + '', + "$header encoded correctly"); + is(mime_encode_header($header, '', 'utf8'), + '', + "$header encoded correctly"); +} + +for my $header (qw(Subject Comments X-NonStandard)) { + is(mime_encode_header($header, 'Ricardo', 'utf8'), + 'Ricardo', + "$header encoded correctly"); + is(mime_encode_header($header, 'Julián', 'utf8'), + '=?UTF-8?B?SnVsacOhbg==?=', + "$header encoded correctly"); + is(mime_encode_header($header, '=?UTF-8?B?SnVsacOhbg==?=', 'utf8'), + '=?UTF-8?B?PT9VVEYtOD9CP1NuVnNhY09oYmc9PT89?=', + "$header encoded correctly"); + is(mime_encode_header($header, 'test test test test test test test test tést te (12 34)', 'utf8'), + '=?UTF-8?B?dGVzdCB0ZXN0IHRlc3QgdGVzdCB0ZXN0IHRlc3QgdGVzdCB0ZXN0IHTDqXN0?= =?UTF-8?B?IHRlICgxMiAzNCk=?=', + "$header encoded correctly"); + is(mime_encode_header($header, 'test test test test test test test test test te (12 34)', 'utf8'), + 'test test test test test test test test test te (12 34)', + "$header encoded correctly"); +} + +done_testing; -- cgit v1.2.3