Message/MIME/EncodedWord.pm


=head1 NAME

Message::MIME::EncodedWord Perl module

=head1 DESCRIPTION

Perl module for MIME C<encoded-word>.

=cut

package Message::MIME::EncodedWord;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%ENCODER %DECODER %OPTION %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::MIME::Charset;

$REG{WSP} = qr/[\x09\x20]/;
$REG{FWS} = qr/[\x09\x20]*/;
$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;

$REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;
$REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;

=head1 OPTIONS

=cut

%OPTION = (
        forcedecode     => 0,
);

=over 4

=item $Message::MIME::EncodedWord::OPTION{forcedecode} = 1/0

When no charset decoder (See L<Message::MIME::Charset>)
for C<ISO-8859-I<n>> is defined, and this option is TRUE, 
decoding C<encoded-word> functions attempt to decode
ASCII part of these charset.

RFC 2047 says that ASCII part of C<ISO-8859-I<n>> be at least
supported.  This requirement is convinience for human user who 
sees final rendering result.  But it is not appropriate to process message.

Defalt value is C<0>, force decoding is disenabled.

=back

=head2 Note

Before you set new value for these options,
C<Message::MIME::EncodedWord> should be loaded (C<require>ed).
Other modules which use C<Message::MIME::EncodedWord>
will automatically require this module, and this module
will set initial (default) option value.

Bad example:

  #! perl
  $Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
  use Message::Field::Subject;
  my $subject = Message::Field::Subject->parse ($ARGV[0]);
        ## At this time, M::F::Subject call M::M::EWord,
        ## and $OPTION{forcedecode} is set C<1>, default value.

Shold be:

  #! perl
  require Message::MIME::EncodedWord;
  $Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
  use Message::Field::Subject;
  my $subject = Message::Field::Subject->parse ($ARGV[0]);
        ## At this time, M::F::Subject call M::M::EWord,
        ## but perl takes no action since it has already loaded.

=cut

%DECODER = (
  '*DEFAULT'    => sub { $_[1] },
  '7'   => sub { $_[1] },
  b     => sub {require MIME::Base64; MIME::Base64::decode ($_[1])},
  q     => sub {my $s = $_[1]; $s =~ tr/_/\x20/; 
    $s=~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ge; $s},
);

sub decode ($) {
  my $s = shift;
  my (@s, @r) = ();
  $s =~ s{\G([\x09\x20]*[^\x09\x20]+)}{push @s, $1}goex;
  for my $i (0..$#s) {
    $r[$i] = 0;
    if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
      my ($t, $w) = ('', $1);
      ($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
      if ($r[$i]) {
        $s[$i] = $t;
        if ($i == 0 || $r[$i-1] == 0) {
          $s[$i] = $w.$s[$i];
        }
      }
    }
  }
  join '', @s;
}

sub decode_ccontent ($$) {
  my $yourself = shift;  my $s = shift;
  my (@s, @r) = ();
  my ($i, @t) = (-1);
  $s =~ s{$REG{FWS}$REG{comment}}{$i++; $t[$i] = $&; "\x28${i}\x29"}gex;
  $s =~ s{($REG{FWS}(?:\x5C[\x00-\xFF]
                     |[\x00-\x08\x0A-\x1F\x21-\x27\x2A-\x5B\x5D-\xFF])+)
         |(\x28[0-9]+\x29)}{my ($t,$c) = ($1, $2);
     if ($t) {$i++; $t[$i] = $t; "\x28${i}\x29"}
     else {$c}}gex;
  $s =~ s{\x28([0-9]+)\x29}{push @s, $t[$1]; ''}gex;
  push @s, $s if length $s;
  for my $i (0..$#s) {
    if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
      my ($t, $w) = ('', $1);
      ($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
      if ($r[$i]) {
        $s[$i] = $t;
        if ($i == 0 || $r[$i-1] == 0) {
          $s[$i] = $w.$s[$i];
        }
      }
    } elsif ($s[$i] =~ /^($REG{FWS})$REG{M_comment}$/) {
      $s[$i] = $1.'('.&decode_ccontent ($2, $yourself).')';
    } else {
      $s[$i] =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $s[$i],
                type => 'ccontent/quoted');
      $s[$i] = $s{value};
    }
  }
  join '', @s;
}

sub _decode_eword ($$$$) {
  my ($charset, $lang, $encoding, $etext) = (shift, shift, lc shift, shift);
  $charset = Message::MIME::Charset::name_normalize ($charset);
  my ($r,$s) = ('', 0);
  if (ref $DECODER{$encoding}) {        ## decode TE
    $r = &{$DECODER{$encoding}} ($encoding, $etext);
    ($r,$s) = Message::MIME::Charset::decode ($charset, $r);
    if (!$s && $OPTION{forcedecode} && $charset =~ /^iso-8859-([0-9]+(?:-[ie])?)$/) {
      my $n = $1;
      $r =~ s{([\x09\x0A\x0D\x20]*[\x80-\xFF]+[\x09\x0A\x0D\x20]*)}{
        my $t = $1;
        $t =~ s/([\x09\x0A\x0D\x80-\xFF])/sprintf('=%02X', ord $1)/ge;
        $t =~ tr/\x20/_/;
        sprintf ' =?iso-8859-%s?q?%s?= ', $n.($lang?'*'.$lang:''), $t;
      }goex;
      $s = 1;
    }
  }
  ($r, $s);
}


=head1 LICENSE

Copyright 2002 wakaba E<lt>[email protected]<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/06/09 11:13:14 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::MIME::EncodedWord Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for MIME C<encoded-word>.
9
10			=cut
11
12			package Message::MIME::EncodedWord;
13	wakaba	1.3	require 5.6.0;
14	wakaba	1.1	use strict;
15	wakaba	1.3	use re 'eval';
16	wakaba	1.4	use vars qw(%ENCODER %DECODER %OPTION %REG $VERSION);
17	wakaba	1.8	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18	wakaba	1.1	require Message::MIME::Charset;
19
20			$REG{WSP} = qr/[\x09\x20]/;
21			$REG{FWS} = qr/[\x09\x20]*/;
22	wakaba	1.3	$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
23	wakaba	1.1
24			$REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
25			$REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
26	wakaba	1.3	$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*)\x29/;
27	wakaba	1.1	$REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
28			$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
29
30	wakaba	1.4	=head1 OPTIONS
31
32			=cut
33
34			%OPTION = (
35	wakaba	1.6	forcedecode => 0,
36	wakaba	1.4	);
37
38			=over 4
39
40			=item $Message::MIME::EncodedWord::OPTION{forcedecode} = 1/0
41
42			When no charset decoder (See L<Message::MIME::Charset>)
43			for C<ISO-8859-I<n>> is defined, and this option is TRUE,
44			decoding C<encoded-word> functions attempt to decode
45			ASCII part of these charset.
46
47	wakaba	1.7	RFC 2047 says that ASCII part of C<ISO-8859-I<n>> be at least
48			supported. This requirement is convinience for human user who
49			sees final rendering result. But it is not appropriate to process message.
50	wakaba	1.4
51	wakaba	1.7	Defalt value is C<0>, force decoding is disenabled.
52	wakaba	1.4
53			=back
54
55			=head2 Note
56
57			Before you set new value for these options,
58			C<Message::MIME::EncodedWord> should be loaded (C<require>ed).
59			Other modules which use C<Message::MIME::EncodedWord>
60			will automatically require this module, and this module
61			will set initial (default) option value.
62
63			Bad example:
64
65			#! perl
66			$Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
67			use Message::Field::Subject;
68			my $subject = Message::Field::Subject->parse ($ARGV[0]);
69			## At this time, M::F::Subject call M::M::EWord,
70			## and $OPTION{forcedecode} is set C<1>, default value.
71
72			Shold be:
73
74			#! perl
75			require Message::MIME::EncodedWord;
76			$Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
77			use Message::Field::Subject;
78			my $subject = Message::Field::Subject->parse ($ARGV[0]);
79			## At this time, M::F::Subject call M::M::EWord,
80			## but perl takes no action since it has already loaded.
81
82			=cut
83
84	wakaba	1.1	%DECODER = (
85	wakaba	1.7	'*DEFAULT' => sub { $_[1] },
86			'7' => sub { $_[1] },
87	wakaba	1.1	b => sub {require MIME::Base64; MIME::Base64::decode ($_[1])},
88			q => sub {my $s = $_[1]; $s =~ tr/_/\x20/;
89			$s=~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ge; $s},
90			);
91
92	wakaba	1.3	sub decode ($) {
93			my $s = shift;
94			my (@s, @r) = ();
95			$s =~ s{\G([\x09\x20]*[^\x09\x20]+)}{push @s, $1}goex;
96			for my $i (0..$#s) {
97	wakaba	1.6	$r[$i] = 0;
98	wakaba	1.3	if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
99			my ($t, $w) = ('', $1);
100			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
101	wakaba	1.4	if ($r[$i]) {
102	wakaba	1.3	$s[$i] = $t;
103	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
104	wakaba	1.3	$s[$i] = $w.$s[$i];
105			}
106	wakaba	1.2	}
107	wakaba	1.1	}
108	wakaba	1.3	}
109			join '', @s;
110	wakaba	1.1	}
111
112	wakaba	1.3	sub decode_ccontent ($$) {
113	wakaba	1.8	my $yourself = shift; my $s = shift;
114	wakaba	1.3	my (@s, @r) = ();
115	wakaba	1.5	my ($i, @t) = (-1);
116			$s =~ s{$REG{FWS}$REG{comment}}{$i++; $t[$i] = $&; "\x28${i}\x29"}gex;
117			$s =~ s{($REG{FWS}(?:\x5C[\x00-\xFF]
118	wakaba	1.6	\|[\x00-\x08\x0A-\x1F\x21-\x27\x2A-\x5B\x5D-\xFF])+)
119	wakaba	1.5	\|(\x28[0-9]+\x29)}{my ($t,$c) = ($1, $2);
120			if ($t) {$i++; $t[$i] = $t; "\x28${i}\x29"}
121			else {$c}}gex;
122	wakaba	1.6	$s =~ s{\x28([0-9]+)\x29}{push @s, $t[$1]; ''}gex;
123			push @s, $s if length $s;
124	wakaba	1.3	for my $i (0..$#s) {
125			if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
126			my ($t, $w) = ('', $1);
127			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
128	wakaba	1.4	if ($r[$i]) {
129	wakaba	1.3	$s[$i] = $t;
130	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
131	wakaba	1.3	$s[$i] = $w.$s[$i];
132			}
133			}
134			} elsif ($s[$i] =~ /^($REG{FWS})$REG{M_comment}$/) {
135	wakaba	1.6	$s[$i] = $1.'('.&decode_ccontent ($2, $yourself).')';
136	wakaba	1.3	} else {
137			$s[$i] =~ s/\x5C([\x00-\xFF])/$1/g;
138			my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $s[$i],
139			type => 'ccontent/quoted');
140			$s[$i] = $s{value};
141			}
142			}
143			join '', @s;
144			}
145
146			sub _decode_eword ($$$$) {
147			my ($charset, $lang, $encoding, $etext) = (shift, shift, lc shift, shift);
148			$charset = Message::MIME::Charset::name_normalize ($charset);
149	wakaba	1.4	my ($r,$s) = ('', 0);
150	wakaba	1.6	if (ref $DECODER{$encoding}) { ## decode TE
151	wakaba	1.3	$r = &{$DECODER{$encoding}} ($encoding, $etext);
152			($r,$s) = Message::MIME::Charset::decode ($charset, $r);
153	wakaba	1.4	if (!$s && $OPTION{forcedecode} && $charset =~ /^iso-8859-([0-9]+(?:-[ie])?)$/) {
154	wakaba	1.3	my $n = $1;
155			$r =~ s{([\x09\x0A\x0D\x20][\x80-\xFF]+[\x09\x0A\x0D\x20])}{
156			my $t = $1;
157			$t =~ s/([\x09\x0A\x0D\x80-\xFF])/sprintf('=%02X', ord $1)/ge;
158			$t =~ tr/\x20/_/;
159			sprintf ' =?iso-8859-%s?q?%s?= ', $n.($lang?'*'.$lang:''), $t;
160			}goex;
161			$s = 1;
162			}
163			}
164			($r, $s);
165			}
166
167
168	wakaba	1.1	=head1 LICENSE
169
170			Copyright 2002 wakaba E<lt>[email protected]<gt>.
171
172			This program is free software; you can redistribute it and/or modify
173			it under the terms of the GNU General Public License as published by
174			the Free Software Foundation; either version 2 of the License, or
175			(at your option) any later version.
176
177			This program is distributed in the hope that it will be useful,
178			but WITHOUT ANY WARRANTY; without even the implied warranty of
179			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
180			GNU General Public License for more details.
181
182			You should have received a copy of the GNU General Public License
183			along with this program; see the file COPYING. If not, write to
184			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
185			Boston, MA 02111-1307, USA.
186
187			=head1 CHANGE
188
189			See F<ChangeLog>.
190	wakaba	1.8	$Date: 2002/06/09 11:13:14 $
191	wakaba	1.1
192			=cut
193
194			1;