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:>, C<Content-Type>,
C<Content-Transfer-Encoding:>, 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,
  separator     => ', ',
  max   => -1,
);

sub _init_option ($$) {
  my $self = shift;
  my %field_type = qw(accept-charset accept accept-encoding accept 
     accept-language accept
     content-disposition content-type
     content-language keywords content-transfer-encoding content-type
     followup-to newsgroups
     x-brother accept x-daughter accept x-face-type content-type x-moe accept 
     x-respect accept x-syster accept x-wife accept);
  my $field_name = lc shift;
  $field_name = $field_type{$field_name} || $field_name;
  if ($field_name eq 'content-type') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{max} = 1;
  } elsif ($field_name eq 'newsgroups') {
    $self->{option}->{is_quoted_string} = -1;
    $self->{option}->{separator} = ',';
  } 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->_unquote_quoted_string ($s);
    } else {
      push @ids, $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}}, $value;
  $self;
}

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