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.3 $=~/\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;
}

=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/26 05:31:56 $

=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.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\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			$self->{param} = \@p;
88			$self;
89			}
90
91			=head2 $self->replace ($name, $value, [%option]
92
93			Sets new parameter C<value> of $name.
94
95			Example:
96			$self->add (title => 'foo of bar'); ## title="foo of bar"
97			$self->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
98			$self->add (foo => 'bar', language => 'en') ## foo*='en'bar
99
100			This method returns array reference of (name, {value => value, attribute...}).
101			C<value> is same as returned value of C<$self-E<gt>parameter>.
102
103			Available options: charset (charset name), language (language tag),
104			value (1/0, see example above).
105
106			=head2 $self->count ()
107
108			Returns the number of C<parameter>.
109
110			=head2 $self->parameter ($name, [$new_value])
111
112			Returns given C<name>'ed C<parameter>'s C<value>.
113
114			Note that when $self->{option}->{value_type}->{$name}
115			is defined (and it is class name), returned value
116			is a reference to the object.
117
118			=head2 $self->parameter_name ($index, [$new_name])
119
120			Returns (and set) C<$index>'th C<parameter>'s name.
121
122			=head2 $self->parameter_value ($index, [$new_value])
123
124			Returns (and set) C<$index>'th C<parameter>'s value.
125
126			Note that when $self->{option}->{value_type}->{$name}
127			is defined (and it is class name), returned value
128			is a reference to the object.
129
130			=cut
131
132			## replace, count, parameter, parameter_name, parameter_value: Inherited.
133			## add: inherited but should not be used.
134
135			## Hook called before returning C<value>.
136			## $self->_param_value ($name, $value);
137	wakaba	1.4	## -- Inherited.
138	wakaba	1.1
139			=head2 $self->stringify ([%option])
140
141			Returns Content-Disposition C<field-body> as a string.
142
143			=head2 $self->as_string ([%option])
144
145			An alias of C<stringify>.
146
147			=cut
148
149			sub stringify ($;%) {
150			my $self = shift;
151			my $param = $self->SUPER::stringify (@_);
152	wakaba	1.2	$self->value_as_string (@_).($param? '; '.$param: '');
153	wakaba	1.1	}
154
155			=head2 $self->value ([$new_value])
156
157			Returns or set value.
158
159			=cut
160
161	wakaba	1.2	sub value ($;$%) {
162	wakaba	1.1	my $self = shift;
163			my $new_value = shift;
164	wakaba	1.2	my %option = @_;
165	wakaba	1.1	if ($new_value && $new_value !~ m#$self->{option}->{value_no_regex}#) {
166			$self->{value} = $new_value;
167			}
168	wakaba	1.4	$self->{value} = $self->_param_value ('*value', $self->{value});
169	wakaba	1.2	$self->{value};
170			}
171
172			=head2 $self->value_as_string ([%options])
173
174			Returns value. If necessary, quoted and encoded in
175			message format. Same as C<stringify> except that
176			only first "value" is outputed.
177
178			=cut
179
180			sub value_as_string ($;%) {
181			my $self = shift;
182			my %option = @_;
183			my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
184			$self->{value}, type => 'phrase');
185			my $unsafe_rule = $option{unsafe_rule} \|\| $self->{option}->{value_unsafe_rule};
186	wakaba	1.4	$self->_quote_unsafe_string ($e{value}, unsafe_regex => $REG{$unsafe_rule});
187	wakaba	1.1	}
188
189
190			=head2 $self->option ($option_name)
191
192			Returns/set (new) value of the option.
193
194			=cut
195
196			## Inherited.
197
198
199			=head1 LICENSE
200
201			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
202
203			This program is free software; you can redistribute it and/or modify
204			it under the terms of the GNU General Public License as published by
205			the Free Software Foundation; either version 2 of the License, or
206			(at your option) any later version.
207
208			This program is distributed in the hope that it will be useful,
209			but WITHOUT ANY WARRANTY; without even the implied warranty of
210			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
211			GNU General Public License for more details.
212
213			You should have received a copy of the GNU General Public License
214			along with this program; see the file COPYING. If not, write to
215			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
216			Boston, MA 02111-1307, USA.
217
218			=head1 CHANGE
219
220			See F<ChangeLog>.
221	wakaba	1.4	$Date: 2002/03/26 05:31:56 $
222	wakaba	1.1
223			=cut
224
225			1;