Message/Field/UA.pm


=head1 NAME

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

=cut

package Message::Field::UA;
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.12 $=~/\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? 'WindowsNT':
                          '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 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/30 08:50:36 $

=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			package Message::Field::UA;
10			use strict;
11	wakaba	1.12	use vars qw(%DEFAULT @ISA %REG $VERSION);
12	wakaba	1.13	$VERSION=do{my @r=(q$Revision: 1.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.4	require Message::Field::Structured;
14			push @ISA, qw(Message::Field::Structured);
15	wakaba	1.12	use overload '.=' => sub {
16	wakaba	1.5	if (ref $_[1] eq 'HASH') {
17			$_[0]->add (%{$_[1]});
18			} elsif (ref $_[1] eq 'ARRAY') {
19			$_[0]->add (@{$_[1]});
20			} else {
21			$_[0]->add ($_[1] => '', -prepend => 0);
22			}
23			$_[0];
24			},
25			fallback => 1;
26	wakaba	1.1
27	wakaba	1.12	*REG = \%Message::Util::REG;
28
29			## Initialize of this class -- called by constructors
30			%DEFAULT = (
31			-_HASH_NAME => 'product',
32			-_METHODS => [qw\|add count delete item\|],
33			-_MEMBERS => [qw\|product\|],
34			-by => 'product-name', ## Default key for item, delete,...
35			#encoding_after_encode
36			#encoding_before_decode
37			#field_param_name
38			#field_name
39			#format
40			#hook_encode_string
41			#hook_decode_string
42			-prepend => 1, ## For add, replace
43			-use_Config => 1,
44			-use_comment => 1,
45			#-use_quoted_string => 1,
46			-use_Win32 => 1,
47	wakaba	1.13	-use_Win32_API => 1,
48	wakaba	1.12	);
49	wakaba	1.4
50			=head1 CONSTRUCTORS
51
52	wakaba	1.5	The following methods construct new objects:
53	wakaba	1.1
54	wakaba	1.4	=over 4
55	wakaba	1.1
56	wakaba	1.4	=cut
57	wakaba	1.1
58	wakaba	1.4	## Initialize of this class -- called by constructors
59			sub _init ($;%) {
60			my $self = shift;
61			my %options = @_;
62			$self->SUPER::_init (%DEFAULT, %options);
63	wakaba	1.12
64			unless (defined $self->{option}->{use_quoted_string}) {
65			if ($self->{option}->{format} =~ /http/) {
66			$self->{option}->{use_quoted_string} = 0;
67			} else {
68			$self->{option}->{use_quoted_string} = 1;
69			}
70			}
71
72	wakaba	1.5	my @a = ();
73			for (grep {/^[^-]/} keys %options) {
74			push @a, $_ => $options{$_};
75			}
76			$self->add (@a) if $#a > -1;
77	wakaba	1.4	}
78	wakaba	1.1
79	wakaba	1.5	=item $ua = Message::Field::UA->new ([%options])
80	wakaba	1.1
81	wakaba	1.4	Constructs a new C<Message::Field::UA> object. You might pass some
82			options as parameters to the constructor.
83	wakaba	1.1
84			=cut
85
86	wakaba	1.4	## Inherited
87	wakaba	1.1
88	wakaba	1.5	=item $ua = Message::Field::UA->parse ($field-body, [%options])
89	wakaba	1.1
90	wakaba	1.4	Constructs a new C<Message::Field::UA> object with
91			given field body. You might pass some options as parameters to the constructor.
92	wakaba	1.1
93			=cut
94
95			sub parse ($$;%) {
96			my $class = shift;
97	wakaba	1.4	my $self = bless {}, $class;
98	wakaba	1.1	my $field_body = shift; my @ua = ();
99	wakaba	1.4	$self->_init (@_);
100	wakaba	1.13	use re 'eval';
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.13
343			## Perl version and architecture
344	wakaba	1.6	my @perl_comment;
345	wakaba	1.13	eval q{use Config; push @perl_comment, $Config{archname}} if $option{use_Config};
346			eval q{require Win32; my $build; $build = &Win32::BuildNumber ();
347			push @perl_comment, "ActivePerl build $build" if $build;
348			} if $option{use_Win32};
349			undef $@;
350
351			if ($^V) { ## 5.6 or later
352			$ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
353			} elsif ($]) { ## Before 5.005
354			$ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
355			}
356			$option{prepend} = 0;
357			$ua->replace_system_version ('os', \%option);
358			$ua;
359			}
360
361			sub replace_system_version ($$;%) {
362			my $ua = shift;
363			my $type = shift;
364			my %option;
365			if (ref $_[0]) {
366			%option = %{$_[0]};
367			} else {
368			my %o = @_; %option = %{ $ua->{option} };
369			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
370			}
371
372			if ($type eq 'os') {
373			my @os_comment = ('');
374			my @os = ($^O => \@os_comment);
375			eval q{use Config; @os_comment = ($Config{osvers})} if $option{use_Config};
376			eval q{require Win32;
377			my @osv = &Win32::GetOSVersion ();
378	wakaba	1.6	@os = (
379			$osv[4] == 0? 'Win32s':
380			$osv[4] == 1? 'Windows':
381			$osv[4] == 2? 'WindowsNT':
382			'Win32', \@os_comment);
383			@os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
384	wakaba	1.13	push @os_comment, $osv[0] if $osv[0] =~ /[^\x00\x09\x20]/;
385	wakaba	1.6	if ($osv[4] == 1) {
386			if ($osv[1] == 4) {
387			if ($osv[2] == 0) {
388			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 95 OSR1' }
389			elsif ($osv[0] =~ /[Bb]/) { push @os_comment, 'Windows 95 OSR2' }
390			elsif ($osv[0] =~ /[Cc]/) { push @os_comment, 'Windows 95 OSR2.5' }
391			else { push @os_comment, 'Windows 95' }
392			} elsif ($osv[2] == 10) {
393			if ($osv[0] =~ /[Aa]/) { push @os_comment, 'Windows 98 SE' }
394			else { push @os_comment, 'Windows 98' }
395			} elsif ($osv[2] == 90) {
396			push @os_comment, 'Windows Me';
397			}
398			}
399			} elsif ($osv[4] == 2) {
400			push @os_comment, 'Windows 2000' if $osv[1] == 5 && $osv[2] == 0;
401			push @os_comment, 'Windows XP' if $osv[1] == 5 && $osv[2] == 1;
402			}
403	wakaba	1.13	push @os_comment, &Win32::GetChipName ();
404			} if $option{use_Win32};
405			undef $@;
406			$ua->replace (@os, -prepend => $option{prepend});
407			} elsif ('ie') { ## Internet Explorer
408			my $flag = 0;
409			eval q{use Win32::Registry;
410			my $ie;
411			$::HKEY_LOCAL_MACHINE->Open('SOFTWARE\Microsoft\Internet Explorer', $ie) or die $^E;
412			my ($type, $value);
413			$ie->QueryValueEx (Version => $type, $value) or die $^E;
414			die unless $value;
415			$ua->replace (MSIE => $value, -prepend => $option{prepend});
416			$flag = 1;
417			} or Carp::carp ($@) if !$flag;
418			eval q{require Win32::API;
419			my $GV = new Win32::API (shlwapi => "DllGetVersion", P => 'N');
420			my $ver = pack lllll => 4*5, 0, 0, 0, 0;
421			$GV->Call ($ver);
422			my (undef, $major, $minor, $build) = unpack lllll => $ver;
423			$ua->replace (MSIE => sprintf ("%d.%02d.%04d", $major, $minor, $build),
424			-prepend => $option{prepend});
425			$flag = 1;
426			} if $option{use_Win32_API} && !$flag;
427			}
428	wakaba	1.6	$ua;
429			}
430
431	wakaba	1.11	sub add_rcs ($$;%) {
432			my $self = shift;
433			my ($rcsid, %option) = @_;
434			my ($name, $version, $date) = ($option{name}, $option{version}, $option{date});
435			for (grep {/^[^-]/} keys %option) { delete $option{$_} }
436			if ($rcsid =~ m!(?:Id\|Header): (?:.+?/)?([^/]+?),v ([\d.]+) (\d+/\d+/\d+ \d+:\d+:\d+)!) {
437			$name \|\|= $1;
438			$version \|\|= $2;
439			$date \|\|= $3;
440			} elsif ($rcsid =~ m!^Date: (\d+/\d+/\d+ \d+:\d+:\d+)!) {
441			$date \|\|= $1;
442			} elsif ($rcsid =~ m!^Revision: ([\d.]+)!) {
443			$version \|\|= $1;
444			} elsif ($rcsid =~ m!(?:Source\|RCSfile): (?:.+?/)?([^/]+?),v!) {
445			$name \|\|= $1;
446			}
447			if ($option{is_replace}) {
448			$self->replace ($name => [$version, $date], %option);
449			} else {
450			$self->add ($name => [$version, $date], %option);
451			}
452			}
453			sub replace_rcs ($$;%) {
454			shift->add_rcs (@_, is_replace => 1);
455			}
456
457	wakaba	1.4	=back
458	wakaba	1.1
459			=head1 LICENSE
460
461			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
462
463			This program is free software; you can redistribute it and/or modify
464			it under the terms of the GNU General Public License as published by
465			the Free Software Foundation; either version 2 of the License, or
466			(at your option) any later version.
467
468			This program is distributed in the hope that it will be useful,
469			but WITHOUT ANY WARRANTY; without even the implied warranty of
470			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
471			GNU General Public License for more details.
472
473			You should have received a copy of the GNU General Public License
474			along with this program; see the file COPYING. If not, write to
475			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
476			Boston, MA 02111-1307, USA.
477
478			=head1 CHANGE
479
480			See F<ChangeLog>.
481	wakaba	1.13	$Date: 2002/07/30 08:50:36 $
482	wakaba	1.1
483			=cut
484
485			1;