Message/Field/Token.pm


=head1 NAME

Message::Field::Token --- Message-pm: Lexical tokens used in Internet message formats

=head1 DESCRIPTION

This module provides functions for handling lexical tokens of Internet message formats,
such as quoted-string, comment, etc.

This module is part of Message::* Perl Modules.

=cut

package Message::Field::Token;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

=head1 $phrase = Message::Field::Token::en_phrase ($string, %option)

Return given string (in internal code) as a phrase (= atom / quoted-string / encoded-word).

Options:

=over 4

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

Charset name (in lower cases) to be used to encode the output string.

=item -ebcdic_safe

=item -encode_encoded_word_like

=item -quoted_pair

=item -token_maxlength

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

See options of C<en_quoted_string>.

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

Charset name (in lower case) of given string.

=back

=cut

sub en_phrase ($;%) {
  my $string = shift;
  my %option = @_;
  my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, $string;
  my @str = ([0, '']);
  for my $i (0..$#string) {
    if (Message::MIME::Charset::is_representable_in ($option{-charset}, $string[$i], \%option) && $string[$i] !~ /[\x00\x0A\x0D]/) {
      if ($str[$#str]->[0]) {   ## Preceding token should be encoded
        push @str, [0, $string[$i]];
      } else {  ## Preceding token need not be encoded
        $str[$#str]->[1] .= $string[$i];
      }
    } else {    ## Should be encoded
      if ($str[$#str]->[0]) {   ## Preceding token should be encoded
        $str[$#str]->[1] .= $string[$i];
      } else {  ## Preceding token need not be encoded
        push @str, [1, $string[$i]];
      }
    }
  }
  my $phrase = '';
  for my $i (0..$#str) {
    my $ws = ''; $ws = $1 if $i != 0 && $str[$i]->[1] =~ s/^([\x09\x20])//;
    if ($str[$i]->[0]) {
      $str[$i]->[1] = Message::MIME::EncodedWord::encode ($str[$i]->[1], %option, -context => 'phrase', -encode_char => '\x00-\x7F');
    } else {
      $str[$i]->[1] = _to_quoted_string ($str[$i]->[1], \%option);
    }
    $phrase .= $ws . $str[$i]->[1];
  }
  $phrase;
}

=head1 $quoted_string = Message::Field::Token::en_quoted_string ($string, %option)

Quote string as a quoted-string if necessary.

Options:

=over 4

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

Charset name (in lower cases) to be used to encode the output string.

=item -context => 'quoted_string' (default) / 'atom' / 'token' / 'http_token' / 'attr_char' / 'http_attr_char'

Context in which given string is embeded.  This value is used to check if
string should be quoted as a quoted-string.  'quoted_string', the default value,
makes string ALWAYS quoted.  'atom' makes it quoted when string contains
one or more characters not included in the atext (see RFC 2822).
Likewise, 'token' is for token of MIME, 'http_token' is for token of HTTP,
'attr_char' is attribute-char of MIME (RFC 2231) and 'http_attr_char'
is 'http_token' AND 'attr_char' (ie. safe for both HTTP and RFC 2231).

=item -ebcdic_safe

This option is only meaningful when C<-use_quoted_string> is true.
See L<Message::MIME::EncodedWord>::decode.

=item -encode_encoded_word_like

This option is only meaningful when C<-use_quoted_string> is true.
See L<Message::MIME::EncodedWord>::decode.

=item -quoted_pair => 1*CHAR / qr|(:: pattern ::)| (default: qr/([\x0D\\"]|(?<==)\?)/)

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.

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

Charset name (in lower case) of given string.

=item -token_maxlength

This option is only meaningful when C<-use_quoted_string> is true.
See L<Message::MIME::EncodedWord>::decode.

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

The list of characters that when one of them is included in the string
it should be quoted, in addition to special characters determined by C<-context> option.

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

If true, characters in qcontent which unable to be represented in C<-charset> charset
are encoded in encoded-words.

=back

=cut

sub en_quoted_string ($;%) {
  my ($string, %option) = @_;
  if ($option{-use_encoded_word}) {
    require Message::MIME::EncodedWord;
    $option{-quoted_pair} ||= qr/([\x0D\\"]|(?<==)\?)/;
    $string = Message::MIME::EncodedWord::encode ($string, %option, -context => 'quoted_string', -preserve_wsp => 0);
    $option{-quoted_pair} = qr/(?!)/;
  }
  $string = _to_quoted_string ($string, \%option);
  my ($s, %r) = Message::MIME::Charset::encode ($option{-charset}, $string);
  $r{success} ? $s : $string;
}

sub _to_quoted_string ($$) {
  my ($string, $option) = @_;
  ## -- What characters should be quoted?
    my $achar = {
      atom      => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+/=?^_`{|}~-),
      token     => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+^_`{|}~.-),
      http_token        => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+^_`|~.-),
      attr_char => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$&+^_`{|}~.-),
      http_attr_char    => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$&+^_`|~.-),
      quoted_string     => '',
    }->{$option->{-context} || 'quoted_string'};
    my $echar = $option->{-unsafe_char}; $echar =~ s/([\/\\])/\\$1/g;
    eval qq{\$achar =~ tr/$echar//d};
    $achar =~ s/([\\\[\]])/\\$1/g;
    $option->{-quoted_pair} ||= qr/([\x0D"\\]|(?<==)\?)/;
    if (!ref $option->{-quoted_pair}) {
      $option->{-quoted_pair} = quotemeta $option->{-quoted_pair};
      $option->{-quoted_pair} = qr/([$option->{-quoted_pair}])/;
    }
  ## -- Quote
    if (length ($achar) == 0 || $string =~ /[^$achar]/) {
      $string =~ s/$option->{-quoted_pair}/\\$1/g if $option->{-quoted_pair};
      $string = '"' . $string . '"';
    }
  $string;
}

=head1 $string = Message::Field::Token::de_phrase ($phrase, %option)

Parses given phrase or a quoted-string and return it as a string (in internal code).

Options:

=over 4

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

Charset name of input.  The charset MUST be a superset of ASCII.

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

Decodes encoded-words (out of quoted-strings).

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

Decodes encoded-words in quoted-strings.

=back

=cut

sub de_phrase ($;%) {
  my ($string, %option) = @_;
  $option{-use_encoded_word} = 1 unless defined $option{-use_encoded_word};
  require Message::MIME::EncodedWord if $option{-use_encoded_word};
  require Message::MIME::Charset;
  $string =~ s("((?:\\.|[^"])*)"|([^"]+)){      ## Note: broken <"> does not match with this.
    my ($qcontent, $atom) = ($1, $2);
    if (defined $qcontent) {
      if ($option{-use_quoted_encoded_word}) {
        $qcontent = Message::MIME::EncodedWord::decode($qcontent, -process_non_encoded_word => sub {
          $_[0] =~ s/\\(.)/$1/g;
          my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} || 'us-ascii', $_[0]);
          $s{success} ? ($s, 0) : ($_[0], 0);
        });
      } else {
        $qcontent =~ s/\\(.)/$1/g;
        my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} || 'us-ascii', $qcontent);
        $qcontent = $s if $s{success};
      }
      $qcontent;
    } else {    ## 1*(atom / encoded-word / FWS)
      if ($option{-use_encoded_word}) {
        $atom = Message::MIME::EncodedWord::decode ($atom, -process_non_encoded_word => sub {
          my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} || 'us-ascii', $_[0]);
          $s{success} ? ($s, 0) : ($_[0], 0);
        });
      }
      $atom;
    }
  }ges;
  $string;
}

=head1 $string = Message::Field::Token::de_quoted_string ($quoted_string, %option)

An alias to C<de_phrase>.

=cut

*de_quoted_string = \&de_phrase;

=head1 LICENSE

Copyright 2002 Wakaba <w@suika.fam.cx>

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::Field::Token --- Message-pm: Lexical tokens used in Internet message formats
5
6			=head1 DESCRIPTION
7
8			This module provides functions for handling lexical tokens of Internet message formats,
9			such as quoted-string, comment, etc.
10
11			This module is part of Message::* Perl Modules.
12
13			=cut
14
15			package Message::Field::Token;
16			use strict;
17			our $VERSION=do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18
19			=head1 $phrase = Message::Field::Token::en_phrase ($string, %option)
20
21			Return given string (in internal code) as a phrase (= atom / quoted-string / encoded-word).
22
23			Options:
24
25			=over 4
26
27			=item -charset => charset (default: 'us-ascii')
28
29			Charset name (in lower cases) to be used to encode the output string.
30
31			=item -ebcdic_safe
32
33			=item -encode_encoded_word_like
34
35			=item -quoted_pair
36
37			=item -token_maxlength
38
39			=item -unsafe_char => 1*CHAR / '' (default)
40
41			See options of C<en_quoted_string>.
42
43			=item -source_charset => charset (default = *internal)
44
45			Charset name (in lower case) of given string.
46
47			=back
48
49			=cut
50
51			sub en_phrase ($;%) {
52			my $string = shift;
53			my %option = @_;
54			my @string = split /(?<=[^\x09\x20])(?=[\x09\x20])/, $string;
55			my @str = ([0, '']);
56			for my $i (0..$#string) {
57			if (Message::MIME::Charset::is_representable_in ($option{-charset}, $string[$i], \%option) && $string[$i] !~ /[\x00\x0A\x0D]/) {
58			if ($str[$#str]->[0]) { ## Preceding token should be encoded
59			push @str, [0, $string[$i]];
60			} else { ## Preceding token need not be encoded
61			$str[$#str]->[1] .= $string[$i];
62			}
63			} else { ## Should be encoded
64			if ($str[$#str]->[0]) { ## Preceding token should be encoded
65			$str[$#str]->[1] .= $string[$i];
66			} else { ## Preceding token need not be encoded
67			push @str, [1, $string[$i]];
68			}
69			}
70			}
71			my $phrase = '';
72			for my $i (0..$#str) {
73			my $ws = ''; $ws = $1 if $i != 0 && $str[$i]->[1] =~ s/^([\x09\x20])//;
74			if ($str[$i]->[0]) {
75			$str[$i]->[1] = Message::MIME::EncodedWord::encode ($str[$i]->[1], %option, -context => 'phrase', -encode_char => '\x00-\x7F');
76			} else {
77			$str[$i]->[1] = _to_quoted_string ($str[$i]->[1], \%option);
78			}
79			$phrase .= $ws . $str[$i]->[1];
80			}
81			$phrase;
82			}
83
84			=head1 $quoted_string = Message::Field::Token::en_quoted_string ($string, %option)
85
86			Quote string as a quoted-string if necessary.
87
88			Options:
89
90			=over 4
91
92			=item -charset => charset (default: 'us-ascii')
93
94			Charset name (in lower cases) to be used to encode the output string.
95
96			=item -context => 'quoted_string' (default) / 'atom' / 'token' / 'http_token' / 'attr_char' / 'http_attr_char'
97
98			Context in which given string is embeded. This value is used to check if
99			string should be quoted as a quoted-string. 'quoted_string', the default value,
100			makes string ALWAYS quoted. 'atom' makes it quoted when string contains
101			one or more characters not included in the atext (see RFC 2822).
102			Likewise, 'token' is for token of MIME, 'http_token' is for token of HTTP,
103			'attr_char' is attribute-char of MIME (RFC 2231) and 'http_attr_char'
104			is 'http_token' AND 'attr_char' (ie. safe for both HTTP and RFC 2231).
105
106			=item -ebcdic_safe
107
108			This option is only meaningful when C<-use_quoted_string> is true.
109			See L<Message::MIME::EncodedWord>::decode.
110
111			=item -encode_encoded_word_like
112
113			This option is only meaningful when C<-use_quoted_string> is true.
114			See L<Message::MIME::EncodedWord>::decode.
115
116			=item -quoted_pair => 1*CHAR / qr\|(:: pattern ::)\| (default: qr/([\x0D\\"]\|(?<==)\?)/)
117
118			A character list or a Regexp pattern for characters to be quoted as
119			the quoted-pairs. When '', no character is quoted.
120			Quoting is performed to characters NOT encoded as encoded-words.
121
122			=item -source_charset => charset (default = *internal)
123
124			Charset name (in lower case) of given string.
125
126			=item -token_maxlength
127
128			This option is only meaningful when C<-use_quoted_string> is true.
129			See L<Message::MIME::EncodedWord>::decode.
130
131			=item -unsafe_char => 1*CHAR / '' (default)
132
133			The list of characters that when one of them is included in the string
134			it should be quoted, in addition to special characters determined by C<-context> option.
135
136			=item -use_encoded_word => 0 (default)/1
137
138			If true, characters in qcontent which unable to be represented in C<-charset> charset
139			are encoded in encoded-words.
140
141			=back
142
143			=cut
144
145			sub en_quoted_string ($;%) {
146			my ($string, %option) = @_;
147			if ($option{-use_encoded_word}) {
148			require Message::MIME::EncodedWord;
149			$option{-quoted_pair} \|\|= qr/([\x0D\\"]\|(?<==)\?)/;
150			$string = Message::MIME::EncodedWord::encode ($string, %option, -context => 'quoted_string', -preserve_wsp => 0);
151			$option{-quoted_pair} = qr/(?!)/;
152			}
153			$string = _to_quoted_string ($string, \%option);
154			my ($s, %r) = Message::MIME::Charset::encode ($option{-charset}, $string);
155			$r{success} ? $s : $string;
156			}
157
158			sub _to_quoted_string ($$) {
159			my ($string, $option) = @_;
160			## -- What characters should be quoted?
161			my $achar = {
162			atom => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+/=?^_`{\|}~-),
163			token => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+^_`{\|}~.-),
164			http_token => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$%&'*+^_`\|~.-),
165			attr_char => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$&+^_`{\|}~.-),
166			http_attr_char => qq(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!#\$&+^_`\|~.-),
167			quoted_string => '',
168			}->{$option->{-context} \|\| 'quoted_string'};
169			my $echar = $option->{-unsafe_char}; $echar =~ s/([\/\\])/\\$1/g;
170			eval qq{\$achar =~ tr/$echar//d};
171			$achar =~ s/([\\\[\]])/\\$1/g;
172			$option->{-quoted_pair} \|\|= qr/([\x0D"\\]\|(?<==)\?)/;
173			if (!ref $option->{-quoted_pair}) {
174			$option->{-quoted_pair} = quotemeta $option->{-quoted_pair};
175			$option->{-quoted_pair} = qr/([$option->{-quoted_pair}])/;
176			}
177			## -- Quote
178			if (length ($achar) == 0 \|\| $string =~ /[^$achar]/) {
179			$string =~ s/$option->{-quoted_pair}/\\$1/g if $option->{-quoted_pair};
180			$string = '"' . $string . '"';
181			}
182			$string;
183			}
184
185			=head1 $string = Message::Field::Token::de_phrase ($phrase, %option)
186
187			Parses given phrase or a quoted-string and return it as a string (in internal code).
188
189			Options:
190
191			=over 4
192
193			=item -charset => charset (default: 'us-ascii')
194
195			Charset name of input. The charset MUST be a superset of ASCII.
196
197			=item -use_encoded_word => 0/1 (default)
198
199			Decodes encoded-words (out of quoted-strings).
200
201			=item -use_quoted_encoded_word => 0 (default)/1
202
203			Decodes encoded-words in quoted-strings.
204
205			=back
206
207			=cut
208
209			sub de_phrase ($;%) {
210			my ($string, %option) = @_;
211			$option{-use_encoded_word} = 1 unless defined $option{-use_encoded_word};
212			require Message::MIME::EncodedWord if $option{-use_encoded_word};
213			require Message::MIME::Charset;
214			$string =~ s("((?:\\.\|[^"])*)"\|([^"]+)){ ## Note: broken <"> does not match with this.
215			my ($qcontent, $atom) = ($1, $2);
216			if (defined $qcontent) {
217			if ($option{-use_quoted_encoded_word}) {
218			$qcontent = Message::MIME::EncodedWord::decode($qcontent, -process_non_encoded_word => sub {
219			$_[0] =~ s/\\(.)/$1/g;
220			my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} \|\| 'us-ascii', $_[0]);
221			$s{success} ? ($s, 0) : ($_[0], 0);
222			});
223			} else {
224			$qcontent =~ s/\\(.)/$1/g;
225			my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} \|\| 'us-ascii', $qcontent);
226			$qcontent = $s if $s{success};
227			}
228			$qcontent;
229			} else { ## 1*(atom / encoded-word / FWS)
230			if ($option{-use_encoded_word}) {
231			$atom = Message::MIME::EncodedWord::decode ($atom, -process_non_encoded_word => sub {
232			my ($s, %s) = Message::MIME::Charset::decode ($option{-charset} \|\| 'us-ascii', $_[0]);
233			$s{success} ? ($s, 0) : ($_[0], 0);
234			});
235			}
236			$atom;
237			}
238			}ges;
239			$string;
240			}
241
242			=head1 $string = Message::Field::Token::de_quoted_string ($quoted_string, %option)
243
244			An alias to C<de_phrase>.
245
246			=cut
247
248			*de_quoted_string = \&de_phrase;
249
250			=head1 LICENSE
251
252			Copyright 2002 Wakaba <w@suika.fam.cx>
253
254			This program is free software; you can redistribute it and/or modify
255			it under the terms of the GNU General Public License as published by
256			the Free Software Foundation; either version 2 of the License, or
257			(at your option) any later version.
258
259			This program is distributed in the hope that it will be useful,
260			but WITHOUT ANY WARRANTY; without even the implied warranty of
261			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
262			GNU General Public License for more details.
263
264			You should have received a copy of the GNU General Public License
265			along with this program; see the file COPYING. If not, write to
266			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
267			Boston, MA 02111-1307, USA.
268
269			=cut
270
271			1; # $Date: $