1 package Encode::MIME::Header;
4 our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
6 use Encode qw(find_encoding encode_utf8);
12 decode_b => '1', # decodes 'B' encoding ?
13 decode_q => '1', # decodes 'Q' encoding ?
14 encode => 'B', # encode with 'B' or 'Q' ?
15 bpl => 75, # bytes per line
18 $Encode::Encoding{'MIME-Header'} =
21 Name => 'MIME-Header',
24 $Encode::Encoding{'MIME-B'} =
31 $Encode::Encoding{'MIME-Q'} =
39 sub name { shift->{'Name'} }
40 sub new_sequence { $_[0] }
46 my ($obj, $str, $chk) = @_;
47 # zap spaces between encoded words
48 $str =~ s/\?=\s+=\?/\?==\?/gos;
49 # multi-line header to single line
50 $str =~ s/(:?\r|\n|\r\n)[ \t]//gos;
53 =\? # begin encoded word
54 ([0-9A-Za-z\-]+) # charset (encoding)
55 \?([QqBb])\? # delimiter
56 (.*?) # Base64-encodede contents
57 \?= # end encoded word
60 $obj->{decode_b} or croak qq(MIME "B" unsupported);
62 }elsif(uc($2) eq 'Q'){
63 $obj->{decode_q} or croak qq(MIME "Q" unsupported);
66 croak qq(MIME "$2" encoding is nonexistent!);
75 my $d = find_encoding($enc) or croak(Unknown encoding "$enc");
76 my $db64 = decode_base64(shift);
77 return $d->decode($db64, Encode::FB_PERLQQ);
82 my $d = find_encoding($enc) or croak(Unknown encoding "$enc");
84 $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego;
85 return $d->decode($q, Encode::FB_PERLQQ);
90 map {quotemeta(chr($_))}
91 unpack("C*", qq{()<>@,;:\"\'/[]?.=}));
93 my $re_especials = qr/$especials/o;
96 my ($obj, $str, $chk) = @_;
98 for my $line (split /\r|\n|\r\n/o, $str){
100 for my $word (split /($re_especials)/o, $line){
101 if ($word =~ /[^\x00-\x7f]/o){
102 push @word, $obj->_encode($word);
108 for my $word (@word){
110 if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){
111 push @subline, $subline;
116 $subline and push @subline, $subline;
117 push @line, join("\n " => @subline);
120 return join("\n", @line);
123 use constant HEAD => '=?UTF-8?';
124 use constant TAIL => '?=';
125 use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, };
129 my $enc = $o->{encode};
130 my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL));
131 $llen *= $enc eq 'B' ? 3/4 : 1/3;
134 while(my $chr = substr($str, 0, 1, '')){
136 if (bytes::length($chunk) + bytes::length($chr) > $llen){
137 push @result, SINGLE->{$enc}($chunk);
142 $chunk and push @result, SINGLE->{$enc}($chunk);
147 HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL;
155 join("" => map {sprintf "=%02X", $_} unpack("C*", $1))
157 return HEAD . 'Q?' . $chunk . TAIL;
165 Encode::MIME::Header -- MIME 'B' and 'Q' header encoding
169 use Encode qw/encode decode/;
170 $utf8 = decode('MIME-Header', $header);
171 $header = encode('MIME-Header', $utf8);
175 This module implements RFC 2047 Mime Header Encoding. There are 3
176 variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The
177 difference is described below
180 ----------------------------------------------
181 MIME-Header Both B and Q =?UTF-8?B?....?=
182 MIME-B B only; Q croaks =?UTF-8?B?....?=
183 MIME-Q Q only; B croaks =?UTF-8?Q?....?=
187 When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD>
188 is extracted and decoded for I<X> encoding (B for Base64, Q for
189 Quoted-Printable). Then the decoded chunk is fed to
190 decode(I<encoding>). So long as I<encoding> is supported by Encode,
191 any source encoding is fine.
193 When you encode, it just encodes UTF-8 string with I<X> encoding then
194 quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to
195 encode are left as is and long lines are folded within 76 bytes per
200 It would be nice to support non-UTF8 encoding, such as =?ISO-2022-JP?
201 and =?ISO-8859-1?= but that makes the implementation too complicated.
202 These days major mail agents all support =?UTF-8? so I think it is
209 RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other