| 1 |
|
| 2 |
=head1 NAME |
| 3 |
|
| 4 |
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 |
|
| 13 |
=cut |
| 14 |
|
| 15 |
package Message::Field::UA; |
| 16 |
use strict; |
| 17 |
use vars qw(%DEFAULT @ISA %REG $VERSION); |
| 18 |
$VERSION=do{my @r=(q$Revision: 1.13 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 19 |
require Message::Field::Structured; |
| 20 |
push @ISA, qw(Message::Field::Structured); |
| 21 |
use overload '.=' => sub { |
| 22 |
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 |
|
| 33 |
*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 |
-use_Win32_API => 1, |
| 54 |
); |
| 55 |
|
| 56 |
=head1 CONSTRUCTORS |
| 57 |
|
| 58 |
The following methods construct new objects: |
| 59 |
|
| 60 |
=over 4 |
| 61 |
|
| 62 |
=cut |
| 63 |
|
| 64 |
## Initialize of this class -- called by constructors |
| 65 |
sub _init ($;%) { |
| 66 |
my $self = shift; |
| 67 |
my %options = @_; |
| 68 |
$self->SUPER::_init (%DEFAULT, %options); |
| 69 |
|
| 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 |
my @a = (); |
| 79 |
for (grep {/^[^-]/} keys %options) { |
| 80 |
push @a, $_ => $options{$_}; |
| 81 |
} |
| 82 |
$self->add (@a) if $#a > -1; |
| 83 |
} |
| 84 |
|
| 85 |
=item $ua = Message::Field::UA->new ([%options]) |
| 86 |
|
| 87 |
Constructs a new C<Message::Field::UA> object. You might pass some |
| 88 |
options as parameters to the constructor. |
| 89 |
|
| 90 |
=cut |
| 91 |
|
| 92 |
## Inherited |
| 93 |
|
| 94 |
=item $ua = Message::Field::UA->parse ($field-body, [%options]) |
| 95 |
|
| 96 |
Constructs a new C<Message::Field::UA> object with |
| 97 |
given field body. You might pass some options as parameters to the constructor. |
| 98 |
|
| 99 |
=cut |
| 100 |
|
| 101 |
sub parse ($$;%) { |
| 102 |
my $class = shift; |
| 103 |
my $self = bless {}, $class; |
| 104 |
my $field_body = shift; my @ua = (); |
| 105 |
$self->_init (@_); |
| 106 |
use re 'eval'; |
| 107 |
$field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{ |
| 108 |
my $comments = $1; |
| 109 |
$comments =~ s{$REG{M_comment}}{ |
| 110 |
my $comment = $self->Message::Util::decode_ccontent ($1); |
| 111 |
push @ua, {comment => [$comment]} if $comment; |
| 112 |
}goex; |
| 113 |
''; |
| 114 |
}goex; |
| 115 |
$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 |
for ($product, $product_version) { |
| 127 |
my ($s,$q) = (Message::Util::unquote_if_quoted_string ($_), 0); |
| 128 |
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 |
my $comment = $self->Message::Util::decode_ccontent ($1); |
| 135 |
push @comment, $comment if $comment; |
| 136 |
}goex; |
| 137 |
push @ua, {name => $product, version => $product_version, |
| 138 |
comment => \@comment}; |
| 139 |
}goex; |
| 140 |
push @{$self->{product}}, @ua; |
| 141 |
$self; |
| 142 |
} |
| 143 |
|
| 144 |
=back |
| 145 |
|
| 146 |
=head1 METHODS |
| 147 |
|
| 148 |
=over 4 |
| 149 |
|
| 150 |
=cut |
| 151 |
|
| 152 |
|
| 153 |
=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 |
sub _add_hash_check ($$$\%) { |
| 174 |
my $self = shift; |
| 175 |
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 |
} |
| 187 |
|
| 188 |
(1, $name => { |
| 189 |
name => $name, |
| 190 |
version => $version, |
| 191 |
comment => \@comment, |
| 192 |
}); |
| 193 |
} |
| 194 |
|
| 195 |
*_add_return_value = \&_replace_return_value; |
| 196 |
|
| 197 |
## (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 |
|
| 201 |
|
| 202 |
## $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 |
|
| 215 |
## $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 |
|
| 223 |
## 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 |
my $self = shift; |
| 228 |
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 |
} |
| 235 |
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 |
} |
| 260 |
undef; |
| 261 |
} |
| 262 |
|
| 263 |
## TODO: Implement count,item_exist method |
| 264 |
|
| 265 |
=item $self->stringify () |
| 266 |
|
| 267 |
Returns C<field-body> as a string. |
| 268 |
|
| 269 |
=cut |
| 270 |
|
| 271 |
sub stringify ($;%) { |
| 272 |
my $self = shift; |
| 273 |
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 |
} |
| 313 |
join ' ', @r; |
| 314 |
} |
| 315 |
*as_string = \&stringify; |
| 316 |
|
| 317 |
=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 |
## Inherited |
| 337 |
|
| 338 |
sub add_our_name ($;%) { |
| 339 |
my $ua = shift; |
| 340 |
my %o = @_; my %option = %{ $ua->{option} }; |
| 341 |
for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}} |
| 342 |
|
| 343 |
if ($Message::Entity::VERSION) { |
| 344 |
$ua->replace_rcs ($option{date}, name => 'Message-pm', |
| 345 |
version => $Message::Entity::VERSION, |
| 346 |
-prepend => 0); |
| 347 |
} |
| 348 |
|
| 349 |
## Perl version and architecture |
| 350 |
my @perl_comment; |
| 351 |
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 |
@os = ( |
| 385 |
$osv[4] == 0? 'Win32s': |
| 386 |
$osv[4] == 1? 'Windows': |
| 387 |
$osv[4] == 2? 'Windows NT': |
| 388 |
'Win32', \@os_comment); |
| 389 |
@os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF)); |
| 390 |
push @os_comment, $osv[0] if $osv[0] =~ /[^\x00\x09\x20]/; |
| 391 |
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 |
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 |
$ua; |
| 435 |
} |
| 436 |
|
| 437 |
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 |
=back |
| 464 |
|
| 465 |
=head1 LICENSE |
| 466 |
|
| 467 |
Copyright 2002 Wakaba <w@suika.fam.cx> |
| 468 |
|
| 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 |
1; # $Date: $ |
Parent Directory
| 
Revision Log