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.4 $=~/\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';
    $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/03/31 13:11:55 $

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