Message/Field/UA.pm


=head1 NAME

Message::Field::UA Perl module

=head1 DESCRIPTION

Perl module for C<User-Agent:> field-body.

=cut

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

use overload '""' => sub {shift->stringify},
             '@{}' => sub {shift->product};

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;
$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]+/;
$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/;
$REG{M_product} = qr#($REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}|$REG{quoted_string}))?#;

$REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
$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,
);

=head2 Message::Field::UA->new ()

Return empty Message::Field::UA object.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self;
}

=head2 Message::Field::UA->parse ($unfolded_field_body)

Parse UA: styled C<field-body>.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {option => {@_}}, $class;
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  my $field_body = shift;  my @ua = ();
  $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
    my $comments = $1;
    $comments =~ s{$REG{M_comment}}{
      my $comment = $self->_decode_ccontent ($1);
      push @ua, {comment => [$comment]} if $comment;
    }goex;
  }goex;
  $field_body =~ s{$REG{M_product}((?:$REG{FWS}$REG{comment})*)}{
    my ($product, $product_version, $comments) = ($1, $2, $3);
    for ($product, $product_version) {
      my ($s,$q) = ($self->_unquote_if_quoted_string ($_), 0);
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
                type => ($q?'token/quoted':'token'));   ## What token/quoted is? :-)
      $_ = $s{value};
    }
    my @comment = ();
    $comments =~ s{$REG{M_comment}}{
      my $comment = $self->_decode_ccontent ($1);
      push @comment, $comment if $comment;
    }goex;
    push @ua, {product => $product, product_version => $product_version, 
               comment => \@comment};
  }goex;
  $self->{product} = \@ua;
  $self;
}

=head2 $self->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($) {
  my $self = shift;
  my @r = ();
  for my $p (@{$self->{product}}) {
    if ($p->{product}) {
      my %e = &{$self->{option}->{hook_encode_string}} ($self, 
         $p->{product}, type => 'token');
      my %f = &{$self->{option}->{hook_encode_string}} ($self, 
         $p->{product_version}, type => 'token');
      push @r, $self->_quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')
        .($f{value}?'/'
         .$self->_quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')
         :'');
    } elsif ($p->{product_version}) {   ## Error!
      my %f = &{$self->{option}->{hook_encode_string}} ($self, 
         $p->{product_version}, type => 'ccontent');
      $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;

      push @r, '('.$f{value}.')';
    }
    for (@{$p->{comment}}) {
      my %f = &{$self->{option}->{hook_encode_string}} ($self, 
         $_, type => 'ccontent');
      $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
      push @r, '('.$f{value}.')' if $f{value};
    }
  }
  join ' ', @r;
}

sub product ($;%) {
  my $self = shift;
  $self->_delete_empty;
  @{$self->{product}};
}

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];
}

sub product_comment ($;$%) {
  my $self = shift;
  my $index = shift;
  if (ref $self->{product}->[$index]) {
    wantarray?
      @{$self->{product}->[$index]->{comment}}:
      $self->{product}->[$index]->{comment}->[0];
  }
}

sub add ($;%) {
  my $self = shift;
  my %option = @_;
  my %a = (product => $option{name}, product_version => $option{version},
           comment => $option{comment});
  if ($option{prepend}||$self->{option}->{add_prepend}>0) {
    unshift @{$self->{product}}, \%a;
  } else {
    push @{$self->{product}}, \%a;
  }
  \%a;
}

sub replace ($;%) {
  my $self = shift;
  my %option = @_;
  my %a = (product => $option{name}, product_version => $option{version},
           comment => $option{comment});
  if ($a{product}) {
    for my $p (@{$self->{product}}) {
      if ($p->{product} eq $a{product}) {
        $p = \%a;
        return $p;
      }
    }
  }
  if ($option{add_prepend}||$self->{option}->{add_prepend}>0) {
    unshift @{$self->{product}}, \%a;
  } else {
    push @{$self->{product}}, \%a;
  }
  \%a;
}

sub _delete_empty ($) {
  my $self = shift;
  my @nid;
  for my $id (@{$self->{product}}) {push @nid, $id if ref $id}
  $self->{product} = \@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;
}

sub _decode_ccontent ($$) {
  my $self = shift;
  my $ccontent = shift;
  $ccontent =~ s{((?:\G|$REG{WSP})$REG{S_encoded_word_comment}(?:$REG{WSP}|$))|((?:\x5C[\x00-\xFF]|[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x27\x2A-\x5B\x5D-\xFF])+)|$REG{M_comment}}{
    my ($eword, $ccont, $comment) = ($1, $2, $3);
    my $r = '';
    if ($comment) {
      $r = '('.$self->_decode_ccontent ($comment).')';
    } elsif ($eword) {
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $eword,
                type => 'ccontent');
      $r = $s{value};
    } else {
      $ccont =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $ccont,
                type => 'ccontent/quoted');
      $r = $s{value};
    }
    $r;
  }goex;
  $ccontent;
}

## Unquote C<DQOUTE> and C<quoted-pair> if it is itself a
## 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;
}

=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>.

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::UA Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for C<User-Agent:> field-body.
9
10			=cut
11
12			package Message::Field::UA;
13			require 5.6.0;
14			use strict;
15			use re 'eval';
16			use vars qw(%DEFAULT %REG $VERSION);
17			$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
18			require Message::Util;
19
20			use overload '""' => sub {shift->stringify},
21			'@{}' => sub {shift->product};
22
23			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
24			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
25			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
26
27			$REG{WSP} = qr/[\x20\x09]+/;
28			$REG{FWS} = qr/[\x20\x09]*/;
29			$REG{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+/;
30			$REG{product} = qr#(?:$REG{http_token}\|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}(?:$REG{http_token}\|$REG{quoted_string}))?#;
31			$REG{S_encoded_word_comment} = qr/=\x3F[\x21-\x27\x2A-\x5B\x5D-\x7E]+\x3F=/;
32
33			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
34			$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*)\x29/;
35			$REG{M_product} = qr#($REG{http_token}\|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}\|$REG{quoted_string}))?#;
36
37			$REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
38			$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
39
40			%DEFAULT = (
41			add_prepend => 1,
42			encoding_after_encode => '*default',
43			encoding_before_decode => '*default',
44			hook_encode_string => #sub {shift; (value => shift, @_)},
45			\&Message::Util::encode_header_string,
46			hook_decode_string => #sub {shift; (value => shift, @_)},
47			\&Message::Util::decode_header_string,
48			);
49
50			=head2 Message::Field::UA->new ()
51
52			Return empty Message::Field::UA object.
53
54			=cut
55
56			sub new ($;%) {
57			my $class = shift;
58			my $self = bless {option => {@_}}, $class;
59			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
60			$self;
61			}
62
63			=head2 Message::Field::UA->parse ($unfolded_field_body)
64
65			Parse UA: styled C<field-body>.
66
67			=cut
68
69			sub parse ($$;%) {
70			my $class = shift;
71			my $self = bless {option => {@_}}, $class;
72			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
73			my $field_body = shift; my @ua = ();
74			$field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
75			my $comments = $1;
76			$comments =~ s{$REG{M_comment}}{
77			my $comment = $self->_decode_ccontent ($1);
78			push @ua, {comment => [$comment]} if $comment;
79			}goex;
80			}goex;
81			$field_body =~ s{$REG{M_product}((?:$REG{FWS}$REG{comment})*)}{
82			my ($product, $product_version, $comments) = ($1, $2, $3);
83			for ($product, $product_version) {
84			my ($s,$q) = ($self->_unquote_if_quoted_string ($_), 0);
85			my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
86			type => ($q?'token/quoted':'token')); ## What token/quoted is? :-)
87			$_ = $s{value};
88			}
89			my @comment = ();
90			$comments =~ s{$REG{M_comment}}{
91			my $comment = $self->_decode_ccontent ($1);
92			push @comment, $comment if $comment;
93			}goex;
94			push @ua, {product => $product, product_version => $product_version,
95			comment => \@comment};
96			}goex;
97			$self->{product} = \@ua;
98			$self;
99			}
100
101			=head2 $self->stringify ()
102
103			Returns C<field-body> as a string.
104
105			=cut
106
107			sub stringify ($) {
108			my $self = shift;
109			my @r = ();
110			for my $p (@{$self->{product}}) {
111			if ($p->{product}) {
112			my %e = &{$self->{option}->{hook_encode_string}} ($self,
113			$p->{product}, type => 'token');
114			my %f = &{$self->{option}->{hook_encode_string}} ($self,
115			$p->{product_version}, type => 'token');
116			push @r, $self->_quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')
117			.($f{value}?'/'
118			.$self->_quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')
119			:'');
120			} elsif ($p->{product_version}) { ## Error!
121			my %f = &{$self->{option}->{hook_encode_string}} ($self,
122			$p->{product_version}, type => 'ccontent');
123			$f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
124
125			push @r, '('.$f{value}.')';
126			}
127			for (@{$p->{comment}}) {
128			my %f = &{$self->{option}->{hook_encode_string}} ($self,
129			$_, type => 'ccontent');
130			$f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
131			push @r, '('.$f{value}.')' if $f{value};
132			}
133			}
134			join ' ', @r;
135			}
136
137			sub product ($;%) {
138			my $self = shift;
139			$self->_delete_empty;
140			@{$self->{product}};
141			}
142
143			sub product_name ($;$%) {
144			my $self = shift;
145			my $index = shift;
146			$self->{product}->[$index]->{product} if ref $self->{product}->[$index];
147			}
148
149			sub product_version ($;$%) {
150			my $self = shift;
151			my $index = shift;
152			$self->{product}->[$index]->{product_version} if ref $self->{product}->[$index];
153			}
154
155			sub product_comment ($;$%) {
156			my $self = shift;
157			my $index = shift;
158			if (ref $self->{product}->[$index]) {
159			wantarray?
160			@{$self->{product}->[$index]->{comment}}:
161			$self->{product}->[$index]->{comment}->[0];
162			}
163			}
164
165			sub add ($;%) {
166			my $self = shift;
167			my %option = @_;
168			my %a = (product => $option{name}, product_version => $option{version},
169			comment => $option{comment});
170			if ($option{prepend}\|\|$self->{option}->{add_prepend}>0) {
171			unshift @{$self->{product}}, \%a;
172			} else {
173			push @{$self->{product}}, \%a;
174			}
175			\%a;
176			}
177
178			sub replace ($;%) {
179			my $self = shift;
180			my %option = @_;
181			my %a = (product => $option{name}, product_version => $option{version},
182			comment => $option{comment});
183			if ($a{product}) {
184			for my $p (@{$self->{product}}) {
185			if ($p->{product} eq $a{product}) {
186			$p = \%a;
187			return $p;
188			}
189			}
190			}
191			if ($option{add_prepend}\|\|$self->{option}->{add_prepend}>0) {
192			unshift @{$self->{product}}, \%a;
193			} else {
194			push @{$self->{product}}, \%a;
195			}
196			\%a;
197			}
198
199			sub _delete_empty ($) {
200			my $self = shift;
201			my @nid;
202			for my $id (@{$self->{product}}) {push @nid, $id if ref $id}
203			$self->{product} = \@nid;
204			}
205
206			sub _quote_unsafe_string ($$;%) {
207			my $self = shift;
208			my $string = shift;
209			my %option = @_;
210			$option{unsafe} \|\|= 'NON_atext_dot';
211			if ($string =~ /$REG{$option{unsafe}}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
212			$string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
213			$string = '"'.$string.'"';
214			}
215			$string;
216			}
217
218			sub _decode_ccontent ($$) {
219			my $self = shift;
220			my $ccontent = shift;
221			$ccontent =~ s{((?:\G\|$REG{WSP})$REG{S_encoded_word_comment}(?:$REG{WSP}\|$))\|((?:\x5C[\x00-\xFF]\|[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x27\x2A-\x5B\x5D-\xFF])+)\|$REG{M_comment}}{
222			my ($eword, $ccont, $comment) = ($1, $2, $3);
223			my $r = '';
224			if ($comment) {
225			$r = '('.$self->_decode_ccontent ($comment).')';
226			} elsif ($eword) {
227			my %s = &{$self->{option}->{hook_decode_string}} ($self, $eword,
228			type => 'ccontent');
229			$r = $s{value};
230			} else {
231			$ccont =~ s/\x5C([\x00-\xFF])/$1/g;
232			my %s = &{$self->{option}->{hook_decode_string}} ($self, $ccont,
233			type => 'ccontent/quoted');
234			$r = $s{value};
235			}
236			$r;
237			}goex;
238			$ccontent;
239			}
240
241			## Unquote C<DQOUTE> and C<quoted-pair> if it is itself a
242			## C<quoted-string>. (Do nothing if it is MULTIPLE
243			## C<quoted-string>"S".)
244			sub _unquote_if_quoted_string ($$) {
245			my $self = shift;
246			my $quoted_string = shift; my $isq = 0;
247			$quoted_string =~ s{^$REG{M_quoted_string}$}{
248			my $qtext = $1;
249			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
250			$isq = 1;
251			$qtext;
252			}goex;
253			wantarray? ($quoted_string, $isq): $quoted_string;
254			}
255
256			=head1 LICENSE
257
258			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
259
260			This program is free software; you can redistribute it and/or modify
261			it under the terms of the GNU General Public License as published by
262			the Free Software Foundation; either version 2 of the License, or
263			(at your option) any later version.
264
265			This program is distributed in the hope that it will be useful,
266			but WITHOUT ANY WARRANTY; without even the implied warranty of
267			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
268			GNU General Public License for more details.
269
270			You should have received a copy of the GNU General Public License
271			along with this program; see the file COPYING. If not, write to
272			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
273			Boston, MA 02111-1307, USA.
274
275			=head1 CHANGE
276
277			See F<ChangeLog>.
278
279			=cut
280
281			1;