/[suikacvs]/messaging/manakai/lib/Message/Field/UA.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/UA.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by wakaba, Tue Jul 30 08:50:36 2002 UTC revision 1.13 by wakaba, Wed Nov 13 08:08:52 2002 UTC
# Line 6  header field body consist of C<product> Line 6  header field body consist of C<product>
6    
7  =cut  =cut
8    
 require 5.6.0;  
9  package Message::Field::UA;  package Message::Field::UA;
10  use strict;  use strict;
 use re 'eval';  
11  use vars qw(%DEFAULT @ISA %REG $VERSION);  use vars qw(%DEFAULT @ISA %REG $VERSION);
12  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13  require Message::Field::Structured;  require Message::Field::Structured;
# Line 46  use overload '.='      => sub { Line 44  use overload '.='      => sub {
44      -use_comment        => 1,      -use_comment        => 1,
45      #-use_quoted_string => 1,      #-use_quoted_string => 1,
46      -use_Win32  => 1,      -use_Win32  => 1,
47        -use_Win32_API      => 1,
48  );  );
49    
50  =head1 CONSTRUCTORS  =head1 CONSTRUCTORS
# Line 98  sub parse ($$;%) { Line 97  sub parse ($$;%) {
97    my $self = bless {}, $class;    my $self = bless {}, $class;
98    my $field_body = shift;  my @ua = ();    my $field_body = shift;  my @ua = ();
99    $self->_init (@_);    $self->_init (@_);
100      use re 'eval';
101    $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{    $field_body =~ s{^((?:$REG{FWS}$REG{comment})+)}{
102      my $comments = $1;      my $comments = $1;
103      $comments =~ s{$REG{M_comment}}{      $comments =~ s{$REG{M_comment}}{
# Line 339  sub add_our_name ($;%) { Line 339  sub add_our_name ($;%) {
339                        version => $Message::Entity::VERSION,                        version => $Message::Entity::VERSION,
340                        -prepend => 0);                        -prepend => 0);
341    }    }
342      my (@os, @os_comment);    
343      ## Perl version and architecture
344      my @perl_comment;      my @perl_comment;
345      if ($option{use_Config}) {      eval q{use Config; push @perl_comment, $Config{archname}} if $option{use_Config};
346        @os_comment = ('');      eval q{require Win32; my $build; $build = &Win32::BuildNumber ();
347        @os = ($^O => \@os_comment);        push @perl_comment, "ActivePerl build $build" if $build;
348        eval q{use Config;      } if $option{use_Win32};
349          @os_comment = ($Config{osvers});      undef $@;
350          push @perl_comment, $Config{archname};      
351        };      if ($^V) {  ## 5.6 or later
352        eval q{use Win32;        $ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);
353          my $build = Win32::BuildNumber;      } elsif ($]) {      ## Before 5.005
354          push @perl_comment, "ActivePerl build $build" if $build;        $ua->replace (Perl => [ $], @perl_comment], -prepend => 0);
355          my @osv = Win32::GetOSVersion;      }
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          @os = (          @os = (
379              $osv[4] == 0? 'Win32s':              $osv[4] == 0? 'Win32s':
380              $osv[4] == 1? 'Windows':              $osv[4] == 1? 'Windows':
381              $osv[4] == 2? 'WindowsNT':              $osv[4] == 2? 'WindowsNT':
382                            'Win32',       \@os_comment);                            'Win32',       \@os_comment);
383          @os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));          @os_comment = (sprintf ('%d.%02d.%d', @osv[1,2], $osv[3] & 0xFFFF));
384          push @os_comment, $osv[0] if $osv[0] =~ /[^\x09\x20]/;          push @os_comment, $osv[0] if $osv[0] =~ /[^\x00\x09\x20]/;
385          if ($osv[4] == 1) {          if ($osv[4] == 1) {
386            if ($osv[1] == 4) {            if ($osv[1] == 4) {
387              if ($osv[2] == 0) {              if ($osv[2] == 0) {
# Line 377  sub add_our_name ($;%) { Line 400  sub add_our_name ($;%) {
400            push @os_comment, 'Windows 2000' if $osv[1] == 5 && $osv[2] == 0;            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;            push @os_comment, 'Windows XP' if $osv[1] == 5 && $osv[2] == 1;
402          }          }
403          push @os_comment, Win32::GetChipName;          push @os_comment, &Win32::GetChipName ();
404        } if $option{use_Win32};      } if $option{use_Win32};
405        undef $@;      undef $@;
406      } else {      $ua->replace (@os, -prepend => $option{prepend});
407        push @perl_comment, $^O;    } elsif ('ie') {      ## Internet Explorer
408      }      my $flag = 0;
409      if ($^V) {  ## 5.6 or later      eval q{use Win32::Registry;
410        $ua->replace (Perl => [sprintf ('%vd', $^V), @perl_comment], -prepend => 0);        my $ie;
411      } elsif ($]) {      ## Before 5.005        $::HKEY_LOCAL_MACHINE->Open('SOFTWARE\Microsoft\Internet Explorer', $ie) or die $^E;
412        $ua->replace (Perl => [ $], @perl_comment], -prepend => 0);        my ($type, $value);
413      }        $ie->QueryValueEx (Version => $type, $value) or die $^E;
414      $ua->replace (@os, -prepend => 0) if $option{use_Config};        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    $ua;    $ua;
429  }  }
430    
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24