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.3 $=~/\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-
     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};
  $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';
  } 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 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 _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/03/25 10:15:26 $

=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.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
22	wakaba	1.1	use overload '@{}' => sub {[shift->value]},
23			'""' => 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.2	x-brother x-moe x-daughter x-moe
78			x-respect x-moe x-syster x-moe x-wife x-moe);
79	wakaba	1.4	my $field_name = lc $self->{option}->{field_name};
80	wakaba	1.1	$field_name = $field_type{$field_name} \|\| $field_name;
81	wakaba	1.2	if ($field_name eq 'newsgroups') {
82			$self->{option}->{separator} = ',';
83	wakaba	1.4	$self->{option}->{separator_long} = ', ';
84			$self->{option}->{long_count} = 5;
85			$self->{option}->{value_unsafe_rule} = 'NON_component';
86			} elsif ($field_name eq 'distribution') {
87			$self->{option}->{separator} = ',';
88			$self->{option}->{separator_long} = ', ';
89			$self->{option}->{long_count} = 15;
90			$self->{option}->{value_unsafe_rule} = 'NON_distribution';
91	wakaba	1.2	} elsif ($field_name eq 'x-moe') {
92	wakaba	1.1	$self->{option}->{is_quoted_string} = -1;
93	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::ValueParams',
94			{format => $self->{option}->{format}}];
95	wakaba	1.1	} elsif ($field_name eq 'accept') {
96			$self->{option}->{is_quoted_string} = -1;
97	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::ValueParams',
98			{format => $self->{option}->{format}}];
99			} elsif ($field_name eq 'list-') {
100			$self->{option}->{is_quoted_string} = -1;
101			$self->{option}->{remove_comment} = -1;
102			$self->{option}->{value_type} = ['Message::Field::URI',
103			{field_name => $self->{option}->{field_name},
104			format => $self->{option}->{format}}];
105	wakaba	1.1	} elsif ($field_name eq 'encrypted') {
106			$self->{option}->{max} = 2;
107			}
108			$self;
109			}
110
111			=head2 Message::Field::CSV->new ()
112
113			Returns new CSV field body.
114
115			=cut
116
117			sub new ($;%) {
118			my $self = bless {}, shift;
119			my %option = @_;
120			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
121			$self->{option} = \%option;
122	wakaba	1.4	$self->_init_option ();
123	wakaba	1.1	$self;
124			}
125
126			=head2 Message::Field::CSV->parse ($unfolded_field_body)
127
128			Parses C<field-body>.
129
130			=cut
131
132			sub parse ($$;%) {
133			my $self = bless {}, shift;
134			my $field_body = shift;
135			my %option = @_;
136			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
137			$self->{option} = \%option;
138	wakaba	1.4	$self->_init_option ();
139			$field_body = $self->_delete_comment ($field_body)
140			unless $option{remove_comment}<0;
141	wakaba	1.1	@{$self->{value}} = $self->_parse_list ($field_body);
142			$self;
143			}
144
145			sub _parse_list ($$) {
146			my $self = shift;
147			my $fb = shift;
148			my @ids;
149	wakaba	1.4	$fb =~ s{((?:$REG{quoted_string}\|$REG{uri_literal}\|$REG{domain_literal}\|$REG{comment}\|[^\x22\x28\x2C\x3C\x5B])+)}{
150	wakaba	1.1	my $s = $1; $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
151			if ($self->{option}->{is_quoted_string}>0) {
152	wakaba	1.3	push @ids, $self->_value ($self->_decode_quoted_string ($s));
153	wakaba	1.1	} else {
154	wakaba	1.2	push @ids, $self->_value ($s);
155	wakaba	1.1	}
156			}goex;
157			@ids;
158			}
159
160			=head2 $self->value ()
161
162			Returns value list.
163
164			=cut
165
166			sub value ($) {@{shift->{value}}}
167
168			=head2 $self->add ($value, [%option])
169
170			Adds new value.
171
172			=cut
173
174			sub add ($;$%) {
175			my $self = shift;
176			my ($value, %option) = @_;
177	wakaba	1.2	push @{$self->{value}}, $self->_value ($value);
178			$value;
179			}
180
181			## Hook called before returning C<value>.
182			## $self->_param_value ($name, $value);
183			sub _value ($$) {
184			my $self = shift;
185			my $value = shift;
186			my $vtype = $self->{option}->{value_type}->[0];
187			my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}
188			if ref $self->{option}->{value_type}->[1];
189			if (ref $value) {
190			return $value;
191			} elsif ($vtype eq ':none:') {
192			return $value;
193			} elsif ($value) {
194			eval "require $vtype";
195			return $vtype->parse ($value, %vopt);
196			} else {
197			eval "require $vtype";
198			return $vtype->new (%vopt);
199			}
200	wakaba	1.1	}
201
202			sub stringify ($;%) {
203			my $self = shift;
204			my %option = @_;
205			$option{separator} \|\|= $self->{option}->{separator};
206	wakaba	1.4	$option{separator_long} \|\|= $self->{option}->{separator_long};
207			$option{long_count} \|\|= $self->{option}->{long_count};
208	wakaba	1.1	$option{max} \|\|= $self->{option}->{max};
209			$option{is_quoted_string} \|\|= $self->{option}->{is_quoted_string};
210	wakaba	1.4	$option{value_unsafe_rule} \|\|= $self->{option}->{value_unsafe_rule};
211	wakaba	1.1	$self->_delete_empty ();
212			$option{max}--;
213			$option{max} = $#{$self->{value}} if $option{max}<0;
214			$option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};
215	wakaba	1.4	$option{separator} = $option{separator_long}
216			if $option{max} >= $option{long_count};
217	wakaba	1.1	join $option{separator},
218	wakaba	1.3	map {
219			if ($option{is_quoted_string}>0) {
220			my %s = &{$self->{option}->{hook_encode_string}} ($self,
221			$_, type => 'phrase');
222	wakaba	1.4	$self->_quote_unsafe_string ($s{value},
223			unsafe => $option{value_unsafe_rule});
224	wakaba	1.3	} else {
225			$_;
226			}
227			} @{$self->{value}}[0..$option{max}];
228	wakaba	1.1	}
229
230	wakaba	1.4	=head2 $self->option ($option_name, [$option_value])
231
232			Set/gets new value of the option.
233
234			=cut
235
236			sub option ($$;$) {
237			my $self = shift;
238			my ($name, $value) = @_;
239			if (defined $value) {
240			$self->{option}->{$name} = $value;
241			}
242			$self->{option}->{$name};
243			}
244
245	wakaba	1.1	sub _delete_empty ($) {
246			my $self = shift;
247			my @nid;
248			for my $id (@{$self->{value}}) {push @nid, $id if length $id}
249			$self->{value} = \@nid;
250			}
251
252	wakaba	1.4	sub _quote_unsafe_string ($$;%) {
253	wakaba	1.1	my $self = shift;
254			my $string = shift;
255	wakaba	1.4	my %option = @_;
256			$option{unsafe} \|\|= 'NON_atext_dot';
257			if ($string =~ /$REG{$option{unsafe}}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
258			$string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
259	wakaba	1.1	$string = '"'.$string.'"';
260			}
261			$string;
262			}
263
264
265			=head2 $self->_unquote_quoted_string ($string)
266
267			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
268			C<REVERSED SOLIDUS> included in C<quoted-pair>.
269			This method is intended for internal use.
270
271			=cut
272
273			sub _unquote_quoted_string ($$) {
274			my $self = shift;
275			my $quoted_string = shift;
276			$quoted_string =~ s{$REG{M_quoted_string}}{
277			my $qtext = $1;
278			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
279			$qtext;
280			}goex;
281			$quoted_string;
282			}
283
284	wakaba	1.3	sub _decode_quoted_string ($$) {
285			my $self = shift;
286			my $quoted_string = shift;
287			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
288			my ($qtext,$t) = ($1, $2);
289			if ($t) {
290			my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
291			type => 'phrase');
292			$s{value};
293			} else {
294			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
295			my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
296			type => 'phrase/quoted');
297			$s{value};
298			}
299			}goex;
300			$quoted_string;
301			}
302
303	wakaba	1.1	=head2 $self->_delete_comment ($field_body)
304
305			Remove all C<comment> in given strictured C<field-body>.
306			This method is intended to be used for internal process.
307
308			=cut
309
310			sub _delete_comment ($$) {
311			my $self = shift;
312			my $body = shift;
313	wakaba	1.4	$body =~ s{($REG{quoted_string}\|$REG{uri_literal}\|$REG{domain_literal})\|$REG{comment}}{
314	wakaba	1.1	my $o = $1; $o? $o : ' ';
315			}gex;
316			$body;
317			}
318
319			=head1 EXAMPLE
320
321
322			=head1 LICENSE
323
324			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
325
326			This program is free software; you can redistribute it and/or modify
327			it under the terms of the GNU General Public License as published by
328			the Free Software Foundation; either version 2 of the License, or
329			(at your option) any later version.
330
331			This program is distributed in the hope that it will be useful,
332			but WITHOUT ANY WARRANTY; without even the implied warranty of
333			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
334			GNU General Public License for more details.
335
336			You should have received a copy of the GNU General Public License
337			along with this program; see the file COPYING. If not, write to
338			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
339			Boston, MA 02111-1307, USA.
340
341			=head1 CHANGE
342
343			See F<ChangeLog>.
344	wakaba	1.4	$Date: 2002/03/25 10:15:26 $
345	wakaba	1.1
346			=cut
347
348			1;