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.1 $=~/\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) = @_;
  if ($param->[0]->{no_value} && $param->[0]->{charset} eq '*bare') {
    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 @$param, {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);
}

=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/05/04 06:03:58 $

=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			$VERSION=do{my @r=(q$Revision: 1.1 $=~/\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			if ($param->[0]->{no_value} && $param->[0]->{charset} eq '*bare') {
95			my $name = shift (@$param)->{attribute};
96			my $from = '';
97	wakaba	1.1	if ($name =~ m#^((?:$REG{quoted_string}\|[^\x22\x2F])+)/((?:$REG{quoted_string}\|[^\x22])+)$#) {
98			($from, $name) = ($1, $2);
99			} elsif ($name =~ m#^((?:$REG{quoted_string}\|[^\x22\x40])+)$REG{FWS}\@$REG{FWS}((?:$REG{quoted_string}\|[^\x22])+)$#) {
100			($name, $from) = ($1, $2);
101			}
102	wakaba	1.2	$name =~ s/^$REG{WSP}+//; $name =~ s/$REG{WSP}+$//;
103	wakaba	1.1	$self->{value} = Message::Util::decode_quoted_string ($self, $name);
104	wakaba	1.2	$from =~ s/^$REG{WSP}+//; $from =~ s/$REG{WSP}+$//;
105			$from = Message::Util::decode_quoted_string ($self, $from) if length $from;
106	wakaba	1.1	if (length $from) {
107	wakaba	1.2	push @$param, {attribute => 'of', value => $from};
108	wakaba	1.1	}
109	wakaba	1.2	} elsif ($param->[0]->{no_value}) { ## was A quoted-string
110			my %s = &{$option->{hook_decode_string}}
111			($self, shift (@$param)->{attribute}, type => 'phrase/quoted-string');
112			$self->{value} = $s{value};
113	wakaba	1.1	}
114	wakaba	1.2	$self->SUPER::_decode_parameters ($param, $option);
115	wakaba	1.1	}
116
117			=back
118
119			=head1 METHODS
120
121			=over 4
122
123			=item $moe->replace ($name => [$value], [$name => $value,...])
124
125			Sets new parameter C<value> of $name.
126
127			Example:
128			$self->replace (age => 18);
129			$self->replace (of => 'Kizuato');
130
131			=item $count = $moe->count ()
132
133			Returns the number of C<parameter>s.
134
135			=item $param-value = $moe->parameter ($name, [$new_value])
136
137			Returns given C<name>'ed C<parameter>'s C<value>.
138
139			=item $param-name = $moe->parameter_name ($index, [$new_name])
140
141			Returns (and set) C<$index>'th C<parameter>'s name.
142
143			=item $param-value = $moe->parameter_value ($index, [$new_value])
144
145			Returns (and set) C<$index>'th C<parameter>'s value.
146
147			=cut
148
149			## replace, add, count, parameter, parameter_name, parameter_value: Inherited.
150			## (add should not be used for these field)
151
152	wakaba	1.2	sub value ($;$) {
153			my $self = shift;
154			my $new_value = shift;
155			if (defined $new_value) {
156			$self->{value} = $new_value;
157			}
158			$self->{value};
159			}
160
161	wakaba	1.1	=item $field-body = $moe->stringify ()
162
163			Returns C<field-body> as a string.
164
165			=cut
166
167			sub stringify ($;%) {
168			my $self = shift;
169			my $param = $self->SUPER::stringify_params (@_);
170	wakaba	1.2	my %o = @_; my %option = %{$self->{option}};
171			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
172			my $name = $self->stringify_value \|\| $option{value_default};
173			if ($option{value_style} eq 'slash') {
174			my %e = &{$option{hook_encode_string}}
175			($self,$self->parameter ('of') \|\| '', type => 'parameter/value/quoted-string');
176			my $v = Message::Util::quote_unsafe_string
177			($e{value}, unsafe => 'NON_http_token_wsp');
178	wakaba	1.1	$name = $v.'/'.$name if length $v;
179	wakaba	1.2	} elsif ($option{value_style} eq 'at') {
180			my %e = &{$option{hook_encode_string}}
181			($self,$self->parameter ('of') \|\| '', type => 'parameter/value/quoted-string');
182			my $v = Message::Util::quote_unsafe_string
183			($e{value}, unsafe => 'NON_http_token_wsp');
184	wakaba	1.1	$name .= ' @ '.$v if length $v;
185			}
186			$name.(length $param? '; '.$param: '');
187			}
188
189	wakaba	1.2	## $self->_stringify_param_check (\%item, \%option)
190			## -- Checks parameter (and modify if necessary).
191			## Returns either 1 (ok) or 0 (don't output)
192			sub _stringify_param_check ($\%\%) {
193			my $self = shift;
194			my ($item, $option) = @_;
195			if ($option->{value_style} eq 'slash' \|\| $option->{value_style} eq 'at') {
196			return (0) if $item->{attribute} eq 'of' && !$item->{no_value};
197	wakaba	1.1	}
198	wakaba	1.2	(1, $item);
199	wakaba	1.1	}
200
201
202			=item $option-value = $moe->option ($option-name)
203
204			Gets option value.
205
206			=item $moe->option ($option-name, $option-value, ...)
207
208			Set option value(s). You can pass multiple option name-value pair
209			as parameter when setting.
210
211			=cut
212
213			## Inherited.
214
215			=item $clone = $moe->clone ()
216
217			Returns a copy of the object.
218
219			=cut
220
221			## Inherited
222
223			=head1 LICENSE
224
225			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
226
227			This program is free software; you can redistribute it and/or modify
228			it under the terms of the GNU General Public License as published by
229			the Free Software Foundation; either version 2 of the License, or
230			(at your option) any later version.
231
232			This program is distributed in the hope that it will be useful,
233			but WITHOUT ANY WARRANTY; without even the implied warranty of
234			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
235			GNU General Public License for more details.
236
237			You should have received a copy of the GNU General Public License
238			along with this program; see the file COPYING. If not, write to
239			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
240			Boston, MA 02111-1307, USA.
241
242			=head1 CHANGE
243
244			See F<ChangeLog>.
245	wakaba	1.2	$Date: 2002/05/04 06:03:58 $
246	wakaba	1.1
247			=cut
248
249			1;