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.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

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

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

=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);
sub _param_value ($$$) {
  my $self = shift;
  my $name = shift;
  my $value = shift;
  my $vtype = $self->{option}->{value_type}->{$name}
           || $self->{option}->{value_type}->{'*DEFAULT'};
  if (ref $value) {
    return $value;
  } elsif ($vtype eq ':none:') {
    return $value;
  } elsif ($value) {
    eval "require $vtype";
    return $vtype->parse ($value);
  } else {
    eval "require $vtype";
    return $vtype->new ();
  }
}

=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;
  }
  #my $unsafe_rule = $option{unsafe_rule} || $self->{option}->{value_unsafe_rule};
  #$self->_quote_unsafe_string ($self->{value}, unsafe => $unsafe_rule);
  $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 => $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/25 10:15:26 $

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