/[suikacvs]/messaging/manakai/lib/Message/Field/CSV.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/CSV.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.6 by wakaba, Sat Apr 13 01:33:54 2002 UTC revision 1.7 by wakaba, Sun Apr 21 04:27:42 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::CSV Perl module  Message::Field::CSV --- Perl module for Internet message
5    field body consist of comma separated values
 =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.  
6    
7  =cut  =cut
8    
# Line 17  package Message::Field::CSV; Line 10  package Message::Field::CSV;
10  require 5.6.0;  require 5.6.0;
11  use strict;  use strict;
12  use re 'eval';  use re 'eval';
13  use vars qw(%OPTION %REG $VERSION);  use vars qw(@ISA %REG $VERSION);
14  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
 use overload '@{}' => sub {shift->value},  
              '""' => sub {shift->stringify};  
15  require Message::Util;  require Message::Util;
16  $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;  require Message::Field::Structured;
17  $REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;  push @ISA, qw(Message::Field::Structured);
18  $REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;  
19  $REG{uri_literal} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;  use overload '""' => sub { $_[0]->stringify },
20                 '0+' => sub { $_[0]->count },
21  $REG{WSP} = qr/[\x20\x09]+/;               '.=' => sub { $_[0]->add ($_[1]); $_[0] },
22  $REG{FWS} = qr/[\x20\x09]*/;               fallback => 1;
23  $REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;  
24  $REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;  *REG = \%Message::Util::REG;
25  $REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;  ## Inherited: comment, quoted_string, domain_literal, angle_quoted
26  $REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;          ## WSP, FWS, atext
27  $REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;  
28  $REG{NON_atom} = qr/[^\x09\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x2E]/;  ## From usefor-article
29  $REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;          $REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;
30  $REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;          $REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;
31  $REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;  
32  $REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;  =head1 CONSTRUCTORS
33  $REG{NON_component} = qr/[^\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5F\x61-\x7A\x80-\xFF\x2F\x3D\x3F]/;  
34  $REG{NON_distribution} = qr/[^\x21\x2B\x2D\x30-\x39\x41-\x5A\x5F\x61-\x7A]/;  The following methods construct new objects:
35  $REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;  
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    
64  ## Keywords: foo, bar, "and so on"  ## Keywords: foo, bar, "and so on"
65  ## Newsgroups: local.test,local.foo,local.bar  ## Newsgroups: local.test,local.foo,local.bar
66  ## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01  ## Accept: text/html; q=1.0, text/plain; q=0.03; *; q=0.01
67    
 %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?  
   long_count    => 10,  
   remove_comment        => 1,  
   separator     => ', ',  
   separator_long        => ', ',  
   max   => -1,  
   value_type    => [':none:'],  
   value_unsafe_rule     => 'NON_http_token_wsp',  
 );  
   
 sub _init_option ($) {  
   my $self = shift;  
68    my %field_type = qw(accept-charset accept accept-encoding accept    my %field_type = qw(accept-charset accept accept-encoding accept
69       accept-language accept       accept-language accept
70       content-language keywords       content-language keywords
# Line 77  sub _init_option ($) { Line 75  sub _init_option ($) {
75       posted-to newsgroups       posted-to newsgroups
76       x-brother x-moe x-daughter x-moe       x-brother x-moe x-daughter x-moe
77       x-respect x-moe x-syster x-moe x-wife x-moe);       x-respect x-moe x-syster x-moe x-wife x-moe);
78    my $field_name = lc $self->{option}->{field_name}    my $field_name = lc $self->{option}->{field_name};
                 || lc $self->{option}->{-field_name};   ## AD HOC  
79    $field_name = $field_type{$field_name} || $field_name;    $field_name = $field_type{$field_name} || $field_name;
80    if ($field_name eq 'newsgroups') {    if ($field_name eq 'newsgroups') {
81      $self->{option}->{separator} = ',';      $self->{option}->{separator} = ',';
# Line 92  sub _init_option ($) { Line 89  sub _init_option ($) {
89      $self->{option}->{long_count} = 15;      $self->{option}->{long_count} = 15;
90      $self->{option}->{value_unsafe_rule} = 'NON_distribution';      $self->{option}->{value_unsafe_rule} = 'NON_distribution';
91    } elsif ($field_name eq 'x-moe') {    } elsif ($field_name eq 'x-moe') {
92      $self->{option}->{is_quoted_string} = -1;      $self->{option}->{is_quoted_string} = 0;
93      $self->{option}->{value_type} = ['Message::Field::ValueParams',      $self->{option}->{value_type} = ['Message::Field::ValueParams',
94        {format => $self->{option}->{format}}];        {format => $self->{option}->{format}}];
95    } elsif ($field_name eq 'accept') {    } elsif ($field_name eq 'accept') {
96      $self->{option}->{is_quoted_string} = -1;      $self->{option}->{is_quoted_string} = 0;
97      $self->{option}->{value_type} = ['Message::Field::ValueParams',      $self->{option}->{value_type} = ['Message::Field::ValueParams',
98        {format => $self->{option}->{format}}];        {format => $self->{option}->{format}}];
99    } elsif ($field_name eq 'list-') {    } elsif ($field_name eq 'list-') {
100      $self->{option}->{is_quoted_string} = -1;      $self->{option}->{is_quoted_string} = 0;
101      $self->{option}->{remove_comment} = -1;      $self->{option}->{remove_comment} = 0;
102      $self->{option}->{value_type} = ['Message::Field::URI',      $self->{option}->{value_type} = ['Message::Field::URI',
103        {field_name => $self->{option}->{field_name},        {-field_name => $self->{option}->{field_name},
104        format => $self->{option}->{format}}];        -format => $self->{option}->{format}}];
105    } elsif ($field_name eq 'encrypted') {    } elsif ($field_name eq 'encrypted') {
106      $self->{option}->{max} = 2;      $self->{option}->{max} = 2;
107    }    }
108      
109      if (ref $options{value} eq 'ARRAY') {
110        $self->add (@{$options{value}});
111      } elsif ($options{value}) {
112        $self->add ($options{value});
113      }
114    $self;    $self;
115  }  }
116    
117  =head2 Message::Field::CSV->new ()  =item $csv = Message::Field::CSV->new ([%options])
118    
119  Returns new CSV field body.  Constructs a new object.  You might pass some options as parameters
120    to the constructor.
121    
122  =cut  =cut
123    
124  sub new ($;%) {  ## Inherited
   my $self = bless {}, shift;  
   my %option = @_;  
   for (%OPTION) {$option{$_} ||= $OPTION{$_}}  
   $self->{option} = \%option;  
   $self->_init_option ();  
   $self;  
 }  
125    
126  =head2 Message::Field::CSV->parse ($unfolded_field_body)  =item $csv = Message::Field::CSV->parse ($field-body, [%options])
127    
128  Parses C<field-body>.  Constructs a new object with given field body.  You might pass
129    some options as parameters to the constructor.
130    
131  =cut  =cut
132    
133  sub parse ($$;%) {  sub parse ($$;%) {
134    my $self = bless {}, shift;    my $class = shift;
135      my $self = bless {}, $class;
136    my $field_body = shift;    my $field_body = shift;
137    my %option = @_;    $self->_init (@_);
138    for (%OPTION) {$option{$_} ||= $OPTION{$_}}    $field_body = Message::Util::delete_comment ($field_body)
139    $self->{option} = \%option;      if $self->{option}->{remove_comment};
140    $self->_init_option ();    push @{$self->{value}}, $self->_parse_list ($field_body);
   $field_body = $self->_delete_comment ($field_body)  
     unless $option{remove_comment}<0;  
   @{$self->{value}} = $self->_parse_list ($field_body);  
141    $self;    $self;
142  }  }
143    
144    ## Parses csv string and returns array
145  sub _parse_list ($$) {  sub _parse_list ($$) {
146    my $self = shift;    my $self = shift;
147    my $fb = shift;    my $fb = shift;
148    my @ids;    my @ids;
149    $fb =~ s{((?:$REG{quoted_string}|$REG{uri_literal}|$REG{domain_literal}|$REG{comment}|[^\x22\x28\x2C\x3C\x5B])+)}{    $fb =~ s{((?:$REG{quoted_string}|$REG{angle_quoted}|$REG{domain_literal}|$REG{comment}|[^\x22\x28\x2C\x3C\x5B])+)}{
150      my $s = $1;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;      my $s = $1;  $s =~ s/^$REG{WSP}+//;  $s =~ s/$REG{WSP}+$//;
151      if ($self->{option}->{is_quoted_string}>0) {      if ($self->{option}->{is_quoted_string}) {
152        push @ids, $self->_value ($self->_decode_quoted_string ($s));        $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      } else {      } else {
156        push @ids, $self->_value ($s);        $s = $self->_value ($s) if $self->{option}->{parse_all};
157          push @ids, $s;
158      }      }
159    }goex;    }goex;
160    @ids;    @ids;
161  }  }
162    
163  =head2 $self->value ()  =back
164    
165    =head1 METHODS
166    
167    =over 4
168    
169  Returns array reference to value list.  =head2 $values = $csv->value ($index1, [$index2, $index3,...])
170    
171    Returns C<$index>'th value(s).
172    
173  =cut  =cut
174    
175  sub value ($) {shift->{value}}  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  =head2 $self->add ($value, [%option])  =item $number = $csv->count
187    
188  Adds new value.  Returns number of values.
189    
190  =cut  =cut
191    
192  sub add ($;$%) {  sub count ($) {
193    my $self = shift;    my $self = shift;
194    my ($value, %option) = @_;    $self->_delete_empty;
195    push @{$self->{value}}, $self->_value ($value);    $#{$self->{value}}+1;
   $value;  
196  }  }
197    
198  ## Hook called before returning C<value>.  =iterm $csv->add ($value1, [$value2, $value3,...])
199  ## $self->_param_value ($name, $value);  
200  sub _value ($$) {  Adds (appends) new value(s).
201    
202    =iterm $csv->prepend ($value1, [$value2, $value3,...])
203    
204    Prepends new value(s).
205    
206    =cut
207    
208    sub add ($@) {
209    my $self = shift;    my $self = shift;
210    my $value = shift;    push @{$self->{value}}, @_;
211    my $vtype = $self->{option}->{value_type}->[0];  }
212    my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}  
213      if ref $self->{option}->{value_type}->[1];  sub prepend ($@) {
214    if (ref $value) {    my $self = shift;
215      return $value;    unshift @{$self->{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);  
   }  
216  }  }
217    
218    =item $field-body = $csv->stringify ()
219    
220    Returns C<field-body> as a string.
221    
222    =cut
223    
224  sub stringify ($;%) {  sub stringify ($;%) {
225    my $self = shift;    my $self = shift;
226    my %option = @_;    my %o = @_;
227    $option{separator} ||= $self->{option}->{separator};    my %option = %{$self->{option}};
228    $option{separator_long} ||= $self->{option}->{separator_long};    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
229    $option{long_count} ||= $self->{option}->{long_count};    $self->_delete_empty;
   $option{max} ||= $self->{option}->{max};  
   $option{is_quoted_string} ||= $self->{option}->{is_quoted_string};  
   $option{value_unsafe_rule} ||= $self->{option}->{value_unsafe_rule};  
   $self->_delete_empty ();  
230    $option{max}--;    $option{max}--;
231    $option{max} = $#{$self->{value}} if $option{max}<0;    $option{max} = $#{$self->{value}} if $option{max} <= 0;
232    $option{max} = $#{$self->{value}} if $#{$self->{value}}<$option{max};    $option{max} = $#{$self->{value}} if $#{$self->{value}} < $option{max};
233    $option{separator} = $option{separator_long}    $option{separator} = $option{separator_long}
234      if $option{max} >= $option{long_count};      if $option{max} >= $option{long_count};
235    join $option{separator},    join $option{separator},
236      map {      map {
237        if ($option{is_quoted_string}>0) {        if ($option{is_quoted_string}) {
238          my %s = &{$self->{option}->{hook_encode_string}} ($self,          my %s = &{$self->{option}->{hook_encode_string}} ($self,
239            $_, type => 'phrase');            $_, type => 'phrase');
240          $self->_quote_unsafe_string ($s{value},          Message::Util::quote_unsafe_string ($s{value},
241            unsafe => $option{value_unsafe_rule});            unsafe => $option{value_unsafe_rule});
242        } else {        } else {
243          $_;          $_;
244        }        }
245      } @{$self->{value}}[0..$option{max}];      } @{$self->{value}}[0..$option{max}];
246  }  }
247    *as_string = \&stringify;
248    
249    =item $option-value = $ua->option ($option-name)
250    
251    Gets option value.
252    
253  =head2 $self->option ($option_name, [$option_value])  =item $csv->option ($option-name, $option-value, ...)
254    
255  Set/gets new value of the option.  Set option value(s).  You can pass multiple option name-value pair
256    as parameter when setting.
257    
258  =cut  =cut
259    
260  sub option ($$;$) {  ## Inherited
261    my $self = shift;  
262    my ($name, $value) = @_;  =item $type = $csv->value_type
263    if (defined $value) {  
264      $self->{option}->{$name} = $value;  Gets value-type.  Value-type is package name of module
265    }  used for value modification.  A special value-type, ':none:'
266    $self->{option}->{$name};  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    
275  sub value_type ($;$%) {  sub value_type ($;$) {
276    my $self = shift;    my $self = shift;
277    my $new_value_type = shift;    my $new_value_type = shift;
278    if ($new_value_type) {    if (ref $new_value_type eq 'ARRAY') {
279        $self->{option}->{value_type} = $new_value_type;
280      } elsif ($new_value_type) {
281      $self->{option}->{value_type}->[0] = $new_value_type;      $self->{option}->{value_type}->[0] = $new_value_type;
282    }    }
283    $self->{option}->{value_type}->[0] || ':none:';    $self->{option}->{value_type}->[0] || ':none:';
284  }  }
285    
286  sub _delete_empty ($) {  =item $clone = $ua->clone ()
   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;  
   my %option = @_;  
   $option{unsafe} ||= 'NON_atext_dot';  
   if ($string =~ /$REG{$option{unsafe}}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {  
     $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;  
     $string = '"'.$string.'"';  
   }  
   $string;  
 }  
   
287    
288  =head2 $self->_unquote_quoted_string ($string)  Returns a copy of the object.
   
 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.  
289    
290  =cut  =cut
291    
292  sub _unquote_quoted_string ($$) {  sub clone ($) {
293    my $self = shift;    my $self = shift;
294    my $quoted_string = shift;    $self->_delete_empty;
295    $quoted_string =~ s{$REG{M_quoted_string}}{    my $clone = $self->SUPER::clone;
296      my $qtext = $1;    $clone->{value_type} = Message::Util::make_clone ($self->{value_type});
297      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;    $clone;
     $qtext;  
   }goex;  
   $quoted_string;  
298  }  }
299    
300  sub _decode_quoted_string ($$) {  =back
   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.  
301    
302  =cut  =cut
303    
304  sub _delete_comment ($$) {  ## Internal functions
305    
306    ## Hook called before returning C<value>.
307    ## $csv->_param_value ($name, $value);
308    sub _value ($$) {
309    my $self = shift;    my $self = shift;
310    my $body = shift;    my $value = shift;
311    $body =~ s{($REG{quoted_string}|$REG{uri_literal}|$REG{domain_literal})|$REG{comment}}{    my $vtype = $self->{option}->{value_type}->[0];
312      my $o = $1;  $o? $o : ' ';    my %vopt; %vopt = %{$self->{option}->{value_type}->[1]}
313    }gex;      if ref $self->{option}->{value_type}->[1];
314    $body;    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  }  }
326    
327  =head1 EXAMPLE  sub _delete_empty ($) {
328      my $self = shift;
329      $self->{value} = [grep {length $_} @{$self->{value}}];
330    }
331    
332  =head1 LICENSE  =head1 LICENSE
333    
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24