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

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

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

revision 1.11 by wakaba, Sun Jul 28 00:30:49 2002 UTC revision 1.12 by wakaba, Tue Jul 30 08:50:36 2002 UTC
# Line 6  header field body consist of C<product> Line 6  header field body consist of C<product>
6    
7  =cut  =cut
8    
9    require 5.6.0;
10  package Message::Field::UA;  package Message::Field::UA;
11  use strict;  use strict;
12  use vars qw(@ISA %REG $VERSION);  use re 'eval';
13    use vars qw(%DEFAULT @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};
 require Message::Util;  
15  require Message::Field::Structured;  require Message::Field::Structured;
16  push @ISA, qw(Message::Field::Structured);  push @ISA, qw(Message::Field::Structured);
17  use overload '""'       => sub { $_[0]->stringify },  use overload '.='       => sub {
              '@{}'      => sub { $_[0]->product },  
              '.='       => sub {  
18                  if (ref $_[1] eq 'HASH') {                  if (ref $_[1] eq 'HASH') {
19                    $_[0]->add (%{$_[1]});                    $_[0]->add (%{$_[1]});
20                  } elsif (ref $_[1] eq 'ARRAY') {                  } elsif (ref $_[1] eq 'ARRAY') {
# Line 27  use overload '""'      => sub { $_[0]->string Line 26  use overload '""'      => sub { $_[0]->string
26               },               },
27               fallback   => 1;               fallback   => 1;
28    
29  %REG = %Message::Util::REG;  *REG = \%Message::Util::REG;
30  $REG{product} = qr#(?:$REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}(?:$REG{http_token}|$REG{quoted_string}))?#;  
31  $REG{M_product} = qr#($REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}|$REG{quoted_string}))?#;  ## Initialize of this class -- called by constructors
32      %DEFAULT = (
33        -_HASH_NAME => 'product',
34        -_METHODS   => [qw|add count delete item|],
35        -_MEMBERS   => [qw|product|],
36        -by => 'product-name',      ## Default key for item, delete,...
37        #encoding_after_encode
38        #encoding_before_decode
39        #field_param_name
40        #field_name
41        #format
42        #hook_encode_string
43        #hook_decode_string
44        -prepend    => 1,   ## For add, replace
45        -use_Config => 1,
46        -use_comment        => 1,
47        #-use_quoted_string => 1,
48        -use_Win32  => 1,
49    );
50    
51  =head1 CONSTRUCTORS  =head1 CONSTRUCTORS
52    
# Line 43  The following methods construct new obje Line 60  The following methods construct new obje
60  sub _init ($;%) {  sub _init ($;%) {
61    my $self = shift;    my $self = shift;
62    my %options = @_;    my %options = @_;
   my %DEFAULT = (  
     #encoding_after_encode      ## Inherited  
     #encoding_before_decode     ## Inherited  
     -field_name => 'user-agent',  
     #format     ## Inherited  
     #hook_encode_string ## Inherited  
     #hook_decode_string ## Inherited  
     -prepend    => 1,  
     -use_Config => 1,  
     -use_Win32  => 1,  
   );  
63    $self->SUPER::_init (%DEFAULT, %options);    $self->SUPER::_init (%DEFAULT, %options);
64      
65      unless (defined $self->{option}->{use_quoted_string}) {
66        if ($self->{option}->{format} =~ /http/) {
67          $self->{option}->{use_quoted_string} = 0;
68        } else {
69          $self->{option}->{use_quoted_string} = 1;
70        }
71      }
72      
73    my @a = ();    my @a = ();
74    for (grep {/^[^-]/} keys %options) {    for (grep {/^[^-]/} keys %options) {
75      push @a, $_ => $options{$_};      push @a, $_ => $options{$_};
# Line 91  sub parse ($$;%) { Line 106  sub parse ($$;%) {
106      }goex;      }goex;
107      '';      '';
108    }goex;    }goex;
109    $field_body =~ s{$REG{M_product}((?:$REG{FWS}$REG{comment})*)}{    $field_body =~ s{
110      my ($product, $product_version, $comments) = ($1, $2, $3);          ($REG{quoted_string}|[^\x09\x20\x22\x28\x2F]+)  ## product-name
111            (?:
112              ((?:$REG{FWS}$REG{comment})*)$REG{FWS}
113              /
114              ((?:$REG{FWS}$REG{comment})*)$REG{FWS}
115              ($REG{quoted_string}|[^\x09\x20\x22\x28]+)    ## product-version
116            )?
117            ((?:$REG{FWS}$REG{comment})*)   ## comment
118      }{
119        my ($product, $product_version, $comments) = ($1, $4, $2.$3.$5);
120      for ($product, $product_version) {      for ($product, $product_version) {
121        my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0);        my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0);
122        my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,        my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
# Line 117  sub parse ($$;%) { Line 141  sub parse ($$;%) {
141    
142  =over 4  =over 4
143    
 =item $self->stringify ()  
   
 Returns C<field-body> as a string.  
   
 =cut  
   
 sub stringify ($;%) {  
   my $self = shift;  
   my %option = @_;  
   $option{format} ||= $self->{option}->{format};  
   my @r = ();  
   for my $p (@{$self->{product}}) {  
     if ($p->{name}) {  
       if ($option{format} eq 'http'  
         && (  $p->{name} =~ /$REG{NON_http_token}/  
            || $p->{version} =~ /$REG{NON_http_token}/)) {  
         my $f = $p->{name};  
         $f .= '/'.$p->{version} if $p->{version};  
         push @r, '('. $self->encode_ccontent ($f) .')';  
       } else {  
         my %e = &{$self->{option}->{hook_encode_string}} ($self,  
            $p->{name}, type => 'token');  
         my %f = &{$self->{option}->{hook_encode_string}} ($self,  
            $p->{version}, type => 'token');  
         push @r,  
           Message::Util::quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')  
           .($f{value} ? '/'  
           .Message::Util::quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')  
           :'');  
       }  
     } elsif ($p->{version}) {   ## Error!  
       push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';  
     }  
     for (@{$p->{comment}}) {  
       push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;  
     }  
   }  
   join ' ', @r;  
 }  
 *as_string = \&stringify;  
   
 =item $array = $self->product  
   
 Returns array reference of C<product>s.  Each of array elements  
 are hash reference, and it has three key: C<name>, C<version>,  
 and C<comment>.  C<comment> is array reference.  
   
 Example:  
   
   my $p = $ua->product->[0];  
   printf "%s\t%s\t%s\n", $p->{name}, $p->{version}, join ('; ', @{$p->{comment}});  
   
 =cut  
   
 sub product ($;%) {  
   my $self = shift;  
   $self->_delete_empty;  
   $self->{product};  
 }  
   
 =item $name = $ua->product_name ($index)  
   
 =item $version = $ua->product_version ($index)  
   
 Returns product-name/-version of C<$index>'th C<product>.  
   
 =cut  
   
 sub product_name ($;$%) {  
   my $self = shift;  
   my $index = shift;  
   $self->{product}->[$index]->{product} if ref $self->{product}->[$index];  
 }  
   
 sub product_version ($;$%) {  
   my $self = shift;  
   my $index = shift;  
   $self->{product}->[$index]->{product_version} if ref $self->{product}->[$index];  
 }  
   
 =item $comment_ref = $ua->product_comment ($index)  
   
 Returns array reference of C<comment> of C<$index>'th C<product>.  
 (You can edit this array.)  
   
144  =cut  =cut
145    
 sub product_comment ($;$%) {  
   my $self = shift;  
   my $index = shift;  
   $self->{product}->[$index]->{comment} if ref $self->{product}->[$index];  
 }  
146    
147  =item $hdr->add ($name, $version, [$name, $version, ...])  =item $hdr->add ($name, $version, [$name, $version, ...])
148    
# Line 230  Example: Line 164  Example:
164    
165  =cut  =cut
166    
167  sub add ($%) {  sub _add_hash_check ($$$\%) {
168    my $self = shift;    my $self = shift;
169    my %products = @_;    my ($name, $version, $option) = @_;
170    my %option = %{$self->{option}};    my @comment;
171    for (grep {/^-/} keys %products) {$option{substr ($_, 1)} = $products{$_}}    if (ref $version eq 'ARRAY') {
172    for (grep {/^[^-]/} keys %products) {      ($version, @comment) = @$version;
     my $name = $_;  
     my ($ver, $comment);  
     if (ref $products{$_} eq 'ARRAY') {  
       $ver = shift @{$products{$_}};  
       $comment = $products{$_};  
     } else {  
       $ver = $products{$_};  
       $comment = [];  
     }  
     ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)  
     if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {  
       $ver = sprintf '%vd', $ver;  
     }  
     if ($option{prepend}) {  
       unshift @{$self->{product}}, {name => $name, version => $ver,  
                                     comment => $comment};  
     } else {  
       push @{$self->{product}}, {name => $name, version => $ver,  
                                  comment => $comment};  
     }  
173    }    }
174      
175      ## Convert vX.Y.Z value to string (But there is no way to be sure that
176      ## the value is a version value.)
177      #$^V gt v5.6.0 &&     ## <- This check itself doesn't work before v5.6.0:)
178      if ($version =~ /[\x00-\x1F]/) {
179        $version = sprintf '%vd', $version;
180      }
181      
182      (1, $name => {
183        name        => $name,
184        version     => $version,
185        comment     => \@comment,
186      });
187    }
188    
189    *_add_return_value = \&_replace_return_value;
190    
191    ## (1/0, $name => $value) = $self->_replace_hash_check ($name => $value, \%option)
192    ## -- Checks given value and prepares saving value (hash version)
193    *_replace_hash_check = \&_add_hash_check;
194    
195    
196    ## $value = $self->_replace_hash_shift (\%values, $name, $option)
197    ## -- Returns a value (from %values) and deletes it from %values
198    ##    (like CORE::shift for array).
199    sub _replace_hash_shift ($\%$\%) {
200      shift; my $r = shift;  my $n = $_[0]->{name};
201      if ($$r{$n}) {
202        my $d = $$r{$n};
203        $$r{$n} = undef;
204        return $d;
205      }
206      undef;
207  }  }
208    
209  =item $hdr->replace ($field-name, $field-body, [$name, $body, ...])  ## $value = $self->_replace_return_value (\$item, \%option)
210    ## -- Returns returning value of replace method
211  Adds some field name/body pairs.  If there are already  sub _replace_return_value ($\$\%) {
212  one or more field with name of C<$field-name>, it is replaced    my $self = shift;
213  by new one.    my ($item, $value) = @_;
214      $$item;
215    }
216    
217  Instead of C<$version>, you can pass array reference.  ## 1/0 = $self->_delete_match ($by, \$item, \%delete_list, \%option)
218  [0] is used for C<version>, the others are saved as elements  ## -- Checks and returns whether given item is matched with
219  of C<comment>.  ##    deleting item list
220    sub _delete_match ($$\$\%\%) {
221      my $self = shift;
222      my ($by, $item, $list, $option) = @_;
223      return 0 unless ref $$item;   ## Already removed
224      if ($by eq 'name') {
225        return 1 if $$list{ $$item->{name} };
226      } elsif ($by eq 'version') {
227        return 1 if $$list{ $$item->{version} };
228      }
229      0;
230    }
231    
232  C<-prepend> options is available.  C<1> is default.  ## Delete empty items
233    sub _delete_empty ($) {
234      my $self = shift;
235      my $array = $self->{option}->{_HASH_NAME};
236      $self->{ $array } = [grep { ref $_ } @{$self->{ $array }}] if $array;
237    }
238    
239  =cut  *_item_match = \&_delete_match;
240    *_item_return_value = \&_replace_return_value;
241    
242  sub replace ($%) {  ## $item = $self->_item_new_value ($name, \%option)
243    my $self = shift;  ## -- Returns new item with key of $name (called when
244    my %params = @_;  ##    no returned value is found and -new_value_unless_exist
245    my %option = %{$self->{option}};  ##    option is true)
246    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}  sub _item_new_value ($$\%) {
247    my (%new_product);    my $self = shift;
248    for (grep {/^[^-]/} keys %params) {    my ($key, $option) = @_;
249      my $name = $_;    if ($option->{by} eq 'name') {
250      my ($ver, $comment);      return {name => $key, version => '', comment => []};
251      if (ref $params{$_} eq 'ARRAY') {    } elsif ($option->{by} eq 'version') {
252        $ver = shift @{$params{$_}};      return {name => '', version => $key, comment => []};
       $comment = $params{$_};  
     } else {  
       $ver = $params{$_};  
       $comment = [];  
     }  
     ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)  
     if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {  
       $ver = sprintf '%vd', $ver;  
     }  
     $new_product{$name} = {name => $name, version => $ver, comment => $comment};  
   }  
   for my $product (@{$self->{product}}) {  
     if ($product->{name} && defined $new_product{$product->{name}}) {  
       $product = $new_product {$product->{name}};  
       $new_product{$product->{name}} = undef;  
     }  
   }  
   for (keys %new_product) {  
     push @{$self->{product}}, $new_product{$_};  
253    }    }
254      undef;
255  }  }
256    
257  =item $ua->delete ($name, [$name, $name,...]);  ## TODO: Implement count,item_exist method
258    
259  Deletes C<product>s whose name is C<$name>.  =item $self->stringify ()
260    
261    Returns C<field-body> as a string.
262    
263  =cut  =cut
264    
265  sub delete ($@) {  sub stringify ($;%) {
266    my $self = shift;    my $self = shift;
267    my %delete;  for (@_) {$delete{$_} = 1}    my %o = @_; my %option = %{$self->{option}};
268    for my $product (@{$self->{product}}) {    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
269      undef $product if $delete{$product->{name}};    my @r = ();
270      for my $p (@{$self->{product}}) {
271        if (length $p->{name}) {
272          my %name = &{$self->{option}->{hook_encode_string}} ($self,
273             $p->{name}, type => 'token');
274          my %version = &{$self->{option}->{hook_encode_string}} ($self,
275             $p->{version}, type => 'token');
276          if (!$option{use_quoted_string}
277            && (  $name{value} =~ /$REG{NON_http_token}/
278               || $version{value} =~ /$REG{NON_http_token}/)) {
279            if ($name{value} =~ /$REG{NON_http_token}/) {
280            ## Both of name & version are unsafe
281              push @r, '(' . Message::Util::quote_ccontent (
282                $name{value} .
283                (length $version{value}? '/' . $version{value} : '')
284              ) . ')';
285            } else {
286            ## Only version is unsafe
287              push @r, $name{value}
288                .' (' . Message::Util::quote_ccontent ($version{value}) . ')';
289            }
290          } else {
291            push @r,
292              Message::Util::quote_unsafe_string
293                ($name{value}, unsafe => 'NON_http_token')
294              .(length $version{value} ?
295              '/' . Message::Util::quote_unsafe_string
296                ($version{value}, unsafe => 'NON_http_token') : '');
297          }
298        } elsif ($p->{version}) {
299        ## There is no product-name but the product-version.  It's error!
300          push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';
301        }
302        ## If there are some additional information,
303        for (@{$p->{comment}}) {
304          push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;
305        }
306    }    }
307      join ' ', @r;
308  }  }
309    *as_string = \&stringify;
 sub _delete_empty ($) {  
   my $self = shift;  
   my @nid;  
   for my $id (@{$self->{product}}) {push @nid, $id if ref $id}  
   $self->{product} = \@nid;  
 }  
310    
311  =item $option-value = $ua->option ($option-name)  =item $option-value = $ua->option ($option-name)
312    
# Line 346  Returns a copy of the object. Line 327  Returns a copy of the object.
327    
328  =cut  =cut
329    
330  sub clone ($) {  ## Inherited
   my $self = shift;  
   $self->_delete_empty;  
   my $clone = $self->SUPER::clone;  
   my @p;  
   for (@{$self->{product}}) {  
     my $name = ref $_->{name}? $_->{name}->clone: $_->{name};  
     my $ver = ref $_->{version}? $_->{version}->clone: $_->{version};  
     my @comment;  
     for (@{$_->{comment}}) {  
       push @comment, ref $_? $_->clone: $_;  
     }  
     push @p, {name => $name, version => $ver, comment => \@comment};  
   }  
   $clone->{product} = \@p;  
   $clone;  
 }  
331    
332  sub add_our_name ($;%) {  sub add_our_name ($;%) {
333    my $ua = shift;    my $ua = shift;
Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24