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.5 $=~/\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 to support ASCII part of C<ISO-8859-I<n>> at least.
This requirement is convinient for human users who see final rendering
result.  But it is not appropriate to process message.

Defalt value is C<1>, force decoding is enabled.

=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]},
  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 $s = shift;  my $yourself = 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/05/17 05:46:25 $

=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.6	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\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			RFC 2047 says to support ASCII part of C<ISO-8859-I<n>> at least.
48			This requirement is convinient for human users who see final rendering
49			result. But it is not appropriate to process message.
50
51			Defalt value is C<1>, force decoding is enabled.
52
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			'*DEFAULT' => sub {$_[1]},
86			b => sub {require MIME::Base64; MIME::Base64::decode ($_[1])},
87			q => sub {my $s = $_[1]; $s =~ tr/_/\x20/;
88			$s=~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ge; $s},
89			);
90
91	wakaba	1.3	sub decode ($) {
92			my $s = shift;
93			my (@s, @r) = ();
94			$s =~ s{\G([\x09\x20]*[^\x09\x20]+)}{push @s, $1}goex;
95			for my $i (0..$#s) {
96	wakaba	1.6	$r[$i] = 0;
97	wakaba	1.3	if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
98			my ($t, $w) = ('', $1);
99			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
100	wakaba	1.4	if ($r[$i]) {
101	wakaba	1.3	$s[$i] = $t;
102	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
103	wakaba	1.3	$s[$i] = $w.$s[$i];
104			}
105	wakaba	1.2	}
106	wakaba	1.1	}
107	wakaba	1.3	}
108			join '', @s;
109	wakaba	1.1	}
110
111	wakaba	1.3	sub decode_ccontent ($$) {
112			my $s = shift; my $yourself = shift;
113			my (@s, @r) = ();
114	wakaba	1.5	my ($i, @t) = (-1);
115			$s =~ s{$REG{FWS}$REG{comment}}{$i++; $t[$i] = $&; "\x28${i}\x29"}gex;
116			$s =~ s{($REG{FWS}(?:\x5C[\x00-\xFF]
117	wakaba	1.6	\|[\x00-\x08\x0A-\x1F\x21-\x27\x2A-\x5B\x5D-\xFF])+)
118	wakaba	1.5	\|(\x28[0-9]+\x29)}{my ($t,$c) = ($1, $2);
119			if ($t) {$i++; $t[$i] = $t; "\x28${i}\x29"}
120			else {$c}}gex;
121	wakaba	1.6	$s =~ s{\x28([0-9]+)\x29}{push @s, $t[$1]; ''}gex;
122			push @s, $s if length $s;
123	wakaba	1.3	for my $i (0..$#s) {
124			if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
125			my ($t, $w) = ('', $1);
126			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
127	wakaba	1.4	if ($r[$i]) {
128	wakaba	1.3	$s[$i] = $t;
129	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
130	wakaba	1.3	$s[$i] = $w.$s[$i];
131			}
132			}
133			} elsif ($s[$i] =~ /^($REG{FWS})$REG{M_comment}$/) {
134	wakaba	1.6	$s[$i] = $1.'('.&decode_ccontent ($2, $yourself).')';
135	wakaba	1.3	} else {
136			$s[$i] =~ s/\x5C([\x00-\xFF])/$1/g;
137			my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $s[$i],
138			type => 'ccontent/quoted');
139			$s[$i] = $s{value};
140			}
141			}
142			join '', @s;
143			}
144
145			sub _decode_eword ($$$$) {
146			my ($charset, $lang, $encoding, $etext) = (shift, shift, lc shift, shift);
147			$charset = Message::MIME::Charset::name_normalize ($charset);
148	wakaba	1.4	my ($r,$s) = ('', 0);
149	wakaba	1.6	if (ref $DECODER{$encoding}) { ## decode TE
150	wakaba	1.3	$r = &{$DECODER{$encoding}} ($encoding, $etext);
151			($r,$s) = Message::MIME::Charset::decode ($charset, $r);
152	wakaba	1.4	if (!$s && $OPTION{forcedecode} && $charset =~ /^iso-8859-([0-9]+(?:-[ie])?)$/) {
153	wakaba	1.3	my $n = $1;
154			$r =~ s{([\x09\x0A\x0D\x20][\x80-\xFF]+[\x09\x0A\x0D\x20])}{
155			my $t = $1;
156			$t =~ s/([\x09\x0A\x0D\x80-\xFF])/sprintf('=%02X', ord $1)/ge;
157			$t =~ tr/\x20/_/;
158			sprintf ' =?iso-8859-%s?q?%s?= ', $n.($lang?'*'.$lang:''), $t;
159			}goex;
160			$s = 1;
161			}
162			}
163			($r, $s);
164			}
165
166
167	wakaba	1.1	=head1 LICENSE
168
169			Copyright 2002 wakaba E<lt>[email protected]<gt>.
170
171			This program is free software; you can redistribute it and/or modify
172			it under the terms of the GNU General Public License as published by
173			the Free Software Foundation; either version 2 of the License, or
174			(at your option) any later version.
175
176			This program is distributed in the hope that it will be useful,
177			but WITHOUT ANY WARRANTY; without even the implied warranty of
178			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
179			GNU General Public License for more details.
180
181			You should have received a copy of the GNU General Public License
182			along with this program; see the file COPYING. If not, write to
183			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
184			Boston, MA 02111-1307, USA.
185
186			=head1 CHANGE
187
188			See F<ChangeLog>.
189	wakaba	1.6	$Date: 2002/05/17 05:46:25 $
190	wakaba	1.1
191			=cut
192
193			1;