/[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.3 by wakaba, Mon Apr 1 05:32:15 2002 UTC revision 1.4 by wakaba, Sat Apr 6 06:01:04 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::UA Perl module  Message::Field::UA -- Perl module for Internet message
5    header field body consist of C<product> tokens
 =head1 DESCRIPTION  
   
 Perl module for C<User-Agent:> field-body.  
6    
7  =cut  =cut
8    
9  package Message::Field::UA;  package Message::Field::UA;
 require 5.6.0;  
10  use strict;  use strict;
11  use re 'eval';  use vars qw(@ISA %REG $VERSION);
 use vars qw(%DEFAULT %REG $VERSION);  
12  $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};
13  require Message::Util;  require Message::Util;
14  require Message::MIME::EncodedWord;  require Message::Field::Structured;
15    push @ISA, qw(Message::Field::Structured);
16  use overload '""' => sub {shift->stringify},  use overload '""' => sub {shift->stringify},
17               '@{}' => sub {shift->product};               '@{}' => sub {shift->product};
18    
19  $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;  *REG = \%Message::Util::REG;
 $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{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+/;  
20  $REG{product} = qr#(?:$REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}(?:$REG{http_token}|$REG{quoted_string}))?#;  $REG{product} = qr#(?:$REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}(?:$REG{http_token}|$REG{quoted_string}))?#;
 $REG{S_encoded_word_comment} = qr/=\x3F[\x21-\x27\x2A-\x5B\x5D-\x7E]+\x3F=/;  
   
 $REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;  
 $REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;  
21  $REG{M_product} = qr#($REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}|$REG{quoted_string}))?#;  $REG{M_product} = qr#($REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}|$REG{quoted_string}))?#;
22    
23  $REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;  =head1 CONSTRUCTORS
 $REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;  
   
 %DEFAULT = (  
   add_prepend   => 1,  
   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,  
 );  
24    
25  =head2 Message::Field::UA->new ()  The following methods construct new C<Message::Field::Numval> objects:
26    
27  Return empty Message::Field::UA object.  =over 4
28    
29  =cut  =cut
30    
31  sub new ($;%) {  ## Initialize of this class -- called by constructors
32    my $class = shift;  sub _init ($;%) {
33    my $self = bless {option => {@_}}, $class;    my $self = shift;
34    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    my %options = @_;
35    $self;    my %DEFAULT = (
36        #encoding_after_encode      ## Inherited
37        #encoding_before_decode     ## Inherited
38        -field_name => 'user-agent',
39        #format     ## Inherited
40        #hook_encode_string ## Inherited
41        #hook_decode_string ## Inherited
42        -prepend    => 1,
43      );
44      $self->SUPER::_init (%DEFAULT, %options);
45  }  }
46    
47  =head2 Message::Field::UA->parse ($unfolded_field_body)  =item Message::Field::UA->new ([%options])
48    
49  Parse UA: styled C<field-body>.  Constructs a new C<Message::Field::UA> object.  You might pass some
50    options as parameters to the constructor.
51    
52    =cut
53    
54    ## Inherited
55    
56    =item Message::Field::UA->parse ($field-body, [%options])
57    
58    Constructs a new C<Message::Field::UA> object with
59    given field body.  You might pass some options as parameters to the constructor.
60    
61  =cut  =cut
62    
63  sub parse ($$;%) {  sub parse ($$;%) {
64    my $class = shift;    my $class = shift;
65    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
   for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}  
66    my $field_body = shift;  my @ua = ();    my $field_body = shift;  my @ua = ();
67      $self->_init (@_);
68    $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{    $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
69      my $comments = $1;      my $comments = $1;
70      $comments =~ s{$REG{M_comment}}{      $comments =~ s{$REG{M_comment}}{
71        my $comment = $self->_decode_ccontent ($1);        my $comment = $self->Message::Util::decode_ccontent ($1);
72        push @ua, {comment => [$comment]} if $comment;        push @ua, {comment => [$comment]} if $comment;
73      }goex;      }goex;
74      '';      '';
# Line 83  sub parse ($$;%) { Line 76  sub parse ($$;%) {
76    $field_body =~ s{$REG{M_product}((?:$REG{FWS}$REG{comment})*)}{    $field_body =~ s{$REG{M_product}((?:$REG{FWS}$REG{comment})*)}{
77      my ($product, $product_version, $comments) = ($1, $2, $3);      my ($product, $product_version, $comments) = ($1, $2, $3);
78      for ($product, $product_version) {      for ($product, $product_version) {
79        my ($s,$q) = ($self->_unquote_if_quoted_string ($_), 0);        my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0);
80        my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,        my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
81                  type => ($q?'token/quoted':'token'));   ## What token/quoted is? :-)                  type => ($q?'token/quoted':'token'));   ## What token/quoted is? :-)
82        $_ = $s{value};        $_ = $s{value};
83      }      }
84      my @comment = ();      my @comment = ();
85      $comments =~ s{$REG{M_comment}}{      $comments =~ s{$REG{M_comment}}{
86        my $comment = $self->_decode_ccontent ($1);        my $comment = $self->Message::Util::decode_ccontent ($1);
87        push @comment, $comment if $comment;        push @comment, $comment if $comment;
88      }goex;      }goex;
89      push @ua, {product => $product, product_version => $product_version,      push @ua, {name => $product, version => $product_version,
90                 comment => \@comment};                 comment => \@comment};
91    }goex;    }goex;
92    $self->{product} = \@ua;    $self->{product} = \@ua;
93    $self;    $self;
94  }  }
95    
96  =head2 $self->stringify ()  =back
97    
98    =head1 METHODS
99    
100    =over 4
101    
102    =item $self->stringify ()
103    
104  Returns C<field-body> as a string.  Returns C<field-body> as a string.
105    
# Line 112  sub stringify ($;%) { Line 111  sub stringify ($;%) {
111    $option{format} ||= $self->{option}->{format};    $option{format} ||= $self->{option}->{format};
112    my @r = ();    my @r = ();
113    for my $p (@{$self->{product}}) {    for my $p (@{$self->{product}}) {
114      if ($p->{product}) {      if ($p->{name}) {
115        if ($option{format} eq 'http'        if ($option{format} eq 'http'
116          && (  $p->{product} =~ /$REG{NON_http_token}/          && (  $p->{name} =~ /$REG{NON_http_token}/
117             || $p->{product_version} =~ /$REG{NON_http_token}/)) {             || $p->{version} =~ /$REG{NON_http_token}/)) {
118          my %f = (value => $p->{product});          my $f = $p->{name};
119          $f{value} .= '/'.$p->{product_version} if $p->{product_version};          $f .= '/'.$p->{version} if $p->{version};
120          %f = &{$self->{option}->{hook_encode_string}} ($self,          push @r, '('. $self->encode_ccontent ($f) .')';
           $f{value}, type => 'ccontent');  
         $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;  
         push @r, '('.$f{value}.')';  
121        } else {        } else {
122          my %e = &{$self->{option}->{hook_encode_string}} ($self,          my %e = &{$self->{option}->{hook_encode_string}} ($self,
123             $p->{product}, type => 'token');             $p->{name}, type => 'token');
124          my %f = &{$self->{option}->{hook_encode_string}} ($self,          my %f = &{$self->{option}->{hook_encode_string}} ($self,
125             $p->{product_version}, type => 'token');             $p->{version}, type => 'token');
126          push @r, $self->_quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')          push @r,
127            .($f{value}?'/'            Message::Util::quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')
128             .$self->_quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')            .($f{value} ? '/'
129             :'');            .Message::Util::quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')
130              :'');
131        }        }
132      } elsif ($p->{product_version}) {   ## Error!      } elsif ($p->{version}) {   ## Error!
133        my %f = &{$self->{option}->{hook_encode_string}} ($self,        push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';
          $p->{product_version}, type => 'ccontent');  
       $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;  
       push @r, '('.$f{value}.')';  
134      }      }
135      for (@{$p->{comment}}) {      for (@{$p->{comment}}) {
136        my %f = &{$self->{option}->{hook_encode_string}} ($self,        push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;
          $_, type => 'ccontent');  
       $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;  
       push @r, '('.$f{value}.')' if $f{value};  
137      }      }
138    }    }
139    join ' ', @r;    join ' ', @r;
140  }  }
141    *as_string = \&stringify;
142    
143    =item $array = $self->product
144    
145    Returns array reference of C<product>s.  Each of array elements
146    are hash reference, and it has three key: C<name>, C<version>,
147    and C<comment>.  C<comment> is array reference.
148    
149    Example:
150    
151      my $p = $ua->product->[0];
152      printf "%s\t%s\t%s\n", $p->{name}, $p->{version}, join ('; ', @{$p->{comment}});
153    
154    =cut
155    
156  sub product ($;%) {  sub product ($;%) {
157    my $self = shift;    my $self = shift;
# Line 154  sub product ($;%) { Line 159  sub product ($;%) {
159    $self->{product};    $self->{product};
160  }  }
161    
162    =item $name = $ua->product_name ($index)
163    
164    =item $version = $ua->product_version ($index)
165    
166    Returns product-name/-version of C<$index>'th C<product>.
167    
168    =cut
169    
170  sub product_name ($;$%) {  sub product_name ($;$%) {
171    my $self = shift;    my $self = shift;
172    my $index = shift;    my $index = shift;
# Line 166  sub product_version ($;$%) { Line 179  sub product_version ($;$%) {
179    $self->{product}->[$index]->{product_version} if ref $self->{product}->[$index];    $self->{product}->[$index]->{product_version} if ref $self->{product}->[$index];
180  }  }
181    
182    =item $comment_ref = $ua->product_comment ($index)
183    
184    Returns array reference of C<comment> of C<$index>'th C<product>.
185    (You can edit this array.)
186    
187    =cut
188    
189  sub product_comment ($;$%) {  sub product_comment ($;$%) {
190    my $self = shift;    my $self = shift;
191    my $index = shift;    my $index = shift;
192    if (ref $self->{product}->[$index]) {    $self->{product}->[$index]->{comment} if ref $self->{product}->[$index];
     wantarray?  
       @{$self->{product}->[$index]->{comment}}:  
       $self->{product}->[$index]->{comment}->[0];  
   }  
193  }  }
194    
195  sub add ($;%) {  =item $hdr->add ($name, $version, [$name, $version, ...])
196    
197    Adds some field name/version pairs.  Even if there are
198    one or more C<product>s whose name is same as C<$name>
199    (case sensible), given name/body pairs are ADDed.  Use C<replace>
200    to remove C<old> one.
201    
202    Instead of C<$version>, you can pass array reference.
203    [0] is used for C<version>, the others are saved as elements
204    of C<comment>.
205    
206    C<-prepend> options is available.  C<1> is default.
207    
208    Example:
209    
210      $ua->add (Perl => [$^V, $^O], 'foo.pl' => $VERSION, -prepend => 0);
211      print $ua;    # foo.pl/1.00 Perl/5.6.1 (MSWin32)
212    
213    =cut
214    
215    sub add ($%) {
216    my $self = shift;    my $self = shift;
217    my %option = @_;    my %products = @_;
218    my %a = (product => $option{name}, product_version => $option{version},    my %option = %{$self->{option}};
219             comment => $option{comment});    for (grep {/^-/} keys %products) {$option{substr ($_, 1)} = $products{$_}}
220    if ($option{prepend}||$self->{option}->{add_prepend}>0) {    for (grep {/^[^-]/} keys %products) {
221      unshift @{$self->{product}}, \%a;      my $name = $_;
222    } else {      my ($ver, $comment);
223      push @{$self->{product}}, \%a;      if (ref $products{$_} eq 'ARRAY') {
224          $ver = shift @{$products{$_}};
225          $comment = $products{$_};
226        } else {
227          $ver = $products{$_};
228          $comment = [];
229        }
230        ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)
231        if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {
232          $ver = sprintf '%vd', $ver;
233        }
234        if ($option{prepend}) {
235          unshift @{$self->{product}}, {name => $name, version => $ver,
236                                        comment => $comment};
237        } else {
238          push @{$self->{product}}, {name => $name, version => $ver,
239                                     comment => $comment};
240        }
241    }    }
   \%a;  
242  }  }
243    
244  sub replace ($;%) {  =item $hdr->replace ($field-name, $field-body, [$name, $body, ...])
245    
246    Adds some field name/body pairs.  If there are already
247    one or more field with name of C<$field-name>, it is replaced
248    by new one.
249    
250    Instead of C<$version>, you can pass array reference.
251    [0] is used for C<version>, the others are saved as elements
252    of C<comment>.
253    
254    C<-prepend> options is available.  C<1> is default.
255    
256    =cut
257    
258    sub replace ($%) {
259    my $self = shift;    my $self = shift;
260    my %option = @_;    my %params = @_;
261    my %a = (product => $option{name}, product_version => $option{version},    my %option = %{$self->{option}};
262             comment => $option{comment});    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
263    if ($a{product}) {    my (%new_product);
264      for my $p (@{$self->{product}}) {    for (grep {/^[^-]/} keys %params) {
265        if ($p->{product} eq $a{product}) {      my $name = $_;
266          $p = \%a;      my ($ver, $comment);
267          return $p;      if (ref $params{$_} eq 'ARRAY') {
268        }        $ver = shift @{$params{$_}};
269          $comment = $params{$_};
270        } else {
271          $ver = $params{$_};
272          $comment = [];
273        }
274        ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)
275        if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {
276          $ver = sprintf '%vd', $ver;
277      }      }
278        $new_product{$name} = {name => $name, version => $ver, comment => $comment};
279      }
280      for my $product (@{$self->{product}}) {
281        if (defined $new_product{$product->{name}}) {
282          $product = $new_product {$product->{name}};
283          $new_product{$product->{name}} = undef;
284        }
285      }
286      for (keys %new_product) {
287        push @{$self->{product}}, $new_product{$_};
288    }    }
289    if (($option{add_prepend}||$self->{option}->{add_prepend})>0) {  }
290      unshift @{$self->{product}}, \%a;  
291    } else {  =item $ua->delete ($name, [$name, $name,...]);
292      push @{$self->{product}}, \%a;  
293    Deletes C<product>s whose name is C<$name>.
294    
295    =cut
296    
297    sub delete ($@) {
298      my $self = shift;
299      my %delete;  for (@_) {$delete{$_} = 1}
300      for my $product (@{$self->{product}}) {
301        undef $product if $delete{$product->{name}};
302    }    }
   \%a;  
303  }  }
304    
305  sub _delete_empty ($) {  sub _delete_empty ($) {
# Line 217  sub _delete_empty ($) { Line 309  sub _delete_empty ($) {
309    $self->{product} = \@nid;    $self->{product} = \@nid;
310  }  }
311    
312  sub _quote_unsafe_string ($$;%) {  =item $option-value = $ua->option ($option-name)
313    
314    Gets option value.
315    
316    =item $ua->option ($option-name, $option-value, ...)
317    
318    Set option value(s).  You can pass multiple option name-value pair
319    as parameter when setting.
320    
321    =cut
322    
323    ## Inherited
324    
325    =item $clone = $ua->clone ()
326    
327    Returns a copy of the object.
328    
329    =cut
330    
331    sub clone ($) {
332    my $self = shift;    my $self = shift;
333    my $string = shift;    $self->_delete_empty;
334    my %option = @_;    my $clone = $self->SUPER::clone;
335    $option{unsafe} ||= 'NON_atext_dot';    my @p;
336    if ($string =~ /$REG{$option{unsafe}}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {    for (@{$self->{product}}) {
337      $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;      my $name = ref $_->{name}? $_->{name}->clone: $_->{name};
338      $string = '"'.$string.'"';      my $ver = ref $_->{version}? $_->{version}->clone: $_->{version};
339        my @comment;
340        for (@{$_->{comment}}) {
341          push @comment, ref $_? $_->clone: $_;
342        }
343        push @p, {name => $name, version => $ver, comment => \@comment};
344    }    }
345    $string;    $clone->{product} = \@p;
346      $clone;
347  }  }
348    
349  ## Unquote C<DQOUTE> and C<quoted-pair> if it is itself a  =back
 ## C<quoted-string>.  (Do nothing if it is MULTIPLE  
 ## C<quoted-string>"S".)  
 sub _unquote_if_quoted_string ($$) {  
   my $self = shift;  
   my $quoted_string = shift;  my $isq = 0;  
   $quoted_string =~ s{^$REG{M_quoted_string}$}{  
     my $qtext = $1;  
     $qtext =~ s/\x5C([\x00-\xFF])/$1/g;  
     $isq = 1;  
     $qtext;  
   }goex;  
   wantarray? ($quoted_string, $isq): $quoted_string;  
 }  
   
 sub _decode_ccontent ($$) {  
   &Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);  
 }  
350    
351  =head1 LICENSE  =head1 LICENSE
352    
# Line 270  Boston, MA 02111-1307, USA. Line 370  Boston, MA 02111-1307, USA.
370  =head1 CHANGE  =head1 CHANGE
371    
372  See F<ChangeLog>.  See F<ChangeLog>.
373    $Date$
374    
375  =cut  =cut
376    
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24