Message/Field/UA.pm


=head1 NAME

Message::Field::UA -- Perl module for Internet message
header field body consist of C<product> tokens

=cut

require 5.6.0;
package Message::Field::UA;
use strict;
use re 'eval';
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.11 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);
use overload '.='       => sub { 
                if (ref $_[1] eq 'HASH') {
                  $_[0]->add (%{$_[1]});
                } elsif (ref $_[1] eq 'ARRAY') {
                  $_[0]->add (@{$_[1]});
                } else {
                  $_[0]->add ($_[1] => '', -prepend => 0);
                }
                $_[0];
             },
             fallback   => 1;

*REG = \%Message::Util::REG;

## Initialize of this class -- called by constructors
  %DEFAULT = (
    -_HASH_NAME => 'product',
    -_METHODS   => [qw|add count delete item|],
    -_MEMBERS   => [qw|product|],
    -by => 'product-name',      ## Default key for item, delete,...
    #encoding_after_encode
    #encoding_before_decode
    #field_param_name
    #field_name
    #format
    #hook_encode_string
    #hook_decode_string
    -prepend    => 1,   ## For add, replace
    -use_Config => 1,
    -use_comment        => 1,
    #-use_quoted_string => 1,
    -use_Win32  => 1,
);

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  $self->SUPER::_init (%DEFAULT, %options);
  
  unless (defined $self->{option}->{use_quoted_string}) {
    if ($self->{option}->{format} =~ /http/) {
      $self->{option}->{use_quoted_string} = 0;
    } else {
      $self->{option}->{use_quoted_string} = 1;
    }
  }
  
  my @a = ();
  for (grep {/^[^-]/} keys %options) {
    push @a, $_ => $options{$_};
  }
  $self->add (@a) if $#a > -1;
}

=item $ua = Message::Field::UA->new ([%options])

Constructs a new C<Message::Field::UA> object.  You might pass some 
options as parameters to the constructor.

=cut

## Inherited

=item $ua = Message::Field::UA->parse ($field-body, [%options])

Constructs a new C<Message::Field::UA> object with
given field body.  You might pass some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $field_body = shift;  my @ua = ();
  $self->_init (@_);
  $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
    my $comments = $1;
    $comments =~ s{$REG{M_comment}}{
      my $comment = $self->Message::Util::decode_ccontent ($1);
      push @ua, {comment => [$comment]} if $comment;
    }goex;
    '';
  }goex;
  $field_body =~ s{
        ($REG{quoted_string}|[^\x09\x20\x22\x28\x2F]+)  ## product-name
        (?:
          ((?:$REG{FWS}$REG{comment})*)$REG{FWS}
          /
          ((?:$REG{FWS}$REG{comment})*)$REG{FWS}
          ($REG{quoted_string}|[^\x09\x20\x22\x28]+)    ## product-version
        )?
        ((?:$REG{FWS}$REG{comment})*)   ## comment
  }{
    my ($product, $product_version, $comments) = ($1, $4, $2.$3.$5);
    for ($product, $product_version) {
      my ($s,$q) = (Message::Util::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->Message::Util::decode_ccontent ($1);
      push @comment, $comment if $comment;
    }goex;
    push @ua, {name => $product, version => $product_version, 
               comment => \@comment};
  }goex;
  push @{$self->{product}}, @ua;
  $self;
}

=back

=head1 METHODS

=over 4

=cut


=item $hdr->add ($name, $version, [$name, $version, ...])

Adds some field name/version pairs.  Even if there are
one or more C<product>s whose name is same as C<$name>
(case sensible), given name/body pairs are ADDed.  Use C<replace>
to remove C<old> one.

Instead of C<$version>, you can pass array reference.
[0] is used for C<version>, the others are saved as elements
of C<comment>.

C<-prepend> options is available.  C<1> is default.

Example:

  $ua->add (Perl => [$^V, $^O], 'foo.pl' => $VERSION, -prepend => 0);
  print $ua;    # foo.pl/1.00 Perl/5.6.1 (MSWin32)

=cut

sub _add_hash_check ($$$\%) {
  my $self = shift;
  my ($name, $version, $option) = @_;
  my @comment;
  if (ref $version eq 'ARRAY') {
    ($version, @comment) = @$version;
  }
  
  ## Convert vX.Y.Z value to string (But there is no way to be sure that 
  ## the value is a version value.)
  #$^V gt v5.6.0 &&     ## <- This check itself doesn't work before v5.6.0:)
  if ($version =~ /[\x00-\x1F]/) {
    $version = sprintf '%vd', $version;
  }
  
  (1, $name => {
    name        => $name,
    version     => $version,
    comment     => \@comment,
  });
}

*_add_return_value = \&_replace_return_value;

## (1/0, $name => $value) = $self->_replace_hash_check ($name => $value, \%option)
## -- Checks given value and prepares saving value (hash version)
*_replace_hash_check = \&_add_hash_check;


## $value = $self->_replace_hash_shift (\%values, $name, $option)
## -- Returns a value (from %values) and deletes it from %values
##    (like CORE::shift for array).
sub _replace_hash_shift ($\%$\%) {
  shift; my $r = shift;  my $n = $_[0]->{name};
  if ($$r{$n}) {
    my $d = $$r{$n};
    $$r{$n} = undef;
    return $d;
  }
  undef;
}

## $value = $self->_replace_return_value (\$item, \%option)
## -- Returns returning value of replace method
sub _replace_return_value ($\$\%) {
  my $self = shift;
  my ($item, $value) = @_;
  $$item;
}

## 1/0 = $self->_delete_match ($by, \$item, \%delete_list, \%option)
## -- Checks and returns whether given item is matched with
##    deleting item list
sub _delete_match ($$\$\%\%) {
  my $self = shift;
  my ($by, $item, $list, $option) = @_;
  return 0 unless ref $$item;   ## Already removed
  if ($by eq 'name') {
    return 1 if $$list{ $$item->{name} };
  } elsif ($by eq 'version') {
    return 1 if $$list{ $$item->{version} };
  }
  0;
}

## Delete empty items
sub _delete_empty ($) {
  my $self = shift;
  my $array = $self->{option}->{_HASH_NAME};
  $self->{ $array } = [grep { ref $_ } @{$self->{ $array }}] if $array;
}

*_item_match = \&_delete_match;
*_item_return_value = \&_replace_return_value;

## $item = $self->_item_new_value ($name, \%option)
## -- Returns new item with key of $name (called when
##    no returned value is found and -new_value_unless_exist
##    option is true)
sub _item_new_value ($$\%) {
  my $self = shift;
  my ($key, $option) = @_;
  if ($option->{by} eq 'name') {
    return {name => $key, version => '', comment => []};
  } elsif ($option->{by} eq 'version') {
    return {name => '', version => $key, comment => []};
  }
  undef;
}

## TODO: Implement count,item_exist method

=item $self->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my @r = ();
  for my $p (@{$self->{product}}) {
    if (length $p->{name}) {
      my %name = &{$self->{option}->{hook_encode_string}} ($self, 
         $p->{name}, type => 'token');
      my %version = &{$self->{option}->{hook_encode_string}} ($self, 
         $p->{version}, type => 'token');
      if (!$option{use_quoted_string}
        && (  $name{value} =~ /$REG{NON_http_token}/
           || $version{value} =~ /$REG{NON_http_token}/)) {
        if ($name{value} =~ /$REG{NON_http_token}/) {
        ## Both of name & version are unsafe
          push @r, '(' . Message::Util::quote_ccontent (
            $name{value} .
            (length $version{value}? '/' . $version{value} : '')
          ) . ')';
        } else {
        ## Only version is unsafe
          push @r, $name{value}
            .' (' . Message::Util::quote_ccontent ($version{value}) . ')';
        }
      } else {
        push @r, 
          Message::Util::quote_unsafe_string
            ($name{value}, unsafe => 'NON_http_token')
          .(length $version{value} ?
          '/' . Message::Util::quote_unsafe_string
            ($version{value}, unsafe => 'NON_http_token') : '');
      }
    } elsif ($p->{version}) {
    ## There is no product-name but the product-version.  It's error!
      push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';
    }
    ## If there are some additional information,
    for (@{$p->{comment}}) {
      push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;
    }
  }
  join ' ', @r;
}
*as_string = \&stringify;

=item $option-value = $ua->option ($option-name)

Gets option value.

=item $ua->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

=item $clone = $ua->clone ()

Returns a copy of the object.

=cut

## Inherited

sub add_our_name ($;%) {
  my $ua = shift;
  my %o = @_;  my %option = %{ $ua->{option} };
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  
  if ($Message::Entity::VERSION) {
    $ua->replace_rcs ($option{date}, name => 'Message-pm', 
                      version => $Message::Entity::VERSION, 
                      -prepend => 0);
  }
    my (@os, @os_comment);
    my @perl_comment;
    if ($option{use_Config}) {
      @os_comment = ('');
      @os = ($^O => \@os_comment);
      eval q{use Config;
        @os_comment = ($Config{osvers});
        push @perl_comment, $Config{archname};
      };
      eval q{use Win32;
        my $build = Win32::BuildNumber;
        push @perl_comment, "ActivePerl build $build" if $build;
        my @osv = Win32::GetOSVersion;
        @os = (
            $osv[4] == 0? 'Win32s':
            $osv[4] == 1? 'Windows':
            $osv[4] == 2? 'WindowsNT':
                          'Win32',       \@os_comment);
        @os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
        push @os_comment, $osv[0] if $osv[0] =~ /[^\x09\x20]/;
        if ($osv[4] == 1) {
          if ($osv[1] == 4) {
            if ($osv[2] == 0) {
              if    ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 95 OSR1' }
              elsif ($osv[0] =~ /[Bb]/) { push @os_comment, 'Windows 95 OSR2' }
              elsif ($osv[0] =~ /[Cc]/) { push @os_comment, 'Windows 95 OSR2.5' }
              else                      { push @os_comment, 'Windows 95' }
            } elsif ($osv[2] == 10) {
              if    ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 98 SE' }
              else                      { push @os_comment, 'Windows 98' }
            } elsif ($osv[2] == 90) {
              push @os_comment, 'Windows Me';
            }
          }
        } elsif ($osv[4] == 2) {
          push @os_comment, 'Windows 2000' if $osv[1] == 5 && $osv[2] == 0;
          push @os_comment, 'Windows XP' if $osv[1] == 5 && $osv[2] == 1;
        }
        push @os_comment, Win32::GetChipName;
      } if $option{use_Win32};
      undef $@;
    } else {
      push @perl_comment, $^O;
    }
    if ($^V) {  ## 5.6 or later
      $ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
    } elsif ($]) {      ## Before 5.005
      $ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
    }
    $ua->replace (@os, -prepend => 0) if $option{use_Config};
  $ua;
}

sub add_rcs ($$;%) {
  my $self = shift;
  my ($rcsid, %option) = @_;
  my ($name, $version, $date) = ($option{name}, $option{version}, $option{date});
  for (grep {/^[^-]/} keys %option) { delete $option{$_} }
  if ($rcsid =~ m!(?:Id|Header): (?:.+?/)?([^/]+?),v ([\d.]+) (\d+/\d+/\d+ \d+:\d+:\d+)!) {
    $name ||= $1;
    $version ||= $2;
    $date ||= $3;
  } elsif ($rcsid =~ m!^Date: (\d+/\d+/\d+ \d+:\d+:\d+)!) {
    $date ||= $1;
  } elsif ($rcsid =~ m!^Revision: ([\d.]+)!) {
    $version ||= $1;
  } elsif ($rcsid =~ m!(?:Source|RCSfile): (?:.+?/)?([^/]+?),v!) {
    $name ||= $1;
  }
  if ($option{is_replace}) {
    $self->replace ($name => [$version, $date], %option);
  } else {
    $self->add ($name => [$version, $date], %option);
  }
}
sub replace_rcs ($$;%) {
  shift->add_rcs (@_, is_replace => 1);
}

=back

=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>.
$Date: 2002/07/28 00:30:49 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.4	Message::Field::UA -- Perl module for Internet message
5			header field body consist of C<product> tokens
6	wakaba	1.1
7			=cut
8
9	wakaba	1.12	require 5.6.0;
10	wakaba	1.1	package Message::Field::UA;
11			use strict;
12	wakaba	1.12	use re 'eval';
13			use vars qw(%DEFAULT @ISA %REG $VERSION);
14			$VERSION=do{my @r=(q$Revision: 1.11 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.4	require Message::Field::Structured;
16			push @ISA, qw(Message::Field::Structured);
17	wakaba	1.12	use overload '.=' => sub {
18	wakaba	1.5	if (ref $_[1] eq 'HASH') {
19			$_[0]->add (%{$_[1]});
20			} elsif (ref $_[1] eq 'ARRAY') {
21			$_[0]->add (@{$_[1]});
22			} else {
23			$_[0]->add ($_[1] => '', -prepend => 0);
24			}
25			$_[0];
26			},
27			fallback => 1;
28	wakaba	1.1
29	wakaba	1.12	*REG = \%Message::Util::REG;
30
31			## 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	wakaba	1.4
51			=head1 CONSTRUCTORS
52
53	wakaba	1.5	The following methods construct new objects:
54	wakaba	1.1
55	wakaba	1.4	=over 4
56	wakaba	1.1
57	wakaba	1.4	=cut
58	wakaba	1.1
59	wakaba	1.4	## Initialize of this class -- called by constructors
60			sub _init ($;%) {
61			my $self = shift;
62			my %options = @_;
63			$self->SUPER::_init (%DEFAULT, %options);
64	wakaba	1.12
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	wakaba	1.5	my @a = ();
74			for (grep {/^[^-]/} keys %options) {
75			push @a, $_ => $options{$_};
76			}
77			$self->add (@a) if $#a > -1;
78	wakaba	1.4	}
79	wakaba	1.1
80	wakaba	1.5	=item $ua = Message::Field::UA->new ([%options])
81	wakaba	1.1
82	wakaba	1.4	Constructs a new C<Message::Field::UA> object. You might pass some
83			options as parameters to the constructor.
84	wakaba	1.1
85			=cut
86
87	wakaba	1.4	## Inherited
88	wakaba	1.1
89	wakaba	1.5	=item $ua = Message::Field::UA->parse ($field-body, [%options])
90	wakaba	1.1
91	wakaba	1.4	Constructs a new C<Message::Field::UA> object with
92			given field body. You might pass some options as parameters to the constructor.
93	wakaba	1.1
94			=cut
95
96			sub parse ($$;%) {
97			my $class = shift;
98	wakaba	1.4	my $self = bless {}, $class;
99	wakaba	1.1	my $field_body = shift; my @ua = ();
100	wakaba	1.4	$self->_init (@_);
101	wakaba	1.1	$field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
102			my $comments = $1;
103			$comments =~ s{$REG{M_comment}}{
104	wakaba	1.4	my $comment = $self->Message::Util::decode_ccontent ($1);
105	wakaba	1.1	push @ua, {comment => [$comment]} if $comment;
106			}goex;
107	wakaba	1.2	'';
108	wakaba	1.1	}goex;
109	wakaba	1.12	$field_body =~ s{
110			($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	wakaba	1.1	for ($product, $product_version) {
121	wakaba	1.4	my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0);
122	wakaba	1.1	my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
123			type => ($q?'token/quoted':'token')); ## What token/quoted is? :-)
124			$_ = $s{value};
125			}
126			my @comment = ();
127			$comments =~ s{$REG{M_comment}}{
128	wakaba	1.4	my $comment = $self->Message::Util::decode_ccontent ($1);
129	wakaba	1.1	push @comment, $comment if $comment;
130			}goex;
131	wakaba	1.4	push @ua, {name => $product, version => $product_version,
132	wakaba	1.1	comment => \@comment};
133			}goex;
134	wakaba	1.5	push @{$self->{product}}, @ua;
135	wakaba	1.1	$self;
136			}
137
138	wakaba	1.4	=back
139
140			=head1 METHODS
141
142			=over 4
143
144			=cut
145	wakaba	1.1
146
147	wakaba	1.4	=item $hdr->add ($name, $version, [$name, $version, ...])
148
149			Adds some field name/version pairs. Even if there are
150			one or more C<product>s whose name is same as C<$name>
151			(case sensible), given name/body pairs are ADDed. Use C<replace>
152			to remove C<old> one.
153
154			Instead of C<$version>, you can pass array reference.
155			[0] is used for C<version>, the others are saved as elements
156			of C<comment>.
157
158			C<-prepend> options is available. C<1> is default.
159
160			Example:
161
162			$ua->add (Perl => [$^V, $^O], 'foo.pl' => $VERSION, -prepend => 0);
163			print $ua; # foo.pl/1.00 Perl/5.6.1 (MSWin32)
164
165			=cut
166
167	wakaba	1.12	sub _add_hash_check ($$$\%) {
168	wakaba	1.1	my $self = shift;
169	wakaba	1.12	my ($name, $version, $option) = @_;
170			my @comment;
171			if (ref $version eq 'ARRAY') {
172			($version, @comment) = @$version;
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	wakaba	1.1	}
181	wakaba	1.12
182			(1, $name => {
183			name => $name,
184			version => $version,
185			comment => \@comment,
186			});
187	wakaba	1.1	}
188
189	wakaba	1.12	*_add_return_value = \&_replace_return_value;
190	wakaba	1.4
191	wakaba	1.12	## (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	wakaba	1.4
195
196	wakaba	1.12	## $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	wakaba	1.4
209	wakaba	1.12	## $value = $self->_replace_return_value (\$item, \%option)
210			## -- Returns returning value of replace method
211			sub _replace_return_value ($\$\%) {
212			my $self = shift;
213			my ($item, $value) = @_;
214			$$item;
215			}
216	wakaba	1.4
217	wakaba	1.12	## 1/0 = $self->_delete_match ($by, \$item, \%delete_list, \%option)
218			## -- Checks and returns whether given item is matched with
219			## deleting item list
220			sub _delete_match ($$\$\%\%) {
221	wakaba	1.1	my $self = shift;
222	wakaba	1.12	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	wakaba	1.4	}
229	wakaba	1.12	0;
230			}
231
232			## 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			*_item_match = \&_delete_match;
240			*_item_return_value = \&_replace_return_value;
241
242			## $item = $self->_item_new_value ($name, \%option)
243			## -- Returns new item with key of $name (called when
244			## no returned value is found and -new_value_unless_exist
245			## option is true)
246			sub _item_new_value ($$\%) {
247			my $self = shift;
248			my ($key, $option) = @_;
249			if ($option->{by} eq 'name') {
250			return {name => $key, version => '', comment => []};
251			} elsif ($option->{by} eq 'version') {
252			return {name => '', version => $key, comment => []};
253	wakaba	1.4	}
254	wakaba	1.12	undef;
255	wakaba	1.4	}
256
257	wakaba	1.12	## TODO: Implement count,item_exist method
258
259			=item $self->stringify ()
260	wakaba	1.4
261	wakaba	1.12	Returns C<field-body> as a string.
262	wakaba	1.4
263			=cut
264
265	wakaba	1.12	sub stringify ($;%) {
266	wakaba	1.4	my $self = shift;
267	wakaba	1.12	my %o = @_; my %option = %{$self->{option}};
268			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
269			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	wakaba	1.1	}
307	wakaba	1.12	join ' ', @r;
308	wakaba	1.1	}
309	wakaba	1.12	*as_string = \&stringify;
310	wakaba	1.1
311	wakaba	1.4	=item $option-value = $ua->option ($option-name)
312
313			Gets option value.
314
315			=item $ua->option ($option-name, $option-value, ...)
316
317			Set option value(s). You can pass multiple option name-value pair
318			as parameter when setting.
319
320			=cut
321
322			## Inherited
323
324			=item $clone = $ua->clone ()
325
326			Returns a copy of the object.
327
328			=cut
329
330	wakaba	1.12	## Inherited
331	wakaba	1.1
332	wakaba	1.6	sub add_our_name ($;%) {
333			my $ua = shift;
334	wakaba	1.11	my %o = @_; my %option = %{ $ua->{option} };
335	wakaba	1.6	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
336	wakaba	1.9
337	wakaba	1.11	if ($Message::Entity::VERSION) {
338			$ua->replace_rcs ($option{date}, name => 'Message-pm',
339			version => $Message::Entity::VERSION,
340			-prepend => 0);
341			}
342	wakaba	1.6	my (@os, @os_comment);
343			my @perl_comment;
344			if ($option{use_Config}) {
345			@os_comment = ('');
346			@os = ($^O => \@os_comment);
347			eval q{use Config;
348			@os_comment = ($Config{osvers});
349			push @perl_comment, $Config{archname};
350			};
351			eval q{use Win32;
352			my $build = Win32::BuildNumber;
353			push @perl_comment, "ActivePerl build $build" if $build;
354			my @osv = Win32::GetOSVersion;
355			@os = (
356			$osv[4] == 0? 'Win32s':
357			$osv[4] == 1? 'Windows':
358			$osv[4] == 2? 'WindowsNT':
359			'Win32', \@os_comment);
360			@os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
361			push @os_comment, $osv[0] if $osv[0] =~ /[^\x09\x20]/;
362			if ($osv[4] == 1) {
363			if ($osv[1] == 4) {
364			if ($osv[2] == 0) {
365			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 95 OSR1' }
366			elsif ($osv[0] =~ /[Bb]/) { push @os_comment, 'Windows 95 OSR2' }
367			elsif ($osv[0] =~ /[Cc]/) { push @os_comment, 'Windows 95 OSR2.5' }
368			else { push @os_comment, 'Windows 95' }
369			} elsif ($osv[2] == 10) {
370			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 98 SE' }
371			else { push @os_comment, 'Windows 98' }
372			} elsif ($osv[2] == 90) {
373			push @os_comment, 'Windows Me';
374			}
375			}
376			} elsif ($osv[4] == 2) {
377			push @os_comment, 'Windows 2000' if $osv[1] == 5 && $osv[2] == 0;
378			push @os_comment, 'Windows XP' if $osv[1] == 5 && $osv[2] == 1;
379			}
380			push @os_comment, Win32::GetChipName;
381			} if $option{use_Win32};
382	wakaba	1.10	undef $@;
383	wakaba	1.6	} else {
384			push @perl_comment, $^O;
385			}
386			if ($^V) { ## 5.6 or later
387			$ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
388			} elsif ($]) { ## Before 5.005
389			$ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
390			}
391			$ua->replace (@os, -prepend => 0) if $option{use_Config};
392			$ua;
393			}
394
395	wakaba	1.11	sub add_rcs ($$;%) {
396			my $self = shift;
397			my ($rcsid, %option) = @_;
398			my ($name, $version, $date) = ($option{name}, $option{version}, $option{date});
399			for (grep {/^[^-]/} keys %option) { delete $option{$_} }
400			if ($rcsid =~ m!(?:Id\|Header): (?:.+?/)?([^/]+?),v ([\d.]+) (\d+/\d+/\d+ \d+:\d+:\d+)!) {
401			$name \|\|= $1;
402			$version \|\|= $2;
403			$date \|\|= $3;
404			} elsif ($rcsid =~ m!^Date: (\d+/\d+/\d+ \d+:\d+:\d+)!) {
405			$date \|\|= $1;
406			} elsif ($rcsid =~ m!^Revision: ([\d.]+)!) {
407			$version \|\|= $1;
408			} elsif ($rcsid =~ m!(?:Source\|RCSfile): (?:.+?/)?([^/]+?),v!) {
409			$name \|\|= $1;
410			}
411			if ($option{is_replace}) {
412			$self->replace ($name => [$version, $date], %option);
413			} else {
414			$self->add ($name => [$version, $date], %option);
415			}
416			}
417			sub replace_rcs ($$;%) {
418			shift->add_rcs (@_, is_replace => 1);
419			}
420
421	wakaba	1.4	=back
422	wakaba	1.1
423			=head1 LICENSE
424
425			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
426
427			This program is free software; you can redistribute it and/or modify
428			it under the terms of the GNU General Public License as published by
429			the Free Software Foundation; either version 2 of the License, or
430			(at your option) any later version.
431
432			This program is distributed in the hope that it will be useful,
433			but WITHOUT ANY WARRANTY; without even the implied warranty of
434			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
435			GNU General Public License for more details.
436
437			You should have received a copy of the GNU General Public License
438			along with this program; see the file COPYING. If not, write to
439			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
440			Boston, MA 02111-1307, USA.
441
442			=head1 CHANGE
443
444			See F<ChangeLog>.
445	wakaba	1.12	$Date: 2002/07/28 00:30:49 $
446	wakaba	1.1
447			=cut
448
449			1;