From 9d5fea2e415bc9374d0152349a9ac6a0e1fca027 Mon Sep 17 00:00:00 2001
From: Jesse Luehrs <doy@tozt.net>
Date: Wed, 7 Mar 2012 18:56:40 -0600
Subject: initial implementation

---
 lib/Email/MIME/Header/Encode.pm | 136 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 136 insertions(+)

(limited to 'lib')

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;
-- 
cgit v1.2.3-54-g00ecf