Message/Field/Unstructured.pm


=head1 NAME

Message::Field::Structured -- Perl module for
unstructured header field bodies of the Internet message

=cut

package Message::Field::Unstructured;
use strict;
use vars qw(%DEFAULT $VERSION);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
use overload '""' => sub { $_[0]->stringify },
             '.=' => sub { $_[0]->value_append ($_[1]) },
             #'eq' => sub { $_[0]->{field_body} eq $_[1] },
             #'ne' => sub { $_[0]->{field_body} ne $_[1] },
             fallback => 1;


## Initialize of this class -- called by constructors
  %DEFAULT = (
    _METHODS    => [qw|value value_append|],
    _MEMBERS    => [qw|_charset|],
    encoding_after_encode       => '*default',
    encoding_before_decode      => '*default',
    field_param_name    => '',
    field_name  => 'x-structured',
    #field_ns   => '',
    format      => 'mail-rfc2822',
    ## MIME charset name of '*default' charset
      header_default_charset    => 'iso-2022-int-1',
      header_default_charset_input      => 'iso-2022-int-1',
    hook_encode_string  => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
    hook_decode_string  => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
    internal_charset_name       => 'utf-8',
  );
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->{option} = Message::Util::make_clone (\%DEFAULT);
  $self->{value} = '';
  
  for my $name (keys %options) {
    if (substr ($name, 0, 1) eq '-') {
      $self->{option}->{substr ($name, 1)} = $options{$name};
    } elsif ($name eq 'body') {
      $self->{value} = $options{$name};
    }
  }
}

=head1 CONSTRUCTORS

The following methods construct new C<Message::Field::Unstructured> objects:

=over 4

=item Message::Field::Unstructured->new ([%options])

Constructs a new C<Message::Field::Unstructured> object.  You might pass some 
options as parameters to the constructor.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {}, $class;
  $self->_init (@_);
  $self;
}

=item Message::Field::Unstructured->parse ($field-body, [%options])

Constructs a new C<Message::Field::Unstructured> object with
given field body.  You might pass some options as parameters to the constructor.

Although name, this method doesn't parse C<$field-body> (first
argument) since there is no need to parse unstructured field body:-)

=cut

sub parse ($$;%) {
  my $class = shift;
  my $field_body = shift;
  my $self = bless {}, $class;
  $self->_init (@_);
  my %s = &{$self->{option}->{hook_decode_string}} ($self,
    $field_body,
    type => 'text',
    charset     => $option->{encoding_before_decode},
  );
  if ($s{charset}) {    ## Convertion failed
    $self->{_charset} = $s{charset};
  } elsif (!$s{success}) {
    $self->{_charset} = $self->{option}->{header_default_charset_input};
  }
  $self->{value} = $s{value};
  $self;
}

=back

=head1 METHODS

=over 4

=item $self->stringify ([%options])

Returns field body as a string.  Returned string is encoded
if necessary (by C<hook_encode_string>).

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  if ($self->{_charset}) {
    $self->{value};
  } else {
    my (%e) = &{$option{hook_encode_string}} ($self,
      $self->{value},
      charset => $option{encoding_after_encode},
      current_charset => $option{internal_charset},
      type => 'text',
    );
    $e{value};
  }
}
*as_string = \&stringify;

=item $self->value ([$new-value])

Set/gets current value of this field.  Returned/given value
should not be encoded (i.e. in internal code).

=cut

sub value ($;$) {
  my $self = shift;
  my $v = shift;
  if (defined $v) {
    $self->{value} = $v;
  }
  $self->{value};
}
*as_plain_string = \&value;

sub value_append ($$) {
  $_[0]->{field_body} .= $_[1];
}

=item $self->option ( $option-name / $option-name, $option-value, ...)

If @_ == 1, returns option value.  Else...

Set option value.  You can pass multiple option name-value pair
as parameter.  Example:

  $msg->option (-format => 'mail-rfc822',
                -capitalize => 0);
  print $msg->option ('-format');       ## mail-rfc822

Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
is optional.  You can also write as this:

  $msg->option (format => 'mail-rfc822',
                capitalize => 0);
  print $msg->option ('format');        ## mail-rfc822

=cut

sub option ($@) {
  my $self = shift;
  if (@_ == 1) {
    return $self->{option}->{ $_[0] };
  }
  my %option = @_;
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $self->{option}->{$name} = $value;
  }
  if ($option{-recursive}) {
    $self->_option_recursive (\%option);
  }
  $self;
}

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {}

=item $self->clone ()

Returns a copy of Message::Field::Unstructured object.

=cut

sub clone ($) {
  my $self = shift;
  my $clone = ref ($self)->new;
  $clone->{option} = Message::Util::make_clone ($self->{option});
  $clone->{value} = Message::Util::make_clone ($self->{value});
  for (@{$self->{option}->{_MEMBERS}}) {
    $clone->{$_} = Message::Util::make_clone ($self->{$_});
  }
  $clone;
}

my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
sub method_available ($$) {
  my $self = shift;
  my $name = shift;
  return 1 if $_method_default_list{$name};
  for (@{$self->{option}->{_METHODS}}) {
    return 1 if $_ eq $name;
  }
  0;
}

=head1 SEE ALSO

=over 4

=item L<Message::Entity>, L<Message::Header>

=item L<Message::Field::Structured>

=item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1

=back

=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	wakaba	1.5	Message::Field::Structured -- Perl module for
5			unstructured header field bodies of the Internet message
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Unstructured;
10			use strict;
11	wakaba	1.7	use vars qw(%DEFAULT $VERSION);
12			$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.3	require Message::Util;
14	wakaba	1.5	use overload '""' => sub { $_[0]->stringify },
15			'.=' => sub { $_[0]->value_append ($_[1]) },
16	wakaba	1.7	#'eq' => sub { $_[0]->{field_body} eq $_[1] },
17			#'ne' => sub { $_[0]->{field_body} ne $_[1] },
18	wakaba	1.5	fallback => 1;
19
20	wakaba	1.7
21	wakaba	1.5	## Initialize of this class -- called by constructors
22	wakaba	1.7	%DEFAULT = (
23			_METHODS => [qw\|value value_append\|],
24			_MEMBERS => [qw\|_charset\|],
25	wakaba	1.5	encoding_after_encode => '*default',
26			encoding_before_decode => '*default',
27	wakaba	1.7	field_param_name => '',
28			field_name => 'x-structured',
29			#field_ns => '',
30			format => 'mail-rfc2822',
31			## MIME charset name of '*default' charset
32			header_default_charset => 'iso-2022-int-1',
33			header_default_charset_input => 'iso-2022-int-1',
34	wakaba	1.5	hook_encode_string => #sub {shift; (value => shift, @_)},
35			\&Message::Util::encode_header_string,
36			hook_decode_string => #sub {shift; (value => shift, @_)},
37			\&Message::Util::decode_header_string,
38	wakaba	1.7	internal_charset_name => 'utf-8',
39			);
40			sub _init ($;%) {
41			my $self = shift;
42			my %options = @_;
43			$self->{option} = Message::Util::make_clone (\%DEFAULT);
44			$self->{value} = '';
45	wakaba	1.5
46			for my $name (keys %options) {
47			if (substr ($name, 0, 1) eq '-') {
48			$self->{option}->{substr ($name, 1)} = $options{$name};
49	wakaba	1.7	} elsif ($name eq 'body') {
50			$self->{value} = $options{$name};
51	wakaba	1.5	}
52			}
53			}
54	wakaba	1.1
55	wakaba	1.5	=head1 CONSTRUCTORS
56	wakaba	1.1
57	wakaba	1.5	The following methods construct new C<Message::Field::Unstructured> objects:
58	wakaba	1.1
59	wakaba	1.5	=over 4
60
61			=item Message::Field::Unstructured->new ([%options])
62
63			Constructs a new C<Message::Field::Unstructured> object. You might pass some
64			options as parameters to the constructor.
65	wakaba	1.1
66			=cut
67
68	wakaba	1.2	sub new ($;%) {
69	wakaba	1.3	my $class = shift;
70	wakaba	1.5	my $self = bless {}, $class;
71			$self->_init (@_);
72	wakaba	1.3	$self;
73	wakaba	1.1	}
74
75	wakaba	1.5	=item Message::Field::Unstructured->parse ($field-body, [%options])
76
77			Constructs a new C<Message::Field::Unstructured> object with
78			given field body. You might pass some options as parameters to the constructor.
79	wakaba	1.1
80	wakaba	1.5	Although name, this method doesn't parse C<$field-body> (first
81			argument) since there is no need to parse unstructured field body:-)
82	wakaba	1.1
83			=cut
84
85	wakaba	1.2	sub parse ($$;%) {
86	wakaba	1.3	my $class = shift;
87	wakaba	1.1	my $field_body = shift;
88	wakaba	1.5	my $self = bless {}, $class;
89			$self->_init (@_);
90	wakaba	1.7	my %s = &{$self->{option}->{hook_decode_string}} ($self,
91			$field_body,
92			type => 'text',
93			charset => $option->{encoding_before_decode},
94			);
95			if ($s{charset}) { ## Convertion failed
96			$self->{_charset} = $s{charset};
97			} elsif (!$s{success}) {
98			$self->{_charset} = $self->{option}->{header_default_charset_input};
99			}
100			$self->{value} = $s{value};
101	wakaba	1.1	$self;
102			}
103
104	wakaba	1.5	=back
105
106			=head1 METHODS
107
108			=over 4
109	wakaba	1.3
110	wakaba	1.5	=item $self->stringify ([%options])
111
112			Returns field body as a string. Returned string is encoded
113			if necessary (by C<hook_encode_string>).
114	wakaba	1.3
115			=cut
116
117			sub stringify ($;%) {
118	wakaba	1.1	my $self = shift;
119	wakaba	1.7	my %o = @_; my %option = %{$self->{option}};
120			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
121			if ($self->{_charset}) {
122			$self->{value};
123			} else {
124			my (%e) = &{$option{hook_encode_string}} ($self,
125			$self->{value},
126			charset => $option{encoding_after_encode},
127			current_charset => $option{internal_charset},
128			type => 'text',
129			);
130			$e{value};
131			}
132	wakaba	1.1	}
133	wakaba	1.5	*as_string = \&stringify;
134
135			=item $self->value ([$new-value])
136
137			Set/gets current value of this field. Returned/given value
138			should not be encoded (i.e. in internal code).
139
140			=cut
141
142			sub value ($;$) {
143			my $self = shift;
144			my $v = shift;
145			if (defined $v) {
146	wakaba	1.7	$self->{value} = $v;
147	wakaba	1.5	}
148	wakaba	1.7	$self->{value};
149	wakaba	1.5	}
150			*as_plain_string = \&value;
151	wakaba	1.1
152	wakaba	1.5	sub value_append ($$) {
153	wakaba	1.7	$_[0]->{field_body} .= $_[1];
154	wakaba	1.4	}
155
156	wakaba	1.5	=item $self->option ( $option-name / $option-name, $option-value, ...)
157
158			If @_ == 1, returns option value. Else...
159
160			Set option value. You can pass multiple option name-value pair
161			as parameter. Example:
162
163			$msg->option (-format => 'mail-rfc822',
164			-capitalize => 0);
165			print $msg->option ('-format'); ## mail-rfc822
166
167			Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
168			is optional. You can also write as this:
169
170			$msg->option (format => 'mail-rfc822',
171			capitalize => 0);
172			print $msg->option ('format'); ## mail-rfc822
173	wakaba	1.4
174			=cut
175
176	wakaba	1.5	sub option ($@) {
177	wakaba	1.4	my $self = shift;
178	wakaba	1.5	if (@_ == 1) {
179			return $self->{option}->{ $_[0] };
180			}
181	wakaba	1.7	my %option = @_;
182	wakaba	1.5	while (my ($name, $value) = splice (@_, 0, 2)) {
183	wakaba	1.4	$self->{option}->{$name} = $value;
184			}
185	wakaba	1.7	if ($option{-recursive}) {
186			$self->_option_recursive (\%option);
187			}
188			$self;
189	wakaba	1.1	}
190
191	wakaba	1.7	## $self->_option_recursive (\%argv)
192			sub _option_recursive ($\%) {}
193
194	wakaba	1.5	=item $self->clone ()
195
196			Returns a copy of Message::Field::Unstructured object.
197
198			=cut
199
200			sub clone ($) {
201			my $self = shift;
202	wakaba	1.7	my $clone = ref ($self)->new;
203	wakaba	1.6	$clone->{option} = Message::Util::make_clone ($self->{option});
204	wakaba	1.7	$clone->{value} = Message::Util::make_clone ($self->{value});
205			for (@{$self->{option}->{_MEMBERS}}) {
206			$clone->{$_} = Message::Util::make_clone ($self->{$_});
207			}
208	wakaba	1.5	$clone;
209			}
210
211	wakaba	1.7	my %_method_default_list = qw(new 1 parse 1 stringify 1 option 1 clone 1 method_available 1);
212			sub method_available ($$) {
213			my $self = shift;
214			my $name = shift;
215			return 1 if $_method_default_list{$name};
216			for (@{$self->{option}->{_METHODS}}) {
217			return 1 if $_ eq $name;
218			}
219			0;
220			}
221
222	wakaba	1.5	=head1 SEE ALSO
223
224			=over 4
225
226			=item L<Message::Entity>, L<Message::Header>
227
228			=item L<Message::Field::Structured>
229
230			=item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
231
232			=back
233
234	wakaba	1.1	=head1 LICENSE
235
236			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
237
238			This program is free software; you can redistribute it and/or modify
239			it under the terms of the GNU General Public License as published by
240			the Free Software Foundation; either version 2 of the License, or
241			(at your option) any later version.
242
243			This program is distributed in the hope that it will be useful,
244			but WITHOUT ANY WARRANTY; without even the implied warranty of
245			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
246			GNU General Public License for more details.
247
248			You should have received a copy of the GNU General Public License
249			along with this program; see the file COPYING. If not, write to
250			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
251			Boston, MA 02111-1307, USA.
252
253			=head1 CHANGE
254
255			See F<ChangeLog>.
256	wakaba	1.7	$Date: 2002/05/04 06:03:58 $
257	wakaba	1.1
258			=cut
259
260			1;