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.1 $=~/\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]/;

## Keywords: foo, bar, "and so on"
## Newsgroups: local.test,local.foo,local.bar
## Content-Type: text/plain; charset=us-ascii
## Content-Transfer-Encoding: base64
## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01

%OPTION = (
  field_name    => 'keywords',
  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;
  } 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->_unquote_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 {$option{is_quoted_string}>0?$self->_quote_unsafe_string ($_):$_}
    @{$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])/\x5C$1/g;
    $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;
}

=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/21 04:18:38 $

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