Message/Field/UA.pm


=head1 NAME

Message::Field::UA --- Message-pm: User-Agent header fields

=head1 DESCRIPTION

This module provides interface to User-Agent: and other header fields
which have product-name/product-version pair.

This module is part of Message::* Perl Modules.

=cut

package Message::Field::UA;
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.13 $=~/\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,
    -use_Win32_API      => 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 (@_);
  use re 'eval';
  $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);
  }
  
  ## Perl version and architecture
    my @perl_comment;
    eval q{use Config; push @perl_comment, $Config{archname}} if $option{use_Config};
    eval q{require Win32; my $build; $build = &Win32::BuildNumber ();
      push @perl_comment, "ActivePerl build $build" if $build;
    } if $option{use_Win32};
    undef $@;
    
    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);
    }
    $option{prepend} = 0;
    $ua->replace_system_version ('os', \%option);
  $ua;
}

sub replace_system_version ($$;%) {
  my $ua = shift;
  my $type = shift;
  my %option;
  if (ref $_[0]) {
    %option = %{$_[0]};
  } else {
    my %o = @_;  %option = %{ $ua->{option} };
    for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  }
  
  if ($type eq 'os') {
    my @os_comment = ('');
    my @os = ($^O => \@os_comment);
    eval q{use Config; @os_comment = ($Config{osvers})} if $option{use_Config};
    eval q{require Win32;
        my @osv = &Win32::GetOSVersion ();
        @os = (
            $osv[4] == 0? 'Win32s':
            $osv[4] == 1? 'Windows':
            $osv[4] == 2? 'Windows NT':
                          'Win32',       \@os_comment);
        @os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
        push @os_comment, $osv[0] if $osv[0] =~ /[^\x00\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 $@;
    $ua->replace (@os, -prepend => $option{prepend});
  } elsif ('ie') {      ## Internet Explorer
    my $flag = 0;
    eval q{use Win32::Registry;
      my $ie;
      $::HKEY_LOCAL_MACHINE->Open('SOFTWARE\Microsoft\Internet Explorer', $ie) or die $^E;
      my ($type, $value);
      $ie->QueryValueEx (Version => $type, $value) or die $^E;
      die unless $value;
      $ua->replace (MSIE => $value, -prepend => $option{prepend});
      $flag = 1;
    } or Carp::carp ($@) if !$flag;
    eval q{require Win32::API;
      my $GV = new Win32::API (shlwapi => "DllGetVersion", P => 'N');
      my $ver = pack lllll => 4*5, 0, 0, 0, 0;
      $GV->Call ($ver);
      my (undef, $major, $minor, $build) = unpack lllll => $ver;
      $ua->replace (MSIE => sprintf ("%d.%02d.%04d", $major, $minor, $build),
        -prepend => $option{prepend});
      $flag = 1;
    } if $option{use_Win32_API} && !$flag;
  }
  $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 <w@suika.fam.cx>

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.

=cut

1; # $Date: $
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.14	Message::Field::UA --- Message-pm: User-Agent header fields
5
6			=head1 DESCRIPTION
7
8			This module provides interface to User-Agent: and other header fields
9			which have product-name/product-version pair.
10
11			This module is part of Message::* Perl Modules.
12	wakaba	1.1
13			=cut
14
15			package Message::Field::UA;
16			use strict;
17	wakaba	1.12	use vars qw(%DEFAULT @ISA %REG $VERSION);
18	wakaba	1.14	$VERSION=do{my @r=(q$Revision: 1.13 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19	wakaba	1.4	require Message::Field::Structured;
20			push @ISA, qw(Message::Field::Structured);
21	wakaba	1.12	use overload '.=' => sub {
22	wakaba	1.5	if (ref $_[1] eq 'HASH') {
23			$_[0]->add (%{$_[1]});
24			} elsif (ref $_[1] eq 'ARRAY') {
25			$_[0]->add (@{$_[1]});
26			} else {
27			$_[0]->add ($_[1] => '', -prepend => 0);
28			}
29			$_[0];
30			},
31			fallback => 1;
32	wakaba	1.1
33	wakaba	1.12	*REG = \%Message::Util::REG;
34
35			## Initialize of this class -- called by constructors
36			%DEFAULT = (
37			-_HASH_NAME => 'product',
38			-_METHODS => [qw\|add count delete item\|],
39			-_MEMBERS => [qw\|product\|],
40			-by => 'product-name', ## Default key for item, delete,...
41			#encoding_after_encode
42			#encoding_before_decode
43			#field_param_name
44			#field_name
45			#format
46			#hook_encode_string
47			#hook_decode_string
48			-prepend => 1, ## For add, replace
49			-use_Config => 1,
50			-use_comment => 1,
51			#-use_quoted_string => 1,
52			-use_Win32 => 1,
53	wakaba	1.13	-use_Win32_API => 1,
54	wakaba	1.12	);
55	wakaba	1.4
56			=head1 CONSTRUCTORS
57
58	wakaba	1.5	The following methods construct new objects:
59	wakaba	1.1
60	wakaba	1.4	=over 4
61	wakaba	1.1
62	wakaba	1.4	=cut
63	wakaba	1.1
64	wakaba	1.4	## Initialize of this class -- called by constructors
65			sub _init ($;%) {
66			my $self = shift;
67			my %options = @_;
68			$self->SUPER::_init (%DEFAULT, %options);
69	wakaba	1.12
70			unless (defined $self->{option}->{use_quoted_string}) {
71			if ($self->{option}->{format} =~ /http/) {
72			$self->{option}->{use_quoted_string} = 0;
73			} else {
74			$self->{option}->{use_quoted_string} = 1;
75			}
76			}
77
78	wakaba	1.5	my @a = ();
79			for (grep {/^[^-]/} keys %options) {
80			push @a, $_ => $options{$_};
81			}
82			$self->add (@a) if $#a > -1;
83	wakaba	1.4	}
84	wakaba	1.1
85	wakaba	1.5	=item $ua = Message::Field::UA->new ([%options])
86	wakaba	1.1
87	wakaba	1.4	Constructs a new C<Message::Field::UA> object. You might pass some
88			options as parameters to the constructor.
89	wakaba	1.1
90			=cut
91
92	wakaba	1.4	## Inherited
93	wakaba	1.1
94	wakaba	1.5	=item $ua = Message::Field::UA->parse ($field-body, [%options])
95	wakaba	1.1
96	wakaba	1.4	Constructs a new C<Message::Field::UA> object with
97			given field body. You might pass some options as parameters to the constructor.
98	wakaba	1.1
99			=cut
100
101			sub parse ($$;%) {
102			my $class = shift;
103	wakaba	1.4	my $self = bless {}, $class;
104	wakaba	1.1	my $field_body = shift; my @ua = ();
105	wakaba	1.4	$self->_init (@_);
106	wakaba	1.13	use re 'eval';
107	wakaba	1.1	$field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
108			my $comments = $1;
109			$comments =~ s{$REG{M_comment}}{
110	wakaba	1.4	my $comment = $self->Message::Util::decode_ccontent ($1);
111	wakaba	1.1	push @ua, {comment => [$comment]} if $comment;
112			}goex;
113	wakaba	1.2	'';
114	wakaba	1.1	}goex;
115	wakaba	1.12	$field_body =~ s{
116			($REG{quoted_string}\|[^\x09\x20\x22\x28\x2F]+) ## product-name
117			(?:
118			((?:$REG{FWS}$REG{comment})*)$REG{FWS}
119			/
120			((?:$REG{FWS}$REG{comment})*)$REG{FWS}
121			($REG{quoted_string}\|[^\x09\x20\x22\x28]+) ## product-version
122			)?
123			((?:$REG{FWS}$REG{comment})*) ## comment
124			}{
125			my ($product, $product_version, $comments) = ($1, $4, $2.$3.$5);
126	wakaba	1.1	for ($product, $product_version) {
127	wakaba	1.4	my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0);
128	wakaba	1.1	my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
129			type => ($q?'token/quoted':'token')); ## What token/quoted is? :-)
130			$_ = $s{value};
131			}
132			my @comment = ();
133			$comments =~ s{$REG{M_comment}}{
134	wakaba	1.4	my $comment = $self->Message::Util::decode_ccontent ($1);
135	wakaba	1.1	push @comment, $comment if $comment;
136			}goex;
137	wakaba	1.4	push @ua, {name => $product, version => $product_version,
138	wakaba	1.1	comment => \@comment};
139			}goex;
140	wakaba	1.5	push @{$self->{product}}, @ua;
141	wakaba	1.1	$self;
142			}
143
144	wakaba	1.4	=back
145
146			=head1 METHODS
147
148			=over 4
149
150			=cut
151	wakaba	1.1
152
153	wakaba	1.4	=item $hdr->add ($name, $version, [$name, $version, ...])
154
155			Adds some field name/version pairs. Even if there are
156			one or more C<product>s whose name is same as C<$name>
157			(case sensible), given name/body pairs are ADDed. Use C<replace>
158			to remove C<old> one.
159
160			Instead of C<$version>, you can pass array reference.
161			[0] is used for C<version>, the others are saved as elements
162			of C<comment>.
163
164			C<-prepend> options is available. C<1> is default.
165
166			Example:
167
168			$ua->add (Perl => [$^V, $^O], 'foo.pl' => $VERSION, -prepend => 0);
169			print $ua; # foo.pl/1.00 Perl/5.6.1 (MSWin32)
170
171			=cut
172
173	wakaba	1.12	sub _add_hash_check ($$$\%) {
174	wakaba	1.1	my $self = shift;
175	wakaba	1.12	my ($name, $version, $option) = @_;
176			my @comment;
177			if (ref $version eq 'ARRAY') {
178			($version, @comment) = @$version;
179			}
180
181			## Convert vX.Y.Z value to string (But there is no way to be sure that
182			## the value is a version value.)
183			#$^V gt v5.6.0 && ## <- This check itself doesn't work before v5.6.0:)
184			if ($version =~ /[\x00-\x1F]/) {
185			$version = sprintf '%vd', $version;
186	wakaba	1.1	}
187	wakaba	1.12
188			(1, $name => {
189			name => $name,
190			version => $version,
191			comment => \@comment,
192			});
193	wakaba	1.1	}
194
195	wakaba	1.12	*_add_return_value = \&_replace_return_value;
196	wakaba	1.4
197	wakaba	1.12	## (1/0, $name => $value) = $self->_replace_hash_check ($name => $value, \%option)
198			## -- Checks given value and prepares saving value (hash version)
199			*_replace_hash_check = \&_add_hash_check;
200	wakaba	1.4
201
202	wakaba	1.12	## $value = $self->_replace_hash_shift (\%values, $name, $option)
203			## -- Returns a value (from %values) and deletes it from %values
204			## (like CORE::shift for array).
205			sub _replace_hash_shift ($\%$\%) {
206			shift; my $r = shift; my $n = $_[0]->{name};
207			if ($$r{$n}) {
208			my $d = $$r{$n};
209			$$r{$n} = undef;
210			return $d;
211			}
212			undef;
213			}
214	wakaba	1.4
215	wakaba	1.12	## $value = $self->_replace_return_value (\$item, \%option)
216			## -- Returns returning value of replace method
217			sub _replace_return_value ($\$\%) {
218			my $self = shift;
219			my ($item, $value) = @_;
220			$$item;
221			}
222	wakaba	1.4
223	wakaba	1.12	## 1/0 = $self->_delete_match ($by, \$item, \%delete_list, \%option)
224			## -- Checks and returns whether given item is matched with
225			## deleting item list
226			sub _delete_match ($$\$\%\%) {
227	wakaba	1.1	my $self = shift;
228	wakaba	1.12	my ($by, $item, $list, $option) = @_;
229			return 0 unless ref $$item; ## Already removed
230			if ($by eq 'name') {
231			return 1 if $$list{ $$item->{name} };
232			} elsif ($by eq 'version') {
233			return 1 if $$list{ $$item->{version} };
234	wakaba	1.4	}
235	wakaba	1.12	0;
236			}
237
238			## Delete empty items
239			sub _delete_empty ($) {
240			my $self = shift;
241			my $array = $self->{option}->{_HASH_NAME};
242			$self->{ $array } = [grep { ref $_ } @{$self->{ $array }}] if $array;
243			}
244
245			*_item_match = \&_delete_match;
246			*_item_return_value = \&_replace_return_value;
247
248			## $item = $self->_item_new_value ($name, \%option)
249			## -- Returns new item with key of $name (called when
250			## no returned value is found and -new_value_unless_exist
251			## option is true)
252			sub _item_new_value ($$\%) {
253			my $self = shift;
254			my ($key, $option) = @_;
255			if ($option->{by} eq 'name') {
256			return {name => $key, version => '', comment => []};
257			} elsif ($option->{by} eq 'version') {
258			return {name => '', version => $key, comment => []};
259	wakaba	1.4	}
260	wakaba	1.12	undef;
261	wakaba	1.4	}
262
263	wakaba	1.12	## TODO: Implement count,item_exist method
264
265			=item $self->stringify ()
266	wakaba	1.4
267	wakaba	1.12	Returns C<field-body> as a string.
268	wakaba	1.4
269			=cut
270
271	wakaba	1.12	sub stringify ($;%) {
272	wakaba	1.4	my $self = shift;
273	wakaba	1.12	my %o = @_; my %option = %{$self->{option}};
274			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
275			my @r = ();
276			for my $p (@{$self->{product}}) {
277			if (length $p->{name}) {
278			my %name = &{$self->{option}->{hook_encode_string}} ($self,
279			$p->{name}, type => 'token');
280			my %version = &{$self->{option}->{hook_encode_string}} ($self,
281			$p->{version}, type => 'token');
282			if (!$option{use_quoted_string}
283			&& ( $name{value} =~ /$REG{NON_http_token}/
284			\|\| $version{value} =~ /$REG{NON_http_token}/)) {
285			if ($name{value} =~ /$REG{NON_http_token}/) {
286			## Both of name & version are unsafe
287			push @r, '(' . Message::Util::quote_ccontent (
288			$name{value} .
289			(length $version{value}? '/' . $version{value} : '')
290			) . ')';
291			} else {
292			## Only version is unsafe
293			push @r, $name{value}
294			.' (' . Message::Util::quote_ccontent ($version{value}) . ')';
295			}
296			} else {
297			push @r,
298			Message::Util::quote_unsafe_string
299			($name{value}, unsafe => 'NON_http_token')
300			.(length $version{value} ?
301			'/' . Message::Util::quote_unsafe_string
302			($version{value}, unsafe => 'NON_http_token') : '');
303			}
304			} elsif ($p->{version}) {
305			## There is no product-name but the product-version. It's error!
306			push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';
307			}
308			## If there are some additional information,
309			for (@{$p->{comment}}) {
310			push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;
311			}
312	wakaba	1.1	}
313	wakaba	1.12	join ' ', @r;
314	wakaba	1.1	}
315	wakaba	1.12	*as_string = \&stringify;
316	wakaba	1.1
317	wakaba	1.4	=item $option-value = $ua->option ($option-name)
318
319			Gets option value.
320
321			=item $ua->option ($option-name, $option-value, ...)
322
323			Set option value(s). You can pass multiple option name-value pair
324			as parameter when setting.
325
326			=cut
327
328			## Inherited
329
330			=item $clone = $ua->clone ()
331
332			Returns a copy of the object.
333
334			=cut
335
336	wakaba	1.12	## Inherited
337	wakaba	1.1
338	wakaba	1.6	sub add_our_name ($;%) {
339			my $ua = shift;
340	wakaba	1.11	my %o = @_; my %option = %{ $ua->{option} };
341	wakaba	1.6	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
342	wakaba	1.9
343	wakaba	1.11	if ($Message::Entity::VERSION) {
344			$ua->replace_rcs ($option{date}, name => 'Message-pm',
345			version => $Message::Entity::VERSION,
346			-prepend => 0);
347			}
348	wakaba	1.13
349			## Perl version and architecture
350	wakaba	1.6	my @perl_comment;
351	wakaba	1.13	eval q{use Config; push @perl_comment, $Config{archname}} if $option{use_Config};
352			eval q{require Win32; my $build; $build = &Win32::BuildNumber ();
353			push @perl_comment, "ActivePerl build $build" if $build;
354			} if $option{use_Win32};
355			undef $@;
356
357			if ($^V) { ## 5.6 or later
358			$ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
359			} elsif ($]) { ## Before 5.005
360			$ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
361			}
362			$option{prepend} = 0;
363			$ua->replace_system_version ('os', \%option);
364			$ua;
365			}
366
367			sub replace_system_version ($$;%) {
368			my $ua = shift;
369			my $type = shift;
370			my %option;
371			if (ref $_[0]) {
372			%option = %{$_[0]};
373			} else {
374			my %o = @_; %option = %{ $ua->{option} };
375			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
376			}
377
378			if ($type eq 'os') {
379			my @os_comment = ('');
380			my @os = ($^O => \@os_comment);
381			eval q{use Config; @os_comment = ($Config{osvers})} if $option{use_Config};
382			eval q{require Win32;
383			my @osv = &Win32::GetOSVersion ();
384	wakaba	1.6	@os = (
385			$osv[4] == 0? 'Win32s':
386			$osv[4] == 1? 'Windows':
387	wakaba	1.14	$osv[4] == 2? 'Windows NT':
388	wakaba	1.6	'Win32', \@os_comment);
389			@os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
390	wakaba	1.13	push @os_comment, $osv[0] if $osv[0] =~ /[^\x00\x09\x20]/;
391	wakaba	1.6	if ($osv[4] == 1) {
392			if ($osv[1] == 4) {
393			if ($osv[2] == 0) {
394			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 95 OSR1' }
395			elsif ($osv[0] =~ /[Bb]/) { push @os_comment, 'Windows 95 OSR2' }
396			elsif ($osv[0] =~ /[Cc]/) { push @os_comment, 'Windows 95 OSR2.5' }
397			else { push @os_comment, 'Windows 95' }
398			} elsif ($osv[2] == 10) {
399			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 98 SE' }
400			else { push @os_comment, 'Windows 98' }
401			} elsif ($osv[2] == 90) {
402			push @os_comment, 'Windows Me';
403			}
404			}
405			} elsif ($osv[4] == 2) {
406			push @os_comment, 'Windows 2000' if $osv[1] == 5 && $osv[2] == 0;
407			push @os_comment, 'Windows XP' if $osv[1] == 5 && $osv[2] == 1;
408			}
409	wakaba	1.13	push @os_comment, &Win32::GetChipName ();
410			} if $option{use_Win32};
411			undef $@;
412			$ua->replace (@os, -prepend => $option{prepend});
413			} elsif ('ie') { ## Internet Explorer
414			my $flag = 0;
415			eval q{use Win32::Registry;
416			my $ie;
417			$::HKEY_LOCAL_MACHINE->Open('SOFTWARE\Microsoft\Internet Explorer', $ie) or die $^E;
418			my ($type, $value);
419			$ie->QueryValueEx (Version => $type, $value) or die $^E;
420			die unless $value;
421			$ua->replace (MSIE => $value, -prepend => $option{prepend});
422			$flag = 1;
423			} or Carp::carp ($@) if !$flag;
424			eval q{require Win32::API;
425			my $GV = new Win32::API (shlwapi => "DllGetVersion", P => 'N');
426			my $ver = pack lllll => 4*5, 0, 0, 0, 0;
427			$GV->Call ($ver);
428			my (undef, $major, $minor, $build) = unpack lllll => $ver;
429			$ua->replace (MSIE => sprintf ("%d.%02d.%04d", $major, $minor, $build),
430			-prepend => $option{prepend});
431			$flag = 1;
432			} if $option{use_Win32_API} && !$flag;
433			}
434	wakaba	1.6	$ua;
435			}
436
437	wakaba	1.11	sub add_rcs ($$;%) {
438			my $self = shift;
439			my ($rcsid, %option) = @_;
440			my ($name, $version, $date) = ($option{name}, $option{version}, $option{date});
441			for (grep {/^[^-]/} keys %option) { delete $option{$_} }
442			if ($rcsid =~ m!(?:Id\|Header): (?:.+?/)?([^/]+?),v ([\d.]+) (\d+/\d+/\d+ \d+:\d+:\d+)!) {
443			$name \|\|= $1;
444			$version \|\|= $2;
445			$date \|\|= $3;
446			} elsif ($rcsid =~ m!^Date: (\d+/\d+/\d+ \d+:\d+:\d+)!) {
447			$date \|\|= $1;
448			} elsif ($rcsid =~ m!^Revision: ([\d.]+)!) {
449			$version \|\|= $1;
450			} elsif ($rcsid =~ m!(?:Source\|RCSfile): (?:.+?/)?([^/]+?),v!) {
451			$name \|\|= $1;
452			}
453			if ($option{is_replace}) {
454			$self->replace ($name => [$version, $date], %option);
455			} else {
456			$self->add ($name => [$version, $date], %option);
457			}
458			}
459			sub replace_rcs ($$;%) {
460			shift->add_rcs (@_, is_replace => 1);
461			}
462
463	wakaba	1.4	=back
464	wakaba	1.1
465			=head1 LICENSE
466
467	wakaba	1.14	Copyright 2002 Wakaba <w@suika.fam.cx>
468	wakaba	1.1
469			This program is free software; you can redistribute it and/or modify
470			it under the terms of the GNU General Public License as published by
471			the Free Software Foundation; either version 2 of the License, or
472			(at your option) any later version.
473
474			This program is distributed in the hope that it will be useful,
475			but WITHOUT ANY WARRANTY; without even the implied warranty of
476			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
477			GNU General Public License for more details.
478
479			You should have received a copy of the GNU General Public License
480			along with this program; see the file COPYING. If not, write to
481			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
482			Boston, MA 02111-1307, USA.
483
484			=cut
485
486	wakaba	1.14	1; # $Date: $