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.11 $=~/\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] },
  '8'   => 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},
);

%ENCODER = (
  b     => sub {require MIME::Base64; my $b = MIME::Base64::encode ($_[1]); $b =~ tr/\x00-\x20//d; ($b, {-encoded => 1})},
  q     => \&_encode_q_encoding,
);

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 ($yourself, $2) .')';
    } 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) = ('');
  if (ref $DECODER{$encoding}) {        ## decode TE
    $r = &{$DECODER{$encoding}} ($encoding, $etext);
    ($r,%s) = Message::MIME::Charset::decode ($charset, $r);
    if (!$s{success} && $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{success} = 1;
    }
  }
  ($r, $s{success});
}

=head1 $encoded_words = Message::MIME::EncodedWord::encode ($string, %option)

Encode given string as encoded-words if necessary.

Available options:

=over 4

=item -charset => charset (default: 'us-ascii')

Charset name (in lower cases) to be used to encode the output string.
(Currently 'us-ascii', 'iso-8859-1' and 'us-ascii' is supported.
'iso-2022-int', 'euc-jp' or other charsets are unable to co-exist with
encoded-words, in current implemention.)

=item -context => 'default' (default) / 'comment' / 'phrase' / 'quoted_string'

Context in which given string is embeded.

=item -ebcdic_safe => 0/1 (default)

Encode additional ASCII characters (shown in RFC 2047) that
are not safe in EBCDIC transports.  This option is meaningful only when
"Q" encoding is used.

=item -encode_char => 1*CHAR / '' (default)

The list of ASCII characters should be encoded in encoded-word
in addition to non-ASCII characters and special ASCII characters
determined by C<-context> and C<-ebcdic_safe> options.

=item -encode_encoded_word_like => 0/1 (default)

Encode encoded-word-like tokens in given string or not.

=item -preserve_wsp => 0/1 (default)

If true, 2*WSP is encoded in encoded-word.  Unless string is the content
of comment or quoted-string, this option value should be true.

=item -q_encode_char => 1*CHAR / '' (default)

The list of ASCII characters should be encoded in q encoding of encoded-word
in addition to non-ASCII characters and special ASCII characters
determined by C<-context> and C<-ebcdic_safe> options.

=item -quoted_pair => 1*CHAR / qr|(:: pattern ::)| '' (default)

A character list or a Regexp pattern for characters to be quoted as
the quoted-pairs.  When '', no character is quoted.
Quoting is performed to characters NOT encoded as encoded-words.
This option should be useful if given string is to be a content
of a comment or quoted-string.  Usually, "\" is also included in
the character list to represent "\" itself as "\\".

=item -source_charset => charset (default = *internal)

Charset name (in lower case) of given string.

=item -token_maxlength => 1*DIGIT / 0 (default)

Maximal length of a string (1*l<OCTET except WSP>) that can be represented
as a non-encoded-word.  If 0, no length limit is implied.
Note that this option does NOT change maximal length of encoded-word.
(Maximal length of encoded-word is always 75, as defined in RFC 2047.)

=cut

sub encode ($;%) {
  my $string = shift;
  my %option = @_;
  $option{-preserve_wsp} = 1 unless defined $option{-preserve_wsp};
  $option{-source_charset} ||= '*internal';
  my $re_encode = join ('|', grep {$_}
     (($option{-charset} eq 'utf-8' ? '' :
       $option{-charset} eq 'iso-8859-1' ? '[^\x00-\xFF]' : '[^\x00-\x7F]'),
      (defined $option{-encode_char} ? qq([$option{-encode_char}]) : ''),
      (!defined $option{-encode_encoded_word_like}||$option{-encode_encoded_word_like} ? '^=\?' :'')
     )) || '(?!)';
  if ($option{-quoted_pair} && !ref $option{-quoted_pair}) {
    $option{-quoted_pair} = quotemeta $option{-quoted_pair};
    $option{-quoted_pair} = qr/([$option{-quoted_pair}])/;
  }
  my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, $string;
  my @encoded;
  for my $i (0..$#string) {
    my $string_nows = $string[$i];
    my $ws = ''; $ws = $1 if $string_nows =~ s/^([\x09\x20]+)//;
    $encoded[$i] = -1;
    if ($i == 0) {      ## First component of string
      if ($string_nows =~ /$re_encode/ || ($option{-preserve_wsp} && length ($ws) > 1)
      || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
        my $estring = _encode ($string[$i], \%option);
        if ($estring) {
          $string[$i] = $estring;
          $encoded[$i] = 1;
        }
      }
    } elsif ($i == $#string && length ($string_nows) == 0) {    ## Last component of string is 1*WSP
      my $estring = _encode ($ws, \%option);
      if ($estring) {
        $string[$i] = ' ' . $estring;
        $encoded[$i] = 1;
      }
    } elsif ($i == 0 || !$encoded[$i-1]) {      ## Previous token is not encoded
      if ($string_nows =~ /$re_encode/
      || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
        if ($option{-preserve_wsp} && length ($ws) > 1 && $i) {
          $string_nows = substr ($ws, 1) . $string_nows;
          $ws = substr ($ws, 0, 1);
        } elsif (!$ws) {
          $ws = ' ';
        }
        my $estring = _encode ($string_nows, \%option);
        if ($estring) {
          $string[$i] = $ws . $estring;
          $encoded[$i] = 1;
        }
      } elsif ($option{-preserve_wsp} && length ($ws) == 2) {
        my $estring = _encode (substr ($ws, 1) . $string_nows, \%option);
        if ($estring) {
          $string[$i] = substr ($ws, 0, 1) . $estring;
          $encoded[$i] = 1;
        }
      } elsif ($option{-preserve_wsp} && length ($ws) > 2) {
        my $estring = _encode (substr ($ws, 1, length ($ws) - 2), \%option);
        if ($estring) {
          $string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
          $string[$i] = substr ($ws, 0, 1) . $estring . substr ($ws, -1) . $string_nows;
          $encoded[$i] = 0;
        }
      }
    } else {    ## Previous token is encoded
      if ($string_nows =~ /$re_encode/
      || ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
        my $estring = _encode ($string[$i], \%option);
        if ($estring) {
          $string[$i] = ($i!=0?' ':'') . $estring;
          $encoded[$i] = 1;
        }
      } elsif ($option{-preserve_wsp} && length ($ws) > 1) {
        my $estring = _encode (substr ($ws, 0, length ($ws) - 1), \%option);
        if ($estring) {
          $string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
          $string[$i] = ($i!=0?' ':'') . $estring . substr ($ws, -1) . $string_nows;
          $encoded[$i] = 0;
        }
      }
    }
    if ($encoded[$i] == -1) {
      $string[$i] =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
      $encoded[$i] = 0;
    }
  }
  join '', @string;
}

## $encoded_text must be octet string (not utf8 string).
sub _encode_q_encoding ($$;\%) {
    my ($encoding, $encoded_text, $option) = @_;
    ## -- What characters are encoded?
    my $achar = {
      default   => q(!"#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~\\[]-),
      comment   => q(!"#$%&'*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~[]-),
      phrase    => q(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!*+/-),
      quoted_string     => q(!#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{|}~[]-),
    }->{$option->{-context} || 'default'};
    my $echar = $option->{-q_encode_char}; $echar =~ s/([\/\\])/\\$1/g;
    eval qq{\$achar =~ tr/$echar//d};
    $achar =~ tr/!"#$@[\\]^`{|}~//d unless defined $option->{-ebcdic_safe} && $option->{-ebcdic_safe} == 0;
    $achar = quotemeta $achar;
    ## -- Encode
    $encoded_text =~ s/([^$achar])/sprintf '=%02X', ord $1/ge;
    $encoded_text =~ s/=20/_/g;
    ($encoded_text, {-encoded => 1});
}
sub _encode ($$) {
  my $option = $_[1];
  my $charset = $option->{-source_charset};
  my $encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $charset);
  my @estr;
  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)))}) {
    my $echarset = Message::MIME::Charset::get_interchange_charset ($charset, $str, $option)->{charset} || $charset;
    my ($estr, %r) = Message::MIME::Charset::encode ($echarset, $str);
    do {$echarset = $charset; $estr = $str; Message::MIME::Charset::_utf8_off ($estr)} unless $r{success};
    $encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $echarset);
    if ($encoding eq '*auto') {
      $encoding = (($estr =~ tr/\x20-\x7E/\x20-\x7E/) < (length ($estr) * 0.55)) ? 'b' : 'q';
    }
    my ($s, $r) = &{$ENCODER{$encoding}} ($encoding, $estr, $option);
    if ($r->{-encoded}) {       ## Success
      my $echarset = {Message::MIME::Charset::name_minimumize ($echarset, $estr, {-name_only=>1})}->{charset};
      push @estr, sprintf ('=?%s?%s?%s?=', $echarset, $encoding, $s);
    } else {
      return undef;
    }
  }
  join ' ', @estr;
}


=head1 LICENSE

Copyright 2002 Wakaba <[email protected]>.

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.

=cut

1; # $Date: $
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.12	$VERSION=do{my @r=(q$Revision: 1.11 $=~/\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.12	'8' => sub { $_[1] },
88	wakaba	1.1	b => sub {require MIME::Base64; MIME::Base64::decode ($_[1])},
89			q => sub {my $s = $_[1]; $s =~ tr/_/\x20/;
90			$s=~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ge; $s},
91			);
92
93	wakaba	1.12	%ENCODER = (
94			b => sub {require MIME::Base64; my $b = MIME::Base64::encode ($_[1]); $b =~ tr/\x00-\x20//d; ($b, {-encoded => 1})},
95			q => \&_encode_q_encoding,
96			);
97
98	wakaba	1.3	sub decode ($) {
99			my $s = shift;
100			my (@s, @r) = ();
101			$s =~ s{\G([\x09\x20]*[^\x09\x20]+)}{push @s, $1}goex;
102			for my $i (0..$#s) {
103	wakaba	1.6	$r[$i] = 0;
104	wakaba	1.3	if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
105			my ($t, $w) = ('', $1);
106			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
107	wakaba	1.4	if ($r[$i]) {
108	wakaba	1.3	$s[$i] = $t;
109	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
110	wakaba	1.3	$s[$i] = $w.$s[$i];
111			}
112	wakaba	1.2	}
113	wakaba	1.1	}
114	wakaba	1.3	}
115			join '', @s;
116	wakaba	1.1	}
117
118	wakaba	1.3	sub decode_ccontent ($$) {
119	wakaba	1.8	my $yourself = shift; my $s = shift;
120	wakaba	1.3	my (@s, @r) = ();
121	wakaba	1.5	my ($i, @t) = (-1);
122			$s =~ s{$REG{FWS}$REG{comment}}{$i++; $t[$i] = $&; "\x28${i}\x29"}gex;
123			$s =~ s{($REG{FWS}(?:\x5C[\x00-\xFF]
124	wakaba	1.6	\|[\x00-\x08\x0A-\x1F\x21-\x27\x2A-\x5B\x5D-\xFF])+)
125	wakaba	1.5	\|(\x28[0-9]+\x29)}{my ($t,$c) = ($1, $2);
126			if ($t) {$i++; $t[$i] = $t; "\x28${i}\x29"}
127			else {$c}}gex;
128	wakaba	1.6	$s =~ s{\x28([0-9]+)\x29}{push @s, $t[$1]; ''}gex;
129			push @s, $s if length $s;
130	wakaba	1.3	for my $i (0..$#s) {
131			if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
132			my ($t, $w) = ('', $1);
133			($t, $r[$i]) = (_decode_eword ($2, $3, $4, $5));
134	wakaba	1.4	if ($r[$i]) {
135	wakaba	1.3	$s[$i] = $t;
136	wakaba	1.4	if ($i == 0 \|\| $r[$i-1] == 0) {
137	wakaba	1.3	$s[$i] = $w.$s[$i];
138			}
139			}
140			} elsif ($s[$i] =~ /^($REG{FWS})$REG{M_comment}$/) {
141	wakaba	1.10	$s[$i] = $1.'('. &decode_ccontent ($yourself, $2) .')';
142	wakaba	1.3	} else {
143			$s[$i] =~ s/\x5C([\x00-\xFF])/$1/g;
144			my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $s[$i],
145			type => 'ccontent/quoted');
146			$s[$i] = $s{value};
147			}
148			}
149			join '', @s;
150			}
151
152			sub _decode_eword ($$$$) {
153			my ($charset, $lang, $encoding, $etext) = (shift, shift, lc shift, shift);
154			$charset = Message::MIME::Charset::name_normalize ($charset);
155	wakaba	1.11	my ($r,%s) = ('');
156	wakaba	1.6	if (ref $DECODER{$encoding}) { ## decode TE
157	wakaba	1.3	$r = &{$DECODER{$encoding}} ($encoding, $etext);
158	wakaba	1.11	($r,%s) = Message::MIME::Charset::decode ($charset, $r);
159			if (!$s{success} && $OPTION{forcedecode} && $charset =~ /^iso-8859-([0-9]+(?:-[ie])?)$/) {
160	wakaba	1.3	my $n = $1;
161			$r =~ s{([\x09\x0A\x0D\x20][\x80-\xFF]+[\x09\x0A\x0D\x20])}{
162			my $t = $1;
163			$t =~ s/([\x09\x0A\x0D\x80-\xFF])/sprintf('=%02X', ord $1)/ge;
164			$t =~ tr/\x20/_/;
165			sprintf ' =?iso-8859-%s?q?%s?= ', $n.($lang?'*'.$lang:''), $t;
166			}goex;
167	wakaba	1.11	$s{success} = 1;
168	wakaba	1.3	}
169			}
170	wakaba	1.11	($r, $s{success});
171	wakaba	1.3	}
172
173	wakaba	1.12	=head1 $encoded_words = Message::MIME::EncodedWord::encode ($string, %option)
174
175			Encode given string as encoded-words if necessary.
176
177			Available options:
178
179			=over 4
180
181			=item -charset => charset (default: 'us-ascii')
182
183			Charset name (in lower cases) to be used to encode the output string.
184			(Currently 'us-ascii', 'iso-8859-1' and 'us-ascii' is supported.
185			'iso-2022-int', 'euc-jp' or other charsets are unable to co-exist with
186			encoded-words, in current implemention.)
187
188			=item -context => 'default' (default) / 'comment' / 'phrase' / 'quoted_string'
189
190			Context in which given string is embeded.
191
192			=item -ebcdic_safe => 0/1 (default)
193
194			Encode additional ASCII characters (shown in RFC 2047) that
195			are not safe in EBCDIC transports. This option is meaningful only when
196			"Q" encoding is used.
197
198			=item -encode_char => 1*CHAR / '' (default)
199
200			The list of ASCII characters should be encoded in encoded-word
201			in addition to non-ASCII characters and special ASCII characters
202			determined by C<-context> and C<-ebcdic_safe> options.
203
204			=item -encode_encoded_word_like => 0/1 (default)
205
206			Encode encoded-word-like tokens in given string or not.
207
208			=item -preserve_wsp => 0/1 (default)
209
210			If true, 2*WSP is encoded in encoded-word. Unless string is the content
211			of comment or quoted-string, this option value should be true.
212
213			=item -q_encode_char => 1*CHAR / '' (default)
214
215			The list of ASCII characters should be encoded in q encoding of encoded-word
216			in addition to non-ASCII characters and special ASCII characters
217			determined by C<-context> and C<-ebcdic_safe> options.
218
219			=item -quoted_pair => 1*CHAR / qr\|(:: pattern ::)\| '' (default)
220
221			A character list or a Regexp pattern for characters to be quoted as
222			the quoted-pairs. When '', no character is quoted.
223			Quoting is performed to characters NOT encoded as encoded-words.
224			This option should be useful if given string is to be a content
225			of a comment or quoted-string. Usually, "\" is also included in
226			the character list to represent "\" itself as "\\".
227
228			=item -source_charset => charset (default = *internal)
229
230			Charset name (in lower case) of given string.
231
232			=item -token_maxlength => 1*DIGIT / 0 (default)
233
234			Maximal length of a string (1*l<OCTET except WSP>) that can be represented
235			as a non-encoded-word. If 0, no length limit is implied.
236			Note that this option does NOT change maximal length of encoded-word.
237			(Maximal length of encoded-word is always 75, as defined in RFC 2047.)
238
239			=cut
240
241			sub encode ($;%) {
242			my $string = shift;
243			my %option = @_;
244			$option{-preserve_wsp} = 1 unless defined $option{-preserve_wsp};
245			$option{-source_charset} \|\|= '*internal';
246			my $re_encode = join ('\|', grep {$_}
247			(($option{-charset} eq 'utf-8' ? '' :
248			$option{-charset} eq 'iso-8859-1' ? '[^\x00-\xFF]' : '[^\x00-\x7F]'),
249			(defined $option{-encode_char} ? qq([$option{-encode_char}]) : ''),
250			(!defined $option{-encode_encoded_word_like}\|\|$option{-encode_encoded_word_like} ? '^=\?' :'')
251			)) \|\| '(?!)';
252			if ($option{-quoted_pair} && !ref $option{-quoted_pair}) {
253			$option{-quoted_pair} = quotemeta $option{-quoted_pair};
254			$option{-quoted_pair} = qr/([$option{-quoted_pair}])/;
255			}
256			my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, $string;
257			my @encoded;
258			for my $i (0..$#string) {
259			my $string_nows = $string[$i];
260			my $ws = ''; $ws = $1 if $string_nows =~ s/^([\x09\x20]+)//;
261			$encoded[$i] = -1;
262			if ($i == 0) { ## First component of string
263			if ($string_nows =~ /$re_encode/ \|\| ($option{-preserve_wsp} && length ($ws) > 1)
264			\|\| ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
265			my $estring = _encode ($string[$i], \%option);
266			if ($estring) {
267			$string[$i] = $estring;
268			$encoded[$i] = 1;
269			}
270			}
271			} elsif ($i == $#string && length ($string_nows) == 0) { ## Last component of string is 1*WSP
272			my $estring = _encode ($ws, \%option);
273			if ($estring) {
274			$string[$i] = ' ' . $estring;
275			$encoded[$i] = 1;
276			}
277			} elsif ($i == 0 \|\| !$encoded[$i-1]) { ## Previous token is not encoded
278			if ($string_nows =~ /$re_encode/
279			\|\| ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
280			if ($option{-preserve_wsp} && length ($ws) > 1 && $i) {
281			$string_nows = substr ($ws, 1) . $string_nows;
282			$ws = substr ($ws, 0, 1);
283			} elsif (!$ws) {
284			$ws = ' ';
285			}
286			my $estring = _encode ($string_nows, \%option);
287			if ($estring) {
288			$string[$i] = $ws . $estring;
289			$encoded[$i] = 1;
290			}
291			} elsif ($option{-preserve_wsp} && length ($ws) == 2) {
292			my $estring = _encode (substr ($ws, 1) . $string_nows, \%option);
293			if ($estring) {
294			$string[$i] = substr ($ws, 0, 1) . $estring;
295			$encoded[$i] = 1;
296			}
297			} elsif ($option{-preserve_wsp} && length ($ws) > 2) {
298			my $estring = _encode (substr ($ws, 1, length ($ws) - 2), \%option);
299			if ($estring) {
300			$string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
301			$string[$i] = substr ($ws, 0, 1) . $estring . substr ($ws, -1) . $string_nows;
302			$encoded[$i] = 0;
303			}
304			}
305			} else { ## Previous token is encoded
306			if ($string_nows =~ /$re_encode/
307			\|\| ($option{-token_maxlength} && length ($string_nows) > $option{-token_maxlength})) {
308			my $estring = _encode ($string[$i], \%option);
309			if ($estring) {
310			$string[$i] = ($i!=0?' ':'') . $estring;
311			$encoded[$i] = 1;
312			}
313			} elsif ($option{-preserve_wsp} && length ($ws) > 1) {
314			my $estring = _encode (substr ($ws, 0, length ($ws) - 1), \%option);
315			if ($estring) {
316			$string_nows =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
317			$string[$i] = ($i!=0?' ':'') . $estring . substr ($ws, -1) . $string_nows;
318			$encoded[$i] = 0;
319			}
320			}
321			}
322			if ($encoded[$i] == -1) {
323			$string[$i] =~ s/$option{-quoted_pair}/\\$1/g if $option{-quoted_pair};
324			$encoded[$i] = 0;
325			}
326			}
327			join '', @string;
328			}
329
330			## $encoded_text must be octet string (not utf8 string).
331			sub _encode_q_encoding ($$;\%) {
332			my ($encoding, $encoded_text, $option) = @_;
333			## -- What characters are encoded?
334			my $achar = {
335			default => q(!"#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{\|}~\\[]-),
336			comment => q(!"#$%&'*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{\|}~[]-),
337			phrase => q(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!*+/-),
338			quoted_string => q(!#$%&'()*+,./0123456789:;<>@ABCDEFGHIJKLMNOPQRSTUVWXYZ^`abcdefghijklmnopqrstuvwxyz{\|}~[]-),
339			}->{$option->{-context} \|\| 'default'};
340			my $echar = $option->{-q_encode_char}; $echar =~ s/([\/\\])/\\$1/g;
341			eval qq{\$achar =~ tr/$echar//d};
342			$achar =~ tr/!"#$@[\\]^`{\|}~//d unless defined $option->{-ebcdic_safe} && $option->{-ebcdic_safe} == 0;
343			$achar = quotemeta $achar;
344			## -- Encode
345			$encoded_text =~ s/([^$achar])/sprintf '=%02X', ord $1/ge;
346			$encoded_text =~ s/=20/_/g;
347			($encoded_text, {-encoded => 1});
348			}
349			sub _encode ($$) {
350			my $option = $_[1];
351			my $charset = $option->{-source_charset};
352			my $encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $charset);
353			my @estr;
354			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)))}) {
355			my $echarset = Message::MIME::Charset::get_interchange_charset ($charset, $str, $option)->{charset} \|\| $charset;
356			my ($estr, %r) = Message::MIME::Charset::encode ($echarset, $str);
357			do {$echarset = $charset; $estr = $str; Message::MIME::Charset::_utf8_off ($estr)} unless $r{success};
358			$encoding = Message::MIME::Charset::get_property ('cte_header_preferred', $echarset);
359			if ($encoding eq '*auto') {
360			$encoding = (($estr =~ tr/\x20-\x7E/\x20-\x7E/) < (length ($estr) * 0.55)) ? 'b' : 'q';
361			}
362			my ($s, $r) = &{$ENCODER{$encoding}} ($encoding, $estr, $option);
363			if ($r->{-encoded}) { ## Success
364			my $echarset = {Message::MIME::Charset::name_minimumize ($echarset, $estr, {-name_only=>1})}->{charset};
365			push @estr, sprintf ('=?%s?%s?%s?=', $echarset, $encoding, $s);
366			} else {
367			return undef;
368			}
369			}
370			join ' ', @estr;
371			}
372
373	wakaba	1.3
374	wakaba	1.1	=head1 LICENSE
375
376	wakaba	1.12	Copyright 2002 Wakaba <[email protected]>.
377	wakaba	1.1
378			This program is free software; you can redistribute it and/or modify
379			it under the terms of the GNU General Public License as published by
380			the Free Software Foundation; either version 2 of the License, or
381			(at your option) any later version.
382
383			This program is distributed in the hope that it will be useful,
384			but WITHOUT ANY WARRANTY; without even the implied warranty of
385			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
386			GNU General Public License for more details.
387
388			You should have received a copy of the GNU General Public License
389			along with this program; see the file COPYING. If not, write to
390			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
391			Boston, MA 02111-1307, USA.
392
393			=cut
394
395	wakaba	1.12	1; # $Date: $