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;  ## eval 're'
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.17 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
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;
        ## We need this is Msg::Util::REG itself (not copy of it)
        ## to carry out $self->stringify correctly.  (This bad
        ## implemention should be done away by making new module
        ## for Newsgroups: and Distribution:.
## 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]/;

%DEFAULT = (
        -_ARRAY_NAME    => 'value',
        -_MEMBERS       => [qw|value_type|],
        -_METHODS       => [qw|add  count delete item
                       comment_add comment_delete comment_count
                       comment_item|],  # replace (not implemented yet)
        #encoding_after_encode
        #encoding_before_decode
        #field_param_name
        #field_name
        #field_ns
        #format
        #header_default_charset
        #header_default_charset_input
        #hook_encode_string
        #hook_decode_string
    -is_quoted_string   => 1,   ## Can it be itself a quoted-string?
    -long_count => 10,
        #parse_all
    -remove_comment     => 1,
    -separator  => ', ',
    -separator_long     => ', ',
    -use_comment        => 1,
    -max        => 0,
    #value_type
    -value_unsafe_rule  => 'NON_http_token_wsp',
);

=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 = @_;
  $self->SUPER::_init (%DEFAULT, %options);
  
  my %field_type = qw(accept-charset accept accept-encoding accept 
     accept-language accept followup-to newsgroups
     posted-to newsgroups
     x-brother x-moe x-boss x-moe x-classmate x-moe x-daughter x-moe 
     x-dearfriend x-moe x-favoritesong x-moe 
     x-friend x-moe x-me x-moe
     x-respect x-moe x-sister x-moe x-son x-moe x-sublimate x-moe x-wife x-moe);
  my $field_name = $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}->{'*default'} = ['Message::Field::XMoe'];
  } elsif ($field_name eq 'accept') {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{remove_comment} = 0;
    $self->{option}->{value_type}->{'*default'} = ['Message::Field::ValueParams'];
  } elsif ($self->{option}->{field_ns} eq $Message::Header::NS_phname2uri{'x-rfc822-list'}) {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{remove_comment} = 0;
    $self->{option}->{value_type}->{'*default'} = ['Message::Field::URI'];
  } elsif ($field_name eq 'man' || $field_name eq 'opt') {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{remove_comment} = 0;
    $self->{option}->{value_type}->{'*default'} = ['Message::Field::ValueParams'];
  } elsif ($field_name eq 'uri') {
    $self->{option}->{is_quoted_string} = 0;
    $self->{option}->{remove_comment} = 0;
    $self->{option}->{value_type}->{'*default'} = ['Message::Field::URI'];
  } 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}->{use_comment} && $self->{option}->{remove_comment};
  push @{$self->{value}}, $self->_parse_list ($field_body);
  $self;
}

## Parses csv string and returns array
sub _parse_list ($$) {
  use re 'eval';
  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->_parse_value ('*default' => 
        Message::Util::decode_quoted_string ($self, $s))
        if $self->{option}->{parse_all};
      push @ids, Message::Util::decode_quoted_string ($self, $s);
    } else {
      $s = $self->_parse_value ('*default' => $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 ($@) { shift->item (@_) }

=item $number = $csv->count

Returns number of values.

=cut

## Inherited

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

Adds (appends) new value(s).

=cut

sub _add_array_check ($$\%) {
  my $self = shift;
  my ($value, $option) = @_;
  my $value_option = {};
  if (ref $value eq 'ARRAY') {
    ($value, %$value_option) = @$value;
  }
  (1, value => $value);
}
*_replace_array_check = \&_add_array_check;

=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 {$self->_stringify_item ($_, \%option)} @{$self->{value}}[0..$option{max}];
}
*as_string = \&stringify;

sub _stringify_item ($$\%) {
  my $self = shift;
  my $item = shift;
  my $option = shift;
      if ($$option{is_quoted_string}) {
        my %s = &{$$option{hook_encode_string}} ($self, 
          $item, type => 'phrase');
        Message::Util::quote_unsafe_string ($s{value}, 
          unsafe => $$option{value_unsafe_rule});
      } else {
        $item;
      }
}

=item $option-value = $csv->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.

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

Returns a copy of the object.

=cut

## value_type, clone, method_available: Inherited

=back

=cut

## Internal functions

sub _delete_empty ($) {
  my $self = shift;
  $self->{value} = [grep {ref $_ || 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/08/03 23:32:04 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Field::CSV --- Perl module for Internet message
5	field body consist of comma separated values
6
7	=cut
8
9	package Message::Field::CSV;
10	require 5.6.0; ## eval 're'
11	use strict;
12	use vars qw(%DEFAULT @ISA %REG $VERSION);
13	$VERSION=do{my @r=(q$Revision: 1.17 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
14	require Message::Field::Structured;
15	push @ISA, qw(Message::Field::Structured);
16
17	use overload '""' => sub { $_[0]->stringify },
18	'0+' => sub { $_[0]->count },
19	'.=' => sub { $_[0]->add ($_[1]); $_[0] },
20	fallback => 1;
21
22	*REG = \%Message::Util::REG;
23	## We need this is Msg::Util::REG itself (not copy of it)
24	## to carry out $self->stringify correctly. (This bad
25	## implemention should be done away by making new module
26	## for Newsgroups: and Distribution:.
27	## Inherited: comment, quoted_string, domain_literal, angle_quoted
28	## WSP, FWS, atext
29
30	## From usefor-article
31	$REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;
32	$REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;
33
34	%DEFAULT = (
35	-_ARRAY_NAME => 'value',
36	-_MEMBERS => [qw\|value_type\|],
37	-_METHODS => [qw\|add count delete item
38	comment_add comment_delete comment_count
39	comment_item\|], # replace (not implemented yet)
40	#encoding_after_encode
41	#encoding_before_decode
42	#field_param_name
43	#field_name
44	#field_ns
45	#format
46	#header_default_charset
47	#header_default_charset_input
48	#hook_encode_string
49	#hook_decode_string
50	-is_quoted_string => 1, ## Can it be itself a quoted-string?
51	-long_count => 10,
52	#parse_all
53	-remove_comment => 1,
54	-separator => ', ',
55	-separator_long => ', ',
56	-use_comment => 1,
57	-max => 0,
58	#value_type
59	-value_unsafe_rule => 'NON_http_token_wsp',
60	);
61
62	=head1 CONSTRUCTORS
63
64	The following methods construct new objects:
65
66	=over 4
67
68	=cut
69
70	## Initialize of this class -- called by constructors
71	sub _init ($;%) {
72	my $self = shift;
73	my %options = @_;
74	$self->SUPER::_init (%DEFAULT, %options);
75
76	my %field_type = qw(accept-charset accept accept-encoding accept
77	accept-language accept followup-to newsgroups
78	posted-to newsgroups
79	x-brother x-moe x-boss x-moe x-classmate x-moe x-daughter x-moe
80	x-dearfriend x-moe x-favoritesong x-moe
81	x-friend x-moe x-me x-moe
82	x-respect x-moe x-sister x-moe x-son x-moe x-sublimate x-moe x-wife x-moe);
83	my $field_name = $self->{option}->{field_name};
84	$field_name = $field_type{$field_name} \|\| $field_name;
85	if ($field_name eq 'newsgroups') {
86	$self->{option}->{separator} = ',';
87	$self->{option}->{separator_long} = ', ';
88	$self->{option}->{long_count} = 5;
89	$self->{option}->{value_unsafe_rule} = 'NON_component';
90	$self->{option}->{encoding_after_encode} = 'utf-8';
91	} elsif ($field_name eq 'distribution') {
92	$self->{option}->{separator} = ',';
93	$self->{option}->{separator_long} = ', ';
94	$self->{option}->{long_count} = 15;
95	$self->{option}->{value_unsafe_rule} = 'NON_distribution';
96	} elsif ($field_name eq 'x-moe') {
97	$self->{option}->{is_quoted_string} = 0;
98	$self->{option}->{value_type}->{'*default'} = ['Message::Field::XMoe'];
99	} elsif ($field_name eq 'accept') {
100	$self->{option}->{is_quoted_string} = 0;
101	$self->{option}->{remove_comment} = 0;
102	$self->{option}->{value_type}->{'*default'} = ['Message::Field::ValueParams'];
103	} elsif ($self->{option}->{field_ns} eq $Message::Header::NS_phname2uri{'x-rfc822-list'}) {
104	$self->{option}->{is_quoted_string} = 0;
105	$self->{option}->{remove_comment} = 0;
106	$self->{option}->{value_type}->{'*default'} = ['Message::Field::URI'];
107	} elsif ($field_name eq 'man' \|\| $field_name eq 'opt') {
108	$self->{option}->{is_quoted_string} = 0;
109	$self->{option}->{remove_comment} = 0;
110	$self->{option}->{value_type}->{'*default'} = ['Message::Field::ValueParams'];
111	} elsif ($field_name eq 'uri') {
112	$self->{option}->{is_quoted_string} = 0;
113	$self->{option}->{remove_comment} = 0;
114	$self->{option}->{value_type}->{'*default'} = ['Message::Field::URI'];
115	} elsif ($field_name eq 'encrypted') {
116	$self->{option}->{max} = 2;
117	}
118
119	if (ref $options{value} eq 'ARRAY') {
120	$self->add (@{$options{value}});
121	} elsif ($options{value}) {
122	$self->add ($options{value});
123	}
124	$self;
125	}
126
127	=item $csv = Message::Field::CSV->new ([%options])
128
129	Constructs a new object. You might pass some options as parameters
130	to the constructor.
131
132	=cut
133
134	## Inherited
135
136	=item $csv = Message::Field::CSV->parse ($field-body, [%options])
137
138	Constructs a new object with given field body. You might pass
139	some options as parameters to the constructor.
140
141	=cut
142
143	sub parse ($$;%) {
144	my $class = shift;
145	my $self = bless {}, $class;
146	my $field_body = shift;
147	$self->_init (@_);
148	$field_body = Message::Util::delete_comment ($field_body)
149	if $self->{option}->{use_comment} && $self->{option}->{remove_comment};
150	push @{$self->{value}}, $self->_parse_list ($field_body);
151	$self;
152	}
153
154	## Parses csv string and returns array
155	sub _parse_list ($$) {
156	use re 'eval';
157	my $self = shift;
158	my $fb = shift;
159	my @ids;
160	$fb =~ s{((?:$REG{quoted_string}\|$REG{angle_quoted}\|$REG{domain_literal}\|$REG{comment}\|[^\x22\x28\x2C\x3C\x5B])+)}{
161	my $s = $1; $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
162	if ($self->{option}->{is_quoted_string}) {
163	$s = $self->_parse_value ('*default' =>
164	Message::Util::decode_quoted_string ($self, $s))
165	if $self->{option}->{parse_all};
166	push @ids, Message::Util::decode_quoted_string ($self, $s);
167	} else {
168	$s = $self->_parse_value ('*default' => $s) if $self->{option}->{parse_all};
169	push @ids, $s;
170	}
171	}goex;
172	@ids;
173	}
174
175	=back
176
177	=head1 METHODS
178
179	=over 4
180
181	=head2 $values = $csv->value ($index1, [$index2, $index3,...])
182
183	Returns C<$index>'th value(s).
184
185	=cut
186
187	sub value ($@) { shift->item (@_) }
188
189	=item $number = $csv->count
190
191	Returns number of values.
192
193	=cut
194
195	## Inherited
196
197	=item $csv->add ($value1, [$value2, $value3,...])
198
199	Adds (appends) new value(s).
200
201	=cut
202
203	sub _add_array_check ($$\%) {
204	my $self = shift;
205	my ($value, $option) = @_;
206	my $value_option = {};
207	if (ref $value eq 'ARRAY') {
208	($value, %$value_option) = @$value;
209	}
210	(1, value => $value);
211	}
212	*_replace_array_check = \&_add_array_check;
213
214	=item $field-body = $csv->stringify ()
215
216	Returns C<field-body> as a string.
217
218	=cut
219
220	sub stringify ($;%) {
221	my $self = shift;
222	my %o = @_;
223	my %option = %{$self->{option}};
224	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
225	$self->_delete_empty;
226	$option{max}--;
227	$option{max} = $#{$self->{value}} if $option{max} < 0;
228	$option{max} = $#{$self->{value}} if $#{$self->{value}} < $option{max};
229	$option{separator} = $option{separator_long}
230	if $option{max} >= $option{long_count};
231	join $option{separator},
232	map {$self->_stringify_item ($_, \%option)} @{$self->{value}}[0..$option{max}];
233	}
234	*as_string = \&stringify;
235
236	sub _stringify_item ($$\%) {
237	my $self = shift;
238	my $item = shift;
239	my $option = shift;
240	if ($$option{is_quoted_string}) {
241	my %s = &{$$option{hook_encode_string}} ($self,
242	$item, type => 'phrase');
243	Message::Util::quote_unsafe_string ($s{value},
244	unsafe => $$option{value_unsafe_rule});
245	} else {
246	$item;
247	}
248	}
249
250	=item $option-value = $csv->option ($option-name)
251
252	Gets option value.
253
254	=item $csv->option ($option-name, $option-value, ...)
255
256	Set option value(s). You can pass multiple option name-value pair
257	as parameter when setting.
258
259	=cut
260
261	## Inherited
262
263	=item $type = $csv->value_type
264
265	Gets value-type. Value-type is package name of module
266	used for value modification. A special value-type, ':none:'
267	is used to indicate values are non-structured (and no module
268	is automatically used).
269
270	=item $csv->value_type ([$type])
271
272	Set value-type.
273
274	=item $clone = $ua->clone ()
275
276	Returns a copy of the object.
277
278	=cut
279
280	## value_type, clone, method_available: Inherited
281
282	=back
283
284	=cut
285
286	## Internal functions
287
288	sub _delete_empty ($) {
289	my $self = shift;
290	$self->{value} = [grep {ref $_ \|\| length $_} @{$self->{value}}];
291	}
292
293	=head1 LICENSE
294
295	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
296
297	This program is free software; you can redistribute it and/or modify
298	it under the terms of the GNU General Public License as published by
299	the Free Software Foundation; either version 2 of the License, or
300	(at your option) any later version.
301
302	This program is distributed in the hope that it will be useful,
303	but WITHOUT ANY WARRANTY; without even the implied warranty of
304	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
305	GNU General Public License for more details.
306
307	You should have received a copy of the GNU General Public License
308	along with this program; see the file COPYING. If not, write to
309	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
310	Boston, MA 02111-1307, USA.
311
312	=head1 CHANGE
313
314	See F<ChangeLog>.
315	$Date: 2002/08/03 23:32:04 $
316
317	=cut
318
319	1;