diff options
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm')
-rwxr-xr-x | Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm | 364 |
1 files changed, 364 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm new file mode 100755 index 00000000000..98adfbb9b22 --- /dev/null +++ b/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm @@ -0,0 +1,364 @@ +# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Version.pm $ $Author: autrijus $ +# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $ + +package Win32::Exe::Resource::Version; + +use strict; +use base 'Win32::Exe::Resource'; +use constant FORMAT => ( + Data => 'a*', +); +use constant FIXED_INFO => [qw( + Signature StrucVersion FileVersionMS FileVersionLS + ProductVersionMS ProductVersionLS FileFlagsMask FileFlags + FileOS FileType FileSubtype FileDateMS FileDateLS +)]; +use constant STRING_INFO => [qw( + Comments CompanyName FileDescription FileVersion InternalName + LegalCopyright LegalTrademarks OriginalFilename PrivateBuild + ProductName ProductVersion SpecialBuild FileNumber ProductNumber +)]; +use constant FI_TO_ID => { + map { (FIXED_INFO->[$_] => $_) } (0 .. $#{+FIXED_INFO}) +}; +use constant LC_TO_SI => { + (map { (lc($_) => $_) } @{+STRING_INFO}, keys %{+FI_TO_ID}), + (map { (lc($_) => $_) } map { /^(.+)MS$/ ? $1 : () } keys %{+FI_TO_ID}), +}; + +sub fi_to_id { + my ($self, $name) = @_; + return(+FI_TO_ID->{$name}); +} + +sub lc_to_si { + my ($self, $name) = @_; + return(+LC_TO_SI->{lc($name)} || $name); +} + +sub info { + my ($self) = @_; + return $self->{info}; +} + +sub set_info { + my ($self, $info) = @_; + $self->{info} = $info; +} + +sub initialize { + my ($self) = @_; + $self->set_info($self->decode_info($self->Data)); + die 'Invalid structure' unless $self->check; +} + +sub refresh { + my ($self) = @_; + $self->SetData($self->encode_info($self->info)); + my $rsrc = $self->first_parent('Resources'); + $rsrc->remove("/#RT_VERSION"); + $rsrc->insert("/#RT_VERSION/#1/#0" => $self); + $rsrc->refresh; + $self->initialize; +} + +sub encode_info { + my ($self, $info) = @_; + + my $key = shift(@$info); + $key = $self->encode_ucs2("$key\0"); + + my $val = shift(@$info); + my ($type, $vallen); + + if (ref $val) { + $type = 0; # binary + $val = pack('V*', @$val); + $vallen = length($val); + } + elsif (length $val) { + $type = 1; # text; + $val = $self->encode_ucs2("$val\0"); + $vallen = length($val) / 2; + } + else { + $type = 1; + $vallen = 0; + } + + my @sub_objects; + foreach my $sub_info (@$info) { + my $obj = $self->encode_info($sub_info); + push(@sub_objects, $obj); + } + + my $buf = pack('v3', 0, $vallen, $type) . $key; + $buf .= $self->pad($buf, 4); + $buf .= $val; + + foreach my $sub_object (@sub_objects) { + $buf .= $self->pad($buf, 4); + $buf .= $sub_object; + } + + substr($buf, 0, 2, pack('v', length($buf))); + return $buf; +} + +sub decode_info { + my $self = shift; + my $level = $_[1] || 1; + + my ($len, $vallen, $type) = unpack('v3', $_[0]); + die 'No record length' unless $len; + die 'Long length' if $len > length($_[0]); + + my $buf = substr($_[0], 0, $len); + substr($_[0], 0, $self->align($len, 4)) = ''; + + my $endkey = index($buf, "\0\0", 6); + while ($endkey > 0 and ($endkey % 2)) { + $endkey = index($buf, "\0\0", $endkey + 1); + } + + die 'Invalid endkey' if $endkey < 6 or $endkey > $len - $vallen;; + + my $key = substr($buf, 6, $endkey - 6); + my $u8_key = $self->decode_ucs2($key); + + my @res = ($u8_key); + $endkey = $self->align($endkey + 2, 4); + substr($buf, 0, $endkey, ''); + + if ($vallen) { + $vallen *= 2 if $level == 4; # only for strings + my $val = substr($buf, 0, $vallen); + if ($type) { + $val = $self->decode_ucs2($val); + $val =~ s/\0\z//; + } + else { + $val = [ unpack('V*', $val) ]; + } + push(@res, $val); + $vallen = $self->align($vallen, 4); + + substr($buf, 0, $vallen) = ''; + } + else { + push(@res, ''); + } + + while (length $buf) { + push(@res, $self->decode_info($buf, $level + 1)); + } + + return \@res; +} + +sub empty_info { + [ 'VS_VERSION_INFO', [ 0xFEEF04BD, 1 << 16, (0) x 11 ] ]; +} + +sub check_info { + my ($self, $info) = @_; + return 0 unless $info->[0] eq 'VS_VERSION_INFO'; + return 0 unless ref($info->[1]); + return 0 unless $info->[1][0] == 0xFEEF04BD; + return 0 unless $self->check_sub_info($info); + return 1; +} + +sub check_sub_info { + my ($self, $info) = @_; + return unless UNIVERSAL::isa($info, 'ARRAY'); + return if @$info < 2; + return unless defined($info->[0]) and defined($info->[1]); + return unless !ref($info->[0]) and length($info->[0]); + return unless !ref($info->[1]) or UNIVERSAL::isa($info->[1], 'ARRAY'); + foreach my $idx (2 .. @$info - 1) { + return 0 unless $self->check_sub_info($info->[$idx]); + } + return 1; +} + +sub get { + my ($self, $name) = @_; + $name =~ s!\\!/!g; + $name = $self->lc_to_si($name); + my $info = $self->info; + + if ($name eq '/') { + return undef unless ref $info->[1]; + return $info->[1]; + } + + my $fixed = $self->fi_to_id($name); + if (defined $fixed) { + my $struct = $info->[1]; + return undef unless $struct && ref($struct); + return $struct->[$fixed]; + } + + $fixed = $self->fi_to_id($name.'MS'); + if (defined $fixed) { + my $struct = $info->[1]; + return undef unless $struct && ref($struct); + my $ms = $struct->[$fixed]; + my $ls = $struct->[ $self->fi_to_id($name.'LS') ]; + return join(',', $self->split_dword($ms), $self->split_dword($ls)); + } + + my $s; + if ($name =~ s!^/!!) { + $s = $info; + while ($name =~ s!^([^/]+)/!!) { + $s = $self->find_info($s, $1) or return undef; + } + } + else { + $s = $self->find_info($info, 'StringFileInfo') or return undef; + if (my $cur_trans = $self->{cur_trans}) { + $s = $self->find_info($s, $cur_trans, 1) or return undef; + } + else { + $s = $s->[2] or return undef; + $self->{cur_trans} = $s->[0]; + } + } + + $s = $self->find_info($s, $name) or return undef; + return $s->[1]; +} + +sub set { + my ($self, $name, $value) = @_; + $name =~ s!\\!/!g; + $name = $self->lc_to_si($name); + my $info = $self->info; + + if ($name eq '/') { + if (!defined $value) { + $info->[1] = ''; + } + elsif (UNIVERSAL::isa($value, 'ARRAY') and @$value == 13) { + $info->[1] = $value; + } + else { + die 'Invalid array assigned'; + } + } + + my $fixed = $self->fi_to_id($name); + if (defined $fixed) { + $value = oct($value) if $value =~ /^0/; + $info->[1][$fixed] = $value; + return; + } + + $fixed = $self->fi_to_id($name.'MS'); + if (defined $fixed) { + my @value = split(/[,.]/, $value, -1); + if (@value == 4) { + $value[0] = ($value[0] << 16) | $value[1]; + $value[1] = ($value[2] << 16) | $value[3]; + splice(@value, 2); + } + + die 'Invalid MS/LS value' if @value != 2; + $info->[1][$fixed] = $value[0] || 0; + $info->[1][$self->fi_to_id($name.'LS')] = $value[1] || 0; + return; + } + + my $container = $info; + + if ($name =~ s!^/!!) { + while ($name =~ s!^([^/]+)/!!) { + my $n = $1; + my $s = $self->find_info($container, $n); + unless ($s) { + $s = [ $n => '' ]; + push(@$container, $s); + } + $container = $s; + } + } + else { + my $s = $self->find_info($container, 'StringFileInfo'); + unless ($s) { + $s = [ StringFileInfo => '' ]; + push(@$container, $s); + } + $container = $s; + + my $cur_trans = $self->{cur_trans}; + unless ($cur_trans) { + if (@$container > 2) { + $cur_trans = $container->[2][0]; + } + else { + $cur_trans = '000004B0'; # Language Neutral && CP 1200 = Unicode + } + $self->{cur_trans} = $cur_trans; + } + + $s = $self->find_info($container, $cur_trans, 1); + unless ($s) { + $s = [ $cur_trans => '' ]; + push(@$container, $s); + } + $container = $s; + } + + my ($kv, $kv_index) = $self->find_info($container, $name); + unless ($kv) { + push(@$container, [ $name => $value ]) if defined $value; + return; + } + + if (defined $value) { + $kv->[1] = $value; + } + else { + splice(@$container, $kv_index, 1); + } +} + +sub check { + my $self = shift; + return $self->check_info($self->info); +} + +sub find_info { + my ($self, $info, $name, $ignore) = @_; + my $index; + + if ($name =~ /^#(\d+)$/) { + $index = $1 - 1 + 2; + $index = undef if $index < 2 || $index >= @$info; + } + else { + for (2 .. @$info - 1) { + my $e = $info->[$_]; + if ($e->[0] eq $name or $ignore && lc($e->[0]) eq lc($name)) { + $index = $_; + last; + } + } + } + if ($index) { + return $info->[$index] unless wantarray; + return ($info->[$index], $index); + } + + return undef unless wantarray; + return (undef, undef); +} + +sub split_dword { + my ($self, $dword) = @_; + return ($dword >> 16), ($dword & 0xFFFF); +} + +1; |