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(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.10 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);
use overload '""'       => sub { $_[0]->stringify },
             '@{}'      => sub { $_[0]->product },
             '.='       => 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;
$REG{product} = qr#(?:$REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}(?:$REG{http_token}|$REG{quoted_string}))?#;
$REG{M_product} = qr#($REG{http_token}|$REG{quoted_string})(?:$REG{FWS}/$REG{FWS}($REG{http_token}|$REG{quoted_string}))?#;

=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 = @_;
  my %DEFAULT = (
    #encoding_after_encode      ## Inherited
    #encoding_before_decode     ## Inherited
    -field_name => 'user-agent',
    #format     ## Inherited
    #hook_encode_string ## Inherited
    #hook_decode_string ## Inherited
    -prepend    => 1,
    -use_Config => 1,
    -use_Win32  => 1,
  );
  $self->SUPER::_init (%DEFAULT, %options);
  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{M_product}((?:$REG{FWS}$REG{comment})*)}{
    my ($product, $product_version, $comments) = ($1, $2, $3);
    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

=item $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->{name}) {
      if ($option{format} eq 'http'
        && (  $p->{name} =~ /$REG{NON_http_token}/
           || $p->{version} =~ /$REG{NON_http_token}/)) {
        my $f = $p->{name};
        $f .= '/'.$p->{version} if $p->{version};
        push @r, '('. $self->encode_ccontent ($f) .')';
      } else {
        my %e = &{$self->{option}->{hook_encode_string}} ($self, 
           $p->{name}, type => 'token');
        my %f = &{$self->{option}->{hook_encode_string}} ($self, 
           $p->{version}, type => 'token');
        push @r, 
          Message::Util::quote_unsafe_string ($e{value}, unsafe => 'NON_http_token')
          .($f{value} ? '/'
          .Message::Util::quote_unsafe_string ($f{value}, unsafe => 'NON_http_token')
          :'');
      }
    } elsif ($p->{version}) {   ## Error!
      push @r, '('. $self->Message::Util::encode_ccontent ($p->{version}) .')';
    }
    for (@{$p->{comment}}) {
      push @r, '('. $self->Message::Util::encode_ccontent ($_) .')' if $_;
    }
  }
  join ' ', @r;
}
*as_string = \&stringify;

=item $array = $self->product

Returns array reference of C<product>s.  Each of array elements
are hash reference, and it has three key: C<name>, C<version>,
and C<comment>.  C<comment> is array reference.

Example:

  my $p = $ua->product->[0];
  printf "%s\t%s\t%s\n", $p->{name}, $p->{version}, join ('; ', @{$p->{comment}});

=cut

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

=item $name = $ua->product_name ($index)

=item $version = $ua->product_version ($index)

Returns product-name/-version of C<$index>'th C<product>.

=cut

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

=item $comment_ref = $ua->product_comment ($index)

Returns array reference of C<comment> of C<$index>'th C<product>.
(You can edit this array.)

=cut

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

=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 ($%) {
  my $self = shift;
  my %products = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %products) {$option{substr ($_, 1)} = $products{$_}}
  for (grep {/^[^-]/} keys %products) {
    my $name = $_;
    my ($ver, $comment);
    if (ref $products{$_} eq 'ARRAY') {
      $ver = shift @{$products{$_}};
      $comment = $products{$_};
    } else {
      $ver = $products{$_};
      $comment = [];
    }
    ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)
    if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {
      $ver = sprintf '%vd', $ver;
    }
    if ($option{prepend}) {
      unshift @{$self->{product}}, {name => $name, version => $ver,
                                    comment => $comment};
    } else {
      push @{$self->{product}}, {name => $name, version => $ver,
                                 comment => $comment};
    }
  }
}

=item $hdr->replace ($field-name, $field-body, [$name, $body, ...])

Adds some field name/body pairs.  If there are already
one or more field with name of C<$field-name>, it is replaced 
by new 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.

=cut

sub replace ($%) {
  my $self = shift;
  my %params = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
  my (%new_product);
  for (grep {/^[^-]/} keys %params) {
    my $name = $_;
    my ($ver, $comment);
    if (ref $params{$_} eq 'ARRAY') {
      $ver = shift @{$params{$_}};
      $comment = $params{$_};
    } else {
      $ver = $params{$_};
      $comment = [];
    }
    ## BUG: binary unsafe:-) (ISO-2022-KR, UCS-2,... also can't treat)
    if ($ver =~ /[\x00-\x08\x0B\x0E-\x1A\x1C-\x1F\x7F]/) {
      $ver = sprintf '%vd', $ver;
    }
    $new_product{$name} = {name => $name, version => $ver, comment => $comment};
  }
  for my $product (@{$self->{product}}) {
    if ($product->{name} && defined $new_product{$product->{name}}) {
      $product = $new_product {$product->{name}};
      $new_product{$product->{name}} = undef;
    }
  }
  for (keys %new_product) {
    push @{$self->{product}}, $new_product{$_};
  }
}

=item $ua->delete ($name, [$name, $name,...]);

Deletes C<product>s whose name is C<$name>.

=cut

sub delete ($@) {
  my $self = shift;
  my %delete;  for (@_) {$delete{$_} = 1}
  for my $product (@{$self->{product}}) {
    undef $product if $delete{$product->{name}};
  }
}

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

=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

sub clone ($) {
  my $self = shift;
  $self->_delete_empty;
  my $clone = $self->SUPER::clone;
  my @p;
  for (@{$self->{product}}) {
    my $name = ref $_->{name}? $_->{name}->clone: $_->{name};
    my $ver = ref $_->{version}? $_->{version}->clone: $_->{version};
    my @comment;
    for (@{$_->{comment}}) {
      push @comment, ref $_? $_->clone: $_;
    }
    push @p, {name => $name, version => $ver, comment => \@comment};
  }
  $clone->{product} = \@p;
  $clone;
}

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/22 02:42:17 $

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