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($VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\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
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->{option} = {
    encoding_after_encode       => '*default',
    encoding_before_decode      => '*default',
    hook_encode_string  => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
    hook_decode_string  => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
  };
  $self->{field_body} = '';
  
  for my $name (keys %options) {
    if (substr ($name, 0, 1) eq '-') {
      $self->{option}->{substr ($name, 1)} = $options{$name};
    } elsif (lc $name eq 'body') {
      $self->{field_body} = $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');
  $self->{field_body} = $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 %option = @_;
  my (%e) = &{$self->{option}->{hook_encode_string}}
             ($self, $self->{field_body}, -type => 'text');
  $e{value};
}
*as_string = \&stringify;

=item $self->as_plain_string

Returns field body as a string.  Returned string is not encoded,
i.e. internal coded string.

=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->{field_body} = $v;
  }
  $self->{field_body};
}
*as_plain_string = \&value;

sub value_append ($$) {
  shift->{field_body} .= shift;
}

=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] };
  }
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $name =~ s/^-//;
    $self->{option}->{$name} = $value;
  }
}

=item $self->clone ()

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

=cut

sub clone ($) {
  my $self = shift;
  my $clone = ref($self)->new;
  for my $name (%{$self->{option}}) {
    if (ref $self->{option}->{$name} eq 'HASH') {
      $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
    } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
      $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
    } else {
      $clone->{option}->{$name} = $self->{option}->{$name};
    }
  }
  $clone->{field_body} = ref $self->{field_body}? 
                             $self->{field_body}->clone:
                             $self->{field_body};
  $clone;
}

=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: $

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