Message/Field/Structured.pm


=head1 NAME

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

=cut

package Message::Field::Structured;
use strict;
use vars qw($VERSION);
$VERSION=do{my @r=(q$Revision: 1.7 $=~/\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;

=head1 CONSTRUCTORS

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

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->{option} = {
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  field_name    => 'x-structured',
  field_name_case_sensible      => 0,
  format        => 'mail-rfc2822',
  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};
    }
  }
}

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

Constructs a new C<Message::Field::Structured> 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::Structured->parse ($field-body, [%options])

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

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  $self->_init (@_);
  #my $field_body = $self->Message::Util::decode_qcontent (shift);
  $self->{field_body} = shift; #$field_body;
  $self;
}

=back

=head1 METHODS

=over 4

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

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

=cut

sub stringify ($;%) {
  my $self = shift;
  #$self->Message::Util::encode_qcontent ($self->{field_body});
  $self->{field_body};
}
*as_string = \&stringify;

=item $self->as_plain_string

Returns field body as a string.  Returned string is not encoded
or quoted, i.e. internal/bare coded string.  This string
may be unable to use as field body content.  (Its I<structures>
such as C<comment> and C<quoted-string> are lost.)

=cut

sub as_plain_string ($) {
  my $self = shift;
  my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
  Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
}

=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::Structured 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};
  ## Common hash value (not used in this module)
    if (ref $self->{value} eq 'HASH') {
      $clone->{value} = {map {ref $_? $_->clone: $_} %{$self->{value}}};
    } elsif (ref $self->{value} eq 'ARRAY') {
      $clone->{value} = [map {ref $_? $_->clone: $_} @{$self->{value}}];
    } elsif (ref $self->{value}) {
      $clone->{value} = $self->{value}->clone;
    } else {
      $clone->{value} = $self->{value};
    }
  for my $i (@{$self->{comment}}) {
    if (ref $self->{comment}->[$i] eq 'HASH') {
      $clone->{comment}->[$i] = {%{$self->{comment}->[$i]}};
    } elsif (ref $self->{comment}->[$i] eq 'ARRAY') {
      $clone->{comment}->[$i] = [@{$self->{comment}->[$i]}];
    } else {
      $clone->{comment}->[$i] = $self->{comment}->[$i];
    }
  }
  $clone;
}

sub _n11n_field_name ($$) {
  my $self = shift;
  my $s = shift;
  $s = lc $s unless $self->{option}->{field_name_case_sensible};
  $s;
}


=head1 EXAMPLE

  use Message::Field::Structured;
  
  my $field_body = '"This is an example of <\"> (quotation mark)."
                    (Comment within \q\u\o\t\e\d\-\p\a\i\r\(\s\))';
  my $field = Message::Field::Structured->parse ($field_body);
  
  print $field->as_plain_string;

=head1 SEE ALSO

=over 4

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

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

=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/04/13 01:33:54 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.5	Message::Field::Structured -- Perl module for
5			structured header field bodies of the Internet message
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Structured;
10			use strict;
11	wakaba	1.5	use vars qw($VERSION);
12	wakaba	1.8	$VERSION=do{my @r=(q$Revision: 1.7 $=~/\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	wakaba	1.1
20	wakaba	1.5	=head1 CONSTRUCTORS
21	wakaba	1.1
22	wakaba	1.5	The following methods construct new C<Message::Field::Structured> objects:
23	wakaba	1.1
24	wakaba	1.5	=over 4
25	wakaba	1.1
26	wakaba	1.5	=cut
27	wakaba	1.1
28	wakaba	1.5	## Initialize of this class -- called by constructors
29			sub _init ($;%) {
30			my $self = shift;
31			my %options = @_;
32			$self->{option} = {
33	wakaba	1.3	encoding_after_encode => '*default',
34			encoding_before_decode => '*default',
35	wakaba	1.6	field_name => 'x-structured',
36	wakaba	1.8	field_name_case_sensible => 0,
37	wakaba	1.6	format => 'mail-rfc2822',
38	wakaba	1.3	hook_encode_string => #sub {shift; (value => shift, @_)},
39			\&Message::Util::encode_header_string,
40			hook_decode_string => #sub {shift; (value => shift, @_)},
41			\&Message::Util::decode_header_string,
42	wakaba	1.5	};
43			$self->{field_body} = '';
44
45			for my $name (keys %options) {
46			if (substr ($name, 0, 1) eq '-') {
47			$self->{option}->{substr ($name, 1)} = $options{$name};
48			} elsif (lc $name eq 'body') {
49			$self->{field_body} = $options{$name};
50			}
51			}
52			}
53	wakaba	1.3
54	wakaba	1.5	=item Message::Field::Structured->new ([%options])
55	wakaba	1.1
56	wakaba	1.5	Constructs a new C<Message::Field::Structured> object. You might pass some
57			options as parameters to the constructor.
58	wakaba	1.1
59			=cut
60
61	wakaba	1.2	sub new ($;%) {
62	wakaba	1.3	my $class = shift;
63	wakaba	1.5	my $self = bless {}, $class;
64			$self->_init (@_);
65	wakaba	1.3	$self;
66	wakaba	1.1	}
67
68	wakaba	1.5	=item Message::Field::Structured->parse ($field-body, [%options])
69	wakaba	1.1
70	wakaba	1.5	Constructs a new C<Message::Field::Structured> object with
71			given field body. You might pass some options as parameters to the constructor.
72	wakaba	1.1
73			=cut
74
75	wakaba	1.2	sub parse ($$;%) {
76	wakaba	1.3	my $class = shift;
77	wakaba	1.5	my $self = bless {}, $class;
78			$self->_init (@_);
79			#my $field_body = $self->Message::Util::decode_qcontent (shift);
80			$self->{field_body} = shift; #$field_body;
81	wakaba	1.1	$self;
82			}
83
84	wakaba	1.5	=back
85
86			=head1 METHODS
87
88			=over 4
89
90			=item $self->stringify ([%options])
91	wakaba	1.1
92	wakaba	1.5	Returns field body as a string. Returned string is encoded,
93			quoted if necessary (by C<hook_encode_string>).
94	wakaba	1.1
95			=cut
96
97	wakaba	1.7	sub stringify ($;%) {
98	wakaba	1.1	my $self = shift;
99	wakaba	1.5	#$self->Message::Util::encode_qcontent ($self->{field_body});
100			$self->{field_body};
101	wakaba	1.1	}
102	wakaba	1.5	*as_string = \&stringify;
103	wakaba	1.1
104	wakaba	1.5	=item $self->as_plain_string
105	wakaba	1.1
106	wakaba	1.5	Returns field body as a string. Returned string is not encoded
107			or quoted, i.e. internal/bare coded string. This string
108			may be unable to use as field body content. (Its I<structures>
109			such as C<comment> and C<quoted-string> are lost.)
110	wakaba	1.1
111			=cut
112
113			sub as_plain_string ($) {
114			my $self = shift;
115	wakaba	1.5	my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
116			Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
117	wakaba	1.1	}
118	wakaba	1.4
119	wakaba	1.5	=item $self->option ( $option-name / $option-name, $option-value, ...)
120	wakaba	1.4
121	wakaba	1.5	If @_ == 1, returns option value. Else...
122	wakaba	1.4
123	wakaba	1.5	Set option value. You can pass multiple option name-value pair
124			as parameter. Example:
125	wakaba	1.1
126	wakaba	1.5	$msg->option (-format => 'mail-rfc822',
127			-capitalize => 0);
128			print $msg->option ('-format'); ## mail-rfc822
129	wakaba	1.3
130	wakaba	1.5	Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
131			is optional. You can also write as this:
132	wakaba	1.3
133	wakaba	1.5	$msg->option (format => 'mail-rfc822',
134			capitalize => 0);
135			print $msg->option ('format'); ## mail-rfc822
136	wakaba	1.1
137			=cut
138
139	wakaba	1.5	sub option ($@) {
140	wakaba	1.1	my $self = shift;
141	wakaba	1.5	if (@_ == 1) {
142			return $self->{option}->{ $_[0] };
143			}
144			while (my ($name, $value) = splice (@_, 0, 2)) {
145			$name =~ s/^-//;
146			$self->{option}->{$name} = $value;
147			}
148	wakaba	1.1	}
149
150	wakaba	1.5	=item $self->clone ()
151	wakaba	1.1
152	wakaba	1.5	Returns a copy of Message::Field::Structured object.
153	wakaba	1.1
154			=cut
155
156	wakaba	1.5	sub clone ($) {
157	wakaba	1.1	my $self = shift;
158	wakaba	1.5	my $clone = ref($self)->new;
159			for my $name (%{$self->{option}}) {
160			if (ref $self->{option}->{$name} eq 'HASH') {
161			$clone->{option}->{$name} = {%{$self->{option}->{$name}}};
162			} elsif (ref $self->{option}->{$name} eq 'ARRAY') {
163			$clone->{option}->{$name} = [@{$self->{option}->{$name}}];
164			} else {
165			$clone->{option}->{$name} = $self->{option}->{$name};
166			}
167			}
168			$clone->{field_body} = ref $self->{field_body}?
169			$self->{field_body}->clone:
170			$self->{field_body};
171			## Common hash value (not used in this module)
172	wakaba	1.8	if (ref $self->{value} eq 'HASH') {
173			$clone->{value} = {map {ref $_? $_->clone: $_} %{$self->{value}}};
174			} elsif (ref $self->{value} eq 'ARRAY') {
175			$clone->{value} = [map {ref $_? $_->clone: $_} @{$self->{value}}];
176			} elsif (ref $self->{value}) {
177			$clone->{value} = $self->{value}->clone;
178			} else {
179			$clone->{value} = $self->{value};
180			}
181	wakaba	1.5	for my $i (@{$self->{comment}}) {
182			if (ref $self->{comment}->[$i] eq 'HASH') {
183			$clone->{comment}->[$i] = {%{$self->{comment}->[$i]}};
184			} elsif (ref $self->{comment}->[$i] eq 'ARRAY') {
185			$clone->{comment}->[$i] = [@{$self->{comment}->[$i]}];
186			} else {
187			$clone->{comment}->[$i] = $self->{comment}->[$i];
188			}
189			}
190			$clone;
191	wakaba	1.1	}
192
193	wakaba	1.8	sub _n11n_field_name ($$) {
194			my $self = shift;
195			my $s = shift;
196			$s = lc $s unless $self->{option}->{field_name_case_sensible};
197			$s;
198			}
199
200	wakaba	1.5
201	wakaba	1.1	=head1 EXAMPLE
202
203			use Message::Field::Structured;
204
205			my $field_body = '"This is an example of <\"> (quotation mark)."
206			(Comment within \q\u\o\t\e\d\-\p\a\i\r\(\s\))';
207			my $field = Message::Field::Structured->parse ($field_body);
208
209			print $field->as_plain_string;
210
211	wakaba	1.5	=head1 SEE ALSO
212
213			=over 4
214
215			=item L<Message::Entity>, L<Message::Header>
216
217			=item L<Message::Field::Unstructured>
218
219			=item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
220
221			=back
222
223	wakaba	1.1	=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.8	$Date: 2002/04/13 01:33:54 $
246	wakaba	1.1
247			=cut
248
249			1;