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: $ |