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(%DEFAULT $VERSION);
$VERSION=do{my @r=(q$Revision: 1.10 $=~/\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
  %DEFAULT = (
    _ARRAY_NAME => '',
    _ARRAY_VALTYPE      => '*default',
    _HASH_NAME  => '',
    _MATHODS    => [qw|as_plain_string value_append|],
    _MEMBERS    => [qw|field_body|],
    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:']},
  );
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->{option} = Message::Util::make_clone (\%DEFAULT);
  $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};
    $option{parse} = 1 if $option{parse_all} && !defined $option{parse};
    
    ## Additional items
    my $avalue;
    for (@_) {
      local $option{parse} = $option{parse};
      my ($ok, undef, $avalue) = $self->_add_array_check ($_, \%option);
      if ($ok) {
        $avalue = $self->_parse_value
          ($option{_ARRAY_VALTYPE} => $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};
    $option{parse} = 1 if $option{parse_all} && !defined $option{parse};
    
    ## Additional items
    my $avalue;
    while (my ($name => $value) = splice (@_, 0, 2)) {
      next if $name =~ /^-/; $name =~ s/^\\//;
      
      my $ok;
      local $option{parse} = $option{parse};
      ($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{$_}}
    }
    $option{parse} = 1 if defined wantarray && !defined $option{parse};
    $option{parse} = 1 if $option{parse_all} && !defined $option{parse};
    
    ## Additional items
    my ($avalue, %replace);
    for (@_) {
      local $option{parse} = $option{parse};
      my ($ok, $aname);
      ($ok, $aname => $avalue)
        = $self->_replace_array_check ($_, \%option);
      if ($ok) {
        $avalue = $self->_parse_value
          ($option{_ARRAY_VALTYPE} => $avalue) if $option{parse};
        $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};
    $option{parse} = 1 if $option{parse_all} && !defined $option{parse};
    
    ## Additional items
    my ($avalue, %replace);
    while (my ($name => $value) = splice (@_, 0, 2)) {
      next if $name =~ /^-/; $name =~ s/^\\//;
      
      my ($ok, $aname);
      local $option{parse} = $option{parse};
      ($ok, $aname => $avalue)
        = $self->_replace_hash_check ($name => $value, \%option);
      if ($ok) {
        $avalue = $self->_parse_value ($name => $avalue) if $option{parse};
        $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;
  my $array = $self->{option}->{_ARRAY_NAME} || $self->{option}->{_HASH_NAME};
  $self->{$array} = [grep {length $_} @{$self->{$array}}] if $array;
}

sub item ($$;%) {
  my $self = shift;
  my ($name, %p) = (shift, @_); ## BUG: don't support -by
  return $self->replace ($name => $p{-value}, @_) if defined $p{-value};
  my %option = %{$self->{option}};
  $option{new_item_unless_exist} = 1;
  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};
  }
  my @r;
  if ($option{by} eq 'index') {
    for ($self->{$array}->[$name]) {
      return $self->_item_return_value (\$_, \%option);
    }
  } else {
    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);
        }
      }
    }
  }
  if (@r == 0 && $option{new_item_unless_exist}) {
    my $v = $self->_item_new_value ($name, \%option);
    if (defined $v) {
      if ($option{prepend}) {
        unshift @{$self->{$array}}, $v;
      } else {
        push @{$self->{$array}}, $v;
      }
      return $self->_item_return_value (\$v, \%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];
}

## Returns returned (new created) item value    $name, \%option
sub _item_new_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);
  }
}

## comments


sub comment_add ($@) {
  my $self = shift;
  my $array = 'comment';
    ## 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
        if ($option{prepend}) {
          unshift @{$self->{$array}}, reverse @_;
        } else {
          push @{$self->{$array}}, @_;
        }
}

sub comment_count ($) {
  my $self = shift;
  $self->_comment_cleaning;
  $#{$self->{comment}} + 1;
}

sub comment_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{$_}}
    for (@_) {
      $self->{comment}->[$_] = undef;
    }
  $self->_comment_cleaning;
}

sub comment_item ($$) {
  $_[0]->{comment}->[$_[1]];
}

sub _comment_cleaning ($) {
  my $self = shift;
  $self->{comment} = [grep {length $_} @{$self->{comment}}];
}

sub _comment_stringify ($\%) {
  my $self = shift;
  #my $option = shift;
  my @v;
  for (@{$self->{comment}}) {
    push @v, '('. $self->Message::Util::encode_ccontent ($_) .')';
  }
  join ' ', @v;
}

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->{option} = Message::Util::make_clone ($self->{option});
  ## Common hash value (not used in this module)
    $self->_delete_empty;
    $self->_comment_cleaning;
    $clone->{value} = Message::Util::make_clone ($self->{value});
    $clone->{comment} = Message::Util::make_clone ($self->{comment});
  for (@{$self->{option}->{_MEMBERS}}) {
    $clone->{$_} = Message::Util::make_clone ($self->{$_});
  }
  $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/08 09:11:31 $

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