Message/Field/ValueParams.pm


=head1 NAME

Message::Field::ValueParams --- Perl module for "word; parameter(s)" style
Internet message field bodies

=cut

package Message::Field::ValueParams;
use strict;
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::Params;
push @ISA, qw(Message::Field::Params);

use overload '+=' => sub { $_[0]->{value} = $_[0]->{value} + $_[1]; $_[0] },
             '-=' => sub { $_[0]->{value} = $_[0]->{value} - $_[1]; $_[0] },
             '*=' => sub { $_[0]->{value} = $_[0]->{value} * $_[1]; $_[0] },
             '**=' => sub { $_[0]->{value} = $_[0]->{value} ** $_[1]; $_[0] },
             '/=' => sub { $_[0]->{value} = $_[0]->{value} / $_[1]; $_[0] },
             '%=' => sub { $_[0]->{value} = $_[0]->{value} % $_[1]; $_[0] },
             fallback => 1;

*REG = \%Message::Field::Params::REG;
## Inherited: comment, quoted_string, domain_literal, angle_quoted
        ## WSP, FWS, atext, atext_dot, token, attribute_char
        ## S_encoded_word
        ## M_quoted_string
        ## param, parameter
        ## M_parameter, M_parameter_name, M_parameter_extended_value

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    #delete_fws ## Inheritted
    #encoding_after_encode      ## Inherited
    #encoding_before_decode     ## Inherited
    #format     ## Inherited
    #hook_encode_string ## Inherited
    #hook_decode_string ## Inherited
    #parameter_name_case_sensible       ## Inherited
    #parameter_value_max_length ## Inherited
    #parse_all  ## Inherited
    #use_parameter_extension    ## Inherited
    -value_case_sensible        => 1,
    -value_default      => '',
    -value_no_regex     => qr/(?!)/,    ## default = (none)
    -value_regex        => qr/[\x00-\xFF]+/,
    #value_type ## Inherited
  );
  $self->SUPER::_init (%DEFAULT, %options);
  
  #my $fname = $self->_n11n_field_name ($self->{option}->{field_name});
  my $fname = $self->{option}->{field_name};
  my $format = $self->{option}->{format};
  if ($fname eq 'content-disposition') {
    $self->{option}->{value_case_sensible} = 0;
    $self->{option}->{value_default} = 'inline';
    $self->{option}->{value_no_regex} = $REG{NON_token};
    unless ($self->{option}->{format} =~ /^http/) {
      $self->{option}->{value_no_regex} = $REG{NON_http_token};
      $self->{option}->{use_parameter_extension} = 1;
    }
    $self->{option}->{value_type}->{'creation-date'} = ['Message::Field::Date'];
    $self->{option}->{value_type}->{'modification-date'} = ['Message::Field::Date'];
    $self->{option}->{value_type}->{'read-date'} = ['Message::Field::Date'];
  } elsif ($fname eq 'content-transfer-encoding') {
    $self->{option}->{value_case_sensible} = 0;
    $self->{option}->{value_no_regex} = $REG{NON_token};
    if ($format =~ /http/) {
      $self->{option}->{value_default} = 'binary';
    } elsif ($format =~ /news-usefor/) {
      $self->{option}->{value_default} = '8bit';
    } else {
      $self->{option}->{value_default} = '7bit';
    }
  } elsif ($fname eq 'link') {
    $self->{option}->{parameter_value_unsafe_rule}->{'*value'} = 'MATCH_NONE';
    $self->{option}->{value_type}->{'*value'} = ['Message::Field::URI'];
  } elsif ($fname eq 'auto-submitted') {
    $self->{option}->{parameter_value_unsafe_rule}->{'*value'} = 'NON_token';
    $self->{option}->{value_type}->{increment} = ['Message::Field::Numval'];
  } else {
    $self->{option}->{parameter_value_unsafe_rule}->{'*value'}
      = 'NON_http_token_wsp';
  }
}

## Initialization for new () method.
sub _initialize_new ($;%) {
  my $self = shift;
  $self->{value} = $self->{option}->{value_default};
}

## Initialization for parse () method.
#sub _initialize_parse ($;%) {
  ## Inherited
#}

=item $vp = Message::Field::ValueParams->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $vp = Message::Field::ValueParams->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

## Inherited

sub _save_param ($@) {
  my $self = shift;
  my @p = @_;
  $self->{value} = $self->{option}->{value_default};
  if (@p > 0 && $p[0]->[1]->{is_parameter} == 0) {
    my $type = shift (@p)->[0];
    if ($type && $type !~ /$self->{option}->{value_no_regex}/) {
      $self->{value} = $type;
    } elsif ($type) {
      push @p, ['x-invalid-value' => {value => $type, is_parameter => 1}];
    }
  }
  #$self->{param} = \@p;
  $self->SUPER::_save_param (@p);
  $self;
}

=back

=head1 METHODS

=over 4

=item $vp->add ($name => [$value], [$name => $value,...])

Sets new parameter C<value> of $name.

  Example:
    $vp->add (title => 'foo of bar');   ## title="foo of bar"
    $vp->add (subject => 'hogehoge, foo');      ## subject*=''hogehoge%2C%20foo
    $vp->add (foo => 'bar', language => 'en')   ## foo*='en'bar

This method returns array reference of (name, {value => value, attribute...}).
C<value> is same as returned value of C<$self-E<gt>parameter>.

Available options: charset (charset name), language (language tag),
value (1/0, see example above).

=item $vp->replace ($name => [$value], [$name => $value,...])

=item $count = $vp->count

Returns the number of C<parameter>s.

=item $param-value = $vp->parameter ($name, [$new_value])

Returns given C<name>'ed C<parameter>'s C<value>.

Note that when $self->{option}->{value_type}->{$name}
is defined (and it is class name), returned value
is a reference to the object.

=item $param-name = $vp->parameter_name ($index, [$new_name])

Returns (and set) C<$index>'th C<parameter>'s name.

=item $param-value = $vp->parameter_value ($index, [$new_value])

Returns (and set) C<$index>'th C<parameter>'s value.

Note that when $self->{option}->{value_type}->{$name}
is defined (and it is class name), returned value
is a reference to the object.

=cut

## add, replace, count, parameter, parameter_name, parameter_value: Inherited.

## Hook called before returning C<value>.
## $self->_param_value ($name, $value);
## -- Inherited.

=item $field-body = $vp->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my $param = $self->SUPER::stringify (@_);
  $self->value_as_string (@_).(length $param? '; '.$param: '');
}
*as_string = \&stringify;

## This method is intended to be used by child classes
sub stringify_params ($;%) {
  shift->SUPER::stringify (@_);
}

=item $value = $vp->value ([$new_value])

Returns or set value.

=cut

sub value ($;$%) {
  my $self = shift;
  my $new_value = shift;
  my %option = @_;
  if (defined $new_value && $new_value !~ m#$self->{option}->{value_no_regex}#) {
    $self->{value} = $new_value;
  }
  $self->{value} = $self->_parse_value ('*value' => $self->{value});
  $self->{option}->{value_case_sensible}? $self->{value}: lc $self->{value};
}

=item $value = $vp->value_as_string ([%options])

Returns value.  If necessary, quoted and encoded in
message format.  Same as C<stringify> except that
only first "value" is outputed.

=cut

sub value_as_string ($;%) {
  my $self = shift;
  my (%e) = &{$self->{option}->{hook_encode_string}} ($self, 
          $self->{value}, type => 'phrase');
  my $unsafe_rule = $self->{option}->{parameter_value_unsafe_rule}->{'*value'};
  Message::Util::quote_unsafe_string ($e{value}, unsafe => $unsafe_rule);
}


=item $option-value = $vp->option ($option-name)

Gets option value.

=item $vp->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited.

=item $clone = $ua->clone ()

Returns a copy of the object.

=cut

## Inherited

=head1 EXAMPLE

  use Message::Field::ValueParams;
  my $cd = new Message::Field::ValueParams (-field_name => 'Content-Disposition');
  $cd->type ('attachment');
  $cd->parameter ('filename' => 'foobar');
  $cd->parameter ('creation-date' => '')->unix_time (0);
  print $cd;    ## attachment; filename=foobar; 
                ## creation-date="Thr, 01 Jan 1970 00:00:00 +0000"

  use Message::Field::ValueParams;
  my $b = q{attachment; filename*=iso-2022-jp''%1B%24B%25U%25%21%25%24%25k%1B%28B};
  my $cd = Message::Field::ValueParams->parse ($b,
                    -field_name => 'Content-Disposition');
  my $filename = $cd->parameter ('FileName');
  if (!$filename || $filename =~ /[^A-Za-z0-9.,_~=+-]/ || -e $filename) {
    ## $filename can be unsafe, see RFC 2183.
    $filename = 'default';
  }
  open MSG, "> $filename";
    print $something;
  close MSG;

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<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/06/09 11:08:28 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.6	Message::Field::ValueParams --- Perl module for "word; parameter(s)" style
5			Internet message field bodies
6	wakaba	1.1
7			=cut
8
9			package Message::Field::ValueParams;
10			use strict;
11	wakaba	1.6	use vars qw(@ISA %REG $VERSION);
12	wakaba	1.9	$VERSION=do{my @r=(q$Revision: 1.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.6	require Message::Field::Params;
14			push @ISA, qw(Message::Field::Params);
15
16			use overload '+=' => sub { $_[0]->{value} = $_[0]->{value} + $_[1]; $_[0] },
17			'-=' => sub { $_[0]->{value} = $_[0]->{value} - $_[1]; $_[0] },
18			'=' => sub { $_[0]->{value} = $_[0]->{value} $_[1]; $_[0] },
19			'=' => sub { $_[0]->{value} = $_[0]->{value} $_[1]; $_[0] },
20			'/=' => sub { $_[0]->{value} = $_[0]->{value} / $_[1]; $_[0] },
21			'%=' => sub { $_[0]->{value} = $_[0]->{value} % $_[1]; $_[0] },
22			fallback => 1;
23
24			*REG = \%Message::Field::Params::REG;
25			## Inherited: comment, quoted_string, domain_literal, angle_quoted
26			## WSP, FWS, atext, atext_dot, token, attribute_char
27			## S_encoded_word
28			## M_quoted_string
29			## param, parameter
30			## M_parameter, M_parameter_name, M_parameter_extended_value
31
32			=head1 CONSTRUCTORS
33	wakaba	1.4
34	wakaba	1.6	The following methods construct new objects:
35	wakaba	1.1
36	wakaba	1.6	=over 4
37	wakaba	1.1
38			=cut
39
40	wakaba	1.6	## Initialize of this class -- called by constructors
41			sub _init ($;%) {
42			my $self = shift;
43			my %options = @_;
44			my %DEFAULT = (
45			#delete_fws ## Inheritted
46			#encoding_after_encode ## Inherited
47			#encoding_before_decode ## Inherited
48			#format ## Inherited
49			#hook_encode_string ## Inherited
50			#hook_decode_string ## Inherited
51			#parameter_name_case_sensible ## Inherited
52			#parameter_value_max_length ## Inherited
53			#parse_all ## Inherited
54			#use_parameter_extension ## Inherited
55			-value_case_sensible => 1,
56			-value_default => '',
57			-value_no_regex => qr/(?!)/, ## default = (none)
58			-value_regex => qr/[\x00-\xFF]+/,
59			#value_type ## Inherited
60			);
61			$self->SUPER::_init (%DEFAULT, %options);
62
63	wakaba	1.8	#my $fname = $self->_n11n_field_name ($self->{option}->{field_name});
64			my $fname = $self->{option}->{field_name};
65			my $format = $self->{option}->{format};
66	wakaba	1.6	if ($fname eq 'content-disposition') {
67			$self->{option}->{value_case_sensible} = 0;
68			$self->{option}->{value_default} = 'inline';
69			$self->{option}->{value_no_regex} = $REG{NON_token};
70			unless ($self->{option}->{format} =~ /^http/) {
71			$self->{option}->{value_no_regex} = $REG{NON_http_token};
72			$self->{option}->{use_parameter_extension} = 1;
73			}
74			$self->{option}->{value_type}->{'creation-date'} = ['Message::Field::Date'];
75			$self->{option}->{value_type}->{'modification-date'} = ['Message::Field::Date'];
76			$self->{option}->{value_type}->{'read-date'} = ['Message::Field::Date'];
77	wakaba	1.8	} elsif ($fname eq 'content-transfer-encoding') {
78			$self->{option}->{value_case_sensible} = 0;
79			$self->{option}->{value_no_regex} = $REG{NON_token};
80			if ($format =~ /http/) {
81			$self->{option}->{value_default} = 'binary';
82			} elsif ($format =~ /news-usefor/) {
83			$self->{option}->{value_default} = '8bit';
84			} else {
85			$self->{option}->{value_default} = '7bit';
86			}
87	wakaba	1.6	} elsif ($fname eq 'link') {
88			$self->{option}->{parameter_value_unsafe_rule}->{'*value'} = 'MATCH_NONE';
89			$self->{option}->{value_type}->{'*value'} = ['Message::Field::URI'];
90	wakaba	1.7	} elsif ($fname eq 'auto-submitted') {
91			$self->{option}->{parameter_value_unsafe_rule}->{'*value'} = 'NON_token';
92			$self->{option}->{value_type}->{increment} = ['Message::Field::Numval'];
93	wakaba	1.6	} else {
94			$self->{option}->{parameter_value_unsafe_rule}->{'*value'}
95			= 'NON_http_token_wsp';
96			}
97			}
98	wakaba	1.1
99			## Initialization for new () method.
100			sub _initialize_new ($;%) {
101			my $self = shift;
102	wakaba	1.6	$self->{value} = $self->{option}->{value_default};
103	wakaba	1.1	}
104
105			## Initialization for parse () method.
106	wakaba	1.6	#sub _initialize_parse ($;%) {
107			## Inherited
108			#}
109
110			=item $vp = Message::Field::ValueParams->new ([%options])
111
112			Constructs a new object. You might pass some options as parameters
113			to the constructor.
114
115			=cut
116
117			## Inherited
118	wakaba	1.1
119	wakaba	1.6	=item $vp = Message::Field::ValueParams->parse ($field-body, [%options])
120	wakaba	1.1
121	wakaba	1.6	Constructs a new object with given field body. You might pass
122			some options as parameters to the constructor.
123	wakaba	1.1
124			=cut
125
126			## Inherited
127
128			sub _save_param ($@) {
129			my $self = shift;
130			my @p = @_;
131	wakaba	1.6	$self->{value} = $self->{option}->{value_default};
132	wakaba	1.9	if (@p > 0 && $p[0]->[1]->{is_parameter} == 0) {
133	wakaba	1.1	my $type = shift (@p)->[0];
134			if ($type && $type !~ /$self->{option}->{value_no_regex}/) {
135			$self->{value} = $type;
136			} elsif ($type) {
137			push @p, ['x-invalid-value' => {value => $type, is_parameter => 1}];
138			}
139			}
140	wakaba	1.5	#$self->{param} = \@p;
141			$self->SUPER::_save_param (@p);
142	wakaba	1.1	$self;
143			}
144
145	wakaba	1.6	=back
146
147			=head1 METHODS
148
149			=over 4
150
151			=item $vp->add ($name => [$value], [$name => $value,...])
152	wakaba	1.1
153			Sets new parameter C<value> of $name.
154
155			Example:
156	wakaba	1.6	$vp->add (title => 'foo of bar'); ## title="foo of bar"
157			$vp->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
158			$vp->add (foo => 'bar', language => 'en') ## foo*='en'bar
159	wakaba	1.1
160			This method returns array reference of (name, {value => value, attribute...}).
161			C<value> is same as returned value of C<$self-E<gt>parameter>.
162
163			Available options: charset (charset name), language (language tag),
164			value (1/0, see example above).
165
166	wakaba	1.6	=item $vp->replace ($name => [$value], [$name => $value,...])
167	wakaba	1.1
168	wakaba	1.6	=item $count = $vp->count
169	wakaba	1.1
170	wakaba	1.6	Returns the number of C<parameter>s.
171
172			=item $param-value = $vp->parameter ($name, [$new_value])
173	wakaba	1.1
174			Returns given C<name>'ed C<parameter>'s C<value>.
175
176			Note that when $self->{option}->{value_type}->{$name}
177			is defined (and it is class name), returned value
178			is a reference to the object.
179
180	wakaba	1.6	=item $param-name = $vp->parameter_name ($index, [$new_name])
181	wakaba	1.1
182			Returns (and set) C<$index>'th C<parameter>'s name.
183
184	wakaba	1.6	=item $param-value = $vp->parameter_value ($index, [$new_value])
185	wakaba	1.1
186			Returns (and set) C<$index>'th C<parameter>'s value.
187
188			Note that when $self->{option}->{value_type}->{$name}
189			is defined (and it is class name), returned value
190			is a reference to the object.
191
192			=cut
193
194	wakaba	1.6	## add, replace, count, parameter, parameter_name, parameter_value: Inherited.
195	wakaba	1.1
196			## Hook called before returning C<value>.
197			## $self->_param_value ($name, $value);
198	wakaba	1.4	## -- Inherited.
199	wakaba	1.1
200	wakaba	1.6	=item $field-body = $vp->stringify ()
201	wakaba	1.1
202	wakaba	1.6	Returns C<field-body> as a string.
203	wakaba	1.1
204			=cut
205
206			sub stringify ($;%) {
207			my $self = shift;
208			my $param = $self->SUPER::stringify (@_);
209	wakaba	1.7	$self->value_as_string (@_).(length $param? '; '.$param: '');
210	wakaba	1.6	}
211			*as_string = \&stringify;
212
213			## This method is intended to be used by child classes
214			sub stringify_params ($;%) {
215			shift->SUPER::stringify (@_);
216	wakaba	1.1	}
217
218	wakaba	1.6	=item $value = $vp->value ([$new_value])
219	wakaba	1.1
220			Returns or set value.
221
222			=cut
223
224	wakaba	1.2	sub value ($;$%) {
225	wakaba	1.1	my $self = shift;
226			my $new_value = shift;
227	wakaba	1.2	my %option = @_;
228	wakaba	1.6	if (defined $new_value && $new_value !~ m#$self->{option}->{value_no_regex}#) {
229	wakaba	1.1	$self->{value} = $new_value;
230			}
231	wakaba	1.8	$self->{value} = $self->_parse_value ('*value' => $self->{value});
232	wakaba	1.6	$self->{option}->{value_case_sensible}? $self->{value}: lc $self->{value};
233	wakaba	1.2	}
234
235	wakaba	1.6	=item $value = $vp->value_as_string ([%options])
236	wakaba	1.2
237			Returns value. If necessary, quoted and encoded in
238			message format. Same as C<stringify> except that
239			only first "value" is outputed.
240
241			=cut
242
243			sub value_as_string ($;%) {
244			my $self = shift;
245			my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
246			$self->{value}, type => 'phrase');
247	wakaba	1.6	my $unsafe_rule = $self->{option}->{parameter_value_unsafe_rule}->{'*value'};
248			Message::Util::quote_unsafe_string ($e{value}, unsafe => $unsafe_rule);
249	wakaba	1.1	}
250
251
252	wakaba	1.6	=item $option-value = $vp->option ($option-name)
253
254			Gets option value.
255	wakaba	1.1
256	wakaba	1.6	=item $vp->option ($option-name, $option-value, ...)
257
258			Set option value(s). You can pass multiple option name-value pair
259			as parameter when setting.
260	wakaba	1.1
261			=cut
262
263			## Inherited.
264
265	wakaba	1.6	=item $clone = $ua->clone ()
266
267			Returns a copy of the object.
268
269			=cut
270
271			## Inherited
272
273			=head1 EXAMPLE
274
275			use Message::Field::ValueParams;
276			my $cd = new Message::Field::ValueParams (-field_name => 'Content-Disposition');
277			$cd->type ('attachment');
278			$cd->parameter ('filename' => 'foobar');
279			$cd->parameter ('creation-date' => '')->unix_time (0);
280			print $cd; ## attachment; filename=foobar;
281			## creation-date="Thr, 01 Jan 1970 00:00:00 +0000"
282
283			use Message::Field::ValueParams;
284			my $b = q{attachment; filename*=iso-2022-jp''%1B%24B%25U%25%21%25%24%25k%1B%28B};
285			my $cd = Message::Field::ValueParams->parse ($b,
286			-field_name => 'Content-Disposition');
287			my $filename = $cd->parameter ('FileName');
288			if (!$filename \|\| $filename =~ /[^A-Za-z0-9.,_~=+-]/ \|\| -e $filename) {
289			## $filename can be unsafe, see RFC 2183.
290			$filename = 'default';
291			}
292			open MSG, "> $filename";
293			print $something;
294			close MSG;
295	wakaba	1.1
296			=head1 LICENSE
297
298			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
299
300			This program is free software; you can redistribute it and/or modify
301			it under the terms of the GNU General Public License as published by
302			the Free Software Foundation; either version 2 of the License, or
303			(at your option) any later version.
304
305			This program is distributed in the hope that it will be useful,
306			but WITHOUT ANY WARRANTY; without even the implied warranty of
307			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
308			GNU General Public License for more details.
309
310			You should have received a copy of the GNU General Public License
311			along with this program; see the file COPYING. If not, write to
312			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
313			Boston, MA 02111-1307, USA.
314
315			=head1 CHANGE
316
317			See F<ChangeLog>.
318	wakaba	1.9	$Date: 2002/06/09 11:08:28 $
319	wakaba	1.1
320			=cut
321
322			1;