Message/Field/CSV.pm


=head1 NAME

Message::Field::CSV --- Perl module for Internet message
field body consist of comma separated values

=cut

package Message::Field::CSV;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

use overload '""' => sub { $_[0]->stringify },
             '0+' => sub { $_[0]->count },
             '.=' => sub { $_[0]->add ($_[1]); $_[0] },
             fallback => 1;

*REG = \%Message::Util::REG;
## Inherited: comment, quoted_string, domain_literal, angle_quoted
        ## WSP, FWS, atext

## From usefor-article
        $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]/;

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    #encoding_after_encode      ## Inherited
    #encoding_before_decode     ## Inherited
    -field_name => 'keywords',
    #format     ## Inherited
    #hook_encode_string ## Inherited
    #hook_decode_string ## Inherited
    -is_quoted_string   => 1,   ## Can itself quoted-string?
    -long_count => 10,
    -parse_all  => 0,
    -remove_comment     => 1,
    -separator  => ', ',
    -separator_long     => ', ',
    -max        => 0,
    -value_type => [':none:'],
    -value_unsafe_rule  => 'NON_http_token_wsp',
  );
  $self->SUPER::_init (%DEFAULT, %options);
  $self->{value} = [];

## 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

  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-
     posted-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 $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} = 0;
    $self->{option}->{value_type} = ['Message::Field::ValueParams', 
      {format => $self->{option}->{format}}];
  } elsif ($field_name eq 'accept') {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{value_type} = ['Message::Field::ValueParams', 
      {format => $self->{option}->{format}}];
  } elsif ($field_name eq 'list-') {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{remove_comment} = 0;
    $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;
  }
  
  if (ref $options{value} eq 'ARRAY') {
    $self->add (@{$options{value}});
  } elsif ($options{value}) {
    $self->add ($options{value});
  }
  $self;
}

=item $csv = Message::Field::CSV->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $csv = Message::Field::CSV->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $field_body = shift;
  $self->_init (@_);
  $field_body = Message::Util::delete_comment ($field_body)
    if $self->{option}->{remove_comment};
  push @{$self->{value}}, $self->_parse_list ($field_body);
  $self;
}

## Parses csv string and returns array
sub _parse_list ($$) {
  my $self = shift;
  my $fb = shift;
  my @ids;
  $fb =~ s{((?:$REG{quoted_string}|$REG{angle_quoted}|$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}) {
      $s = $self->_value (Message::Util::decode_quoted_string ($self, $s))
        if $self->{option}->{parse_all};
      push @ids, Message::Util::decode_quoted_string ($self, $s);
    } else {
      $s = $self->_value ($s) if $self->{option}->{parse_all};
      push @ids, $s;
    }
  }goex;
  @ids;
}

=back

=head1 METHODS

=over 4

=head2 $values = $csv->value ($index1, [$index2, $index3,...])

Returns C<$index>'th value(s).

=cut

sub value ($@) {
  my $self = shift;
  my @index = @_;
  my @ret = ();
  for (@index) {
    $self->{value}->[$_] = $self->_value ($self->{value}->[$_]);
    push @ret, $self->{value}->[$_];
  }
  @ret;
}

=item $number = $csv->count

Returns number of values.

=cut

sub count ($) {
  my $self = shift;
  $self->_delete_empty;
  $#{$self->{value}}+1;
}

=iterm $csv->add ($value1, [$value2, $value3,...])

Adds (appends) new value(s).

=iterm $csv->prepend ($value1, [$value2, $value3,...])

Prepends new value(s).

=cut

sub add ($@) {
  my $self = shift;
  push @{$self->{value}}, @_;
}

sub prepend ($@) {
  my $self = shift;
  unshift @{$self->{value}}, @_;
}

=item $field-body = $csv->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  $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}) {
        my %s = &{$self->{option}->{hook_encode_string}} ($self, 
          $_, type => 'phrase');
        Message::Util::quote_unsafe_string ($s{value}, 
          unsafe => $option{value_unsafe_rule});
      } else {
        $_;
      }
    } @{$self->{value}}[0..$option{max}];
}
*as_string = \&stringify;

=item $option-value = $ua->option ($option-name)

Gets option value.

=item $csv->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

=item $type = $csv->value_type

Gets value-type.  Value-type is package name of module
used for value modification.  A special value-type, ':none:'
is used to indicate values are non-structured (and no module
is automatically used).

=item $csv->value_type ([$type])

Set value-type.

=cut

sub value_type ($;$) {
  my $self = shift;
  my $new_value_type = shift;
  if (ref $new_value_type eq 'ARRAY') {
    $self->{option}->{value_type} = $new_value_type;
  } elsif ($new_value_type) {
    $self->{option}->{value_type}->[0] = $new_value_type;
  }
  $self->{option}->{value_type}->[0] || ':none:';
}

=item $clone = $ua->clone ()

Returns a copy of the object.

=cut

sub clone ($) {
  my $self = shift;
  $self->_delete_empty;
  my $clone = $self->SUPER::clone;
  $clone->{value_type} = Message::Util::make_clone ($self->{value_type});
  $clone;
}

=back

=cut

## Internal functions

## Hook called before returning C<value>.
## $csv->_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 _delete_empty ($) {
  my $self = shift;
  $self->{value} = [grep {length $_} @{$self->{value}}];
}

=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/04/13 01:33:54 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.7	Message::Field::CSV --- Perl module for Internet message
5			field body consist of comma separated values
6	wakaba	1.1
7			=cut
8
9			package Message::Field::CSV;
10			require 5.6.0;
11			use strict;
12			use re 'eval';
13	wakaba	1.7	use vars qw(@ISA %REG $VERSION);
14			$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.4	require Message::Util;
16	wakaba	1.7	require Message::Field::Structured;
17			push @ISA, qw(Message::Field::Structured);
18
19			use overload '""' => sub { $_[0]->stringify },
20			'0+' => sub { $_[0]->count },
21			'.=' => sub { $_[0]->add ($_[1]); $_[0] },
22			fallback => 1;
23
24			*REG = \%Message::Util::REG;
25			## Inherited: comment, quoted_string, domain_literal, angle_quoted
26			## WSP, FWS, atext
27
28			## From usefor-article
29			$REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;
30			$REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;
31
32			=head1 CONSTRUCTORS
33
34			The following methods construct new objects:
35
36			=over 4
37
38			=cut
39
40			## Initialize of this class -- called by constructors
41			sub _init ($;%) {
42			my $self = shift;
43			my %options = @_;
44			my %DEFAULT = (
45			#encoding_after_encode ## Inherited
46			#encoding_before_decode ## Inherited
47			-field_name => 'keywords',
48			#format ## Inherited
49			#hook_encode_string ## Inherited
50			#hook_decode_string ## Inherited
51			-is_quoted_string => 1, ## Can itself quoted-string?
52			-long_count => 10,
53			-parse_all => 0,
54			-remove_comment => 1,
55			-separator => ', ',
56			-separator_long => ', ',
57			-max => 0,
58			-value_type => [':none:'],
59			-value_unsafe_rule => 'NON_http_token_wsp',
60			);
61			$self->SUPER::_init (%DEFAULT, %options);
62			$self->{value} = [];
63	wakaba	1.1
64			## Keywords: foo, bar, "and so on"
65			## Newsgroups: local.test,local.foo,local.bar
66			## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01
67
68			my %field_type = qw(accept-charset accept accept-encoding accept
69			accept-language accept
70	wakaba	1.2	content-language keywords
71	wakaba	1.1	followup-to newsgroups
72	wakaba	1.4	list-archive list- list-digest list- list-help list-
73			list-owner list- list-post list- list-subscribe list-
74			list-unsubscribe list- list-url list- uri list-
75	wakaba	1.6	posted-to newsgroups
76	wakaba	1.2	x-brother x-moe x-daughter x-moe
77			x-respect x-moe x-syster x-moe x-wife x-moe);
78	wakaba	1.7	my $field_name = lc $self->{option}->{field_name};
79	wakaba	1.1	$field_name = $field_type{$field_name} \|\| $field_name;
80	wakaba	1.2	if ($field_name eq 'newsgroups') {
81			$self->{option}->{separator} = ',';
82	wakaba	1.4	$self->{option}->{separator_long} = ', ';
83			$self->{option}->{long_count} = 5;
84			$self->{option}->{value_unsafe_rule} = 'NON_component';
85	wakaba	1.5	$self->{option}->{encoding_after_encode} = 'utf-8';
86	wakaba	1.4	} 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.7	$self->{option}->{is_quoted_string} = 0;
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	wakaba	1.7	$self->{option}->{is_quoted_string} = 0;
97	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::ValueParams',
98			{format => $self->{option}->{format}}];
99			} elsif ($field_name eq 'list-') {
100	wakaba	1.7	$self->{option}->{is_quoted_string} = 0;
101			$self->{option}->{remove_comment} = 0;
102	wakaba	1.4	$self->{option}->{value_type} = ['Message::Field::URI',
103	wakaba	1.7	{-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	wakaba	1.7
109			if (ref $options{value} eq 'ARRAY') {
110			$self->add (@{$options{value}});
111			} elsif ($options{value}) {
112			$self->add ($options{value});
113			}
114	wakaba	1.1	$self;
115			}
116
117	wakaba	1.7	=item $csv = Message::Field::CSV->new ([%options])
118	wakaba	1.1
119	wakaba	1.7	Constructs a new object. You might pass some options as parameters
120			to the constructor.
121	wakaba	1.1
122			=cut
123
124	wakaba	1.7	## Inherited
125	wakaba	1.1
126	wakaba	1.7	=item $csv = Message::Field::CSV->parse ($field-body, [%options])
127	wakaba	1.1
128	wakaba	1.7	Constructs a new object with given field body. You might pass
129			some options as parameters to the constructor.
130	wakaba	1.1
131			=cut
132
133			sub parse ($$;%) {
134	wakaba	1.7	my $class = shift;
135			my $self = bless {}, $class;
136	wakaba	1.1	my $field_body = shift;
137	wakaba	1.7	$self->_init (@_);
138			$field_body = Message::Util::delete_comment ($field_body)
139			if $self->{option}->{remove_comment};
140			push @{$self->{value}}, $self->_parse_list ($field_body);
141	wakaba	1.1	$self;
142			}
143
144	wakaba	1.7	## Parses csv string and returns array
145	wakaba	1.1	sub _parse_list ($$) {
146			my $self = shift;
147			my $fb = shift;
148			my @ids;
149	wakaba	1.7	$fb =~ s{((?:$REG{quoted_string}\|$REG{angle_quoted}\|$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	wakaba	1.7	if ($self->{option}->{is_quoted_string}) {
152			$s = $self->_value (Message::Util::decode_quoted_string ($self, $s))
153			if $self->{option}->{parse_all};
154			push @ids, Message::Util::decode_quoted_string ($self, $s);
155	wakaba	1.1	} else {
156	wakaba	1.7	$s = $self->_value ($s) if $self->{option}->{parse_all};
157			push @ids, $s;
158	wakaba	1.1	}
159			}goex;
160			@ids;
161			}
162
163	wakaba	1.7	=back
164
165			=head1 METHODS
166
167			=over 4
168
169			=head2 $values = $csv->value ($index1, [$index2, $index3,...])
170
171			Returns C<$index>'th value(s).
172
173			=cut
174
175			sub value ($@) {
176			my $self = shift;
177			my @index = @_;
178			my @ret = ();
179			for (@index) {
180			$self->{value}->[$_] = $self->_value ($self->{value}->[$_]);
181			push @ret, $self->{value}->[$_];
182			}
183			@ret;
184			}
185
186			=item $number = $csv->count
187	wakaba	1.1
188	wakaba	1.7	Returns number of values.
189	wakaba	1.1
190			=cut
191
192	wakaba	1.7	sub count ($) {
193			my $self = shift;
194			$self->_delete_empty;
195			$#{$self->{value}}+1;
196			}
197
198			=iterm $csv->add ($value1, [$value2, $value3,...])
199
200			Adds (appends) new value(s).
201	wakaba	1.1
202	wakaba	1.7	=iterm $csv->prepend ($value1, [$value2, $value3,...])
203	wakaba	1.1
204	wakaba	1.7	Prepends new value(s).
205	wakaba	1.1
206			=cut
207
208	wakaba	1.7	sub add ($@) {
209	wakaba	1.1	my $self = shift;
210	wakaba	1.7	push @{$self->{value}}, @_;
211	wakaba	1.2	}
212
213	wakaba	1.7	sub prepend ($@) {
214	wakaba	1.2	my $self = shift;
215	wakaba	1.7	unshift @{$self->{value}}, @_;
216	wakaba	1.1	}
217
218	wakaba	1.7	=item $field-body = $csv->stringify ()
219
220			Returns C<field-body> as a string.
221
222			=cut
223
224	wakaba	1.1	sub stringify ($;%) {
225			my $self = shift;
226	wakaba	1.7	my %o = @_;
227			my %option = %{$self->{option}};
228			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
229			$self->_delete_empty;
230	wakaba	1.1	$option{max}--;
231	wakaba	1.7	$option{max} = $#{$self->{value}} if $option{max} <= 0;
232			$option{max} = $#{$self->{value}} if $#{$self->{value}} < $option{max};
233	wakaba	1.4	$option{separator} = $option{separator_long}
234			if $option{max} >= $option{long_count};
235	wakaba	1.1	join $option{separator},
236	wakaba	1.3	map {
237	wakaba	1.7	if ($option{is_quoted_string}) {
238	wakaba	1.3	my %s = &{$self->{option}->{hook_encode_string}} ($self,
239			$_, type => 'phrase');
240	wakaba	1.7	Message::Util::quote_unsafe_string ($s{value},
241	wakaba	1.4	unsafe => $option{value_unsafe_rule});
242	wakaba	1.3	} else {
243			$_;
244			}
245			} @{$self->{value}}[0..$option{max}];
246	wakaba	1.1	}
247	wakaba	1.7	*as_string = \&stringify;
248
249			=item $option-value = $ua->option ($option-name)
250
251			Gets option value.
252	wakaba	1.1
253	wakaba	1.7	=item $csv->option ($option-name, $option-value, ...)
254	wakaba	1.4
255	wakaba	1.7	Set option value(s). You can pass multiple option name-value pair
256			as parameter when setting.
257	wakaba	1.4
258			=cut
259
260	wakaba	1.7	## Inherited
261
262			=item $type = $csv->value_type
263
264			Gets value-type. Value-type is package name of module
265			used for value modification. A special value-type, ':none:'
266			is used to indicate values are non-structured (and no module
267			is automatically used).
268
269			=item $csv->value_type ([$type])
270
271			Set value-type.
272
273			=cut
274	wakaba	1.4
275	wakaba	1.7	sub value_type ($;$) {
276	wakaba	1.5	my $self = shift;
277			my $new_value_type = shift;
278	wakaba	1.7	if (ref $new_value_type eq 'ARRAY') {
279			$self->{option}->{value_type} = $new_value_type;
280			} elsif ($new_value_type) {
281	wakaba	1.5	$self->{option}->{value_type}->[0] = $new_value_type;
282			}
283			$self->{option}->{value_type}->[0] \|\| ':none:';
284			}
285
286	wakaba	1.7	=item $clone = $ua->clone ()
287	wakaba	1.1
288	wakaba	1.7	Returns a copy of the object.
289	wakaba	1.1
290	wakaba	1.7	=cut
291	wakaba	1.1
292	wakaba	1.7	sub clone ($) {
293			my $self = shift;
294			$self->_delete_empty;
295			my $clone = $self->SUPER::clone;
296			$clone->{value_type} = Message::Util::make_clone ($self->{value_type});
297			$clone;
298			}
299	wakaba	1.1
300	wakaba	1.7	=back
301	wakaba	1.1
302			=cut
303
304	wakaba	1.7	## Internal functions
305	wakaba	1.1
306	wakaba	1.7	## Hook called before returning C<value>.
307			## $csv->_param_value ($name, $value);
308			sub _value ($$) {
309	wakaba	1.3	my $self = shift;
310	wakaba	1.7	my $value = shift;
311			my $vtype = $self->{option}->{value_type}->[0];
312			my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}
313			if ref $self->{option}->{value_type}->[1];
314			if (ref $value) {
315			return $value;
316			} elsif ($vtype eq ':none:') {
317			return $value;
318			} elsif ($value) {
319			eval "require $vtype";
320			return $vtype->parse ($value, %vopt);
321			} else {
322			eval "require $vtype";
323			return $vtype->new (%vopt);
324			}
325	wakaba	1.3	}
326
327	wakaba	1.7	sub _delete_empty ($) {
328	wakaba	1.1	my $self = shift;
329	wakaba	1.7	$self->{value} = [grep {length $_} @{$self->{value}}];
330	wakaba	1.1	}
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.7	$Date: 2002/04/13 01:33:54 $
355	wakaba	1.1
356			=cut
357
358			1;