Initial Commit
This commit is contained in:
Riley Schneider
69
database/perl/vendor/lib/Win32/Exe/Resource/GroupIcon.pm
vendored
Normal file
69
database/perl/vendor/lib/Win32/Exe/Resource/GroupIcon.pm
vendored
Normal file
@@ -0,0 +1,69 @@
|
||||
# Copyright 2004, 2010 by Audrey Tang <cpan@audreyt.org>
|
||||
|
||||
package Win32::Exe::Resource::GroupIcon;
|
||||
|
||||
use strict;
|
||||
use base 'Win32::Exe::Resource';
|
||||
use constant FORMAT => (
|
||||
Magic => 'a2',
|
||||
Type => 'v',
|
||||
Count => 'v',
|
||||
'Resource::Icon' => [ 'a14', '{$Count}', 1 ],
|
||||
);
|
||||
use constant DEFAULT_ARGS => (
|
||||
Magic => "\0\0",
|
||||
Type => 1,
|
||||
Count => 0,
|
||||
);
|
||||
use constant DELEGATE_SUBS => (
|
||||
'IconFile' => [ 'dump_iconfile', 'write_iconfile' ],
|
||||
);
|
||||
|
||||
sub icons {
|
||||
my $self = shift;
|
||||
$self->members(@_);
|
||||
}
|
||||
|
||||
sub set_icons {
|
||||
my ($self, $icons) = @_;
|
||||
|
||||
$self->SetCount(scalar @$icons);
|
||||
$self->set_members('Resource::Icon' => $icons);
|
||||
|
||||
my $rsrc = $self->first_parent('Resources') or return;
|
||||
|
||||
# get the existing resource icon ids
|
||||
|
||||
my %existids = ();
|
||||
for my $groupicon ($rsrc->objects('GroupIcon')) {
|
||||
for my $icon ( $groupicon->icons ) {
|
||||
my $id = $icon->Id;
|
||||
$existids{$id} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my $nextid = 0;
|
||||
foreach my $idx (0 .. $#{$icons}) {
|
||||
$nextid ++;
|
||||
while(exists($existids{$nextid})) { $nextid ++; }
|
||||
my $icon = $self->icons->[$idx];
|
||||
$icon->SetId($nextid);
|
||||
$rsrc->insert($self->icon_name($icon->Id), $icons->[$idx]);
|
||||
}
|
||||
}
|
||||
|
||||
sub substr {
|
||||
my ($self, $id) = @_;
|
||||
my $section = $self->first_parent('Resources');
|
||||
return $section->res_data($self->icon_name($id));
|
||||
}
|
||||
|
||||
sub icon_name {
|
||||
my ($self, $id) = @_;
|
||||
my @icon_name = split("/", $self->PathName, -1);
|
||||
$icon_name[1] = "#RT_ICON";
|
||||
$icon_name[2] = "#$id";
|
||||
return join("/", @icon_name);
|
||||
}
|
||||
|
||||
1;
|
||||
53
database/perl/vendor/lib/Win32/Exe/Resource/Icon.pm
vendored
Normal file
53
database/perl/vendor/lib/Win32/Exe/Resource/Icon.pm
vendored
Normal file
@@ -0,0 +1,53 @@
|
||||
# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
|
||||
|
||||
package Win32::Exe::Resource::Icon;
|
||||
|
||||
use strict;
|
||||
use base 'Win32::Exe::Resource';
|
||||
use constant FORMAT => (
|
||||
Width => 'C',
|
||||
Height => 'C',
|
||||
ColorCount => 'C',
|
||||
_ => 'C',
|
||||
Planes => 'v',
|
||||
BitCount => 'v',
|
||||
ImageSize => 'V',
|
||||
I_RVA1 => 'v',
|
||||
I_RVA2 => 'v',
|
||||
);
|
||||
|
||||
sub Id {
|
||||
my ($self) = @_;
|
||||
return $self->I_RVA1;
|
||||
}
|
||||
|
||||
sub SetId {
|
||||
my ($self, $value) = @_;
|
||||
return $self->SetI_RVA1($value);
|
||||
}
|
||||
|
||||
sub ImageOffset {
|
||||
my ($self) = @_;
|
||||
return $self->I_RVA1 + (($self->I_RVA2 || 0) * 65536);
|
||||
}
|
||||
|
||||
sub SetImageOffset {
|
||||
my ($self, $value) = @_;
|
||||
$self->SetI_RVA1($value % 65536);
|
||||
$self->SetI_RVA2(int($value / 65536));
|
||||
}
|
||||
|
||||
sub Data {
|
||||
my ($self) = @_;
|
||||
return $self->parent->substr($self->ImageOffset, $self->ImageSize);
|
||||
}
|
||||
|
||||
sub dump {
|
||||
my ($self) = @_;
|
||||
my $parent = $self->parent;
|
||||
my $dump = $self->SUPER::dump;
|
||||
substr($dump, -2, 2, '') unless $parent->is_type('IconFile');
|
||||
return $dump;
|
||||
}
|
||||
|
||||
1;
|
||||
70
database/perl/vendor/lib/Win32/Exe/Resource/Manifest.pm
vendored
Normal file
70
database/perl/vendor/lib/Win32/Exe/Resource/Manifest.pm
vendored
Normal file
@@ -0,0 +1,70 @@
|
||||
package Win32::Exe::Resource::Manifest;
|
||||
|
||||
use strict;
|
||||
use base 'Win32::Exe::Resource';
|
||||
use constant FORMAT => (
|
||||
Data => 'a*',
|
||||
);
|
||||
|
||||
sub get_manifest {
|
||||
my ($self ) = @_;
|
||||
return $self->dump;
|
||||
}
|
||||
|
||||
sub get_manifest_id {
|
||||
my $self = shift;
|
||||
my ($type, $id, @rest);
|
||||
eval{ ($type, $id, @rest) = $self->path; };
|
||||
$id or return 1;
|
||||
$id =~ s/^#//;
|
||||
return( $id =~ /^(1|2|3)$/) ? $id : 1;
|
||||
}
|
||||
|
||||
sub set_manifest {
|
||||
my ( $self, $xmltext, $mid ) = @_;
|
||||
$mid ||= 1;
|
||||
$mid = ( $mid =~ /^(1|2|3)$/ ) ? $mid : 1;
|
||||
$self->SetData( $self->encode_manifest($xmltext) );
|
||||
my $rsrc = $self->first_parent('Resources');
|
||||
$rsrc->remove("/#RT_MANIFEST");
|
||||
$rsrc->insert('/#RT_MANIFEST/#' . $mid . '/#0' => $self);
|
||||
$rsrc->refresh;
|
||||
}
|
||||
|
||||
sub update_manifest {
|
||||
my ( $self, $xmltext ) = @_;
|
||||
$self->SetData( $self->encode_manifest($xmltext) );
|
||||
}
|
||||
|
||||
sub encode_manifest {
|
||||
my ($self, $string) = @_;
|
||||
use bytes;
|
||||
return pack("a*", $string);
|
||||
}
|
||||
|
||||
sub default_manifest {
|
||||
my ( $self ) = @_;
|
||||
my $defman = <<'W32EXEDEFAULTMANIFEST'
|
||||
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
|
||||
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
|
||||
<assemblyIdentity type="win32" version="0.0.0.0" name="Perl.Win32.Application" />
|
||||
<description>Perl.Win32.Application</description>
|
||||
<trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
|
||||
<security>
|
||||
<requestedPrivileges>
|
||||
<requestedExecutionLevel level="asInvoker" uiAccess="false" />
|
||||
</requestedPrivileges>
|
||||
</security>
|
||||
</trustInfo>
|
||||
<dependency>
|
||||
<dependentAssembly>
|
||||
<assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" publicKeyToken="6595b64144ccf1df" language="*" processorArchitecture="*" />
|
||||
</dependentAssembly>
|
||||
</dependency>
|
||||
</assembly>
|
||||
W32EXEDEFAULTMANIFEST
|
||||
;
|
||||
return $defman;
|
||||
}
|
||||
|
||||
1;
|
||||
363
database/perl/vendor/lib/Win32/Exe/Resource/Version.pm
vendored
Normal file
363
database/perl/vendor/lib/Win32/Exe/Resource/Version.pm
vendored
Normal file
@@ -0,0 +1,363 @@
|
||||
# Copyright 2004 by Audrey Tang <cpan@audreyt.org>
|
||||
|
||||
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;
|
||||
Reference in New Issue
Block a user