1N/Apackage Encode::MIME::Header;
1N/Ause strict;
1N/A# use warnings;
1N/Aour $VERSION = do { my @r = (q$Revision: 1.9 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
1N/Ause Encode qw(find_encoding encode_utf8 decode_utf8);
1N/Ause MIME::Base64;
1N/Ause Carp;
1N/A
1N/Amy %seed =
1N/A (
1N/A decode_b => '1', # decodes 'B' encoding ?
1N/A decode_q => '1', # decodes 'Q' encoding ?
1N/A encode => 'B', # encode with 'B' or 'Q' ?
1N/A bpl => 75, # bytes per line
1N/A );
1N/A
1N/A$Encode::Encoding{'MIME-Header'} =
1N/A bless {
1N/A %seed,
1N/A Name => 'MIME-Header',
1N/A } => __PACKAGE__;
1N/A
1N/A$Encode::Encoding{'MIME-B'} =
1N/A bless {
1N/A %seed,
1N/A decode_q => 0,
1N/A Name => 'MIME-B',
1N/A } => __PACKAGE__;
1N/A
1N/A$Encode::Encoding{'MIME-Q'} =
1N/A bless {
1N/A %seed,
1N/A decode_q => 1,
1N/A encode => 'Q',
1N/A Name => 'MIME-Q',
1N/A } => __PACKAGE__;
1N/A
1N/Ause base qw(Encode::Encoding);
1N/A
1N/Asub needs_lines { 1 }
1N/Asub perlio_ok{ 0 };
1N/A
1N/Asub decode($$;$){
1N/A use utf8;
1N/A my ($obj, $str, $chk) = @_;
1N/A # zap spaces between encoded words
1N/A $str =~ s/\?=\s+=\?/\?==\?/gos;
1N/A # multi-line header to single line
1N/A $str =~ s/(:?\r|\n|\r\n)[ \t]//gos;
1N/A $str =~
1N/A s{
1N/A =\? # begin encoded word
1N/A ([0-9A-Za-z\-_]+) # charset (encoding)
1N/A \?([QqBb])\? # delimiter
1N/A (.*?) # Base64-encodede contents
1N/A \?= # end encoded word
1N/A }{
1N/A if (uc($2) eq 'B'){
1N/A $obj->{decode_b} or croak qq(MIME "B" unsupported);
1N/A decode_b($1, $3);
1N/A }elsif(uc($2) eq 'Q'){
1N/A $obj->{decode_q} or croak qq(MIME "Q" unsupported);
1N/A decode_q($1, $3);
1N/A }else{
1N/A croak qq(MIME "$2" encoding is nonexistent!);
1N/A }
1N/A }egox;
1N/A $_[1] = '' if $chk;
1N/A return $str;
1N/A}
1N/A
1N/Asub decode_b{
1N/A my $enc = shift;
1N/A my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
1N/A my $db64 = decode_base64(shift);
1N/A return $d->name eq 'utf8' ?
1N/A Encode::decode_utf8($db64) : $d->decode($db64, Encode::FB_PERLQQ);
1N/A}
1N/A
1N/Asub decode_q{
1N/A my ($enc, $q) = @_;
1N/A my $d = find_encoding($enc) or croak qq(Unknown encoding "$enc");
1N/A $q =~ s/_/ /go;
1N/A $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego;
1N/A return $d->name eq 'utf8' ?
1N/A Encode::decode_utf8($q) : $d->decode($q, Encode::FB_PERLQQ);
1N/A}
1N/A
1N/Amy $especials =
1N/A join('|' =>
1N/A map {quotemeta(chr($_))}
1N/A unpack("C*", qq{()<>@,;:\"\'/[]?.=}));
1N/A
1N/Amy $re_encoded_word =
1N/A qr{
1N/A (?:
1N/A =\? # begin encoded word
1N/A (?:[0-9A-Za-z\-_]+) # charset (encoding)
1N/A \?(?:[QqBb])\? # delimiter
1N/A (?:.*?) # Base64-encodede contents
1N/A \?= # end encoded word
1N/A )
1N/A }xo;
1N/A
1N/Amy $re_especials = qr{$re_encoded_word|$especials}xo;
1N/A
1N/Asub encode($$;$){
1N/A my ($obj, $str, $chk) = @_;
1N/A my @line = ();
1N/A for my $line (split /\r|\n|\r\n/o, $str){
1N/A my (@word, @subline);
1N/A for my $word (split /($re_especials)/o, $line){
1N/A if ($word =~ /[^\x00-\x7f]/o or $word =~ /^$re_encoded_word$/o){
1N/A push @word, $obj->_encode($word);
1N/A }else{
1N/A push @word, $word;
1N/A }
1N/A }
1N/A my $subline = '';
1N/A for my $word (@word){
1N/A use bytes ();
1N/A if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){
1N/A push @subline, $subline;
1N/A $subline = '';
1N/A }
1N/A $subline .= $word;
1N/A }
1N/A $subline and push @subline, $subline;
1N/A push @line, join("\n " => @subline);
1N/A }
1N/A $_[1] = '' if $chk;
1N/A return join("\n", @line);
1N/A}
1N/A
1N/Ause constant HEAD => '=?UTF-8?';
1N/Ause constant TAIL => '?=';
1N/Ause constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, };
1N/A
1N/Asub _encode{
1N/A my ($o, $str) = @_;
1N/A my $enc = $o->{encode};
1N/A my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL));
1N/A # to coerce a floating-point arithmetics, the following contains
1N/A # .0 in numbers -- dankogai
1N/A $llen *= $enc eq 'B' ? 3.0/4.0 : 1.0/3.0;
1N/A my @result = ();
1N/A my $chunk = '';
1N/A while(length(my $chr = substr($str, 0, 1, ''))){
1N/A use bytes ();
1N/A if (bytes::length($chunk) + bytes::length($chr) > $llen){
1N/A push @result, SINGLE->{$enc}($chunk);
1N/A $chunk = '';
1N/A }
1N/A $chunk .= $chr;
1N/A }
1N/A $chunk and push @result, SINGLE->{$enc}($chunk);
1N/A return @result;
1N/A}
1N/A
1N/Asub _encode_b{
1N/A HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL;
1N/A}
1N/A
1N/Asub _encode_q{
1N/A my $chunk = shift;
1N/A $chunk =~ s{
1N/A ([^0-9A-Za-z])
1N/A }{
1N/A join("" => map {sprintf "=%02X", $_} unpack("C*", $1))
1N/A }egox;
1N/A return decode_utf8(HEAD . 'Q?' . $chunk . TAIL);
1N/A}
1N/A
1N/A1;
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/AEncode::MIME::Header -- MIME 'B' and 'Q' header encoding
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A use Encode qw/encode decode/;
1N/A $utf8 = decode('MIME-Header', $header);
1N/A $header = encode('MIME-Header', $utf8);
1N/A
1N/A=head1 ABSTRACT
1N/A
1N/AThis module implements RFC 2047 Mime Header Encoding. There are 3
1N/Avariant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The
1N/Adifference is described below
1N/A
1N/A decode() encode()
1N/A ----------------------------------------------
1N/A MIME-Header Both B and Q =?UTF-8?B?....?=
1N/A MIME-B B only; Q croaks =?UTF-8?B?....?=
1N/A MIME-Q Q only; B croaks =?UTF-8?Q?....?=
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/AWhen you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD>
1N/Ais extracted and decoded for I<X> encoding (B for Base64, Q for
1N/AQuoted-Printable). Then the decoded chunk is fed to
1N/Adecode(I<encoding>). So long as I<encoding> is supported by Encode,
1N/Aany source encoding is fine.
1N/A
1N/AWhen you encode, it just encodes UTF-8 string with I<X> encoding then
1N/Aquoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to
1N/Aencode are left as is and long lines are folded within 76 bytes per
1N/Aline.
1N/A
1N/A=head1 BUGS
1N/A
1N/AIt would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP?
1N/Aand =?ISO-8859-1?= but that makes the implementation too complicated.
1N/AThese days major mail agents all support =?UTF-8? so I think it is
1N/Ajust good enough.
1N/A
1N/A=head1 SEE ALSO
1N/A
1N/AL<Encode>
1N/A
1N/ARFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other
1N/Alocations.
1N/A
1N/A=cut