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.9 $=~/\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  => '',
    _MATHODS    => [qw(as_plain_string)],
    by  => 'index',     ## (Reserved for method level option)
    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{$_}}
      $option{parse} = 1 if defined wantarray && !defined $option{parse};
    }
    
    ## Additional items
    my $avalue;
    for (@_) {
      my ($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
      if ($ok) {
        $avalue = $self->_parse_value ('*default' => $avalue) if $option{parse};
        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, $name, $avalue) = $self->_add_hash_check ($name => $value, \%option);
      if ($ok) {
        $avalue = $self->_parse_value ($name => $avalue) if $option{parse};
        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;
}

sub delete ($@) {
  my $self = shift;
  my %p; %p = %{shift (@_)} if ref $_[0] eq 'HASH';
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
  unless ($array) {
    return if $option{dont_croak};
    Carp::croak q{delete: Method not available for this module};
  }
  if ($option{by} && $option{by} ne 'index') {
    my %name; for (@_) {$name{$_} = 1}
    for (@{$self->{$array}}) {
      if ($self->_delete_match ($option{by}, \$_, \%name, \%option)) {
        $_ = undef;
      }
    }
  } else {      ## by index
    for (@_) {
      $self->{$array}->[$_] = undef;
    }
  }
  $self->_delete_cleaning;
}

## delete-by?, \$checked-item, \%delete-list, \%option
sub _delete_match ($$\$\%\%) {
  0 #return 1 / 0
}

sub _delete_cleaning ($) {
  $_[0]->_delete_empty;
}

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

sub item ($$;%) {
  my $self = shift;
  my ($name, %p) = (shift, @_);
  return $self->replace ($name => $p{-value}, @_) if defined $p{-value};
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  my $array = $option{_ARRAY_NAME} || $option{_HASH_NAME};
  unless ($array) {
    return if $option{dont_croak};
    Carp::croak q{item: Method not available for this module};
  }
  if ($option{by} eq 'index') {
    for ($self->{$array}->[$name]) {
      return $self->_item_return_value (\$_, \%option);
    }
  } else {
    my @r;
    for (@{$self->{$array}}) {
      if ($self->_item_match ($option{by}, \$_, {$name => 1}, \%option)) {
        if (wantarray) {
          push @r, $self->_item_return_value (\$_, \%option);
        } else {
          return $self->_item_return_value (\$_, \%option);
        }
      }
    }
    return undef unless wantarray;
    (@r);
  }
}

## item-by?, \$checked-item, {item-key => 1}, \%option
sub _item_match ($$\$\%\%) {
  0 #return 1 / 0
}

## Returns returned item value    \$item-value, \%option
sub _item_return_value ($\$\%) {
  $_[1]
}

## $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);
  }
}

sub scan ($&) {
  my ($self, $sub) = @_;
  my %p = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %p) {$option{substr ($_, 1)} = $p{$_}}
  my $array = $self->{option}->{_ARRAY_NAME}
           || $self->{option}->{_HASH_NAME};
  my @param = @{$self->{$array}};
  my $sort = $option{sort};
  @param = sort $sort @param if ref $sort;
  for my $param (@param) {
    &$sub($self, $param);
  }
}

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

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