Message/Field/ValueParams.pm


=head1 NAME

Message::Field::ValueParams Perl module

=head1 DESCRIPTION

Perl module for "word; parameter(s)" style field body.

=cut

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

%REG = %Message::Field::Params::REG;

%DEFAULT = (
  use_parameter_extension       => 1,
  value_default => '',
  value_no_regex        => qr/(?!)/,    ## default = (none)
  value_regex   => qr/[\x00-\xFF]+/,
  value_unsafe_rule     => 'NON_http_token_wsp',
);

## Initialization for both C<new ()> and C<parse ()> methods.
sub _initialize ($;%) {
  my $self = shift;
  my $fname = lc $self->{option}->{field_name};
  if ($fname eq 'link') {
    $REG{r_nomatch} = qr/(?!)/;
    $self->{option}->{value_unsafe_rule} = 'r_nomatch';
    $self->{option}->{value_type}->{'*value'} = ['Message::Field::URI',
      {field_name => $self->{option}->{field_name},
      format => $self->{option}->{format}}];
  }
  $self;
}

=head2 Message::Field::ValueParams->new ([%option])

Returns new Message::Field::ValueParams.  Some options can be given as hash.

=cut

## Inherited

## Initialization for new () method.
sub _initialize_new ($;%) {
  my $self = shift;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->{word} = $self->{option}->{value_default};
}

## Initialization for parse () method.
sub _initialize_parse ($;%) {
  my $self = shift;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
}

=head2 Message::Field::ValueParams->parse ($nantara, [%option])

Parse Message::Field::ValueParams and new ValueParams instance.  
Some options can be given as hash.

=cut

## Inherited

sub _save_param ($@) {
  my $self = shift;
  my @p = @_;
  if ($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->{value} ||= $self->{option}->{value_default};
  #$self->{param} = \@p;
  $self->SUPER::_save_param (@p);
  $self;
}

=head2 $self->replace ($name, $value, [%option]

Sets new parameter C<value> of $name.

  Example:
    $self->add (title => 'foo of bar'); ## title="foo of bar"
    $self->add (subject => 'hogehoge, foo');    ## subject*=''hogehoge%2C%20foo
    $self->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).

=head2 $self->count ()

Returns the number of C<parameter>.

=head2 $self->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.

=head2 $self->parameter_name ($index, [$new_name])

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

=head2 $self->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

## replace, count, parameter, parameter_name, parameter_value: Inherited.
## add: inherited but should not be used.

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

=head2 $self->stringify ([%option])

Returns Content-Disposition C<field-body> as a string.

=head2 $self->as_string ([%option])

An alias of C<stringify>.

=cut

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

=head2 $self->value ([$new_value])

Returns or set value.

=cut

sub value ($;$%) {
  my $self = shift;
  my $new_value = shift;
  my %option = @_;
  if ($new_value && $new_value !~ m#$self->{option}->{value_no_regex}#) {
    $self->{value} = $new_value;
  }
  $self->{value} = $self->_param_value ('*value', $self->{value});
  $self->{value};
}

=head2 $self->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 %option = @_;
  my (%e) = &{$self->{option}->{hook_encode_string}} ($self, 
          $self->{value}, type => 'phrase');
  my $unsafe_rule = $option{unsafe_rule} || $self->{option}->{value_unsafe_rule};
  $self->_quote_unsafe_string ($e{value}, unsafe_regex => $REG{$unsafe_rule});
}


=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

## Inherited.


=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/03/31 13:11:55 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::ValueParams Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for "word; parameter(s)" style field body.
9
10			=cut
11
12			package Message::Field::ValueParams;
13			use strict;
14			BEGIN {
15			no strict;
16			use base Message::Field::Params;
17			use vars qw(%DEFAULT %REG $VERSION);
18			}
19	wakaba	1.5	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20	wakaba	1.1
21			%REG = %Message::Field::Params::REG;
22
23			%DEFAULT = (
24			use_parameter_extension => 1,
25			value_default => '',
26	wakaba	1.4	value_no_regex => qr/(?!)/, ## default = (none)
27	wakaba	1.1	value_regex => qr/[\x00-\xFF]+/,
28	wakaba	1.3	value_unsafe_rule => 'NON_http_token_wsp',
29	wakaba	1.1	);
30
31	wakaba	1.4	## Initialization for both C<new ()> and C<parse ()> methods.
32			sub _initialize ($;%) {
33			my $self = shift;
34			my $fname = lc $self->{option}->{field_name};
35			if ($fname eq 'link') {
36			$REG{r_nomatch} = qr/(?!)/;
37			$self->{option}->{value_unsafe_rule} = 'r_nomatch';
38			$self->{option}->{value_type}->{'*value'} = ['Message::Field::URI',
39			{field_name => $self->{option}->{field_name},
40			format => $self->{option}->{format}}];
41			}
42			$self;
43			}
44
45	wakaba	1.1	=head2 Message::Field::ValueParams->new ([%option])
46
47			Returns new Message::Field::ValueParams. Some options can be given as hash.
48
49			=cut
50
51			## Inherited
52
53			## Initialization for new () method.
54			sub _initialize_new ($;%) {
55			my $self = shift;
56			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
57			$self->{word} = $self->{option}->{value_default};
58			}
59
60			## Initialization for parse () method.
61			sub _initialize_parse ($;%) {
62			my $self = shift;
63			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
64			}
65
66			=head2 Message::Field::ValueParams->parse ($nantara, [%option])
67
68			Parse Message::Field::ValueParams and new ValueParams instance.
69			Some options can be given as hash.
70
71			=cut
72
73			## Inherited
74
75			sub _save_param ($@) {
76			my $self = shift;
77			my @p = @_;
78			if ($p[0]->[1]->{is_parameter} == 0) {
79			my $type = shift (@p)->[0];
80			if ($type && $type !~ /$self->{option}->{value_no_regex}/) {
81			$self->{value} = $type;
82			} elsif ($type) {
83			push @p, ['x-invalid-value' => {value => $type, is_parameter => 1}];
84			}
85			}
86			$self->{value} \|\|= $self->{option}->{value_default};
87	wakaba	1.5	#$self->{param} = \@p;
88			$self->SUPER::_save_param (@p);
89	wakaba	1.1	$self;
90			}
91
92			=head2 $self->replace ($name, $value, [%option]
93
94			Sets new parameter C<value> of $name.
95
96			Example:
97			$self->add (title => 'foo of bar'); ## title="foo of bar"
98			$self->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
99			$self->add (foo => 'bar', language => 'en') ## foo*='en'bar
100
101			This method returns array reference of (name, {value => value, attribute...}).
102			C<value> is same as returned value of C<$self-E<gt>parameter>.
103
104			Available options: charset (charset name), language (language tag),
105			value (1/0, see example above).
106
107			=head2 $self->count ()
108
109			Returns the number of C<parameter>.
110
111			=head2 $self->parameter ($name, [$new_value])
112
113			Returns given C<name>'ed C<parameter>'s C<value>.
114
115			Note that when $self->{option}->{value_type}->{$name}
116			is defined (and it is class name), returned value
117			is a reference to the object.
118
119			=head2 $self->parameter_name ($index, [$new_name])
120
121			Returns (and set) C<$index>'th C<parameter>'s name.
122
123			=head2 $self->parameter_value ($index, [$new_value])
124
125			Returns (and set) C<$index>'th C<parameter>'s value.
126
127			Note that when $self->{option}->{value_type}->{$name}
128			is defined (and it is class name), returned value
129			is a reference to the object.
130
131			=cut
132
133			## replace, count, parameter, parameter_name, parameter_value: Inherited.
134			## add: inherited but should not be used.
135
136			## Hook called before returning C<value>.
137			## $self->_param_value ($name, $value);
138	wakaba	1.4	## -- Inherited.
139	wakaba	1.1
140			=head2 $self->stringify ([%option])
141
142			Returns Content-Disposition C<field-body> as a string.
143
144			=head2 $self->as_string ([%option])
145
146			An alias of C<stringify>.
147
148			=cut
149
150			sub stringify ($;%) {
151			my $self = shift;
152			my $param = $self->SUPER::stringify (@_);
153	wakaba	1.2	$self->value_as_string (@_).($param? '; '.$param: '');
154	wakaba	1.1	}
155
156			=head2 $self->value ([$new_value])
157
158			Returns or set value.
159
160			=cut
161
162	wakaba	1.2	sub value ($;$%) {
163	wakaba	1.1	my $self = shift;
164			my $new_value = shift;
165	wakaba	1.2	my %option = @_;
166	wakaba	1.1	if ($new_value && $new_value !~ m#$self->{option}->{value_no_regex}#) {
167			$self->{value} = $new_value;
168			}
169	wakaba	1.4	$self->{value} = $self->_param_value ('*value', $self->{value});
170	wakaba	1.2	$self->{value};
171			}
172
173			=head2 $self->value_as_string ([%options])
174
175			Returns value. If necessary, quoted and encoded in
176			message format. Same as C<stringify> except that
177			only first "value" is outputed.
178
179			=cut
180
181			sub value_as_string ($;%) {
182			my $self = shift;
183			my %option = @_;
184			my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
185			$self->{value}, type => 'phrase');
186			my $unsafe_rule = $option{unsafe_rule} \|\| $self->{option}->{value_unsafe_rule};
187	wakaba	1.4	$self->_quote_unsafe_string ($e{value}, unsafe_regex => $REG{$unsafe_rule});
188	wakaba	1.1	}
189
190
191			=head2 $self->option ($option_name)
192
193			Returns/set (new) value of the option.
194
195			=cut
196
197			## Inherited.
198
199
200			=head1 LICENSE
201
202			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
203
204			This program is free software; you can redistribute it and/or modify
205			it under the terms of the GNU General Public License as published by
206			the Free Software Foundation; either version 2 of the License, or
207			(at your option) any later version.
208
209			This program is distributed in the hope that it will be useful,
210			but WITHOUT ANY WARRANTY; without even the implied warranty of
211			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
212			GNU General Public License for more details.
213
214			You should have received a copy of the GNU General Public License
215			along with this program; see the file COPYING. If not, write to
216			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
217			Boston, MA 02111-1307, USA.
218
219			=head1 CHANGE
220
221			See F<ChangeLog>.
222	wakaba	1.5	$Date: 2002/03/31 13:11:55 $
223	wakaba	1.1
224			=cut
225
226			1;