summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/Win32/Exe/Resource/Version.pm364
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;