path: root/Master/tlpkg/tlperl/lib/Win32/Exe/Resource/Version.pm

# $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;