/[suikacvs]/messaging/manakai/lib/Message/MIME/EncodedWord.pm
Suika

Contents of /messaging/manakai/lib/Message/MIME/EncodedWord.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations) (download)
Sun Dec 29 03:04:53 2002 UTC (23 years, 7 months ago) by wakaba
Branch: MAIN
CVS Tags: before-dis2-200411, manakai-release-0-3-2, manakai-release-0-3-1, manakai-release-0-4-0, manakai-200612, HEAD
Branch point for: branch-suikawiki-1, experimental-xml-parser-200401
Changes since 1.12: +44 -39 lines
en_quoted_string, en_phrase: New

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 use strict;
14 use vars qw(%ENCODER %DECODER %OPTION %REG $VERSION);
15 $VERSION=do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16 require Message::MIME::Charset;
17
18 $REG{WSP} = qr/[\x09\x20]/;
19 $REG{FWS} = qr/[\x09\x20]*/;
20 $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;
21
22 $REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
23 $REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
24 $REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;
25 $REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
26 $REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
27
28 =head1 OPTIONS
29
30 =cut
31
32 %OPTION = (
33 forcedecode => 0,
34 );
35
36 =over 4
37
38 =item $Message::MIME::EncodedWord::OPTION{forcedecode} = 1/0
39
40 When no charset decoder (See L<Message::MIME::Charset>)
41 for C<ISO-8859-I<n>> is defined, and this option is TRUE,
42 decoding C<encoded-word> functions attempt to decode
43 ASCII part of these charset.
44
45 RFC 2047 says that ASCII part of C<ISO-8859-I<n>> be at least
46 supported. This requirement is convinience for human user who
47 sees final rendering result. But it is not appropriate to process message.
48
49 Defalt value is C<0>, force decoding is disenabled.
50
51 =back
52
53 =head2 Note
54
55 Before you set new value for these options,
56 C<Message::MIME::EncodedWord> should be loaded (C<require>ed).
57 Other modules which use C<Message::MIME::EncodedWord>
58 will automatically require this module, and this module
59 will set initial (default) option value.
60
61 Bad example:
62
63 #! perl
64 $Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
65 use Message::Field::Subject;
66 my $subject = Message::Field::Subject->parse ($ARGV[0]);
67 ## At this time, M::F::Subject call M::M::EWord,
68 ## and $OPTION{forcedecode} is set C<1>, default value.
69
70 Shold be:
71
72 #! perl
73 require Message::MIME::EncodedWord;
74 $Message::MIME::EncodedWord::OPTION{forcedecode} = 0;
75 use Message::Field::Subject;
76 my $subject = Message::Field::Subject->parse ($ARGV[0]);
77 ## At this time, M::F::Subject call M::M::EWord,
78 ## but perl takes no action since it has already loaded.
79
80 =cut
81
82 %DECODER = (
83 '*DEFAULT' => sub { $_[1] },
84 '7' => sub { $_[1] },
85 '8' => 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 %ENCODER = (
92 b => sub {require MIME::Base64; my $b = MIME::Base64::encode ($_[1]); $b =~ tr/\x00-\x20//d; ($b, {-encoded => 1})},
93 q => \&_encode_q_encoding,
94 );
95
96 =head1 $string = Message::MIME::EncodedWord::decode ($text, %option)
97
98 Decodes encoded-words in given text and return as a string (in internal code).
99
100 Options:
101
102 =over 4
103
104 =item -process_non_encoded_word => CODE / 0 (default)
105
106 Procedure for non-encoded-word string. This option can be useful
107 with comment decoder to unquote quoted-pair and/or to decode 8-bit string
108 of HTTP.
109
110 =back
111
112 =cut
113
114 sub decode ($;%) {
115 my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, shift;
116 my %option = @_;
117 my @r; ## Token is encoded-word or not
118 for my $i (0..$#string) {
119 if ($string[$i] =~ m(^([\x09\x20]*)=\?([0-9A-Za-z!#\$%&'+^_`{|}~.-]{1,67})(?:\*([0-9A-Za-z!#\$&+^_`{|}~.-]{1,65}))?\?([0-9A-Za-z!#\$%&'*+^_`{|}~.-]{1,67})\?([\x21-\x3E\x40-\x7E]{1,67})\?=$)) {
120 my ($t, $w) = ('', $1);
121 ($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
122 $string[$i] = ($i == 0 || !$r[$i-1] ? $w : '') . $t if $r[$i];
123 } elsif (ref $option{-process_non_encoded_word}) {
124 ($string[$i], $r[$i]) = &{$option{-process_non_encoded_word}} ($string[$i], \%option);
125 } else {
126 $r[$i] = 0;
127 }
128 }
129 join '', @string;
130 }
131
132 sub _decode_eword ($$$$) {
133 my ($charset, $lang, $encoding, $etext) = (shift, shift, lc shift, shift);
134 $charset = Message::MIME::Charset::name_normalize ($charset);
135 my ($r,%s);
136 if (ref $DECODER{$encoding}) { ## decode TE
137 $r = &{$DECODER{$encoding}} ($encoding, $etext);
138 ($r,%s) = Message::MIME::Charset::decode ($charset, $r);
139 }
140 ($r, $s{success});
141 }
142
143 sub decode_ccontent ($$) {
144 use re 'eval';
145 my $yourself = shift; my $s = shift;
146 my (@s, @r) = ();
147 my ($i, @t) = (-1);
148 $s =~ s{$REG{FWS}$REG{comment}}{$i++; $t[$i] = $&; "\x28${i}\x29"}gex;
149 $s =~ s{($REG{FWS}(?:\x5C[\x00-\xFF]
150 |[\x00-\x08\x0A-\x1F\x21-\x27\x2A-\x5B\x5D-\xFF])+)
151 |(\x28[0-9]+\x29)}{my ($t,$c) = ($1, $2);
152 if ($t) {$i++; $t[$i] = $t; "\x28${i}\x29"}
153 else {$c}}gex;
154 $s =~ s{\x28([0-9]+)\x29}{push @s, $t[$1]; ''}gex;
155 push @s, $s if length $s;
156 for my $i (0..$#s) {
157 if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
158 my ($t, $w) = ('', $1);
159 ($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
160 if ($r[$i]) {
161 $s[$i] = $t;
162 if ($i == 0 || $r[$i-1] == 0) {
163 $s[$i] = $w.$s[$i];
164 }
165 }
166 } elsif ($s[$i] =~ /^($REG{FWS})$REG{M_comment}$/) {
167 $s[$i] = $1.'('. &decode_ccontent ($yourself, $2) .')';
168 } else {
169 $s[$i] =~ s/\x5C([\x00-\xFF])/$1/g;
170 my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $s[$i],
171 type => 'ccontent/quoted');
172 $s[$i] = $s{value};
173 }
174 }
175 join '', @s;
176 }
177
178 =head1 $encoded_words = Message::MIME::EncodedWord::encode ($string, %option)
179
180 Encode given string as encoded-words if necessary.
181
182 Available options:
183
184 =over 4
185
186 =item -charset => charset (default: 'us-ascii')
187
188 Charset name (in lower cases) to be used to encode the output string.
189 (Currently 'us-ascii', 'iso-8859-1' and 'us-ascii' is supported.
190 'iso-2022-int', 'euc-jp' or other charsets are unable to co-exist with
191 encoded-words, in current implemention.)
192
193 =item -context => 'default' (default) / 'comment' / 'phrase' / 'quoted_string'
194
195 Context in which given string is embeded.
196
197 =item -ebcdic_safe => 0/1 (default)
198
199 Encode additional ASCII characters (shown in RFC 2047) that
200 are not safe in EBCDIC transports. This option is meaningful only when
201 "Q" encoding is used.
202
203 =item -encode_char => 1*CHAR / '' (default)
204
205 The list of ASCII characters should be encoded in encoded-word
206 in addition to non-ASCII characters and special ASCII characters
207 determined by C<-context> and C<-ebcdic_safe> options.
208
209 =item -encode_encoded_word_like => 0/1 (default)
210
211 Encode encoded-word-like tokens in given string or not.
212
213 =item -preserve_wsp => 0/1 (default)
214
215 If true, 2*WSP is encoded in encoded-word. Unless string is the content
216 of comment or quoted-string, this option value should be true.
217
218 =item -q_encode_char => 1*CHAR / '' (default)
219
220 The list of ASCII characters should be encoded in q encoding of encoded-word
221 in addition to non-ASCII characters and special ASCII characters
222 determined by C<-context> and C<-ebcdic_safe> options.
223
224 =item -quoted_pair => 1*CHAR / qr|(:: pattern ::)| '' (default)
225
226 A character list or a Regexp pattern for characters to be quoted as
227 the quoted-pairs. When '', no character is quoted.
228 Quoting is performed to characters NOT encoded as encoded-words.
229 This option should be useful if given string is to be a content
230 of a comment or quoted-string. Usually, "\" is also included in
231 the character list to represent "\" itself as "\\".
232
233 =item -source_charset => charset (default = *internal)
234
235 Charset name (in lower case) of given string.
236
237 =item -token_maxlength => 1*DIGIT / 0 (default)
238
239 Maximal length of a string (1*l<OCTET except WSP>) that can be represented
240 as a non-encoded-word. If 0, no length limit is implied.
241 Note that this option does NOT change maximal length of encoded-word.
242 (Maximal length of encoded-word is always 75, as defined in RFC 2047.)
243
244 =cut
245
246 sub encode ($;%) {
247 my $string = shift;
248 my %option = @_;
249 $option{-preserve_wsp} = 1 unless defined $option{-preserve_wsp};
250 $option{-source_charset} ||= '*internal';
251 my $re_encode = join ('|', grep {$_}
252 (($option{-charset} eq 'utf-8' ? '' :
253 $option{-charset} eq 'iso-8859-1' ? '[^\x00-\xFF]' : '[^\x00-\x7F]'),
254 (defined $option{-encode_char} ? qq([$option{-encode_char}]) : ''),
255 (!defined $option{-encode_encoded_word_like}||$option{-encode_encoded_word_like} ? '^=\?' :'')
256 )) || '(?!)';
257 if ($option{-quoted_pair} && !ref $option{-quoted_pair}) {
258 $option{-quoted_pair} = quotemeta $option{-quoted_pair};
259 $option{-quoted_pair} = qr/([$option{-quoted_pair}])/;
260 }
261 my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, $string;
262 my @encoded;
263 for my $i (0..$#string) {
264 my $string_nows = $string[$i];
265 my $ws = ''; $ws = $1 if $string_nows =~ s/^([\x09\x20]+)//;
266 $encoded[$i] = -1;
267 if ($i == 0) { ## First component of string
268 if ($string_nows =~ /$re_encode/ || ($option{-preserve_wsp} && length ($ws) > 1)
269 || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
270 my $estring = _encode ($string[$i], \%option);
271 if ($estring) {
272 $string[$i] = $estring;
273 $encoded[$i] = 1;
274 }
275 }
276 } elsif ($i == $#string && length ($string_nows) == 0) { ## Last component of string is 1*WSP
277 my $estring = _encode ($ws, \%option);
278 if ($estring) {
279 $string[$i] = ' ' . $estring;
280 $encoded[$i] = 1;
281 }
282 } elsif ($i == 0 || !$encoded[$i-1]) { ## Previous token is not encoded
283 if ($string_nows =~ /$re_encode/
284 || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
285 if ($option{-preserve_wsp} && length ($ws) > 1 && $i) {
286 $string_nows = substr ($ws, 1) . $string_nows;
287 $ws = substr ($ws, 0, 1);
288 } elsif (!$ws) {
289 $ws = ' ';
290 }
291 my $estring = _encode ($string_nows, \%option);
292 if ($estring) {
293 $string[$i] = $ws . $estring;
294 $encoded[$i] = 1;
295 }
296 } elsif ($option{-preserve_wsp} && length ($ws) == 2) {
297 my $estring = _encode (substr ($ws, 1) . $string_nows, \%option);
298 if ($estring) {
299 $string[$i] = substr ($ws, 0, 1) . $estring;
300 $encoded[$i] = 1;
301 }
302 } elsif ($option{-preserve_wsp} && length ($ws) > 2) {
303 my $estring = _encode (substr ($ws, 1, length ($ws) - 2), \%option);
304 if ($estring) {
305 $string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
306 $string[$i] = substr ($ws, 0, 1) . $estring . substr ($ws, -1) . $string_nows;
307 $encoded[$i] = 0;
308 }
309 }
310 } else { ## Previous token is encoded
311 if ($string_nows =~ /$re_encode/
312 || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
313 my $estring = _encode ($string[$i], \%option);
314 if ($estring) {
315 $string[$i] = ($i!=0?' ':'') . $estring;
316 $encoded[$i] = 1;
317 }
318 } elsif ($option{-preserve_wsp} && length ($ws) > 1) {
319 my $estring = _encode (substr ($ws, 0, length ($ws) - 1), \%option);
320 if ($estring) {
321 $string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
322 $string[$i] = ($i!=0?' ':'') . $estring . substr ($ws, -1) . $string_nows;
323 $encoded[$i] = 0;
324 }
325 }
326 }
327 if ($encoded[$i] == -1) {
328 $string[$i] =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
329 $encoded[$i] = 0;
330 }
331 }
332 join '', @string;
333 }
334
335 ## $encoded_text must be octet string (not utf8 string).
336 sub _encode_q_encoding ($$;\%) {
337 my ($encoding, $encoded_text, $option) = @_;
338 ## -- What characters are encoded?
339 my $achar = {
340 default => q(!"#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~\\[]-),
341 comment => q(!"#$%&'*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~[]-),
342 phrase => q(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!*+/-),
343 quoted_string => q(!#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~[]-),
344 }->{$option->{-context} || 'default'};
345 my $echar = $option->{-q_encode_char}; $echar =~ s/([\/\\])/\\$1/g;
346 eval qq{\$achar =~ tr/$echar//d};
347 $achar =~ tr/!"#$@[\\]^`{|}~//d unless defined $option->{-ebcdic_safe} && $option->{-ebcdic_safe} == 0;
348 $achar = quotemeta $achar;
349 ## -- Encode
350 $encoded_text =~ s/([^$achar])/sprintf '=%02X', ord $1/ge;
351 $encoded_text =~ s/=20/_/g;
352 ($encoded_text, {-encoded => 1});
353 }
354 sub _encode ($$) {
355 my $option = $_[1];
356 my $charset = $option->{-source_charset};
357 my $encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $charset);
358 my @estr;
359 for my $str (@{Message::MIME::Charset::divide_string ($charset, $_[0], -max => int ((75 - length ($charset.$encoding) - 6) * ({b=>3/4,q=>1/3}->{$encoding}||1)))}) {
360 my $echarset = Message::MIME::Charset::get_interchange_charset ($charset, $str, $option)->{charset} || $charset;
361 my ($estr, %r) = Message::MIME::Charset::encode ($echarset, $str);
362 do {$echarset = $charset; $estr = $str; Message::MIME::Charset::_utf8_off ($estr)} unless $r{success};
363 $encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $echarset);
364 if ($encoding eq '*auto') {
365 $encoding = (($estr =~ tr/\x20-\x7E/\x20-\x7E/) < (length ($estr) * 0.55)) ? 'b' : 'q';
366 }
367 my ($s, $r) = &{$ENCODER{$encoding}} ($encoding, $estr, $option);
368 if ($r->{-encoded}) { ## Success
369 my $echarset = {Message::MIME::Charset::name_minimumize ($echarset, $estr, {-name_only=>1})}->{charset};
370 push @estr, sprintf ('=?%s?%s?%s?=', $echarset, $encoding, $s);
371 } else {
372 return undef;
373 }
374 }
375 join ' ', @estr;
376 }
377
378
379 =head1 LICENSE
380
381 Copyright 2002 Wakaba <[email protected]>.
382
383 This program is free software; you can redistribute it and/or modify
384 it under the terms of the GNU General Public License as published by
385 the Free Software Foundation; either version 2 of the License, or
386 (at your option) any later version.
387
388 This program is distributed in the hope that it will be useful,
389 but WITHOUT ANY WARRANTY; without even the implied warranty of
390 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
391 GNU General Public License for more details.
392
393 You should have received a copy of the GNU General Public License
394 along with this program; see the file COPYING. If not, write to
395 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
396 Boston, MA 02111-1307, USA.
397
398 =cut
399
400 1; # $Date: 2002/12/28 09:07:05 $

[email protected]
ViewVC Help
Powered by ViewVC 1.1.24