Message/Field/XMoe.pm


=head1 NAME

Message::Field::XMoe --- Perl module for
Internet message C<X-Moe:> field body items

=cut

package Message::Field::XMoe;
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::ValueParams;
push @ISA, qw(Message::Field::ValueParams);
*REG = \%Message::Field::ValueParams::REG;
$REG{MS_parameter_avpair_noslash} = qr/([^\x22\x2F\x3C\x3D]+)=([\x00-\xFF]*)/;

%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     => 1,
        #parameter_rule
        #parameter_attribute_case_sensible
        #parameter_attribute_unsafe_rule
        -parameter_av_Mrule     => 'MS_parameter_avpair_noslash',
        #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    => 1,
        -use_parameter_extension        => 1,
        -value_case_sensible    => 0,
        -value_default  => '',
        -value_style    => 'slash',     ## name / slash / at
        #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);
}

=item $moe = Message::Field::XMoe->new ([%options])

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

=cut

## Inherited

=item $moe = Message::Field::XMoe->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->_decode_parameters (\@parameter, \%option)
## -- join RFC 2231 splited fragments and decode each parameter
sub _decode_parameters ($\@\%) {
  my $self = shift;
  my ($param, $option) = @_;
  my @a;
  if ($param->[0]->{no_value} && $param->[0]->{charset} eq '*bare') {
    ## first item doesn't have value and is not a quoted-string itself,
    my $name = shift (@$param)->{attribute};
    my $from = '';
    if ($name =~ m#^((?:$REG{quoted_string}|[^\x22\x2F])+)/((?:$REG{quoted_string}|[^\x22])+)$#) {
      ($from, $name) = ($1, $2);
    } elsif ($name =~ m#^((?:$REG{quoted_string}|[^\x22\x40])+)$REG{FWS}\@$REG{FWS}((?:$REG{quoted_string}|[^\x22])+)$#) {
      ($name, $from) = ($1, $2);
    }
    $name =~ s/^$REG{WSP}+//; $name =~ s/$REG{WSP}+$//;
    $self->{value} = Message::Util::decode_quoted_string ($self, $name);
    $from =~ s/^$REG{WSP}+//; $from =~ s/$REG{WSP}+$//;
    $from = Message::Util::decode_quoted_string ($self, $from) if length $from;
    if (length $from) {
      push @a, {attribute => 'of', value => $from};
    }
  } elsif ($param->[0]->{no_value}) {   ## was A quoted-string
    my %s = &{$option->{hook_decode_string}}
        ($self, shift (@$param)->{attribute}, type => 'phrase/quoted-string');
    $self->{value} = $s{value};
  }
  $self->SUPER::_decode_parameters ($param, $option);
  push @$param, @a;
}

=back

=head1 METHODS

=over 4

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

Sets new parameter C<value> of $name.

  Example:
    $self->replace (age => 18);
    $self->replace (of => 'Kizuato');

=item $count = $moe->count ()

Returns the number of C<parameter>s.

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

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

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

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

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

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

=cut

## replace, add, count, parameter, parameter_name, parameter_value: Inherited.
## (add should not be used for these field)

sub value ($;$) {
  my $self = shift;
  my $new_value = shift;
  if (defined $new_value) {
    $self->{value} = $new_value;
  }
  $self->{value};
}

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

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my $param = $self->SUPER::stringify_params (@_);
  my %o = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $name = $self->stringify_value || $option{value_default};
  if ($option{value_style} eq 'slash') {
    my %e = &{$option{hook_encode_string}}
      ($self,$self->parameter ('of') || '', type => 'parameter/value/quoted-string');
    my $v = Message::Util::quote_unsafe_string
      ($e{value}, unsafe => 'NON_http_token_wsp');
    $name = $v.'/'.$name if length $v;
  } elsif ($option{value_style} eq 'at') {
    my %e = &{$option{hook_encode_string}}
      ($self,$self->parameter ('of') || '', type => 'parameter/value/quoted-string');
    my $v = Message::Util::quote_unsafe_string
      ($e{value}, unsafe => 'NON_http_token_wsp');
    $name .= ' @ '.$v if length $v;
  }
  $name.(length $param? '; '.$param: '');
}

## $self->_stringify_param_check (\%item, \%option)
## -- Checks parameter (and modify if necessary).
##    Returns either 1 (ok) or 0 (don't output)
sub _stringify_param_check ($\%\%) {
  my $self = shift;
  my ($item, $option) = @_;
  if ($option->{value_style} eq 'slash' || $option->{value_style} eq 'at') {
    return (0) if $item->{attribute} eq 'of' && !$item->{no_value};
  }
  (1, $item);
}


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

Gets option value.

=item $moe->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 = $moe->clone ()

Returns a copy of the object.

=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/06/29 09:31:46 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::XMoe --- Perl module for
5			Internet message C<X-Moe:> field body items
6
7			=cut
8
9			package Message::Field::XMoe;
10			use strict;
11	wakaba	1.2	use vars qw(%DEFAULT @ISA %REG $VERSION);
12	wakaba	1.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.1	require Message::Field::ValueParams;
14			push @ISA, qw(Message::Field::ValueParams);
15	wakaba	1.2	*REG = \%Message::Field::ValueParams::REG;
16			$REG{MS_parameter_avpair_noslash} = qr/([^\x22\x2F\x3C\x3D]+)=([\x00-\xFF]*)/;
17
18			%DEFAULT = (
19			#_HASH_NAME
20			#_MEMBERS
21			#_METHODS
22			#accept_coderange
23			#encoding_after_encode
24			#encoding_before_decode
25			#field_param_name
26			#field_name
27			#field_ns
28			#format
29			#header_default_charset
30			#header_default_charset_input
31			#hook_encode_string
32			#hook_decode_string
33			#output_comment
34			-output_parameter_extension => 1,
35			#parameter_rule
36			#parameter_attribute_case_sensible
37			#parameter_attribute_unsafe_rule
38			-parameter_av_Mrule => 'MS_parameter_avpair_noslash',
39			#parameter_no_value_attribute_unsafe_rule
40			#parameter_value_max_length
41			#parameter_value_split_length
42			#parameter_value_unsafe_rule
43			#parse_all
44			#separator
45			#separator_rule
46			-use_comment => 1,
47			-use_parameter_extension => 1,
48			-value_case_sensible => 0,
49			-value_default => '',
50			-value_style => 'slash', ## name / slash / at
51			#value_type
52			-value_unsafe_rule => 'NON_http_attribute_char',
53			);
54	wakaba	1.1
55			=head1 CONSTRUCTORS
56
57			The following methods construct new objects:
58
59			=over 4
60
61			=cut
62
63			## Initialize of this class -- called by constructors
64			sub _init ($;%) {
65			my $self = shift;
66			my %options = @_;
67			$self->SUPER::_init (%DEFAULT, %options);
68			}
69
70			=item $moe = Message::Field::XMoe->new ([%options])
71
72			Constructs a new object. You might pass some options as parameters
73			to the constructor.
74
75			=cut
76
77			## Inherited
78
79			=item $moe = Message::Field::XMoe->parse ($field-body, [%options])
80
81			Constructs a new object with given field body. You might pass
82			some options as parameters to the constructor.
83
84			=cut
85
86			## Inherited
87
88	wakaba	1.2
89			## $self->_decode_parameters (\@parameter, \%option)
90			## -- join RFC 2231 splited fragments and decode each parameter
91			sub _decode_parameters ($\@\%) {
92			my $self = shift;
93			my ($param, $option) = @_;
94	wakaba	1.3	my @a;
95	wakaba	1.2	if ($param->[0]->{no_value} && $param->[0]->{charset} eq '*bare') {
96	wakaba	1.3	## first item doesn't have value and is not a quoted-string itself,
97	wakaba	1.2	my $name = shift (@$param)->{attribute};
98			my $from = '';
99	wakaba	1.1	if ($name =~ m#^((?:$REG{quoted_string}\|[^\x22\x2F])+)/((?:$REG{quoted_string}\|[^\x22])+)$#) {
100			($from, $name) = ($1, $2);
101			} elsif ($name =~ m#^((?:$REG{quoted_string}\|[^\x22\x40])+)$REG{FWS}\@$REG{FWS}((?:$REG{quoted_string}\|[^\x22])+)$#) {
102			($name, $from) = ($1, $2);
103			}
104	wakaba	1.2	$name =~ s/^$REG{WSP}+//; $name =~ s/$REG{WSP}+$//;
105	wakaba	1.1	$self->{value} = Message::Util::decode_quoted_string ($self, $name);
106	wakaba	1.2	$from =~ s/^$REG{WSP}+//; $from =~ s/$REG{WSP}+$//;
107			$from = Message::Util::decode_quoted_string ($self, $from) if length $from;
108	wakaba	1.1	if (length $from) {
109	wakaba	1.3	push @a, {attribute => 'of', value => $from};
110	wakaba	1.1	}
111	wakaba	1.2	} elsif ($param->[0]->{no_value}) { ## was A quoted-string
112			my %s = &{$option->{hook_decode_string}}
113			($self, shift (@$param)->{attribute}, type => 'phrase/quoted-string');
114			$self->{value} = $s{value};
115	wakaba	1.1	}
116	wakaba	1.2	$self->SUPER::_decode_parameters ($param, $option);
117	wakaba	1.3	push @$param, @a;
118	wakaba	1.1	}
119
120			=back
121
122			=head1 METHODS
123
124			=over 4
125
126			=item $moe->replace ($name => [$value], [$name => $value,...])
127
128			Sets new parameter C<value> of $name.
129
130			Example:
131			$self->replace (age => 18);
132			$self->replace (of => 'Kizuato');
133
134			=item $count = $moe->count ()
135
136			Returns the number of C<parameter>s.
137
138			=item $param-value = $moe->parameter ($name, [$new_value])
139
140			Returns given C<name>'ed C<parameter>'s C<value>.
141
142			=item $param-name = $moe->parameter_name ($index, [$new_name])
143
144			Returns (and set) C<$index>'th C<parameter>'s name.
145
146			=item $param-value = $moe->parameter_value ($index, [$new_value])
147
148			Returns (and set) C<$index>'th C<parameter>'s value.
149
150			=cut
151
152			## replace, add, count, parameter, parameter_name, parameter_value: Inherited.
153			## (add should not be used for these field)
154
155	wakaba	1.2	sub value ($;$) {
156			my $self = shift;
157			my $new_value = shift;
158			if (defined $new_value) {
159			$self->{value} = $new_value;
160			}
161			$self->{value};
162			}
163
164	wakaba	1.1	=item $field-body = $moe->stringify ()
165
166			Returns C<field-body> as a string.
167
168			=cut
169
170			sub stringify ($;%) {
171			my $self = shift;
172			my $param = $self->SUPER::stringify_params (@_);
173	wakaba	1.2	my %o = @_; my %option = %{$self->{option}};
174			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
175			my $name = $self->stringify_value \|\| $option{value_default};
176			if ($option{value_style} eq 'slash') {
177			my %e = &{$option{hook_encode_string}}
178			($self,$self->parameter ('of') \|\| '', type => 'parameter/value/quoted-string');
179			my $v = Message::Util::quote_unsafe_string
180			($e{value}, unsafe => 'NON_http_token_wsp');
181	wakaba	1.1	$name = $v.'/'.$name if length $v;
182	wakaba	1.2	} elsif ($option{value_style} eq 'at') {
183			my %e = &{$option{hook_encode_string}}
184			($self,$self->parameter ('of') \|\| '', type => 'parameter/value/quoted-string');
185			my $v = Message::Util::quote_unsafe_string
186			($e{value}, unsafe => 'NON_http_token_wsp');
187	wakaba	1.1	$name .= ' @ '.$v if length $v;
188			}
189			$name.(length $param? '; '.$param: '');
190			}
191
192	wakaba	1.2	## $self->_stringify_param_check (\%item, \%option)
193			## -- Checks parameter (and modify if necessary).
194			## Returns either 1 (ok) or 0 (don't output)
195			sub _stringify_param_check ($\%\%) {
196			my $self = shift;
197			my ($item, $option) = @_;
198			if ($option->{value_style} eq 'slash' \|\| $option->{value_style} eq 'at') {
199			return (0) if $item->{attribute} eq 'of' && !$item->{no_value};
200	wakaba	1.1	}
201	wakaba	1.2	(1, $item);
202	wakaba	1.1	}
203
204
205			=item $option-value = $moe->option ($option-name)
206
207			Gets option value.
208
209			=item $moe->option ($option-name, $option-value, ...)
210
211			Set option value(s). You can pass multiple option name-value pair
212			as parameter when setting.
213
214			=cut
215
216			## Inherited.
217
218			=item $clone = $moe->clone ()
219
220			Returns a copy of the object.
221
222			=cut
223
224			## Inherited
225
226			=head1 LICENSE
227
228			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
229
230			This program is free software; you can redistribute it and/or modify
231			it under the terms of the GNU General Public License as published by
232			the Free Software Foundation; either version 2 of the License, or
233			(at your option) any later version.
234
235			This program is distributed in the hope that it will be useful,
236			but WITHOUT ANY WARRANTY; without even the implied warranty of
237			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
238			GNU General Public License for more details.
239
240			You should have received a copy of the GNU General Public License
241			along with this program; see the file COPYING. If not, write to
242			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
243			Boston, MA 02111-1307, USA.
244
245			=head1 CHANGE
246
247			See F<ChangeLog>.
248	wakaba	1.3	$Date: 2002/06/29 09:31:46 $
249	wakaba	1.1
250			=cut
251
252			1;