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.12 $=~/\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};
    }
  }
  $self->{comment} = [];
}

=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)) {
    $self->{option}->{substr ($name, 1)} = $value;
  }
  $self;
}

## 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/15 07:29:09 $

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