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(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.11 $=~/\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

%DEFAULT = (
        #_HASH_NAME
        #_MEMBERS
        #_METHODS
        #accept_coderange
        #encoding_after_encode
        #encoding_before_decode
        #field_param_name
        #field_name
        #field_ns
        #format
        #header_default_charset
        #header_default_charset_input
        #hook_encode_string
        #hook_decode_string
        #output_comment
        #output_parameter_extension
        #parameter_rule
        #parameter_attribute_case_sensible
        #parameter_attribute_unsafe_rule
        #parameter_av_Mrule
        #parameter_no_value_attribute_unsafe_rule
        #parameter_value_max_length
        #parameter_value_split_length
        #parameter_value_unsafe_rule
        #parse_all
        #separator
        #separator_rule
        #use_comment
        #use_parameter_extension
        -value_case_sensible    => 1,
        -value_default  => '',
        #value_type
        -value_unsafe_rule      => 'NON_http_attribute_char',
);

=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 = @_;
  $self->SUPER::_init (%DEFAULT, %options);
  push @{$self->{option}->{_METHODS}}, 'value';
  
  my $fname = $self->{option}->{field_name};
  my $format = $self->{option}->{format};
  if ($fname eq 'disposition') {        ## Content-Disposition
    $self->{option}->{value_case_sensible} = 0;
    $self->{option}->{value_default} = 'inline';
    unless ($self->{option}->{format} =~ /http/) {
      $self->{option}->{output_parameter_extension} = 1;
    }
    my $dateclass = ['Message::Field::Date', {format => 'mail-rfc822+rfc1123'}];
    $self->{option}->{value_type}->{'creation-date'} = $dateclass;
    $self->{option}->{value_type}->{'modification-date'} = $dateclass;
    $self->{option}->{value_type}->{'read-date'} = $dateclass;
  } elsif ($fname eq 'transfer-encoding') {     ## Content-Transfer-Encoding
    $self->{option}->{value_case_sensible} = 0;
    if ($format =~ /http/) {
      $self->{option}->{value_default} = 'binary';
    } else {
      $self->{option}->{value_default} = '7bit';
    }
    $self->{option}->{output_parameter_extension} = 1;
  } elsif ($fname eq 'link') {
    $self->{option}->{value_type}->{'*value'} = ['Message::Field::URI'];
  } elsif ($fname eq 'auto-submitted') {
    $self->{option}->{value_type}->{increment} = ['Message::Field::Numval'];
  } elsif ($fname eq 'opt' || $fname eq 'man') {
    $self->{option}->{value_unsafe_rule} = 'MATCH_ALL';
  } elsif ($fname eq 'version') {       ## Content-Version [RFC 2068]
    $self->{option}->{value_unsafe_rule} = 'MATCH_ALL';
  }
  $self->{value} = $self->{option}->{value_default};
}

=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

## $self->_save_parameters (\@parameter, \%option)
## -- Save parameters in $self
sub _save_parameters ($\@\%) {
  my $self = shift;
  my ($param, $option) = @_;
  if ($param->[0]->{no_value}) {
    $self->{value} = shift (@$param)->{attribute};
    $self->{value} = $self->_parse_value ('*value' => $self->{value})
      if $option->{parse_all};
  }
  $self->SUPER::_save_parameters ($param, $option);
}

=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.

=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) {
    $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->stringify_value ([%options])

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

=cut

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


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

Returns C<field-body> as a string.

=cut

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

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

=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.

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  $self->{value}->option (%$o) if ref $self->{value};
  $self->SUPER::_option_recursive (%$o);
}

=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/07/06 10:30:43 $

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