/[suikacvs]/messaging/manakai/lib/Message/Field/Params.pm
Suika

Contents of /messaging/manakai/lib/Message/Field/Params.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations) (download)
Mon Apr 1 05:32:15 2002 UTC (22 years, 7 months ago) by wakaba
Branch: MAIN
Changes since 1.5: +26 -9 lines
2002-03-31  wakaba <w@suika.fam.cx>

	* URI.pm: New module.
	* Numval.pm: Likewise.

1 wakaba 1.1
2     =head1 NAME
3    
4     Message::Field::Params Perl module
5    
6     =head1 DESCRIPTION
7    
8     Perl module for parameters field body (such as C<Content-Type:>).
9    
10     =cut
11    
12     package Message::Field::Params;
13     use strict;
14     require 5.6.0;
15     use re 'eval';
16     use vars qw(%DEFAULT %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.3 require Message::Util;
19 wakaba 1.1 use Carp;
20 wakaba 1.6 use overload '@{}' => sub {shift->_delete_empty->{param}},
21 wakaba 1.1 '""' => sub {shift->stringify};
22    
23     $REG{WSP} = qr/[\x09\x20]/;
24     $REG{FWS} = qr/[\x09\x20]*/;
25    
26     $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
27     $REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
28     $REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
29 wakaba 1.5 $REG{uri_literal} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;
30    
31 wakaba 1.1 $REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
32     $REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
33     $REG{token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
34 wakaba 1.4 $REG{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+/;
35 wakaba 1.1 $REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
36 wakaba 1.3 $REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
37 wakaba 1.1
38 wakaba 1.5 $REG{param} = qr/(?:$REG{atext_dot}|$REG{quoted_string}|$REG{uri_literal})(?:$REG{atext_dot}|$REG{quoted_string}|$REG{WSP}|,)*/;
39 wakaba 1.1 ## more naive C<parameter>. (Comma is allowed for RFC 1049)
40     $REG{parameter} = qr/$REG{token}=(?:$REG{token}|$REG{quoted_string})?/;
41     ## as defined by RFC 2045, not RFC 2231.
42    
43     $REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
44     $REG{M_parameter} = qr/($REG{token})=($REG{token}|$REG{quoted_string})?/;
45     ## as defined by RFC 2045, not RFC 2231.
46     $REG{M_parameter_name} = qr/($REG{attribute_char}+)(?:\*([0-9]+)(\*)?|(\*))/;
47     ## as defined by RFC 2231.
48     $REG{M_parameter_extended_value} = qr/([^']*)'([^']*)'($REG{token}*)/;
49     ## as defined by RFC 2231, but more naive.
50    
51     $REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
52     $REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
53 wakaba 1.3 $REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
54 wakaba 1.1 $REG{NON_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
55 wakaba 1.3 $REG{NON_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
56 wakaba 1.4 $REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
57     $REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
58 wakaba 1.1 $REG{NON_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
59 wakaba 1.4 $REG{NON_http_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
60     ## Yes, C<attribute-char> does not appear in HTTP spec.
61 wakaba 1.1
62    
63     %DEFAULT = (
64 wakaba 1.2 delete_fws => 1,
65 wakaba 1.3 encoding_after_encode => '*default',
66     encoding_before_decode => '*default',
67     hook_encode_string => #sub {shift; (value => shift, @_)},
68     \&Message::Util::encode_header_string,
69     hook_decode_string => #sub {shift; (value => shift, @_)},
70     \&Message::Util::decode_header_string,
71 wakaba 1.1 parameter_value_max => 78,
72     use_parameter_extension => -1,
73 wakaba 1.5 value_type => {'*DEFAULT' => [':none:']},
74 wakaba 1.1 );
75    
76 wakaba 1.5 ## Initialization for both C<new ()> and C<parse ()> methods.
77     sub _initialize ($;%) {$_[0]}
78    
79 wakaba 1.1 =head2 Message::Field::Params->new ([%option])
80    
81     Returns new Message::Field::Params. Some options can be given as hash.
82    
83     =cut
84    
85     sub new ($;%) {
86     my $class = shift;
87 wakaba 1.6 my $self = bless {option => {@_}, param => []}, $class;
88 wakaba 1.5 $self->_initialize ();
89 wakaba 1.1 $self->_initialize_new ();
90     for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
91     $self;
92     }
93    
94     ## Initialization for new () method.
95     sub _initialize_new ($;%) {
96     my $self = shift;
97     #for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
98     }
99    
100     =head2 Message::Field::Params->parse ($nantara, [%option])
101    
102     Parse Message::Field::Params and new ContentType instance.
103     Some options can be given as hash.
104    
105     =cut
106    
107     sub parse ($$;%) {
108     my $class = shift;
109     my $body = shift;
110 wakaba 1.6 my $self = bless {option => {@_}, param => []}, $class;
111 wakaba 1.5 $self->_initialize ();
112 wakaba 1.1 $self->_initialize_parse ();
113     for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
114 wakaba 1.2 $body = $self->_delete_comment ($body);
115     $body = $self->_delete_fws ($body) if $self->{option}->{delete_fws}>0;
116 wakaba 1.1 my @b = ();
117     $body =~ s{$REG{FWS}($REG{param})$REG{FWS}(?:;$REG{FWS}|$)}{
118     my $param = $1;
119     push @b, $self->_parse_param ($param);
120     }goex;
121     @b = $self->_restore_param (@b);
122     $self->_save_param (@b);
123     $self;
124     }
125    
126     ## Initialization for parse () method.
127     sub _initialize_parse ($;%) {
128     my $self = shift;
129     #for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
130     }
131    
132     sub _parse_param ($$) {
133     my $self = shift;
134     my $param = shift;
135     if ($param =~ /^$REG{M_parameter}$/) {
136     my ($name, $value) = (lc $1, $2);
137     my ($seq, $isencoded, $charset, $lang) = (-1, 0, '', '');
138     if ($name =~ /^$REG{M_parameter_name}$/) {
139     ($name, $seq, $isencoded) = ($1, $4?-1:$2, ($3||$4)?1:0);
140     }
141     if ($isencoded && $value =~ /^$REG{M_parameter_extended_value}$/) {
142     ($charset, $lang, $value) = ($1, $2, $3);
143     }
144     return [$name, {value => $value, seq => $seq, is_encoded => $isencoded,
145     charset => $charset, language => $lang, is_parameter => 1}];
146     } else {
147     return [$param, {is_parameter => 0}];
148     }
149     }
150    
151     sub _restore_param ($@) {
152     my $self = shift;
153     my @p = @_;
154     my @ret;
155     my %part;
156     for my $i (@p) {
157     if ($i->[1]->{is_parameter}) {
158     my $p = $i->[1];
159     if ($p->{seq}<0) {
160     my $s = $p->{value};
161     if ($p->{is_encoded}) {
162     $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
163 wakaba 1.3 my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
164     language => $p->{language}, charset => $p->{charset},
165     type => 'parameter/encoded');
166     ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
167 wakaba 1.1 } else {
168 wakaba 1.3 my $q = 0;
169     ($s,$q) = $self->_unquote_if_quoted_string ($p->{value});
170     my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
171     type => ($q?'parameter/quoted':'parameter'));
172     ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
173 wakaba 1.1 }
174     push @ret, [$i->[0], {value => $s, language => $p->{language},
175     charset => $p->{charset}, is_parameter => 1}];
176     } else {
177     $part{$i->[0]}->[$p->{seq}] = {
178     value => $self->_unquote_if_quoted_string ($p->{value}),
179     language => $p->{language}, charset => $p->{charset},
180     is_encoded => $p->{is_encoded}};
181     }
182 wakaba 1.3 } else {
183     my $q = 0;
184     ($i->[0], $q) = $self->_unquote_if_quoted_string ($i->[0]);
185     my %s = &{$self->{option}->{hook_decode_string}} ($self, $i->[0],
186     type => ($q?'phrase/quoted':'phrase'));
187 wakaba 1.6 push @ret, [$s{value}, {is_parameter => 0}];
188 wakaba 1.3 }
189 wakaba 1.1 }
190     for my $name (keys %part) {
191     my $t = join '', map {
192     my $v = $_;
193     my $s = $v->{value};
194     $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg if $v->{is_encoded};
195     $s;
196     } @{$part{$name}};
197 wakaba 1.3 my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
198     type => 'parameter/encoded');
199     ($t,@part{$name}->[0]->{qw(charset language)})=(@s{qw(value charset language)});
200 wakaba 1.1 push @ret, [$name, {value => $t, charset => $part{$name}->[0]->{charset},
201     language => $part{$name}->[0]->{language},
202     is_parameter => 1}];
203     }
204     @ret;
205     }
206    
207     sub _save_param ($@) {
208     my $self = shift;
209     my @p = @_;
210     $self->{param} = \@p;
211     $self;
212     }
213    
214     =head2 $self->add ($name, [$value]. [%option]
215    
216     Adds parameter name=value pair.
217    
218     Example:
219     $self->add (title => 'foo of bar'); ## title="foo of bar"
220     $self->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
221     $self->add (foo => 'bar', language => 'en') ## foo*='en'bar
222     $self->add ('text/plain', '', value => 1) ## text/plain
223    
224     This method returns array reference of (name, {value => value, attribute...}).
225    
226     Available options: charset (charset name), language (language tag),
227     value (1/0, see example above).
228    
229     =cut
230    
231     sub add ($$;$%) {
232     my $self = shift;
233     my ($name, $value, %option) = (lc shift, shift, @_);
234     my $p = [$name, {value => $value, charset => $option{charset},
235     is_parameter => 1, language => $option{language}}];
236     $p->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
237     croak "add: \$name contains of non-attribute-char: $name"
238 wakaba 1.4 if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
239 wakaba 1.1 $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value});
240     if ($option{prepend}) {
241     unshift @{$self->{param}}, $p;
242     } else {
243     push @{$self->{param}}, $p;
244     }
245     $p;
246     }
247     sub replace ($$;$%) {
248     my $self = shift;
249     my ($name, $value, %option) = (lc shift, shift, @_);
250     for my $param (@{$self->{param}}) {
251     if ($param->[0] eq $name) {
252     $param->[1] = {value => $value, charset => $option{charset},
253     is_parameter => 1, language => $option{language}};
254     $param->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
255     $param->[1]->{value} = $self->_param_value ($name => $param->[1]->{value});
256     return $param;
257     }
258     }
259     my $p = [$name, {value => $value, charset => $option{charset},
260     is_parameter => 1, language => $option{language}}];
261     $p->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
262     croak "replace: \$name contains of non-attribute-char: $name"
263 wakaba 1.4 if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
264 wakaba 1.1 $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value});
265     push @{$self->{param}}, $p;
266     $p;
267     }
268    
269     sub delete ($$;%) {
270     my $self = shift;
271     my ($name, $index) = (lc shift, shift);
272     my $i = 0;
273     for my $param (@{$self->{param}}) {
274     if ($param->[0] eq $name) {
275     $i++;
276     if ($index == 0 || $i == $index) {
277     undef $param;
278     return $self if $i == $index;
279     }
280     }
281     }
282     $self;
283     }
284    
285     sub count ($;$%) {
286     my $self = shift;
287     my ($name) = (lc shift);
288     unless ($name) {
289     $self->_delete_empty ();
290     return $#{$self->{param}}+1;
291     }
292     my $count = 0;
293     for my $param (@{$self->{param}}) {
294     if ($param->[0] eq $name) {
295     $count++;
296     }
297     }
298     $count;
299     }
300    
301    
302     sub parameter ($$;$) {
303     my $self = shift;
304     my $name = lc shift;
305     my $newvalue = shift;
306     return $self->replace ($name => $newvalue,@_)->[1]->{value} if defined $newvalue;
307     my @ret;
308     for my $param (@{$self->{param}}) {
309     if ($param->[0] eq $name) {
310     unless (wantarray) {
311 wakaba 1.3 $param->[1]->{value}
312     = $self->_param_value ($name => $param->[1]->{value});
313 wakaba 1.1 return $param->[1]->{value};
314     } else {
315 wakaba 1.3 $param->[1]->{value}
316     = $self->_param_value ($name => $param->[1]->{value});
317 wakaba 1.1 push @ret, $param->[1]->{value};
318     }
319     }
320     }
321     @ret;
322     }
323    
324     sub parameter_name ($$;$) {
325     my $self = shift;
326     my $i = shift;
327     my $newname = shift;
328     if ($newname) {
329 wakaba 1.4 return 0 if $newname =~ /$REG{NON_http_attribute_char}/;
330 wakaba 1.1 $self->{param}->[$i]->[0] = $newname;
331     }
332     $self->{param}->[$i]->[0];
333     }
334     sub parameter_value ($$;$) {
335     my $self = shift;
336     my $i = shift;
337     my $newvalue = shift;
338     if ($newvalue) {
339     $newvalue = $self->_param_value ($self->{param}->[$i]->[0] => $newvalue);
340     $self->{param}->[$i]->[1]->{value} = $newvalue;
341     }
342     $self->{param}->[$i]->[1]->{value}
343     = $self->_param_value
344     ($self->{param}->[$i]->[0] => $self->{param}->[$i]->[1]->{value});
345     $self->{param}->[$i]->[1]->{value};
346     }
347    
348 wakaba 1.6 sub value_type ($;$$%) {
349     my $self = shift;
350     my $name = shift || '*DEFAULT';
351     my $new_value_type = shift;
352     if ($new_value_type) {
353     $self->{option}->{value_type}->{$name} = []
354     unless ref $self->{option}->{value_type}->{$name};
355     $self->{option}->{value_type}->{$name}->[0] = $new_value_type;
356     }
357     if (ref $self->{option}->{value_type}->{$name}) {
358     $self->{option}->{value_type}->{$name}->[0]
359     || $self->{option}->{value_type}->{'*DEFAULT'}->[0];
360     } else {
361     $self->{option}->{value_type}->{'*DEFAULT'}->[0];
362     }
363     }
364    
365 wakaba 1.1 ## Hook called before returning C<value>.
366     ## $self->_param_value ($name, $value);
367 wakaba 1.5 sub _param_value ($$$) {
368     my $self = shift;
369     my $name = shift || '*DEFAULT';
370     my $value = shift;
371 wakaba 1.6 my $vtype = $self->{option}->{value_type}->{$name}->[0]
372     || $self->{option}->{value_type}->{'*DEFAULT'}->[0];
373 wakaba 1.5 my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]}
374     if ref $self->{option}->{value_type}->{$name}->[1];
375     if (ref $value) {
376     return $value;
377     } elsif ($vtype eq ':none:') {
378     return $value;
379     } elsif ($value) {
380     eval "require $vtype";
381     return $vtype->parse ($value, %vopt);
382     } else {
383     eval "require $vtype";
384     return $vtype->new (%vopt);
385     }
386     }
387 wakaba 1.1
388     sub _delete_empty ($) {
389     my $self = shift;
390     my @ret;
391     for my $param (@{$self->{param}}) {
392 wakaba 1.6 push @ret, $param if ref $param;
393 wakaba 1.1 }
394     $self->{param} = \@ret;
395     $self;
396     }
397    
398    
399     =head2 $self->stringify ([%option])
400    
401     Returns Message::Field::Params as a string.
402    
403     =head2 $self->as_string ([%option])
404    
405     An alias of C<stringify>.
406    
407     =cut
408    
409     sub stringify ($;%) {
410     my $self = shift;
411     my %option = @_;
412     my $use_xparam = $option{use_parameter_extension}
413     || $self->{option}->{use_parameter_extension};
414     $option{parameter_value_max}
415     ||= $self->{option}->{parameter_value_max};
416     $self->_delete_empty ();
417     join '; ',
418     map {
419     my $v = $_->[1];
420     my $new = '';
421     if ($v->{is_parameter}) {
422     my ($encoded, @value) = (0, '');
423 wakaba 1.3 my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
424     $v->{value}, current_charset => $v->{charset}, language => $v->{language},
425     type => 'parameter');
426     if ($use_xparam>0 && ($e{charset} || $e{language}
427     || $e{value} =~ /[\x00\x0D\x0A\x80-\xFF]/)) {
428 wakaba 1.1 my ($charset, $lang);
429     $encoded = 1;
430 wakaba 1.3 ($charset, $lang) = ($e{charset}, $e{language});
431 wakaba 1.1 ## Note: %-quoting for charset and for language is not allowed.
432     ## But charset name can be included non-sttribute-char such as "'".
433     ## How can we treat this?
434 wakaba 1.4 $charset =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
435     $lang =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
436 wakaba 1.3 if (length $e{value} > $option{parameter_value_max}) {
437     for my $i (0..length ($e{value})/$option{parameter_value_max}) {
438     $value[$i] = substr ($e{value}, $i*$option{parameter_value_max},
439 wakaba 1.1 $option{parameter_value_max});
440     }
441 wakaba 1.3 } else {$value[0] = $e{value}}
442 wakaba 1.1 for my $i (0..$#value) {
443 wakaba 1.4 $value[$i] =~
444     s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
445 wakaba 1.1 }
446     $value[0] = "${charset}'${lang}'".$value[0];
447 wakaba 1.3 } elsif (length $e{value} == 0) {
448 wakaba 1.1 $value[0] = '""';
449     } else {
450 wakaba 1.3 if ($use_xparam>0 && length $e{value} > $option{parameter_value_max}) {
451     for my $i (0..length ($e{value})/$option{parameter_value_max}) {
452 wakaba 1.1 $value[$i] = $self->_quote_unsafe_string
453 wakaba 1.3 (substr ($e{value}, $i*$option{parameter_value_max},
454 wakaba 1.4 $option{parameter_value_max}),
455     unsafe => 'NON_http_attribute_char');
456 wakaba 1.1 }
457     } else {
458     $value[0] = $self->_quote_unsafe_string
459 wakaba 1.4 ($e{value}, unsafe => 'NON_http_attribute_char');
460 wakaba 1.1 }
461     }
462     ## Note: quoted-string for parameter name is not allowed.
463     ## But it is better than output bare non-atext.
464     if ($#value == 0) {
465     $new =
466     $self->_quote_unsafe_string ($_->[0], unsafe => 'NON_attribute_char')
467     .($encoded?'*':'').'='.$value[0];
468     } else {
469     my @new;
470     my $name = $self->_quote_unsafe_string
471 wakaba 1.4 ($_->[0], unsafe => 'NON_http_attribute_char');
472 wakaba 1.1 for my $i (0..$#value) {
473     push @new, $name.'*'.$i.($encoded?'*':'').'='.$value[$i];
474     }
475     $new = join '; ', @new;
476     }
477     } else {
478 wakaba 1.3 my %e = &{$self->{option}->{hook_encode_string}} ($self,
479     $_->[0], type => 'phrase');
480 wakaba 1.4 $new = $self->_quote_unsafe_string ($e{value},
481     unsafe => 'NON_http_token_wsp');
482 wakaba 1.1 }
483     $new;
484     } @{$self->{param}}
485     ;
486     }
487     sub as_string ($;%) {shift->stringify (@_)}
488    
489     =head2 $self->option ($option_name)
490    
491     Returns/set (new) value of the option.
492    
493     =cut
494    
495     sub option ($$;$) {
496     my $self = shift;
497     my ($name, $newval) = @_;
498     if ($newval) {
499     $self->{option}->{$name} = $newval;
500     }
501     $self->{option}->{$name};
502     }
503    
504     sub _quote_unsafe_string ($$;%) {
505     my $self = shift;
506     my $string = shift;
507     my %option = @_;
508     $option{unsafe} ||= 'NON_atext_dot';
509 wakaba 1.5 $option{unsafe_regex} ||= $REG{$option{unsafe}};
510     if ($string =~ /$option{unsafe_regex}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
511 wakaba 1.4 $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
512 wakaba 1.1 $string = '"'.$string.'"';
513     }
514     $string;
515     }
516    
517     =head2 $self->_unquote_quoted_string ($string)
518    
519     Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
520     C<REVERSED SOLIDUS> included in C<quoted-pair>.
521     This method is intended for internal use.
522    
523     =cut
524    
525     sub _unquote_quoted_string ($$) {
526     my $self = shift;
527     my $quoted_string = shift;
528     $quoted_string =~ s{$REG{M_quoted_string}}{
529     my $qtext = $1;
530     $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
531     $qtext;
532     }goex;
533     $quoted_string;
534     }
535    
536 wakaba 1.4 ## Unquote C<DQOUTE> and C<quoted-pair> if it is itself a
537     ## C<quoted-string>. (Do nothing if it is MULTIPLE
538     ## C<quoted-string>"S".)
539 wakaba 1.1 sub _unquote_if_quoted_string ($$) {
540     my $self = shift;
541 wakaba 1.3 my $quoted_string = shift; my $isq = 0;
542 wakaba 1.1 $quoted_string =~ s{^$REG{M_quoted_string}$}{
543     my $qtext = $1;
544     $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
545 wakaba 1.3 $isq = 1;
546 wakaba 1.1 $qtext;
547     }goex;
548 wakaba 1.3 wantarray? ($quoted_string, $isq): $quoted_string;
549 wakaba 1.1 }
550    
551     =head2 $self->_delete_comment ($field_body)
552    
553     Remove all C<comment> in given strictured C<field-body>.
554     This method is intended for internal use.
555    
556     =cut
557    
558     sub _delete_comment ($$) {
559     my $self = shift;
560     my $body = shift;
561 wakaba 1.5 $body =~ s{($REG{quoted_string}|$REG{uri_literal}|$REG{domain_literal})|$REG{comment}}{
562 wakaba 1.1 my $o = $1; $o? $o : ' ';
563     }gex;
564     $body;
565     }
566    
567     sub _delete_fws ($$) {
568     my $self = shift;
569     my $body = shift;
570 wakaba 1.3 $body =~ s{($REG{quoted_string}|$REG{domain_literal})|((?:$REG{token}|$REG{S_encoded_word})(?:$REG{WSP}+(?:$REG{token}|$REG{S_encoded_word}))+)|$REG{WSP}+}{
571     my ($o,$p) = ($1,$2);
572     if ($o) {$o}
573     elsif ($p) {$p=~s/$REG{WSP}+/\x20/g;$p}
574     else {''}
575 wakaba 1.1 }gex;
576     $body;
577     }
578    
579     =head1 LICENSE
580    
581     Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
582    
583     This program is free software; you can redistribute it and/or modify
584     it under the terms of the GNU General Public License as published by
585     the Free Software Foundation; either version 2 of the License, or
586     (at your option) any later version.
587    
588     This program is distributed in the hope that it will be useful,
589     but WITHOUT ANY WARRANTY; without even the implied warranty of
590     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
591     GNU General Public License for more details.
592    
593     You should have received a copy of the GNU General Public License
594     along with this program; see the file COPYING. If not, write to
595     the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
596     Boston, MA 02111-1307, USA.
597    
598     =head1 CHANGE
599    
600     See F<ChangeLog>.
601 wakaba 1.6 $Date: 2002/03/31 13:11:55 $
602 wakaba 1.1
603     =cut
604    
605     1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24