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.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use overload '@{}' => sub {[shift->value]},
             '""' => sub {shift->stringify};

$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{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{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?
  separator     => ', ',
  max   => -1,
  value_type    => [':none:'],
);

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
     x-brother x-moe x-daughter x-moe
     x-respect x-moe x-syster x-moe x-wife x-moe);
  my $field_name = lc shift;
  $field_name = $field_type{$field_name} || $field_name;
  if ($field_name eq 'newsgroups') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{separator} = ',';
  } elsif ($field_name eq 'x-moe') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{value_type} = ['Message::Field::ValueParams'];
  } elsif ($field_name eq 'accept') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{value_type} = ['Message::Field::ValueParams'];
  } 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->{option}->{field_name});
  $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 ($self->{option}->{field_name});
  $field_body = $self->_delete_comment ($field_body);
  @{$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{domain_literal}|[^\x22\x2C\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{max} ||= $self->{option}->{max};
  $option{is_quoted_string} ||= $self->{option}->{is_quoted_string};
  $self->_delete_empty ();
  $option{max}--;
  $option{max} = $#{$self->{value}} if $option{max}<0;
  $option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};
  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});
      } else {
        $_;
      }
    } @{$self->{value}}[0..$option{max}];
}

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;
  if ($string =~ /$REG{NON_atom}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($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{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/23 11:41:36 $

=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.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
22	wakaba	1.1	use overload '@{}' => sub {[shift->value]},
23			'""' => sub {shift->stringify};
24
25			$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
29			$REG{WSP} = qr/[\x20\x09]+/;
30			$REG{FWS} = qr/[\x20\x09]*/;
31			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
32			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
33			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
34			$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
35			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
36			$REG{NON_atom} = qr/[^\x09\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;
37	wakaba	1.3	$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
38	wakaba	1.1
39			## Keywords: foo, bar, "and so on"
40			## Newsgroups: local.test,local.foo,local.bar
41			## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01
42
43			%OPTION = (
44			field_name => 'keywords',
45	wakaba	1.3	encoding_after_encode => '*default',
46			encoding_before_decode => '*default',
47			hook_encode_string => #sub {shift; (value => shift, @_)},
48			\&Message::Util::encode_header_string,
49			hook_decode_string => #sub {shift; (value => shift, @_)},
50			\&Message::Util::decode_header_string,
51	wakaba	1.2	is_quoted_string => 1, ## Can itself quoted-string?
52	wakaba	1.1	separator => ', ',
53			max => -1,
54	wakaba	1.3	value_type => [':none:'],
55	wakaba	1.1	);
56
57			sub _init_option ($$) {
58			my $self = shift;
59			my %field_type = qw(accept-charset accept accept-encoding accept
60			accept-language accept
61	wakaba	1.2	content-language keywords
62	wakaba	1.1	followup-to newsgroups
63	wakaba	1.2	x-brother x-moe x-daughter x-moe
64			x-respect x-moe x-syster x-moe x-wife x-moe);
65	wakaba	1.1	my $field_name = lc shift;
66			$field_name = $field_type{$field_name} \|\| $field_name;
67	wakaba	1.2	if ($field_name eq 'newsgroups') {
68	wakaba	1.1	$self->{option}->{is_quoted_string} = -1;
69	wakaba	1.2	$self->{option}->{separator} = ',';
70			} elsif ($field_name eq 'x-moe') {
71	wakaba	1.1	$self->{option}->{is_quoted_string} = -1;
72	wakaba	1.2	$self->{option}->{value_type} = ['Message::Field::ValueParams'];
73	wakaba	1.1	} elsif ($field_name eq 'accept') {
74			$self->{option}->{is_quoted_string} = -1;
75	wakaba	1.3	$self->{option}->{value_type} = ['Message::Field::ValueParams'];
76	wakaba	1.1	} elsif ($field_name eq 'encrypted') {
77			$self->{option}->{max} = 2;
78			}
79			$self;
80			}
81
82			=head2 Message::Field::CSV->new ()
83
84			Returns new CSV field body.
85
86			=cut
87
88			sub new ($;%) {
89			my $self = bless {}, shift;
90			my %option = @_;
91			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
92			$self->{option} = \%option;
93			$self->_init_option ($self->{option}->{field_name});
94			$self;
95			}
96
97			=head2 Message::Field::CSV->parse ($unfolded_field_body)
98
99			Parses C<field-body>.
100
101			=cut
102
103			sub parse ($$;%) {
104			my $self = bless {}, shift;
105			my $field_body = shift;
106			my %option = @_;
107			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
108			$self->{option} = \%option;
109			$self->_init_option ($self->{option}->{field_name});
110			$field_body = $self->_delete_comment ($field_body);
111			@{$self->{value}} = $self->_parse_list ($field_body);
112			$self;
113			}
114
115			sub _parse_list ($$) {
116			my $self = shift;
117			my $fb = shift;
118			my @ids;
119			$fb =~ s{((?:$REG{quoted_string}\|$REG{domain_literal}\|[^\x22\x2C\x5B])+)}{
120			my $s = $1; $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
121			if ($self->{option}->{is_quoted_string}>0) {
122	wakaba	1.3	push @ids, $self->_value ($self->_decode_quoted_string ($s));
123	wakaba	1.1	} else {
124	wakaba	1.2	push @ids, $self->_value ($s);
125	wakaba	1.1	}
126			}goex;
127			@ids;
128			}
129
130			=head2 $self->value ()
131
132			Returns value list.
133
134			=cut
135
136			sub value ($) {@{shift->{value}}}
137
138			=head2 $self->add ($value, [%option])
139
140			Adds new value.
141
142			=cut
143
144			sub add ($;$%) {
145			my $self = shift;
146			my ($value, %option) = @_;
147	wakaba	1.2	push @{$self->{value}}, $self->_value ($value);
148			$value;
149			}
150
151			## Hook called before returning C<value>.
152			## $self->_param_value ($name, $value);
153			sub _value ($$) {
154			my $self = shift;
155			my $value = shift;
156			my $vtype = $self->{option}->{value_type}->[0];
157			my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}
158			if ref $self->{option}->{value_type}->[1];
159			if (ref $value) {
160			return $value;
161			} elsif ($vtype eq ':none:') {
162			return $value;
163			} elsif ($value) {
164			eval "require $vtype";
165			return $vtype->parse ($value, %vopt);
166			} else {
167			eval "require $vtype";
168			return $vtype->new (%vopt);
169			}
170	wakaba	1.1	}
171
172			sub stringify ($;%) {
173			my $self = shift;
174			my %option = @_;
175			$option{separator} \|\|= $self->{option}->{separator};
176			$option{max} \|\|= $self->{option}->{max};
177			$option{is_quoted_string} \|\|= $self->{option}->{is_quoted_string};
178			$self->_delete_empty ();
179			$option{max}--;
180			$option{max} = $#{$self->{value}} if $option{max}<0;
181			$option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};
182			join $option{separator},
183	wakaba	1.3	map {
184			if ($option{is_quoted_string}>0) {
185			my %s = &{$self->{option}->{hook_encode_string}} ($self,
186			$_, type => 'phrase');
187			$self->_quote_unsafe_string ($s{value});
188			} else {
189			$_;
190			}
191			} @{$self->{value}}[0..$option{max}];
192	wakaba	1.1	}
193
194			sub _delete_empty ($) {
195			my $self = shift;
196			my @nid;
197			for my $id (@{$self->{value}}) {push @nid, $id if length $id}
198			$self->{value} = \@nid;
199			}
200
201			sub _quote_unsafe_string ($$) {
202			my $self = shift;
203			my $string = shift;
204			if ($string =~ /$REG{NON_atom}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
205	wakaba	1.3	$string =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
206	wakaba	1.1	$string = '"'.$string.'"';
207			}
208			$string;
209			}
210
211
212			=head2 $self->_unquote_quoted_string ($string)
213
214			Unquote C<quoted-string>. Get rid of C<DQUOTE>s and
215			C<REVERSED SOLIDUS> included in C<quoted-pair>.
216			This method is intended for internal use.
217
218			=cut
219
220			sub _unquote_quoted_string ($$) {
221			my $self = shift;
222			my $quoted_string = shift;
223			$quoted_string =~ s{$REG{M_quoted_string}}{
224			my $qtext = $1;
225			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
226			$qtext;
227			}goex;
228			$quoted_string;
229			}
230
231	wakaba	1.3	sub _decode_quoted_string ($$) {
232			my $self = shift;
233			my $quoted_string = shift;
234			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
235			my ($qtext,$t) = ($1, $2);
236			if ($t) {
237			my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
238			type => 'phrase');
239			$s{value};
240			} else {
241			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
242			my %s = &{$self->{option}->{hook_decode_string}} ($self, $qtext,
243			type => 'phrase/quoted');
244			$s{value};
245			}
246			}goex;
247			$quoted_string;
248			}
249
250	wakaba	1.1	=head2 $self->_delete_comment ($field_body)
251
252			Remove all C<comment> in given strictured C<field-body>.
253			This method is intended to be used for internal process.
254
255			=cut
256
257			sub _delete_comment ($$) {
258			my $self = shift;
259			my $body = shift;
260			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
261			my $o = $1; $o? $o : ' ';
262			}gex;
263			$body;
264			}
265
266			=head1 EXAMPLE
267
268
269			=head1 LICENSE
270
271			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
272
273			This program is free software; you can redistribute it and/or modify
274			it under the terms of the GNU General Public License as published by
275			the Free Software Foundation; either version 2 of the License, or
276			(at your option) any later version.
277
278			This program is distributed in the hope that it will be useful,
279			but WITHOUT ANY WARRANTY; without even the implied warranty of
280			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
281			GNU General Public License for more details.
282
283			You should have received a copy of the GNU General Public License
284			along with this program; see the file COPYING. If not, write to
285			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
286			Boston, MA 02111-1307, USA.
287
288			=head1 CHANGE
289
290			See F<ChangeLog>.
291	wakaba	1.3	$Date: 2002/03/23 11:41:36 $
292	wakaba	1.1
293			=cut
294
295			1;