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
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	use vars qw(%DEFAULT @ISA %REG $VERSION);
12	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	require Message::Field::ValueParams;
14	push @ISA, qw(Message::Field::ValueParams);
15	*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
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
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	my @a;
95	if ($param->[0]->{no_value} && $param->[0]->{charset} eq '*bare') {
96	## first item doesn't have value and is not a quoted-string itself,
97	my $name = shift (@$param)->{attribute};
98	my $from = '';
99	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	$name =~ s/^$REG{WSP}+//; $name =~ s/$REG{WSP}+$//;
105	$self->{value} = Message::Util::decode_quoted_string ($self, $name);
106	$from =~ s/^$REG{WSP}+//; $from =~ s/$REG{WSP}+$//;
107	$from = Message::Util::decode_quoted_string ($self, $from) if length $from;
108	if (length $from) {
109	push @a, {attribute => 'of', value => $from};
110	}
111	} 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	}
116	$self->SUPER::_decode_parameters ($param, $option);
117	push @$param, @a;
118	}
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	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	=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	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	$name = $v.'/'.$name if length $v;
182	} 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	$name .= ' @ '.$v if length $v;
188	}
189	$name.(length $param? '; '.$param: '');
190	}
191
192	## $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	}
201	(1, $item);
202	}
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	$Date: 2002/06/29 09:31:46 $
249
250	=cut
251
252	1;