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.8 $=~/\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} = Message::Util::make_clone ({
    _ARRAY_NAME => '',
    _HASH_NAME  => '',
    dont_croak  => 0,   ## Don't die unless very very fatal error
    encoding_after_encode       => '*default',
    encoding_before_decode      => '*default',
    field_param_name    => '',
    field_name  => 'x-structured',
    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,
    #name       ## Reserved for method level option
    #parse      ## Reserved for method level option
    parse_all   => 0,
    prepend     => 0,   ## (Reserved for method level option)
    value_type  => {'*default'  => [':none:']},
  });
  $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

=cut

## Template procedures for array/hash fields
## (As bare Message::Field::Structured module,
##  these shall not be used.)

sub add ($$$%) {
  my $self = shift;
  
  my $array = $self->{option}->{_ARRAY_NAME};
  if ($array) {
  
  ## --- field is non-named value list (i.e. not hash)
    
    ## Options
    my %option = %{$self->{option}};
    if (ref $_[0] eq 'HASH') {
      my $option = shift (@_);
      for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
    }
    
    ## Additional items
    my $avalue;
    for (@_) {
      my ($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
      if ($ok) {
        if ($option{prepend}) {
          unshift @{$self->{$array}}, $avalue;
        } else {
          push @{$self->{$array}}, $avalue;
        }
      }
    }
    $avalue;    ## Return last added value if necessary.
    
  } else {
    $array = $self->{option}->{_HASH_NAME};
  
  ## --- field is not list
  
    unless ($array) {
      my %option = @_;
      return if $option{-dont_croak};
      Carp::croak q{add: Method not available for this module};
    }
    
  ## --- field is named value list (i.e. hash)
    
    ## Options
    my %p = @_; my %option = %{$self->{option}};
    for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
    $option{parse} = 1 if defined wantarray && !defined $option{parse};
    
    ## Additional items
    my $avalue;
    while (my ($name => $value) = splice (@_, 0, 2)) {
      next if $name =~ /^-/; $name =~ s/^\\//;
      
      my $ok;
      ($ok, undef, $avalue) = $self->_add_hash_check ($name => $value, \%option);
      if ($ok) {
        if ($option{prepend}) {
          unshift @{$self->{$array}}, $avalue;
        } else {
          push @{$self->{$array}}, $avalue;
        }
      }
    }
    $avalue;    ## Return last added value if necessary.
  }
}

sub _add_array_check ($$\%) {
  shift; 1, $_[0] => $_[0];
}
sub _add_hash_check ($$$\%) {
  shift; 1, $_[0] => [@_[0,1]];
}

sub replace ($$$%) {
  my $self = shift;
  
  $self->_replace_cleaning;
  my $array = $self->{option}->{_ARRAY_NAME};
  if ($array) {
  
  ## --- field is non-named value list (i.e. not hash)
    
    ## Options
    my %option = %{$self->{option}};
    if (ref $_[0] eq 'HASH') {
      my $option = shift (@_);
      for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
    }
    
    ## Additional items
    my ($avalue, %replace);
    for (@_) {
      my ($ok, $aname);
      ($ok, $aname => $avalue)
        = $self->_replace_array_check ($_, \%option);
      if ($ok) {
        $replace{$aname} = $avalue;
      }
    }
    for (@{$self->{$array}}) {
      my ($v) = $self->_replace_array_shift (\%replace => $_, \%option);
      if (defined $v) {
        $_ = $v;
      }
    }
    for (keys %replace) {
      if ($option{prepend}) {
        unshift @{$self->{$array}}, $replace{$_};
      } else {
        push @{$self->{$array}}, $replace{$_};
      }
    }
    $avalue;    ## Return last added value if necessary.
    
  } else {
    $array = $self->{option}->{_HASH_NAME};
  
  ## --- field is not list
  
    unless ($array) {
      my %option = @_;
      return if $option{-dont_croak};
      Carp::croak q{replace: Method not available for this module};
    }
    
  ## --- field is named value list (i.e. hash)
    
    ## Options
    my %p = @_; my %option = %{$self->{option}};
    for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
    $option{parse} = 1 if defined wantarray && !defined $option{parse};
    
    ## Additional items
    my ($avalue, %replace);
    while (my ($name => $value) = splice (@_, 0, 2)) {
      next if $name =~ /^-/; $name =~ s/^\\//;
      
      my ($ok, $aname);
      ($ok, $aname => $avalue)
        = $self->_replace_hash_check ($name => $value, \%option);
      if ($ok) {
        $replace{$aname} = $avalue;
      }
    }
    for (@{$self->{$array}}) {
      my ($v) = $self->_replace_hash_shift (\%replace => $_, \%option);
      if (defined $v) {
        $_ = $v;
      }
    }
    for (keys %replace) {
      if ($option{prepend}) {
        unshift @{$self->{$array}}, $replace{$_};
      } else {
        push @{$self->{$array}}, $replace{$_};
      }
    }
    $avalue;    ## Return last added value if necessary.
  }
}

sub _replace_cleaning ($) {
  # $_[0]->_delete_empty;
}
sub _replace_array_check ($$\%) {
  shift; 1, $_[0] => $_[0];
}
sub _replace_array_shift ($\%$\%) {
  shift; my $r = shift;  my $n = $_[0]->[0];
  if ($$r{$n}) {
    my $d = $$r{$n};
    $$r{$n} = undef;
    return $d;
  }
  undef;
}
sub _replace_hash_check ($$$\%) {
  shift; 1, $_[0] => [@_[0,1]];
}
sub _replace_hash_shift ($\%$\%) {
  shift; my $r = shift;  my $n = $_[0]->[0];
  if ($$r{$n}) {
    my $d = $$r{$n};
    $$r{$n} = undef;
    return $d;
  }
  undef;
}

sub count ($;%) {
  my $self = shift; my %option = @_;
  my $array = $self->{option}->{_ARRAY_NAME}
           || $self->{option}->{_HASH_NAME};
  unless ($array) {
    return if $option{-dont_croak};
    Carp::croak q{count: Method not available for this module};
  }
  $self->_count_cleaning;
  return $self->_count_by_name ($array => \%option) if defined $option{-name};
  $#{$self->{$array}} + 1;
}
sub _count_cleaning ($) {
  # $_[0]->_delete_empty;
}
sub _count_by_name ($$\%) {
  # my $self = shift;
  # my ($array, $option) = @_;
  # my $name = $self->_n11n_*name* ($$option{-name});
  # my @a = grep {$_->[0] eq $name} @{$self->{$array}};
  # $#a + 1;
}

## Delete empty items
sub _delete_empty ($) {
  # my $self = shift;
  # $self->{*$array*} = [grep {ref $_ && length $_->[0]} @{$self->{*$array*}}];
  # $self;
}

## $self->_parse_value ($type, $value);
sub _parse_value ($$$) {
  my $self = shift;
  my $name = shift || '*default';
  my $value = shift;
  return $value if ref $value;
  my $vtype = $self->{option}->{value_type}->{$name}->[0]
      || $self->{option}->{value_type}->{'*default'}->[0];
  my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]} 
    if ref $self->{option}->{value_type}->{$name}->[1];
  if ($vtype eq ':none:') {
    return $value;
  } elsif (defined $value) {
    eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
    return $vtype->parse ($value,
      -format   => $self->{option}->{format},
      -field_name       => $self->{option}->{field_name},
      -field_param_name => $name,
      -parse_all        => $self->{option}->{parse_all},
    %vopt);
  } else {
    eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
    return $vtype->new (
      -format   => $self->{option}->{format},
      -field_name       => $self->{option}->{field_name},
      -field_param_name => $name,
      -parse_all        => $self->{option}->{parse_all},
    %vopt);
  }
}

=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;
  }
}

## TODO: multiple value-type support
sub value_type ($;$$%) {
  my $self = shift;
  my $name = shift || '*default';
  my $new_value_type = shift;
  if ($new_value_type) {
    $self->{option}->{value_type}->{$name} = []
      unless ref $self->{option}->{value_type}->{$name};
    $self->{option}->{value_type}->{$name}->[0] = $new_value_type;
  }
  if (ref $self->{option}->{value_type}->{$name}) {
    $self->{option}->{value_type}->{$name}->[0]
      || $self->{option}->{value_type}->{'*default'}->[0];
  } else {
    $self->{option}->{value_type}->{'*default'}->[0];
  }
}

=item $self->clone ()

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

=cut

sub clone ($) {
  my $self = shift;
  my $clone = ref($self)->new;
  $clone->_delete_empty;
  $clone->{option} = Message::Util::make_clone ($self->{option});
  $clone->{field_body} = Message::Util::make_clone ($self->{field_body});
  ## Common hash value (not used in this module)
  $clone->{value} = Message::Util::make_clone ($self->{value});
  $clone->{comment} = Message::Util::make_clone ($self->{comment});
  $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/21 04:27:42 $

=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.9	$VERSION=do{my @r=(q$Revision: 1.8 $=~/\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	wakaba	1.9	$self->{option} = Message::Util::make_clone ({
33			_ARRAY_NAME => '',
34			_HASH_NAME => '',
35			dont_croak => 0, ## Don't die unless very very fatal error
36			encoding_after_encode => '*default',
37			encoding_before_decode => '*default',
38			field_param_name => '',
39			field_name => 'x-structured',
40			format => 'mail-rfc2822',
41			hook_encode_string => #sub {shift; (value => shift, @_)},
42			\&Message::Util::encode_header_string,
43			hook_decode_string => #sub {shift; (value => shift, @_)},
44			\&Message::Util::decode_header_string,
45			#name ## Reserved for method level option
46			#parse ## Reserved for method level option
47			parse_all => 0,
48			prepend => 0, ## (Reserved for method level option)
49			value_type => {'*default' => [':none:']},
50			});
51	wakaba	1.5	$self->{field_body} = '';
52
53			for my $name (keys %options) {
54			if (substr ($name, 0, 1) eq '-') {
55			$self->{option}->{substr ($name, 1)} = $options{$name};
56			} elsif (lc $name eq 'body') {
57			$self->{field_body} = $options{$name};
58			}
59			}
60			}
61	wakaba	1.3
62	wakaba	1.5	=item Message::Field::Structured->new ([%options])
63	wakaba	1.1
64	wakaba	1.5	Constructs a new C<Message::Field::Structured> object. You might pass some
65			options as parameters to the constructor.
66	wakaba	1.1
67			=cut
68
69	wakaba	1.2	sub new ($;%) {
70	wakaba	1.3	my $class = shift;
71	wakaba	1.5	my $self = bless {}, $class;
72			$self->_init (@_);
73	wakaba	1.3	$self;
74	wakaba	1.1	}
75
76	wakaba	1.5	=item Message::Field::Structured->parse ($field-body, [%options])
77	wakaba	1.1
78	wakaba	1.5	Constructs a new C<Message::Field::Structured> object with
79			given field body. You might pass some options as parameters to the constructor.
80	wakaba	1.1
81			=cut
82
83	wakaba	1.2	sub parse ($$;%) {
84	wakaba	1.3	my $class = shift;
85	wakaba	1.5	my $self = bless {}, $class;
86			$self->_init (@_);
87			#my $field_body = $self->Message::Util::decode_qcontent (shift);
88			$self->{field_body} = shift; #$field_body;
89	wakaba	1.1	$self;
90			}
91
92	wakaba	1.5	=back
93
94	wakaba	1.9	=cut
95
96			## Template procedures for array/hash fields
97			## (As bare Message::Field::Structured module,
98			## these shall not be used.)
99
100			sub add ($$$%) {
101			my $self = shift;
102
103			my $array = $self->{option}->{_ARRAY_NAME};
104			if ($array) {
105
106			## --- field is non-named value list (i.e. not hash)
107
108			## Options
109			my %option = %{$self->{option}};
110			if (ref $_[0] eq 'HASH') {
111			my $option = shift (@_);
112			for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
113			}
114
115			## Additional items
116			my $avalue;
117			for (@_) {
118			my ($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
119			if ($ok) {
120			if ($option{prepend}) {
121			unshift @{$self->{$array}}, $avalue;
122			} else {
123			push @{$self->{$array}}, $avalue;
124			}
125			}
126			}
127			$avalue; ## Return last added value if necessary.
128
129			} else {
130			$array = $self->{option}->{_HASH_NAME};
131
132			## --- field is not list
133
134			unless ($array) {
135			my %option = @_;
136			return if $option{-dont_croak};
137			Carp::croak q{add: Method not available for this module};
138			}
139
140			## --- field is named value list (i.e. hash)
141
142			## Options
143			my %p = @_; my %option = %{$self->{option}};
144			for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
145			$option{parse} = 1 if defined wantarray && !defined $option{parse};
146
147			## Additional items
148			my $avalue;
149			while (my ($name => $value) = splice (@_, 0, 2)) {
150			next if $name =~ /^-/; $name =~ s/^\\//;
151
152			my $ok;
153			($ok, undef, $avalue) = $self->_add_hash_check ($name => $value, \%option);
154			if ($ok) {
155			if ($option{prepend}) {
156			unshift @{$self->{$array}}, $avalue;
157			} else {
158			push @{$self->{$array}}, $avalue;
159			}
160			}
161			}
162			$avalue; ## Return last added value if necessary.
163			}
164			}
165
166			sub _add_array_check ($$\%) {
167			shift; 1, $_[0] => $_[0];
168			}
169			sub _add_hash_check ($$$\%) {
170			shift; 1, $_[0] => [@_[0,1]];
171			}
172
173			sub replace ($$$%) {
174			my $self = shift;
175
176			$self->_replace_cleaning;
177			my $array = $self->{option}->{_ARRAY_NAME};
178			if ($array) {
179
180			## --- field is non-named value list (i.e. not hash)
181
182			## Options
183			my %option = %{$self->{option}};
184			if (ref $_[0] eq 'HASH') {
185			my $option = shift (@_);
186			for (keys %$option) {my $n = $_; $n =~ s/^-//; $option{$n} = $$option{$_}}
187			}
188
189			## Additional items
190			my ($avalue, %replace);
191			for (@_) {
192			my ($ok, $aname);
193			($ok, $aname => $avalue)
194			= $self->_replace_array_check ($_, \%option);
195			if ($ok) {
196			$replace{$aname} = $avalue;
197			}
198			}
199			for (@{$self->{$array}}) {
200			my ($v) = $self->_replace_array_shift (\%replace => $_, \%option);
201			if (defined $v) {
202			$_ = $v;
203			}
204			}
205			for (keys %replace) {
206			if ($option{prepend}) {
207			unshift @{$self->{$array}}, $replace{$_};
208			} else {
209			push @{$self->{$array}}, $replace{$_};
210			}
211			}
212			$avalue; ## Return last added value if necessary.
213
214			} else {
215			$array = $self->{option}->{_HASH_NAME};
216
217			## --- field is not list
218
219			unless ($array) {
220			my %option = @_;
221			return if $option{-dont_croak};
222			Carp::croak q{replace: Method not available for this module};
223			}
224
225			## --- field is named value list (i.e. hash)
226
227			## Options
228			my %p = @_; my %option = %{$self->{option}};
229			for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
230			$option{parse} = 1 if defined wantarray && !defined $option{parse};
231
232			## Additional items
233			my ($avalue, %replace);
234			while (my ($name => $value) = splice (@_, 0, 2)) {
235			next if $name =~ /^-/; $name =~ s/^\\//;
236
237			my ($ok, $aname);
238			($ok, $aname => $avalue)
239			= $self->_replace_hash_check ($name => $value, \%option);
240			if ($ok) {
241			$replace{$aname} = $avalue;
242			}
243			}
244			for (@{$self->{$array}}) {
245			my ($v) = $self->_replace_hash_shift (\%replace => $_, \%option);
246			if (defined $v) {
247			$_ = $v;
248			}
249			}
250			for (keys %replace) {
251			if ($option{prepend}) {
252			unshift @{$self->{$array}}, $replace{$_};
253			} else {
254			push @{$self->{$array}}, $replace{$_};
255			}
256			}
257			$avalue; ## Return last added value if necessary.
258			}
259			}
260
261			sub _replace_cleaning ($) {
262			# $_[0]->_delete_empty;
263			}
264			sub _replace_array_check ($$\%) {
265			shift; 1, $_[0] => $_[0];
266			}
267			sub _replace_array_shift ($\%$\%) {
268			shift; my $r = shift; my $n = $_[0]->[0];
269			if ($$r{$n}) {
270			my $d = $$r{$n};
271			$$r{$n} = undef;
272			return $d;
273			}
274			undef;
275			}
276			sub _replace_hash_check ($$$\%) {
277			shift; 1, $_[0] => [@_[0,1]];
278			}
279			sub _replace_hash_shift ($\%$\%) {
280			shift; my $r = shift; my $n = $_[0]->[0];
281			if ($$r{$n}) {
282			my $d = $$r{$n};
283			$$r{$n} = undef;
284			return $d;
285			}
286			undef;
287			}
288
289			sub count ($;%) {
290			my $self = shift; my %option = @_;
291			my $array = $self->{option}->{_ARRAY_NAME}
292			\|\| $self->{option}->{_HASH_NAME};
293			unless ($array) {
294			return if $option{-dont_croak};
295			Carp::croak q{count: Method not available for this module};
296			}
297			$self->_count_cleaning;
298			return $self->_count_by_name ($array => \%option) if defined $option{-name};
299			$#{$self->{$array}} + 1;
300			}
301			sub _count_cleaning ($) {
302			# $_[0]->_delete_empty;
303			}
304			sub _count_by_name ($$\%) {
305			# my $self = shift;
306			# my ($array, $option) = @_;
307			# my $name = $self->_n11n_name ($$option{-name});
308			# my @a = grep {$_->[0] eq $name} @{$self->{$array}};
309			# $#a + 1;
310			}
311
312			## Delete empty items
313			sub _delete_empty ($) {
314			# my $self = shift;
315			# $self->{$array} = [grep {ref $_ && length $_->[0]} @{$self->{$array}}];
316			# $self;
317			}
318
319			## $self->_parse_value ($type, $value);
320			sub _parse_value ($$$) {
321			my $self = shift;
322			my $name = shift \|\| '*default';
323			my $value = shift;
324			return $value if ref $value;
325			my $vtype = $self->{option}->{value_type}->{$name}->[0]
326			\|\| $self->{option}->{value_type}->{'*default'}->[0];
327			my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]}
328			if ref $self->{option}->{value_type}->{$name}->[1];
329			if ($vtype eq ':none:') {
330			return $value;
331			} elsif (defined $value) {
332			eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
333			return $vtype->parse ($value,
334			-format => $self->{option}->{format},
335			-field_name => $self->{option}->{field_name},
336			-field_param_name => $name,
337			-parse_all => $self->{option}->{parse_all},
338			%vopt);
339			} else {
340			eval "require $vtype" or Carp::croak qq{<parse>: $vtype: Can't load package: $@};
341			return $vtype->new (
342			-format => $self->{option}->{format},
343			-field_name => $self->{option}->{field_name},
344			-field_param_name => $name,
345			-parse_all => $self->{option}->{parse_all},
346			%vopt);
347			}
348			}
349
350	wakaba	1.5	=head1 METHODS
351
352			=over 4
353
354			=item $self->stringify ([%options])
355	wakaba	1.1
356	wakaba	1.5	Returns field body as a string. Returned string is encoded,
357			quoted if necessary (by C<hook_encode_string>).
358	wakaba	1.1
359			=cut
360
361	wakaba	1.7	sub stringify ($;%) {
362	wakaba	1.1	my $self = shift;
363	wakaba	1.5	#$self->Message::Util::encode_qcontent ($self->{field_body});
364			$self->{field_body};
365	wakaba	1.1	}
366	wakaba	1.5	*as_string = \&stringify;
367	wakaba	1.1
368	wakaba	1.5	=item $self->as_plain_string
369	wakaba	1.1
370	wakaba	1.5	Returns field body as a string. Returned string is not encoded
371			or quoted, i.e. internal/bare coded string. This string
372			may be unable to use as field body content. (Its I<structures>
373			such as C<comment> and C<quoted-string> are lost.)
374	wakaba	1.1
375			=cut
376
377			sub as_plain_string ($) {
378			my $self = shift;
379	wakaba	1.5	my $s = $self->Message::Util::decode_qcontent ($self->{field_body});
380			Message::Util::unquote_quoted_string (Message::Util::unquote_ccontent ($s));
381	wakaba	1.1	}
382	wakaba	1.4
383	wakaba	1.5	=item $self->option ( $option-name / $option-name, $option-value, ...)
384	wakaba	1.4
385	wakaba	1.5	If @_ == 1, returns option value. Else...
386	wakaba	1.4
387	wakaba	1.5	Set option value. You can pass multiple option name-value pair
388			as parameter. Example:
389	wakaba	1.1
390	wakaba	1.5	$msg->option (-format => 'mail-rfc822',
391			-capitalize => 0);
392			print $msg->option ('-format'); ## mail-rfc822
393	wakaba	1.3
394	wakaba	1.5	Note that introduction character, i.e. C<-> (HYPHEN-MINUS)
395			is optional. You can also write as this:
396	wakaba	1.3
397	wakaba	1.5	$msg->option (format => 'mail-rfc822',
398			capitalize => 0);
399			print $msg->option ('format'); ## mail-rfc822
400	wakaba	1.1
401			=cut
402
403	wakaba	1.5	sub option ($@) {
404	wakaba	1.1	my $self = shift;
405	wakaba	1.5	if (@_ == 1) {
406			return $self->{option}->{ $_[0] };
407			}
408			while (my ($name, $value) = splice (@_, 0, 2)) {
409			$name =~ s/^-//;
410			$self->{option}->{$name} = $value;
411			}
412	wakaba	1.1	}
413
414	wakaba	1.9	## TODO: multiple value-type support
415			sub value_type ($;$$%) {
416			my $self = shift;
417			my $name = shift \|\| '*default';
418			my $new_value_type = shift;
419			if ($new_value_type) {
420			$self->{option}->{value_type}->{$name} = []
421			unless ref $self->{option}->{value_type}->{$name};
422			$self->{option}->{value_type}->{$name}->[0] = $new_value_type;
423			}
424			if (ref $self->{option}->{value_type}->{$name}) {
425			$self->{option}->{value_type}->{$name}->[0]
426			\|\| $self->{option}->{value_type}->{'*default'}->[0];
427			} else {
428			$self->{option}->{value_type}->{'*default'}->[0];
429			}
430			}
431
432	wakaba	1.5	=item $self->clone ()
433	wakaba	1.1
434	wakaba	1.5	Returns a copy of Message::Field::Structured object.
435	wakaba	1.1
436			=cut
437
438	wakaba	1.5	sub clone ($) {
439	wakaba	1.1	my $self = shift;
440	wakaba	1.5	my $clone = ref($self)->new;
441	wakaba	1.9	$clone->_delete_empty;
442			$clone->{option} = Message::Util::make_clone ($self->{option});
443			$clone->{field_body} = Message::Util::make_clone ($self->{field_body});
444	wakaba	1.5	## Common hash value (not used in this module)
445	wakaba	1.9	$clone->{value} = Message::Util::make_clone ($self->{value});
446			$clone->{comment} = Message::Util::make_clone ($self->{comment});
447	wakaba	1.5	$clone;
448	wakaba	1.1	}
449
450	wakaba	1.8	sub _n11n_field_name ($$) {
451			my $self = shift;
452			my $s = shift;
453	wakaba	1.9	$s = lc $s ;#unless $self->{option}->{field_name_case_sensible};
454	wakaba	1.8	$s;
455			}
456
457	wakaba	1.5
458	wakaba	1.1	=head1 EXAMPLE
459
460			use Message::Field::Structured;
461
462			my $field_body = '"This is an example of <\"> (quotation mark)."
463			(Comment within \q\u\o\t\e\d\-\p\a\i\r\(\s\))';
464			my $field = Message::Field::Structured->parse ($field_body);
465
466			print $field->as_plain_string;
467
468	wakaba	1.5	=head1 SEE ALSO
469
470			=over 4
471
472			=item L<Message::Entity>, L<Message::Header>
473
474			=item L<Message::Field::Unstructured>
475
476			=item RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>, usefor-article, HTTP/1.0, HTTP/1.1
477
478			=back
479
480	wakaba	1.1	=head1 LICENSE
481
482			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
483
484			This program is free software; you can redistribute it and/or modify
485			it under the terms of the GNU General Public License as published by
486			the Free Software Foundation; either version 2 of the License, or
487			(at your option) any later version.
488
489			This program is distributed in the hope that it will be useful,
490			but WITHOUT ANY WARRANTY; without even the implied warranty of
491			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
492			GNU General Public License for more details.
493
494			You should have received a copy of the GNU General Public License
495			along with this program; see the file COPYING. If not, write to
496			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
497			Boston, MA 02111-1307, USA.
498
499			=head1 CHANGE
500
501			See F<ChangeLog>.
502	wakaba	1.9	$Date: 2002/04/21 04:27:42 $
503	wakaba	1.1
504			=cut
505
506			1;