summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/Win32/Exe
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/Win32/Exe')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm13
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm19
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm12
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm24
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm26
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm38
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm57
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm54
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm60
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm364
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm58
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm69
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm47
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm42
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm35
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm154
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm9
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm260
25 files changed, 1541 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm
new file mode 100755
index 00000000000..a90ec19c451
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Base.pm
@@ -0,0 +1,35 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Base.pm $ $Author: autrijus $
+# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Base;
+
+use strict;
+use base 'Parse::Binary';
+use constant BASE_CLASS => 'Win32::Exe';
+use constant FORMAT => (
+ Data => 'a',
+);
+
+sub align {
+ my ($self, $value, $boundary) = @_;
+ my $n = ($value % $boundary) or return $value;
+ return($value + $boundary - $n);
+}
+
+sub pad {
+ my ($self, $value, $bounary) = @_;
+ my $x = length($value) % $bounary or return '';
+ return "\0" x ($bounary - $x);
+}
+
+sub decode_ucs2 {
+ my ($self, $string) = @_;
+ return join('', map chr($_), unpack("v*", $string));
+}
+
+sub encode_ucs2 {
+ my ($self, $string) = @_;
+ return pack("v*", map ord($_), split(//, $string));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm
new file mode 100755
index 00000000000..e544ed372a3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DataDirectory.pm
@@ -0,0 +1,13 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DataDirectory.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DataDirectory;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ VirtualAddress => 'V',
+ Size => 'V',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm
new file mode 100755
index 00000000000..f87cc0062be
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugDirectory.pm
@@ -0,0 +1,19 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugDirectory.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DebugDirectory;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Flags => 'V',
+ TimeStamp => 'V',
+ VersionMajor => 'v',
+ VersionMinor => 'v',
+ Type => 'V',
+ Size => 'V',
+ VirtualAddress => 'V',
+ Offset => 'V',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm
new file mode 100755
index 00000000000..c861ee2397b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/DebugTable.pm
@@ -0,0 +1,12 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/DebugTable.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::DebugTable;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ 'DebugDirectory' => [ 'a28', '*', 1 ],
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm
new file mode 100755
index 00000000000..8c24160951d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/IconFile.pm
@@ -0,0 +1,60 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/IconFile.pm $ $Author: autrijus $
+# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::IconFile;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Magic => 'a2',
+ Type => 'v',
+ Count => 'v',
+ 'Resource::Icon' => [ 'a16', '{$Count}', 1 ],
+ Data => 'a*',
+);
+use constant DEFAULT_ARGS => (
+ Magic => "\0\0",
+ Type => 1,
+ Count => 0,
+ Data => '',
+);
+use constant DISPATCH_FIELD => 'Magic';
+use constant DISPATCH_TABLE => (
+ "\0\0" => '',
+ "MZ" => '__BASE__',
+ '*' => sub { die "Invalid icon file header: $_[1]" },
+);
+
+sub icons {
+ my $self = shift;
+ $self->members(@_);
+}
+
+sub set_icons {
+ my ($self, $icons) = @_;
+ $self->SetCount(scalar @$icons);
+ $self->set_members('Resource::Icon' => $icons);
+ $self->refresh;
+
+ foreach my $idx (0 .. $#{$icons}) {
+ $self->icons->[$idx]->SetImageOffset(length($self->dump));
+ $self->SetData( $self->Data . $icons->[$idx]->Data );
+ }
+
+ $self->refresh;
+}
+
+sub dump_iconfile {
+ my $self = shift;
+ my @icons = $self->icons;
+ my $obj = $self->require_class('IconFile')->new;
+ $obj->set_icons(\@icons);
+ return $obj->dump;
+}
+
+sub write_iconfile {
+ my ($self, $filename) = @_;
+ $self->write_file($filename, $self->dump_iconfile);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm
new file mode 100755
index 00000000000..55251562786
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE.pm
@@ -0,0 +1,24 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE;
+
+use strict;
+use base 'Win32::Exe';
+use constant SUBFORMAT => (
+ Machine => 'v',
+ NumSections => 'v',
+ TimeStamp => 'V',
+ SymbolTable => 'V',
+ _ => 'a4',
+ OptHeaderSize => 'v',
+ Characteristics => 'v',
+ Data => 'a*',
+);
+use constant DISPATCH_FIELD => 'OptHeaderSize';
+use constant DISPATCH_TABLE => (
+ '0' => '',
+ '*' => 'PE::Header',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm
new file mode 100755
index 00000000000..03888fedbd8
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header.pm
@@ -0,0 +1,26 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE::Header;
+
+use strict;
+use base 'Win32::Exe::PE';
+use constant SUBFORMAT => (
+ Magic2 => 'v',
+ LMajor => 'C',
+ LMinor => 'C',
+ CodeSize => 'V',
+ IDataSize => 'V',
+ UDataSize => 'V',
+ EntryPointRVA => 'V',
+ BaseOfCode => 'V',
+ Data => 'a*',
+);
+use constant MEMBER_CLASS => 'Data';
+use constant DISPATCH_FIELD => 'Magic2';
+use constant DISPATCH_TABLE => (
+ 0x20b => 'PE::Header::PE32Plus',
+ '*' => 'PE::Header::PE32',
+);
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm
new file mode 100755
index 00000000000..ad8e641f40b
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/PE/Header/PE32.pm
@@ -0,0 +1,69 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/PE/Header/PE32.pm $ $Author: autrijus $
+# $Revision: #8 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::PE::Header::PE32;
+
+use strict;
+use base 'Win32::Exe::PE::Header';
+use constant SUBFORMAT => (
+ BaseOfData => 'V',
+ ImageBase => 'V',
+ SectionAlign => 'V',
+ FileAlign => 'V',
+ OSMajor => 'v',
+ OSMinor => 'v',
+ UserMajor => 'v',
+ UserMinor => 'v',
+ SubsysMajor => 'v',
+ SubsysMinor => 'v',
+ _ => 'a4',
+ ImageSize => 'V',
+ HeaderSize => 'V',
+ FileChecksum => 'V',
+ SubsystemTypeId => 'v',
+ DLLFlags => 'v',
+ StackReserve => 'V',
+ StackCommit => 'V',
+ HeapReserve => 'V',
+ HeapCommit => 'V',
+ LoaderFlags => 'V',
+ NumDataDirs => 'V',
+ 'DataDirectory' => [
+ 'a8', '{$NumDataDirs}', 1
+ ],
+ 'Section' => [
+ 'a40', '{$NumSections}', 1
+ ],
+ Data => 'a*',
+);
+use constant SUBSYSTEM_TYPES => [qw(
+ _ native windows console _
+ _ _ posix _ windowsce
+)];
+use constant ST_TO_ID => {
+ map { (SUBSYSTEM_TYPES->[$_] => $_) } (0 .. $#{+SUBSYSTEM_TYPES})
+};
+use constant ID_TO_ST => { reverse %{+ST_TO_ID} };
+
+sub st_to_id {
+ my ($self, $name) = @_;
+ return $name unless $name =~ /\D/;
+ return(+ST_TO_ID->{lc($name)} || die "No such type: $name");
+}
+
+sub id_to_st {
+ my ($self, $id) = @_;
+ return(+ID_TO_ST->{$id} || $id);
+}
+
+sub Subsystem {
+ my ($self) = @_;
+ return $self->id_to_st($self->SubsystemTypeId);
+}
+
+sub SetSubsystem {
+ my ($self, $type) = @_;
+ $self->SetSubsystemTypeId($self->st_to_id($type));
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm
new file mode 100755
index 00000000000..433be495ea6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource.pm
@@ -0,0 +1,38 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource.pm $ $Author: autrijus $
+# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Resource;
+
+use strict;
+use base 'Win32::Exe::Base';
+
+sub object {
+ my ($self) = @_;
+ return $self;
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub CodePage {
+ return 1252;
+}
+
+sub PathName {
+ my ($self) = @_;
+ return $self->{pathname} || $self->first_parent('ResourceEntry')->PathName;
+}
+
+sub SetPathName {
+ my ($self, $value) = @_;
+ $self->{pathname} = $value;
+}
+
+sub Data {
+ my ($self) = @_;
+ return $self->dump;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm
new file mode 100755
index 00000000000..c2349ec7383
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/GroupIcon.pm
@@ -0,0 +1,57 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/GroupIcon.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+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;
+
+ foreach my $idx (0 .. $#{$icons}) {
+ my $icon = $self->icons->[$idx];
+ $icon->SetId($idx+1);
+ $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;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm
new file mode 100755
index 00000000000..a6b5348acbf
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Icon.pm
@@ -0,0 +1,54 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Resource/Icon.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+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;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm
new file mode 100755
index 00000000000..28d6ecaeff4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Manifest.pm
@@ -0,0 +1,60 @@
+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 set_manifest {
+ my ( $self, $xmltext ) = @_;
+ $self->SetData( $self->encode_manifest($xmltext) );
+ my $rsrc = $self->first_parent('Resources');
+ $rsrc->remove("/#RT_MANIFEST");
+ $rsrc->insert("/#RT_MANIFEST/#1/#0" => $self);
+ $rsrc->refresh;
+}
+
+sub update_manifest {
+ my ( $self, $xmltext ) = @_;
+ $self->SetData( $self->encode_manifest($xmltext) );
+}
+
+sub encode_manifest {
+ my ($self, $string) = @_;
+ 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 processorArchitecture="x86" version="0.0.0.0" type="win32" name="Win32.Exe.Application" />
+ <description>Win32.Exe.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="x86" />
+ </dependentAssembly>
+ </dependency>
+</assembly>
+W32EXEDEFAULTMANIFEST
+;
+
+
+ return $defman;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Resource/Version.pm
new file mode 100755
index 00000000000..98adfbb9b22
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/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;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm
new file mode 100755
index 00000000000..b33647d519c
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceData.pm
@@ -0,0 +1,58 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceData.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceData;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ VirtualAddress => 'V',
+ Size => 'V',
+ CodePage => 'V',
+);
+
+sub Data {
+ my ($self) = @_;
+ return $self->{data} if defined $self->{data};
+
+ my $section = $self->first_parent('Resources');
+ my $addr = $self->VirtualAddress or return;
+ return $section->substr(
+ $addr - $section->VirtualAddress,
+ $self->Size
+ );
+}
+
+sub SetData {
+ my ($self, $data) = @_;
+ $self->{data} = $data;
+}
+
+sub object {
+ my ($self) = @_;
+ return $self->{object};
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub initialize {
+ my ($self) = @_;
+
+ my ($base) = $self->path or return;
+ $base =~ /^#RT_(?!ICON$)(\w+)$/ or return;
+ $self->VirtualAddress or return;
+
+ my $data = $self->Data;
+ my $class = ucfirst(lc($1));
+ $class =~ s/_(\w)/\U$1/g;
+ $class = $self->require_class("Resource::$class") or return;
+
+ my $obj = $class->new(\$data, { parent => $self });
+ $obj->initialize;
+ $self->{object} = $obj;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm
new file mode 100755
index 00000000000..a44a65daf3d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry.pm
@@ -0,0 +1,69 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry.pm $ $Author: autrijus $
+# $Revision: #7 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Data => 'V',
+ E_RVA => 'V',
+);
+use constant HIGH_BIT => 0x80_00_00_00;
+use Win32::Exe::ResourceData;
+
+sub high_bit {
+ my ($self) = @_;
+ return +HIGH_BIT;
+}
+
+sub path {
+ my ($self) = @_;
+ return $self->parent->path;
+}
+
+sub PathName {
+ my ($self) = @_;
+ return join('/', '', $self->path, $self->Name);
+}
+
+sub VirtualAddress {
+ my ($self) = @_;
+ $self->E_RVA & ~($self->high_bit);
+}
+
+sub SetVirtualAddress {
+ my ($self, $data) = @_;
+ $self->SetE_RVA($data | $self->IsDirectory);
+}
+
+sub IsDirectory {
+ my ($self) = @_;
+ $self->E_RVA & ($self->high_bit);
+}
+
+sub initialize {
+ my ($self) = @_;
+ my $section = $self->first_parent('Resources');
+ my $data = $section->substr($self->VirtualAddress, 12);
+ my $res_data = Win32::Exe::ResourceData->new(\$data, { parent => $self });
+ $res_data->initialize;
+ $self->{res_data} = $res_data;
+}
+
+sub Data {
+ my ($self) = @_;
+ return $self->{res_data}->Data;
+}
+
+sub CodePage {
+ my ($self) = @_;
+ return $self->{res_data}->CodePage;
+}
+
+sub object {
+ my ($self) = @_;
+ return $self->{res_data}->object;
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm
new file mode 100755
index 00000000000..39e35b4000d
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Id.pm
@@ -0,0 +1,47 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Id.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry::Id;
+
+use strict;
+use base 'Win32::Exe::ResourceEntry';
+use constant SUBFORMAT => (
+ Id => 'V',
+);
+use constant RESOURCE_TYPES => [qw(
+ _ CURSOR BITMAP ICON MENU
+ DIALOG STRING FONTDIR FONT ACCELERATOR
+ RCDATA MESSAGETABLE GROUP_CURSOR _ GROUP_ICON
+ _ VERSION DLGINCLUDE _ PLUGPLAY
+ VXD ANICURSOR ANIICON HTML MANIFEST
+)];
+use constant RT_TO_ID => {
+ map { ('RT_'.RESOURCE_TYPES->[$_] => $_) }
+ (0 .. $#{+RESOURCE_TYPES})
+};
+use constant ID_TO_RT => { reverse %{+RT_TO_ID} };
+
+sub Name {
+ my ($self) = @_;
+ my $id = $_[0]->Id;
+ $id = $self->id_to_rt($id) if $self->parent->depth < 1;
+ return "#$id";
+}
+
+sub SetName {
+ my ($self, $name) = @_;
+ $name =~ s/^#//;
+ $self->SetId( $self->rt_to_id($name) );
+}
+
+sub id_to_rt {
+ my ($self, $id) = @_;
+ return(+ID_TO_RT->{$id} || $id);
+}
+
+sub rt_to_id {
+ my ($self, $rt) = @_;
+ return(+RT_TO_ID->{$rt} || $rt);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm
new file mode 100755
index 00000000000..8f6cd1d8784
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceEntry/Name.pm
@@ -0,0 +1,42 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceEntry/Name.pm $ $Author: autrijus $
+# $Revision: #6 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceEntry::Name;
+
+use strict;
+use base 'Win32::Exe::ResourceEntry';
+use constant SUBFORMAT => (
+ N_RVA => 'V',
+);
+
+sub NameAddress {
+ my ($self) = @_;
+ $self->N_RVA & ~($self->high_bit);
+}
+
+sub SetNameAddress {
+ my ($self, $data) = @_;
+ $self->SetN_RVA($data | $self->IsDirectory);
+}
+
+sub IsEscaped {
+ my ($self) = @_;
+ $self->N_RVA & ($self->high_bit);
+}
+
+sub Name {
+ my ($self) = @_;
+ my $section = $self->first_parent('Resources');
+ my $addr = $self->NameAddress;
+ my $size = unpack('v', $section->substr($addr, 2));
+ my $ustr = $section->substr($addr + 2, $size * 2);
+ my $name = $self->decode_ucs2($ustr);
+ $name =~ s{([%#/])}{sprintf('%%%02X', ord($1))}eg;
+ return $name;
+}
+
+sub SetName {
+ die "XXX unimplemented";
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm
new file mode 100755
index 00000000000..7fe9fa1d5dd
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/ResourceTable.pm
@@ -0,0 +1,35 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/ResourceTable.pm $ $Author: autrijus $
+# $Revision: #5 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::ResourceTable;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ DebugDirectory => 'V',
+ TimeStamp => 'V',
+ VersionMajor => 'v',
+ VersionMinor => 'v',
+ NumNameEntry => 'v',
+ NumIdEntry => 'v',
+ 'ResourceEntry::Name' => [ 'a8', '{$NumNameEntry}', 1 ],
+ 'ResourceEntry::Id' => [ 'a8', '{$NumIdEntry}', 1 ],
+);
+
+sub set_path {
+ my ($self, $path) = @_;
+ $self->{path} = $path;
+}
+
+sub path {
+ my ($self) = @_;
+ wantarray ? @{$self->{path}} : $self->{path};
+}
+
+sub depth {
+ my ($self) = @_;
+ scalar @{$self->{path}};
+}
+
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm
new file mode 100755
index 00000000000..d08f91590f7
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section.pm
@@ -0,0 +1,154 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section.pm $ $Author: autrijus $
+# $Revision: #9 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section;
+
+use strict;
+use base 'Win32::Exe::Base';
+use constant FORMAT => (
+ Name => 'Z8',
+ VirtualSize => 'V',
+ VirtualAddress => 'V',
+ FileSize => 'V',
+ FileOffset => 'V',
+ RelocOffset => 'V',
+ LineNumOffset => 'V',
+ NumReloc => 'v',
+ NumLineNum => 'v',
+ Flags => 'V',
+);
+use constant DISPATCH_FIELD => 'Name';
+use constant DISPATCH_TABLE => (
+ '.text' => 'Section::Code',
+ '.debug' => 'Section::Debug',
+ '.data' => 'Section::Data',
+ '.rdata' => 'Section::Data',
+ '.bss' => 'Section::Data',
+ '.edata' => 'Section::Exports',
+ '.idata' => 'Section::Imports',
+ '.rsrc' => 'Section::Resources',
+);
+
+use constant CONTAINS_CODE => 0x20;
+use constant CONTAINS_IDATA => 0x40;
+use constant CONTAINS_UDATA => 0x80;
+
+sub Data {
+ my ($self) = @_;
+ $self->{data} ||= do {
+ my $v_size = $self->VirtualSize;
+ my $f_size = $self->FileSize or return("\0" x $v_size);
+
+ $f_size = $v_size if $v_size < $f_size;
+
+ my $data = $self->parent->substr($self->FileOffset, $f_size);
+ $data .= ("\x0" x ($v_size - length($data)));
+ $data;
+ }
+}
+
+sub SetData {
+ my ($self, $data) = @_;
+ my $pad_size = length($1) if $data =~ s/(\0*)\z//;
+
+ my $exe = $self->parent;
+ $exe->OptHeaderSize == 224 or die "Unsupported binary format";
+
+ my $index = $self->sibling_index;
+ my $data_size = length($data);
+
+ my $f_size = $self->align($data_size, $exe->FileAlign);
+ my $v_size = $self->align($data_size, $exe->SectionAlign);
+ my $f_extra = $f_size - $self->FileSize;
+ my $v_extra = $v_size - $self->align($self->VirtualSize, $exe->SectionAlign);
+
+ $self->pad_data($f_extra, $v_extra) if $f_extra;
+
+ $self->SetVirtualSize($data_size + $pad_size);
+ $data .= ("\0" x ($self->FileSize - $data_size));
+
+ $exe->substr($self->FileOffset, length($data), $data);
+ $self->update_size;
+}
+
+sub update_size {
+ my ($self) = @_;
+
+ my $exe = $self->parent;
+ my $v_addr = $self->VirtualAddress;
+ my $v_size = $self->VirtualSize;
+
+ foreach my $dir ($exe->data_directories) {
+ next unless $dir->VirtualAddress == $v_addr;
+ $dir->SetSize($v_size);
+ $dir->refresh;
+ }
+}
+
+sub pad_data {
+ my ($self, $f_extra, $v_extra) = @_;
+
+ my $exe = $self->parent;
+ my $offset = $self->FileOffset + $self->FileSize;
+
+ $exe->update_debug_directory($offset, $f_extra);
+
+ my $exe_size = $exe->size;
+ if ($exe_size > $offset) {
+ my $buf = $exe->substr($offset, ($exe_size - $offset));
+ $exe->substr($offset + $f_extra, length($buf), $buf);
+ }
+
+ $exe->set_size($exe_size + $f_extra);
+ if ($f_extra > 0) {
+ $exe->SetData($exe->Data . ("\0" x $f_extra));
+ }
+ else {
+ $exe->SetData(substr($exe->Data, 0, $f_extra));
+ }
+
+ my $index = $self->sibling_index;
+ foreach my $section (@{$self->siblings}) {
+ next if $section->sibling_index <= $index;
+ $section->update_offset($f_extra, $v_extra);
+ }
+
+ $self->SetFileSize($self->FileSize + $f_extra);
+ $exe->SetImageSize($exe->ImageSize + $v_extra);
+
+ my $flags = $self->Flags;
+ $exe->SetCodeSize($exe->CodeSize + $f_extra) if $flags & CONTAINS_CODE;
+ $exe->SetIDataSize($exe->IDataSize + $f_extra) if $flags & CONTAINS_IDATA;
+ $exe->SetUDataSize($exe->UDataSize + $f_extra) if $flags & CONTAINS_UDATA;
+}
+
+sub update_offset {
+ my ($self, $f_extra, $v_extra) = @_;
+ return unless $f_extra > 0;
+
+ my $exe = $self->parent;
+ my $v_addr = $self->VirtualAddress;
+
+ $self->SetVirtualAddress( $v_addr + $v_extra );
+ $self->SetFileOffset( $self->FileOffset + $f_extra );
+
+ foreach my $dir ($exe->data_directories) {
+ next unless $dir->VirtualAddress == $v_addr;
+ $dir->SetVirtualAddress($self->VirtualAddress);
+ }
+}
+
+sub substr {
+ my $self = shift;
+ my $data = $self->Data;
+ my $offset = shift;
+ my $length = @_ ? shift(@_) : (length($data) - $offset);
+ my $replace = shift;
+
+ return substr($data, $offset, $length) if !defined $replace;
+
+ substr($data, $offset, $length, $replace);
+ $self->SetData($data);
+}
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm
new file mode 100755
index 00000000000..726707c3064
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Code.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Code.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Code;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm
new file mode 100755
index 00000000000..033d8f504e3
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Data.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Data.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Data;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm
new file mode 100755
index 00000000000..e59ac4b3287
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Debug.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Debug.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Debug;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm
new file mode 100755
index 00000000000..9d1d5117555
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Exports.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Exports.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Exports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm
new file mode 100755
index 00000000000..e736a043f15
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Imports.pm
@@ -0,0 +1,9 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Imports.pm $ $Author: autrijus $
+# $Revision: #4 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Imports;
+
+use strict;
+use base 'Win32::Exe::Section';
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm
new file mode 100755
index 00000000000..afbc41e7309
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/Win32/Exe/Section/Resources.pm
@@ -0,0 +1,260 @@
+# $File: //local/member/autrijus/Win32-Exe/lib/Win32/Exe/Section/Resources.pm $ $Author: autrijus $
+# $Revision: #10 $ $Change: 1130 $ $Date: 2004-02-17T15:40:29.640821Z $
+
+package Win32::Exe::Section::Resources;
+
+use strict;
+use base 'Win32::Exe::Section';
+use constant DELEGATE_SUBS => (
+ 'ResourceEntry' => [ 'high_bit' ],
+ 'ResourceEntry::Id' => [ 'rt_to_id', 'id_to_rt' ],
+);
+
+sub initialize {
+ my $self = shift;
+ $self->make_table(0);
+ return $self;
+}
+
+sub table {
+ my $self = shift;
+ return $self->{table};
+}
+
+sub make_table {
+ my ($self, $offset, @path) = @_;
+ my $image = $self->substr($offset);
+ my $table = $self->require_class('ResourceTable')->new(
+ \$image, {
+ parent => $self,
+ path => \@path
+ },
+ );
+
+ foreach my $entry ($table->members) {
+ if ($entry->IsDirectory) {
+ $self->make_table($entry->VirtualAddress, @path, $entry->Name);
+ }
+ else {
+ $self->{table}{$entry->PathName} = $entry;
+ }
+ }
+}
+
+sub names {
+ my ($self) = @_;
+ my @rv = sort keys %{$self->{table}};
+ wantarray ? @rv : \@rv;
+}
+
+sub resources {
+ my ($self, $name) = @_;
+ my @rv = map $self->{table}{$_}, $self->names;
+ wantarray ? @rv : \@rv;
+}
+
+sub remove {
+ my ($self, $name) = @_;
+ delete $self->{table}{$_} for grep /^\Q$name\E/, $self->names;
+}
+
+sub insert {
+ my ($self, $name, $res) = @_;
+ $self->{table}{$name} = $res;
+}
+
+sub res {
+ my ($self, $name) = @_;
+ return $self->{table}{$name};
+}
+
+sub res_data {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->Data;
+}
+
+sub res_codepage {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->CodePage;
+}
+
+sub res_object {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ return $res->object;
+}
+
+sub res_image {
+ my ($self, $name) = @_;
+ my $res = $self->res($name) or return;
+ my $object = $res->object or return $res->Data;
+ return $object->dump;
+}
+
+sub first_object {
+ my ($self, $type) = @_;
+ foreach my $object (grep $_, map $_->object, $self->resources) {
+ return $object if !$type or $object->is_type($type);
+ }
+ return undef;
+}
+
+sub objects {
+ my ($self, $type) = @_;
+ return grep { $type ? $_->is_type($type) : 1 }
+ grep { $_ } map { $_->object } $self->resources;
+}
+
+sub refresh {
+ my $self = shift;
+
+ my $res_num = @{$self->resources} or return pack('V*', (0) x 4);
+ my $entry_size = $self->entry_size(scalar $self->names);
+ my $data_entry_size = 16 * $res_num;
+
+ my %str_addr;
+ my $str_image = '';
+ my $str_offset = $entry_size + $data_entry_size;
+
+ foreach my $name ($self->names) {
+ $name =~ s!^/!!;
+ foreach my $chunk (split("/", $name, -1)) {
+ $chunk =~ /^#/ and next;
+ $chunk =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ next if exists $str_addr{$chunk};
+
+ die "String too long" if length($chunk) > 0xFFFF;
+
+ my $addr = length($str_image);
+ my $str = $self->encode_ucs2($chunk);
+ $str_image .= pack('v', length($str) / 2) . $str;
+
+ $str_addr{$chunk} = $addr + $str_offset;
+ }
+ }
+ $str_image .= $self->pad($str_image, 8);
+
+ my %data_entry_addr;
+ my $data_entry_image = '';
+ my $data_image = '';
+ my $data_offset = $str_offset + length($str_image);
+
+ foreach my $name ($self->names) {
+ $data_entry_addr{$name} = $entry_size + length($data_entry_image);
+
+ my $data_addr = $data_offset + length($data_image) + $self->VirtualAddress;
+ $data_entry_image .= pack(
+ 'V4',
+ $data_addr,
+ length($self->res_data($name)),
+ $self->res_codepage($name),
+ 0,
+ );
+ $data_image .= $self->res_data($name);
+ $data_image .= $self->pad($data_image, 8);
+ }
+
+ my $entry_image = '';
+ $self->make_entry(
+ \$entry_image,
+ '',
+ [$self->names],
+ \%str_addr,
+ \%data_entry_addr,
+ );
+
+ length($entry_image) == $entry_size or die "Wrong size";
+
+ $self->SetData(
+ join('', $entry_image, $data_entry_image, $str_image, $data_image)
+ );
+}
+
+sub entry_size {
+ my ($self, $names) = @_;
+
+ my %entries;
+ foreach my $name (grep length, @$names) {
+ $name =~ m!^/([^/]*)(.*)! or next;
+ push(@{ $entries{$1} }, $2);
+ }
+
+ my $count = keys %entries or return 0;
+ my $size = 8 * ($count + 2);
+ $size += $self->entry_size($_) for values %entries;
+ return $size;
+}
+
+sub make_entry {
+ my ($self, $image_ref, $prefix, $names, $str_addr, $data_entry_addr) = @_;
+
+ if (@$names == 1 and !length($names->[0])) {
+ return $data_entry_addr->{$prefix};
+ }
+
+ my %entries;
+ foreach my $name (@$names) {
+ $name =~ m!^/([^/]*)(.*)! or next;
+ my ($path, $name) = ($1, $2);
+ my $type = ($path =~ /^#/) ? 'id' : 'name';
+ push(@{ $entries{$type}{$path} }, $name);
+ }
+
+ my $addr = length($$image_ref);
+ my $num_name = keys %{ $entries{name} };
+ my $num_id = keys %{ $entries{id} };
+ $$image_ref .= pack('V3vv', 0, 0, 0, $num_name, $num_id);
+
+ my $entry_offset = length($$image_ref);
+ $$image_ref .= pack('V*', (0) x (($num_name + $num_id) * 2));
+
+ foreach my $entry ($self->sort_entry(\%entries)) {
+ my ($type, $name) = @$entry;
+ my $id;
+ if ($type eq 'id') {
+ $id = $name;
+ $id =~ s/^#//;
+ $id = $self->rt_to_id($id);
+ }
+ else {
+ (my $n = $name) =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ $id = $str_addr->{$n} | $self->high_bit;
+ }
+
+ my $rva = $self->make_entry(
+ $image_ref,
+ "$prefix/$name",
+ $entries{$type}{$name},
+ $str_addr,
+ $data_entry_addr,
+ );
+
+ substr($$image_ref, $entry_offset, 8) = pack('VV', $id, $rva);
+ $entry_offset += 8;
+ }
+
+ return ($addr | $self->high_bit);
+}
+
+sub sort_entry {
+ my ($self, $entries) = @_;
+
+ my @names = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map {
+ my $name = lc($_);
+ $name =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ [ $name => $_ ];
+ } keys %{ $entries->{name} };
+
+ my @ids = map "#$_", sort {
+ $self->rt_to_id($a) <=> $self->rt_to_id($b)
+ } map substr($_, 1), keys %{ $entries->{id} };
+
+ return(
+ (map [ name => $_ ], @names),
+ (map [ id => $_ ], @ids),
+ );
+}
+
+1;