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
2	=head1 NAME
3
4	Message::Field::Structured -- Perl module for
5	unstructured header field bodies of the Internet message
6
7	=cut
8
9	package Message::Field::Unstructured;
10	use strict;
11	use vars qw(%DEFAULT $VERSION);
12	$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	require Message::Util;
14	use overload '""' => sub { $_[0]->stringify },
15	'.=' => sub { $_[0]->value_append ($_[1]) },
16	#'eq' => sub { $_[0]->{field_body} eq $_[1] },
17	#'ne' => sub { $_[0]->{field_body} ne $_[1] },
18	fallback => 1;
19
20
21	## Initialize of this class -- called by constructors
22	%DEFAULT = (
23	_METHODS => [qw\|value value_append\|],
24	_MEMBERS => [qw\|_charset\|],
25	encoding_after_encode => '*default',
26	encoding_before_decode => '*default',
27	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	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	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
46	for my $name (keys %options) {
47	if (substr ($name, 0, 1) eq '-') {
48	$self->{option}->{substr ($name, 1)} = $options{$name};
49	} elsif ($name eq 'body') {
50	$self->{value} = $options{$name};
51	}
52	}
53	}
54
55	=head1 CONSTRUCTORS
56
57	The following methods construct new C<Message::Field::Unstructured> objects:
58
59	=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
66	=cut
67
68	sub new ($;%) {
69	my $class = shift;
70	my $self = bless {}, $class;
71	$self->_init (@_);
72	$self;
73	}
74
75	=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
80	Although name, this method doesn't parse C<$field-body> (first
81	argument) since there is no need to parse unstructured field body:-)
82
83	=cut
84
85	sub parse ($$;%) {
86	my $class = shift;
87	my $field_body = shift;
88	my $self = bless {}, $class;
89	$self->_init (@_);
90	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	$self;
102	}
103
104	=back
105
106	=head1 METHODS
107
108	=over 4
109
110	=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
115	=cut
116
117	sub stringify ($;%) {
118	my $self = shift;
119	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	}
133	*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	$self->{value} = $v;
147	}
148	$self->{value};
149	}
150	*as_plain_string = \&value;
151
152	sub value_append ($$) {
153	$_[0]->{field_body} .= $_[1];
154	}
155
156	=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
174	=cut
175
176	sub option ($@) {
177	my $self = shift;
178	if (@_ == 1) {
179	return $self->{option}->{ $_[0] };
180	}
181	my %option = @_;
182	while (my ($name, $value) = splice (@_, 0, 2)) {
183	$self->{option}->{$name} = $value;
184	}
185	if ($option{-recursive}) {
186	$self->_option_recursive (\%option);
187	}
188	$self;
189	}
190
191	## $self->_option_recursive (\%argv)
192	sub _option_recursive ($\%) {}
193
194	=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	my $clone = ref ($self)->new;
203	$clone->{option} = Message::Util::make_clone ($self->{option});
204	$clone->{value} = Message::Util::make_clone ($self->{value});
205	for (@{$self->{option}->{_MEMBERS}}) {
206	$clone->{$_} = Message::Util::make_clone ($self->{$_});
207	}
208	$clone;
209	}
210
211	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	=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	=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	$Date: 2002/05/04 06:03:58 $
257
258	=cut
259
260	1;