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.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::MIME::EncodedWord;

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 %option = @_;
  $option{format} ||= $self->{option}->{format};
  my @r = ();
  for my $p (@{$self->{product}}) {
    if ($p->{product}) {
      if ($option{format} eq 'http'
        && (  $p->{product} =~ /$REG{NON_http_token}/
           || $p->{product_version} =~ /$REG{NON_http_token}/)) {
        my %f = (value => $p->{product});
        $f{value} .= '/'.$p->{product_version} if $p->{product_version};
        %f = &{$self->{option}->{hook_encode_string}} ($self, 
          $f{value}, type => 'ccontent');
        $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
        push @r, '('.$f{value}.')';
      } else {
        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;
}

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

sub _decode_ccontent ($$) {
  &Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);
}

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