Message/Field/CSV.pm


=head1 NAME

Message::Field::CSV Perl module

=head1 DESCRIPTION

Perl module for comma separated C<field>.

This module supports a number of fields that contains
(or does not contain:-)) of comma separated values,
such as C<Keywords:>, C<Newsgroups:> and so on.

=cut

package Message::Field::CSV;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%OPTION %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use overload '@{}' => sub {shift->value},
             '""' => sub {shift->stringify};
require Message::Util;
$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
$REG{uri_literal} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;

$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
$REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
$REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
$REG{NON_atom} = qr/[^\x09\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;
$REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
$REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;
$REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;
$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;

## Keywords: foo, bar, "and so on"
## Newsgroups: local.test,local.foo,local.bar
## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01

%OPTION = (
  field_name    => 'keywords',
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  hook_encode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
  hook_decode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
  is_quoted_string      => 1,   ## Can itself quoted-string?
  long_count    => 10,
  remove_comment        => 1,
  separator     => ', ',
  separator_long        => ', ',
  max   => -1,
  value_type    => [':none:'],
  value_unsafe_rule     => 'NON_http_token_wsp',
);

sub _init_option ($) {
  my $self = shift;
  my %field_type = qw(accept-charset accept accept-encoding accept 
     accept-language accept
     content-language keywords
     followup-to newsgroups
     list-archive list- list-digest list- list-help list- 
     list-owner list- list-post list- list-subscribe list- 
     list-unsubscribe list- list-url list- uri list-
     posted-to newsgroups
     x-brother x-moe x-daughter x-moe
     x-respect x-moe x-syster x-moe x-wife x-moe);
  my $field_name = lc $self->{option}->{field_name}
                || lc $self->{option}->{-field_name};   ## AD HOC
  $field_name = $field_type{$field_name} || $field_name;
  if ($field_name eq 'newsgroups') {
    $self->{option}->{separator} = ',';
    $self->{option}->{separator_long} = ', ';
    $self->{option}->{long_count} = 5;
    $self->{option}->{value_unsafe_rule} = 'NON_component';
    $self->{option}->{encoding_after_encode} = 'utf-8';
  } elsif ($field_name eq 'distribution') {
    $self->{option}->{separator} = ',';
    $self->{option}->{separator_long} = ', ';
    $self->{option}->{long_count} = 15;
    $self->{option}->{value_unsafe_rule} = 'NON_distribution';
  } elsif ($field_name eq 'x-moe') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{value_type} = ['Message::Field::ValueParams', 
      {format => $self->{option}->{format}}];
  } elsif ($field_name eq 'accept') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{value_type} = ['Message::Field::ValueParams', 
      {format => $self->{option}->{format}}];
  } elsif ($field_name eq 'list-') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{remove_comment} = -1;
    $self->{option}->{value_type} = ['Message::Field::URI', 
      {field_name => $self->{option}->{field_name},
      format => $self->{option}->{format}}];
  } elsif ($field_name eq 'encrypted') {
    $self->{option}->{max} = 2;
  }
  $self;
}

=head2 Message::Field::CSV->new ()

Returns new CSV field body.

=cut

sub new ($;%) {
  my $self = bless {}, shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $self->_init_option ();
  $self;
}

=head2 Message::Field::CSV->parse ($unfolded_field_body)

Parses C<field-body>.

=cut

sub parse ($$;%) {
  my $self = bless {}, shift;
  my $field_body = shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $self->_init_option ();
  $field_body = $self->_delete_comment ($field_body)
    unless $option{remove_comment}<0;
  @{$self->{value}} = $self->_parse_list ($field_body);
  $self;
}

sub _parse_list ($$) {
  my $self = shift;
  my $fb = shift;
  my @ids;
  $fb =~ s{((?:$REG{quoted_string}|$REG{uri_literal}|$REG{domain_literal}|$REG{comment}|[^\x22\x28\x2C\x3C\x5B])+)}{
    my $s = $1;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;
    if ($self->{option}->{is_quoted_string}>0) {
      push @ids, $self->_value ($self->_decode_quoted_string ($s));
    } else {
      push @ids, $self->_value ($s);
    }
  }goex;
  @ids;
}

=head2 $self->value ()

Returns array reference to value list.

=cut

sub value ($) {shift->{value}}

=head2 $self->add ($value, [%option])

Adds new value.

=cut

sub add ($;$%) {
  my $self = shift;
  my ($value, %option) = @_;
  push @{$self->{value}}, $self->_value ($value);
  $value;
}

## Hook called before returning C<value>.
## $self->_param_value ($name, $value);
sub _value ($$) {
  my $self = shift;
  my $value = shift;
  my $vtype = $self->{option}->{value_type}->[0];
  my %vopt; %vopt = %{$self->{option}->{value_type}->[1]} 
    if ref $self->{option}->{value_type}->[1];
  if (ref $value) {
    return $value;
  } elsif ($vtype eq ':none:') {
    return $value;
  } elsif ($value) {
    eval "require $vtype";
    return $vtype->parse ($value, %vopt);
  } else {
    eval "require $vtype";
    return $vtype->new (%vopt);
  }
}

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  $option{separator} ||= $self->{option}->{separator};
  $option{separator_long} ||= $self->{option}->{separator_long};
  $option{long_count} ||= $self->{option}->{long_count};
  $option{max} ||= $self->{option}->{max};
  $option{is_quoted_string} ||= $self->{option}->{is_quoted_string};
  $option{value_unsafe_rule} ||= $self->{option}->{value_unsafe_rule};
  $self->_delete_empty ();
  $option{max}--;
  $option{max} = $#{$self->{value}} if $option{max}<0;
  $option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};
  $option{separator} = $option{separator_long}
    if $option{max} >= $option{long_count};
  join $option{separator}, 
    map {
      if ($option{is_quoted_string}>0) {
        my %s = &{$self->{option}->{hook_encode_string}} ($self, 
          $_, type => 'phrase');
        $self->_quote_unsafe_string ($s{value}, 
          unsafe => $option{value_unsafe_rule});
      } else {
        $_;
      }
    } @{$self->{value}}[0..$option{max}];
}

=head2 $self->option ($option_name, [$option_value])

Set/gets new value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

sub value_type ($;$%) {
  my $self = shift;
  my $new_value_type = shift;
  if ($new_value_type) {
    $self->{option}->{value_type}->[0] = $new_value_type;
  }
  $self->{option}->{value_type}->[0] || ':none:';
}

sub _delete_empty ($) {
  my $self = shift;
  my @nid;
  for my $id (@{$self->{value}}) {push @nid, $id if length $id}
  $self->{value} = \@nid;
}

sub _quote_unsafe_string ($$;%) {
  my $self = shift;
  my $string = shift;
  my %option = @_;
  $option{unsafe} ||= 'NON_atext_dot';
  if ($string =~ /$REG{$option{unsafe}}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
    $string = '"'.$string.'"';
  }
  $string;
}


=head2 $self->_unquote_quoted_string ($string)

Unquote C<quoted-string>.  Get rid of C<DQUOTE>s and
C<REVERSED SOLIDUS> included in C<quoted-pair>.
This method is intended for internal use.

=cut

sub _unquote_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}}{
    my $qtext = $1;
    $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
    $qtext;
  }goex;
  $quoted_string;
}

sub _decode_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}|([^\x22]+)}{
    my ($qtext,$t) = ($1, $2);
    if ($t) {
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
                type => 'phrase');
      $s{value};
    } else {
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
                type => 'phrase/quoted');
      $s{value};
    }
  }goex;
  $quoted_string;
}

=head2 $self->_delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended to be used for internal process.

=cut

sub _delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{uri_literal}|$REG{domain_literal})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

=head1 EXAMPLE


=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/04/01 05:32:15 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::CSV Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for comma separated C<field>.
9
10			This module supports a number of fields that contains
11			(or does not contain:-)) of comma separated values,
12	wakaba	1.2	such as C<Keywords:>, C<Newsgroups:> and so on.
13	wakaba	1.1
14			=cut
15
16			package Message::Field::CSV;
17			require 5.6.0;
18			use strict;
19			use re 'eval';
20			use vars qw(%OPTION %REG $VERSION);
21	wakaba	1.6	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
22	wakaba	1.5	use overload '@{}' => sub {shift->value},
23	wakaba	1.1	'""' => sub {shift->stringify};
24	wakaba	1.4	require Message::Util;
25	wakaba	1.1	$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+\|(??{$REG{comment}}))*\x29/;
26			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
27			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
28	wakaba	1.4	$REG{uri_literal} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;
29	wakaba	1.1
30			$REG{WSP} = qr/[\x20\x09]+/;
31			$REG{FWS} = qr/[\x20\x09]*/;
32			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
33			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
34			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
35			$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
36			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
37			$REG{NON_atom} = qr/[^\x09\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;
38	wakaba	1.4	$REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
39			$REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
40			$REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
41			$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
42			$REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;
43			$REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;
44	wakaba	1.3	$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
45	wakaba	1.1
46			## Keywords: foo, bar, "and so on"
47			## Newsgroups: local.test,local.foo,local.bar
48			## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01
49
50			%OPTION = (
51			field_name => 'keywords',
52	wakaba	1.3	encoding_after_encode => '*default',
53			encoding_before_decode => '*default',
54			hook_encode_string => #sub {shift; (value => shift, @_)},
55			\&Message::Util::encode_header_string,
56			hook_decode_string => #sub {shift; (value => shift, @_)},
57			\&Message::Util::decode_header_string,
58	wakaba	1.2	is_quoted_string => 1, ## Can itself quoted-string?
59	wakaba	1.4	long_count => 10,
60			remove_comment => 1,
61	wakaba	1.1	separator => ', ',
62	wakaba	1.4	separator_long => ', ',
63	wakaba	1.1	max => -1,
64	wakaba	1.3	value_type => [':none:'],
65	wakaba	1.4	value_unsafe_rule => 'NON_http_token_wsp',
66	wakaba	1.1	);
67
68	wakaba	1.4	sub _init_option ($) {
69	wakaba	1.1	my $self = shift;
70			my %field_type = qw(accept-charset accept accept-encoding accept
71			accept-language accept
72	wakaba	1.2	content-language keywords
73	wakaba	1.1	followup-to newsgroups
74	wakaba	1.4	list-archive list- list-digest list- list-help list-
75			list-owner list- list-post list- list-subscribe list-
76			list-unsubscribe list- list-url list- uri list-
77	wakaba	1.6	posted-to newsgroups
78	wakaba	1.2	x-brother x-moe x-daughter x-moe
79			x-respect x-moe x-syster x-moe x-wife x-moe);
80	wakaba	1.6	my $field_name = lc $self->{option}->{field_name}
81			\|\| lc $self->{option}->{-field_name}; ## AD HOC
82	wakaba	1.1	$field_name = $field_type{$field_name} \|\| $field_name;
83	wakaba	1.2	if ($field_name eq 'newsgroups') {
84			$self->{option}->{separator} = ',';
85	wakaba	1.4	$self->{option}->{separator_long} = ', ';
86			$self->{option}->{long_count} = 5;
87			$self->{option}->{value_unsafe_rule} = 'NON_component';
88	wakaba	1.5	$self->{option}->{encoding_after_encode} = 'utf-8';
89	wakaba	1.4	} elsif ($field_name eq 'distribution') {
90			$self->{option}->{separator} = ',';
91			$self->{option}->{separator_long} = ', ';
92			$self->{option}->{long_count} = 15;
93			$self->{option}->{value_unsafe_rule} = 'NON_distribution';
94	wakaba	1.2	} elsif ($field_name eq 'x-moe') {
95	wakaba	1.1	$self->{option}->{is_quoted_string} = -1;
96	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::ValueParams',
97			{format => $self->{option}->{format}}];
98	wakaba	1.1	} elsif ($field_name eq 'accept') {
99			$self->{option}->{is_quoted_string} = -1;
100	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::ValueParams',
101			{format => $self->{option}->{format}}];
102			} elsif ($field_name eq 'list-') {
103			$self->{option}->{is_quoted_string} = -1;
104			$self->{option}->{remove_comment} = -1;
105			$self->{option}->{value_type} = ['Message::Field::URI',
106			{field_name => $self->{option}->{field_name},
107			format => $self->{option}->{format}}];
108	wakaba	1.1	} elsif ($field_name eq 'encrypted') {
109			$self->{option}->{max} = 2;
110			}
111			$self;
112			}
113
114			=head2 Message::Field::CSV->new ()
115
116			Returns new CSV field body.
117
118			=cut
119
120			sub new ($;%) {
121			my $self = bless {}, shift;
122			my %option = @_;
123			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
124			$self->{option} = \%option;
125	wakaba	1.4	$self->_init_option ();
126	wakaba	1.1	$self;
127			}
128
129			=head2 Message::Field::CSV->parse ($unfolded_field_body)
130
131			Parses C<field-body>.
132
133			=cut
134
135			sub parse ($$;%) {
136			my $self = bless {}, shift;
137			my $field_body = shift;
138			my %option = @_;
139			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
140			$self->{option} = \%option;
141	wakaba	1.4	$self->_init_option ();
142			$field_body = $self->_delete_comment ($field_body)
143			unless $option{remove_comment}<0;
144	wakaba	1.1	@{$self->{value}} = $self->_parse_list ($field_body);
145			$self;
146			}
147
148			sub _parse_list ($$) {
149			my $self = shift;
150			my $fb = shift;
151			my @ids;
152	wakaba	1.4	$fb =~ s{((?:$REG{quoted_string}\|$REG{uri_literal}\|$REG{domain_literal}\|$REG{comment}\|[^\x22\x28\x2C\x3C\x5B])+)}{
153	wakaba	1.1	my $s = $1; $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
154			if ($self->{option}->{is_quoted_string}>0) {
155	wakaba	1.3	push @ids, $self->_value ($self->_decode_quoted_string ($s));
156	wakaba	1.1	} else {
157	wakaba	1.2	push @ids, $self->_value ($s);
158	wakaba	1.1	}
159			}goex;
160			@ids;
161			}
162
163			=head2 $self->value ()
164
165	wakaba	1.5	Returns array reference to value list.
166	wakaba	1.1
167			=cut
168
169	wakaba	1.5	sub value ($) {shift->{value}}
170	wakaba	1.1
171			=head2 $self->add ($value, [%option])
172
173			Adds new value.
174
175			=cut
176
177			sub add ($;$%) {
178			my $self = shift;
179			my ($value, %option) = @_;
180	wakaba	1.2	push @{$self->{value}}, $self->_value ($value);
181			$value;
182			}
183
184			## Hook called before returning C<value>.
185			## $self->_param_value ($name, $value);
186			sub _value ($$) {
187			my $self = shift;
188			my $value = shift;
189			my $vtype = $self->{option}->{value_type}->[0];
190			my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}
191			if ref $self->{option}->{value_type}->[1];
192			if (ref $value) {
193			return $value;
194			} elsif ($vtype eq ':none:') {
195			return $value;
196			} elsif ($value) {
197			eval "require $vtype";
198			return $vtype->parse ($value, %vopt);
199			} else {
200			eval "require $vtype";
201			return $vtype->new (%vopt);
202			}
203	wakaba	1.1	}
204
205			sub stringify ($;%) {
206			my $self = shift;
207			my %option = @_;
208			$option{separator} \|\|= $self->{option}->{separator};
209	wakaba	1.4	$option{separator_long} \|\|= $self->{option}->{separator_long};
210			$option{long_count} \|\|= $self->{option}->{long_count};
211	wakaba	1.1	$option{max} \|\|= $self->{option}->{max};
212			$option{is_quoted_string} \|\|= $self->{option}->{is_quoted_string};
213	wakaba	1.4	$option{value_unsafe_rule} \|\|= $self->{option}->{value_unsafe_rule};
214	wakaba	1.1	$self->_delete_empty ();
215			$option{max}--;
216			$option{max} = $#{$self->{value}} if $option{max}<0;
217			$option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};
218	wakaba	1.4	$option{separator} = $option{separator_long}
219			if $option{max} >= $option{long_count};
220	wakaba	1.1	join $option{separator},
221	wakaba	1.3	map {
222			if ($option{is_quoted_string}>0) {
223			my %s = &{$self->{option}->{hook_encode_string}} ($self,
224			$_, type => 'phrase');
225	wakaba	1.4	$self->_quote_unsafe_string ($s{value},
226			unsafe => $option{value_unsafe_rule});
227	wakaba	1.3	} else {
228			$_;
229			}
230			} @{$self->{value}}[0..$option{max}];
231	wakaba	1.1	}
232
233	wakaba	1.4	=head2 $self->option ($option_name, [$option_value])
234
235			Set/gets new value of the option.
236
237			=cut
238
239			sub option ($$;$) {
240			my $self = shift;
241			my ($name, $value) = @_;
242			if (defined $value) {
243			$self->{option}->{$name} = $value;
244			}
245			$self->{option}->{$name};
246			}
247
248	wakaba	1.5	sub value_type ($;$%) {
249			my $self = shift;
250			my $new_value_type = shift;
251			if ($new_value_type) {
252			$self->{option}->{value_type}->[0] = $new_value_type;
253			}
254			$self->{option}->{value_type}->[0] \|\| ':none:';
255			}
256
257	wakaba	1.1	sub _delete_empty ($) {
258			my $self = shift;
259			my @nid;
260			for my $id (@{$self->{value}}) {push @nid, $id if length $id}
261			$self->{value} = \@nid;
262			}
263
264	wakaba	1.4	sub _quote_unsafe_string ($$;%) {
265	wakaba	1.1	my $self = shift;
266			my $string = shift;
267	wakaba	1.4	my %option = @_;
268			$option{unsafe} \|\|= 'NON_atext_dot';
269			if ($string =~ /$REG{$option{unsafe}}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
270			$string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
271	wakaba	1.1	$string = '"'.$string.'"';
272			}
273			$string;
274			}
275
276
277			=head2 $self->_unquote_quoted_string ($string)
278
279			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
280			C<REVERSED SOLIDUS> included in C<quoted-pair>.
281			This method is intended for internal use.
282
283			=cut
284
285			sub _unquote_quoted_string ($$) {
286			my $self = shift;
287			my $quoted_string = shift;
288			$quoted_string =~ s{$REG{M_quoted_string}}{
289			my $qtext = $1;
290			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
291			$qtext;
292			}goex;
293			$quoted_string;
294			}
295
296	wakaba	1.3	sub _decode_quoted_string ($$) {
297			my $self = shift;
298			my $quoted_string = shift;
299			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
300			my ($qtext,$t) = ($1, $2);
301			if ($t) {
302			my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
303			type => 'phrase');
304			$s{value};
305			} else {
306			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
307			my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
308			type => 'phrase/quoted');
309			$s{value};
310			}
311			}goex;
312			$quoted_string;
313			}
314
315	wakaba	1.1	=head2 $self->_delete_comment ($field_body)
316
317			Remove all C<comment> in given strictured C<field-body>.
318			This method is intended to be used for internal process.
319
320			=cut
321
322			sub _delete_comment ($$) {
323			my $self = shift;
324			my $body = shift;
325	wakaba	1.4	$body =~ s{($REG{quoted_string}\|$REG{uri_literal}\|$REG{domain_literal})\|$REG{comment}}{
326	wakaba	1.1	my $o = $1; $o? $o : ' ';
327			}gex;
328			$body;
329			}
330
331			=head1 EXAMPLE
332
333
334			=head1 LICENSE
335
336			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
337
338			This program is free software; you can redistribute it and/or modify
339			it under the terms of the GNU General Public License as published by
340			the Free Software Foundation; either version 2 of the License, or
341			(at your option) any later version.
342
343			This program is distributed in the hope that it will be useful,
344			but WITHOUT ANY WARRANTY; without even the implied warranty of
345			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
346			GNU General Public License for more details.
347
348			You should have received a copy of the GNU General Public License
349			along with this program; see the file COPYING. If not, write to
350			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
351			Boston, MA 02111-1307, USA.
352
353			=head1 CHANGE
354
355			See F<ChangeLog>.
356	wakaba	1.6	$Date: 2002/04/01 05:32:15 $
357	wakaba	1.1
358			=cut
359
360			1;