Win32-Exe-0.17/000775000000000000 011611376477 12670 5ustar00Mark Dootson000000000000Win32-Exe-0.17/Changes000664000000000000 716511611364756 14251 0ustar00Mark Dootson000000000000 Release 0.17: 19 July 2011 * Noted that create_resource_section fails on WinXP and below ---------------------------------------------------------------------- Release 0.16: 26 May 2011 * Fixed Perl 5.14 Compilation ---------------------------------------------------------------------- Release 0.15: 30 November 2010 * Fixed parsing of Windows Object files (thanks to Nicolas Georges) ---------------------------------------------------------------------- Release 0.14: 03 May 2010 * Added support for multiple icons * Added support for creating resource section for PE files that have none (Win32 platforms only). * Removed Module::Install usage - it does not work on Win32 for sub directory build. Will restore usage once CPAN Module::Install works. (next release according to CPAN reports). ---------------------------------------------------------------------- Release 0.13: * Added support for PE+ (x64 64bit executables) * Fixed manifest bug caused by 'pack' changes in perl 5.10 ---------------------------------------------------------------------- Release 0.11: * Applied patch by Mark Dootson to change the default exe manifest. ---------------------------------------------------------------------- Release 0.10: * Updated Module::Install to 0.64. * Applied patch by Mark Dootson to add support for exe manifests. ---------------------------------------------------------------------- Release 0.09: * Updated Module::Install to 0.63. * Updated Audrey's contact information. ---------------------------------------------------------------------- r3715: autrijus | 2004-03-18T05:06:01.118230Z * This be 0.08. * Load all require submodules with 'use', not 'require', so it can work with 'pp' in PAR 0.80. Reported by Alan Stewart. ---------------------------------------------------------------------- r3626: autrijus | 2004-03-16T11:58:23.873748Z * This be 0.07. * Properly raises exception when loading an invalid file to Win32::Exe. Reported by Macolm Noonings. ---------------------------------------------------------------------- r3896: autrijus | 2004-02-17T01:28:40.619691Z * This be 0.06. * conform to Parse::Binary 0.05 API * suggestion by alan to retain the original groupname. ---------------------------------------------------------------------- r3857: autrijus | 2004-02-16T09:22:40.299320Z * This be 0.05. * add docs for exe_update.pl. * Alan Stewart reported that our FindBin magic in tests was not quite good. * Also, predeclare test numbers instead of no_plan. ---------------------------------------------------------------------- r3846: autrijus | 2004-02-15T22:38:40.264114Z * This be 0.04. * Work with Parse::Binary 0.04 to refresh only when needed. This fixes the case of clobbering the exe twice, as reported by Jouke Visser. ---------------------------------------------------------------------- r3819: autrijus | 2004-02-15T00:17:26.298029Z * This be 0.03. * a stupid typo caused all named resource strings to be stripped from the table. oops. * tidy up sort a little. * depend on newer Parse::Binary. ---------------------------------------------------------------------- r3807: autrijus | 2004-02-14T19:43:30.059984Z * This be 0.02. * truncating executables to smaller size now works. * properly extend the executable. it should now really work! * forgot to refresh data directories after updating exe. bummer * fix two gotchas that were probably preventing padding from working ---------------------------------------------------------------------- r3788: autrijus | 2004-02-13T23:49:21.521921Z * This be Win32::Exe, version 0.01. ---------------------------------------------------------------------- Win32-Exe-0.17/insert/000775000000000000 011611376476 14173 5ustar00Mark Dootson000000000000Win32-Exe-0.17/insert/InsertResourceSection.xs000664000000000000 167611611363571 21132 0ustar00Mark Dootson000000000000#define _WIN32_WINNT 0x0500 #include #include #include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = Win32::Exe::InsertResourceSection PACKAGE = Win32::Exe::InsertResourceSection PROTOTYPES: DISABLE void _insert_resource_section( szFileName, lpData, cbData ) LPCSTR szFileName LPVOID lpData DWORD cbData PPCODE: BOOL bDeleteExistingResources = FALSE; LPCTSTR lpType = RT_VERSION; LPCTSTR lpName = RT_VERSION; WORD wLanguage = MAKELANGID(LANG_NEUTRAL, SUBLANG_NEUTRAL); BOOL ok; BOOL fDiscard; HANDLE hUpdate = BeginUpdateResource(szFileName, bDeleteExistingResources); if (hUpdate == NULL) XSRETURN_UNDEF; ok = UpdateResource(hUpdate, lpType, lpName, wLanguage, lpData, cbData); fDiscard = ( ok ) ? FALSE : TRUE; if (!EndUpdateResource(hUpdate, fDiscard)) XSRETURN_UNDEF; if (!ok) XSRETURN_UNDEF; XSRETURN_YES; Win32-Exe-0.17/insert/Makefile.PL000664000000000000 25411567442024 16177 0ustar00Mark Dootson000000000000use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Win32::Exe::InsertResourceSection', VERSION_FROM => '../lib/Win32/Exe/InsertResourceSection.pm', ); Win32-Exe-0.17/insert/t/000775000000000000 011611376476 14436 5ustar00Mark Dootson000000000000Win32-Exe-0.17/insert/t/0-load.t000775000000000000 15511567442024 15734 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use Test::More tests => 1; use_ok('Win32::Exe::InsertResourceSection'); 1; Win32-Exe-0.17/insert/t/1-basic.t000775000000000000 15511567442024 16077 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use Test::More tests => 1; use_ok('Win32::Exe::InsertResourceSection'); 1; Win32-Exe-0.17/insert/typemap000664000000000000 31611567442024 15626 0ustar00Mark Dootson000000000000TYPEMAP BOOL T_IV HWND T_IV HBITMAP T_IV LONG T_IV LPVOID T_PV UINT T_UV LPCTSTR T_PV LPCSTR T_PV HMODULE T_IV DWORD T_IV WORD T_IV Win32-Exe-0.17/lib/000775000000000000 011611376476 13435 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/000775000000000000 011611376476 14337 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/000775000000000000 011611376476 15060 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/Base.pm000664000000000000 130411567442026 16341 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/DataDirectory.pm000664000000000000 32211567442026 20204 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::DataDirectory; use strict; use base 'Win32::Exe::Base'; use constant FORMAT => ( VirtualAddress => 'V', Size => 'V', ); 1; Win32-Exe-0.17/lib/Win32/Exe/DebugDirectory.pm000664000000000000 54711567442026 20372 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/DebugTable.pm000664000000000000 31111567442026 17442 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::DebugTable; use strict; use base 'Win32::Exe::Base'; use constant FORMAT => ( 'DebugDirectory' => [ 'a28', '*', 1 ], ); 1; Win32-Exe-0.17/lib/Win32/Exe/IconFile.pm000664000000000000 237011567442026 17163 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/InsertResourceSection.pm000664000000000000 761511611325741 21775 0ustar00Mark Dootson000000000000######################################################################################### # Package Win32::Exe::InsertResourceSection # Description: Insert Resource Section # Created Sun May 02 17:32:55 2010 # SVN Id $Id: InsertResourceSection.pm 2 2010-11-30 16:40:31Z mark.dootson $ # Copyright: Copyright (c) 2010 Mark Dootson # Licence: This program is free software; you can redistribute it # and/or modify it under the same terms as Perl itself ######################################################################################### package Win32::Exe::InsertResourceSection; ######################################################################################### use strict; use warnings; use Exporter; use base qw( Exporter ); use Carp; use Win32::Exe; our $VERSION = '0.17'; our @EXPORT = qw( insert_pe_resource_section ); sub _is_win { ($^O =~ /^mswin/i) } if (_is_win()) { require XSLoader; XSLoader::load('Win32::Exe::InsertResourceSection', $VERSION); } sub create_resource_section { my $filename = shift; croak('Invalid filename') if $filename !~ /\.(dll|exe)$/i; croak('Filename not found') if !-f $filename; if(!_is_win()) { warn 'Cannot add resource section to PE files on this platform. Requires MSWin'; return undef; } my $replacecode; if($filename =~ /\.(dll|exe)$/i) { #VFT_APP = 0x1 #VFT_DLL = 0x2 #VFT_DRV = 0x3 #VFT_FONT = 0x4 #VFT_VXD = 0x5 #VFT_STATIC_LIB = 0x7 if(lc($1) eq 'exe') { $replacecode = '01'; } elsif(lc($1) eq 'dll') { $replacecode = '02'; } else { croak('Invalid filename'); } } else { croak('Invalid filename'); } my @verdata = qw( 400234000000560053005F0056004500 5200530049004F004E005F0049004E00 46004F0000000000BD04EFFE00000100 00000000000000000000000000000000 3F0000000000000004000400XX000000 000000000000000000000000A0010000 010053007400720069006E0067004600 69006C00650049006E0066006F000000 7C010000010030003000300030003000 34004200300000002400020001004300 6F006D00700061006E0079004E006100 6D00650000000000200000002C000200 0100460069006C006500440065007300 6300720069007000740069006F006E00 00000000200000002400020001004600 69006C00650056006500720073006900 6F006E00000000002000000024000200 010049006E007400650072006E006100 6C004E0061006D006500000020000000 2800020001004C006500670061006C00 43006F00700079007200690067006800 74000000200000002C00020001004C00 6500670061006C005400720061006400 65006D00610072006B00730000000000 200000002C00020001004F0072006900 670069006E0061006C00460069006C00 65006E0061006D006500000020000000 240002000100500072006F0064007500 630074004E0061006D00650000000000 20000000280002000100500072006F00 64007500630074005600650072007300 69006F006E0000002000000044000000 0100560061007200460069006C006500 49006E0066006F000000000024000400 00005400720061006E0073006C006100 740069006F006E00000000000000B004 ); my $verdatahex = join('', @verdata); $verdatahex =~ s/XX/$replacecode/; my $verdataraw = pack('H*', $verdatahex); my $verlen = length($verdataraw); _insert_resource_section($filename, $verdataraw, $verlen); } sub insert_pe_resource_section { my $filename = shift; if(create_resource_section($filename)) { # basic version info resource has been created # we now have to replace the language and original # filename / filename my $exe = Win32::Exe->new($filename); return ($exe->update( info => [ "FileVersion=0.0.0.0" ] )) ? $exe : undef; } else { return undef; } } 1; Win32-Exe-0.17/lib/Win32/Exe/Manifest/000775000000000000 011611376476 16626 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/Manifest/Parser.pm000664000000000000 10113011567442026 20527 0ustar00Mark Dootson000000000000######################################################################################### # Package Win32::Exe::Manifest::Parser # Description: XML Parser for Manifests # Created Wed Apr 21 07:54:51 2010 # SVN Id $Id: Parser.pm 2 2010-11-30 16:40:31Z mark.dootson $ # Copyright: Copyright (c) 2010 Mark Dootson # Licence: This program is free software; you can redistribute it # and/or modify it under the same terms as Perl itself ######################################################################################### package Win32::Exe::Manifest::Parser; ######################################################################################### use strict; use warnings; use XML::Simple 2.18; use base qw( XML::Simple ); use Carp; our $VERSION = '0.15'; =head1 NAME Win32::Exe::Manifest::Parser - MSWin Application and Assembly manifest handling =head1 VERSION This document describes version 0.15 of Win32::Exe::Manifest::Parser, released November 30, 2010. =head1 DESCRIPTION This is an internal module from the Win32::Exe distribution supporting parsing of application and assembly manifests. =cut our $BASESCHEMA; $XML::Simple::PREFERRED_PARSER = 'XML::Parser'; sub new { my $class = shift; my $self = $class->SUPER::new(@_); return $self; } sub get_current_schema { $_[0]->{_w32x_current_schema} || $BASESCHEMA; } sub set_current_schema { $_[0]->{_w32x_current_schema} = $_[1]; } #--------------------------------------------------------------- # override XML Simple methods #--------------------------------------------------------------- sub sorted_keys { my($self, $name, $hashref) = @_; my @unsorted = (sort keys(%$hashref)); my $schema = $self->get_current_schema(); my @sorted = sort { _get_key_ordinal($name,$hashref,$a,$schema) <=> _get_key_ordinal($name,$hashref,$b,$schema) } @unsorted; # set indent my ($namenamespace,$lookupname); if($name =~ /:/) { ($namenamespace,$lookupname) = split(/:/, $name, 2); } else { $lookupname = $name; } if($lookupname) { $self->{opt}->{attrindent} = ( $lookupname =~ /^(assemblyIdentity)$/ ) ? 1 : 0; } else { $self->{opt}->{attrindent} = 0; } return ( @sorted ); } #-------------------------------------------------------------- # END XML::Simple overrides #-------------------------------------------------------------- sub _get_key_ordinal { my($name,$hashref,$key, $schema) = @_; # some defaults return 1001 if $key eq 'xmlns'; return 10000 if $key =~ /^xmlns:.+$/; my ($keynamespace,$lookupkey); if($key =~ /:/) { ($keynamespace,$lookupkey) = split(/:/, $key, 2); } else { $lookupkey = $key; } my ($namenamespace,$lookupname); if($name =~ /:/) { ($namenamespace,$lookupname) = split(/:/, $name, 2); } else { $lookupname = $name; } carp qq(UNKNOWN NAMEKEY NAME $name : $lookupname KEY $key : $lookupkey\n) if (!$lookupname || !$lookupkey); if(ref($hashref->{$key})) { return (exists($schema->{elementtypes}->{$lookupname}->{elements}->{$lookupkey}->{order})) ? $schema->{elementtypes}->{$lookupname}->{elements}->{$lookupkey}->{order} : 9999 ; } else { return (exists($schema->{elementtypes}->{$lookupname}->{attributes}->{$lookupkey}->{order})) ? $schema->{elementtypes}->{$lookupname}->{attributes}->{$lookupkey}->{order} : 9999 ; } } sub get_default_manifest { my $self_or_class = shift; my $defman = q( Perl.Win32.Application ); return $defman; } sub validate_manifest_version { return ($_[1] eq '1.0') ? 1 : 0; } sub validate_string { my ($self, $val) = @_; return 1; } sub validate_class_name { my($this, $name) = @_; return ($name =~ /[^A-Za-z0-9\-_\.]/) ? 0 : 1; } sub validate_type { my($this, $type) = @_; return ( $type eq 'win32'); # specification demands lower case } sub validate_public_key { my ($this, $key) = @_; return 1; } sub validate_language { my ($self, $lang) = @_; return 1; } sub validate_architecture { my ($this, $arch) = @_; return 1 if $arch eq '*'; # many files seem to uppercase X86 so we'll accept case insensitive data return 1 if $arch =~ /^(x86|msil|ia64|amd64)$/i; return 0; } sub validate_yesno { my ($this, $val) = @_; return ( $val =~ /^(yes|no)$/) ? 1 : 0; } sub validate_truefalse { my ($this, $val) = @_; return ( $val =~ /^(true|false)$/) ? 1 : 0; } sub validate_clsid { my ($this, $clsid) = @_; return ( $clsid =~ /^\{[A-Fa-f0-9]{8}-[A-Fa-f0-9]{4}-[A-Fa-f0-9]{4}-[A-Fa-f0-9]{4}-[A-Fa-f0-9]{12}\}$/ ) ? 1 : 0; } sub validate_int4 { my ($this, $int) = @_; return ( $int =~ /^\d{1,4}$/) ? 1 : 0; } sub validate_int8 { my ($this, $int) = @_; return ( $int =~ /^\d{1,8}$/) ? 1 : 0; } sub validate_flags { my ($this, $flags) = @_; return ( $flags =~ /^(control|hidden|restricted|hasdiskimage)$/i ) ? 1 : 0; } sub validate_level { my ($this, $level) = @_; return ( $level =~ /^(asInvoker|highestAvailable|requireAdministrator)$/ ) ? 1 : 0; } sub validate_hashalg { my ($this, $alg) = @_; return ( $alg =~ /^(SHA1|SHA|MD5|MD4|MD2)$/i ) ? 1 : 0; } sub validate_thread_model { my ($this, $model) = @_; return ( $model =~ /^(Apartment|Free|Both|Neutral)$/i ) ? 1 : 0; } sub validate_hex { my ($this, $hex) = @_; return 1; } sub validate_osid { my ($this, $osid) = @_; return 1 if $osid eq '{e2011457-1546-43c5-a5fe-008deee3d3f0}'; # Windows Vista Compatibility return 1 if $osid eq '{35138b9a-5d96-4fbd-8e2d-a2440225f93a}'; # Windows 7 Compatibility return 0; } sub validate_miscstatus { my ($this, $status) = @_; my @vals = split(/\s*,\s*/, $status); my @allowednames = qw( recomposeonresize onlyiconic insertnotreplace static cantlinkinside canlinkbyole1 islinkobject insideout activatewhenvisible renderingisdeviceindependent invisibleatruntime alwaysrun actslikebutton actslikelabel nouiactivate alignable simpleframe setclientsitefirst imemode ignoreativatewhenvisible wantstomenumerge supportsmultilevelundo ); my %allowed; @allowed{@allowednames} = (); my $returnval = 1; for (@vals) { $returnval = (exists($allowed{$_})) ? 1 : 0; last if !$returnval; } return $returnval; } $BASESCHEMA = __PACKAGE__->get_default_schema(); sub get_default_schema { my $self_or_class = shift; my $schema = { namespace => { 'urn:schemas-microsoft-com:compatibility.v1' => 'cmpv1', 'urn:schemas-microsoft-com:asm.v1' => 'asmv1', 'urn:schemas-microsoft-com:asm.v2' => 'asmv2', 'urn:schemas-microsoft-com:asm.v3' => 'asmv3', }, nstranslation => { cmpv1 => 'cmpv1', asmv1 => 'asmv1', asmv2 => 'asmv2', asmv3 => 'asmv3', }, namespacelookup => { cmpv1 => 'urn:schemas-microsoft-com:compatibility.v1', asmv1 => 'urn:schemas-microsoft-com:asm.v1', asmv2 => 'urn:schemas-microsoft-com:asm.v2', asmv3 => 'urn:schemas-microsoft-com:asm.v3', }, attributes => { manifestVersion => 'validate_manifest_version', name => 'validate_class_name', type => 'validate_type', publicKeyToken => 'validate_public_key', language => 'validate_language', processorArchitecture => 'validate_architecture', version => 'validate_string', optional => 'validate_yesno', clsid => 'validate_clsid', description => 'validate_string', threadingModel => 'validate_thread_model', tlbid => 'validate_clsid', progid => 'validate_string', helpdir => 'validate_string', iid => 'validate_clsid', numMethods => 'validate_int4', resourceid => 'validate_string', flags => 'validate_flags', hashalg => 'validate_hashalg', hash => 'validate_hex', proxyStubClsid32 => 'validate_string', baseInterface => 'validate_clsid', versioned => 'validate_yesno', oldVersion => 'validate_string', newVersion => 'validate_string', size => 'validate_int8', runtimeVersion => 'validate_string', Id => 'validate_osid', xmlns => 'validate_string', level => 'validate_level', uiAccess => 'validate_truefalse', miscStatus => 'validate_miscstatus', miscStatusIcon => 'validate_miscstatus', miscStatusContent => 'validate_miscstatus', miscStatusDocprint => 'validate_miscstatus', miscStatusThumbnail => 'validate_miscstatus', }, elementtypes => { assembly => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { xmlns => { required => 1, default => 'urn:schemas-microsoft-com:asm.v1', }, manifestVersion => { required => 1, default => '1.0', order => 1002, }, }, elements => { # files, even from Microsoft, sometimes don't have an assemblyIdentity assemblyIdentity => { min => 0, max => 1, order => 10, }, compatibility => { min => 0, max => 1, order => 64, }, application => { min => 0, max => 1, order => 66, }, description => { min => 0, max => 1, order => 20, }, noInherit => { min => 0, max => 1, order => 30, }, noInheritable => { min => 0, max => 1, order => 40, }, comInterfaceExternalProxyStub => { min => 0, max => 0, order => 50, }, dependency => { min => 0, max => 0, order => 60, }, file => { min => 0, max => 0, order => 70, }, clrClass => { min => 0, max => 0, order => 80, }, clrSurrogate => { min => 0, max => 0, order => 90, }, trustInfo => { min => 0, max => 1, order => 62, }, windowClass => { min => 0, max => 1, order => 150, }, }, }, trustInfo => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { xmlns => { required => 1, default => 'urn:schemas-microsoft-com:asm.v3', }, }, elements => { security => { min => 1, max => 1, order => 10 }, }, }, security => { exclusive => 'none', content => { elements => 1, attributes => 0, value => 0 }, value_validator => undef, attributes => { }, elements => { requestedPrivileges => { min => 1, max => 1, order => 10, }, }, }, requestedPrivileges => { exclusive => 'none', content => { elements => 1, attributes => 0, value => 0 }, value_validator => undef, attributes => { }, elements => { requestedExecutionLevel => { min => 1, max => 1 , order => 10, }, }, }, requestedExecutionLevel => { exclusive => 'none', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { level => { required => 1, default => 'asInvoker', order => 1002, }, uiAccess => { required => 0, default => 'false', order => 1003, }, }, elements => { }, }, compatibility => { exclusive => 'application', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { xmlns => { required => 1, default => 'urn:schemas-microsoft-com:compatibility.v1', }, }, elements => { application => { min => 1, max => 1, order => 10, }, }, }, application => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { xmlns => { required => 0, default => 'urn:schemas-microsoft-com:asm.v3', }, }, elements => { supportedOS => { min => 0, max => 0, order => 10 }, windowsSettings => { min => 0, max => 0, order => 10 }, }, }, supportedOS => { exclusive => 'none', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { Id => { required => 1, # Windows Vista Compatibility Key default => '{e2011457-1546-43c5-a5fe-008deee3d3f0}', order => 1002, }, }, elements => { }, }, clrClass => { exclusive => 'assembly', content => { elements => 1, attributes => 0, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1002, }, clsid => { required => 1, default => undef, order => 1003, }, progid => { required => 0, default => undef, order => 1004, }, tlbid => { required => 0, default => undef, order => 1005, }, description => { required => 0, default => undef, order => 1006, }, runtimeVersion => { required => 0, default => undef, order => 1007, }, threadingModel => { required => 0, default => undef, order => 1008, }, }, elements => { progid => { min => 0, max => 0, order => 10 }, }, }, clrSurrogate => { exclusive => 'assembly', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1002, }, clsid => { required => 1, default => undef, order => 1003, }, runtimeVersion => { required => 0, default => undef, order => 1004, }, }, elements => { }, }, assemblyIdentity => { exclusive => 'none', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1003, }, version => { required => 0, default => '0.0.0.0', order => 1004, }, type => { required => 0, default => 'win32', order => 1002, }, processorArchitecture => { required => 0, default => '*', order => 1006, }, publicKeyToken => { required => 0, default => undef, order => 1007, }, language => { required => 0, default => undef, order => 1005, }, }, elements => { }, }, comInterfaceProxyStub => { exclusive => 'assembly', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1003, }, iid => { required => 1, default => undef, order => 1002, }, tblid => { required => 0, default => undef, order => 1004, }, numMethods => { required => 0, default => undef, order => 1006, }, proxyStubClsid32 => { required => 0, default => undef, order => 1007, }, baseInterface => { required => 0, default => undef, order => 1005, }, threadingModel => { required => 0, default => undef, order => 1008, }, }, elements => { }, }, description => { exclusive => 'none', content => { elements => 0, attributes => 0, value => 1 }, value_validator => 'validate_string', attributes => { }, elements => { }, }, dependency => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { optional => { required => 0, default => 'no', order => 1002, }, }, elements => { dependentAssembly => { min => 0, max => 1, order => 10 }, } }, dependentAssembly => { exclusive => 'none', content => { elements => 1, attributes => 0, value => 0 }, value_validator => undef, attributes => { }, elements => { assemblyIdentity => { min => 1, max => 1, order => 10 }, bindingRedirect => { min => 0, max => 0, order => 20 }, }, }, bindingRedirect => { exclusive => 'application', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { oldVersion => { required => 1, default => undef, order => 1002, }, newVersion => { required => 1, default => undef, order => 1003, }, }, elements => { }, }, file => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1002, }, hash => { required => 0, default => undef, order => 1004, }, hashalg => { required => 0, default => undef, order => 1003, }, size => { required => 0, default => undef, order => 1005, }, }, elements => { comClass => { min => 0, max => 0, order => 10, }, comInterfaceProxyStub => { min => 0, max => 0, order => 20, }, typelib => { min => 0, max => 0, order => 30, }, windowClass => { min => 0, max => 0, order => 40, }, }, }, comClass => { exclusive => 'assembly', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { clsid => { required => 1, default => undef, order => 1003, }, threadingModel => { required => 0, default => undef, order => 1004, }, progid => { required => 0, default => undef, order => 1003, }, tlbid => { required => 0, default => undef, order => 1005, }, description => { required => 0, default => undef, order => 1002, }, miscStatus => { required => 0, default => undef, order => 1006, }, miscStatusIcon => { required => 0, default => undef, order => 1007, }, miscStatusDocprint => { required => 0, default => undef, order => 1008, }, miscStatusContent => { required => 0, default => undef, order => 1009, }, musStatusThumbnail => { required => 0, default => undef, order => 1010, }, }, elements => { progid => { min => 0, max => 0, order => 10, }, }, }, comInterfaceExternalProxyStub => { exclusive => 'assembly', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { name => { required => 1, default => undef, order => 1005, }, iid => { required => 1, default => undef, order => 1002, }, tblid => { required => 0, default => undef, order => 1006, }, numMethods => { required => 0, default => undef, order => 1004, }, proxyStubClsid32 => { required => 0, default => undef, order => 1007, }, baseInterface => { required => 0, default => undef, order => 1003, }, }, elements => { }, }, typelib => { exclusive => 'assembly', content => { elements => 0, attributes => 1, value => 0 }, value_validator => undef, attributes => { tblid => { required => 1, default => undef, order => 1002, }, version => { required => 1, default => undef, order => 1003, }, helpdir => { required => 1, default => '', order => 1004, }, resourceid => { required => 0, default => undef, order => 1006, }, flags => { required => 0, default => undef, order => 1005, }, }, elements => { }, }, windowClass => { exclusive => 'assembly', content => { elements => 0, attributes => 1, value => 1 }, value_validator => 'validate_class_name', attributes => { versioned => { required => 1, default => 'yes', order => 1002, }, }, elements => { }, }, noInherit => { exclusive => 'application', content => { elements => 0, attributes => 0, value => 0 }, value_validator => undef, attributes => { }, elements => { }, }, noInheritable => { exclusive => 'assembly', content => { elements => 0, attributes => 0, value => 0 }, value_validator => undef, attributes => { }, elements => { }, }, progid => { exclusive => 'assembly', content => { elements => 0, attributes => 0, value => 1 }, value_validator => 'validate_class_name', attributes => { }, elements => { }, }, windowsSettings => { exclusive => 'none', content => { elements => 1, attributes => 1, value => 0 }, value_validator => undef, attributes => { xmlns => { required => 1, default => 'http://schemas.microsoft.com/SMI/2005/WindowsSettings', }, }, elements => { dpiAware => { min => 0, max => 1, order => 10 }, }, }, dpiAware => { exclusive => 'none', content => { elements => 0, attributes => 0, value => 1 }, value_validator => 'validate_truefalse', attributes => { }, elements => { }, }, }, }; return $schema; } 1; __END__ =head1 SEE ALSO Win32::Exe::Manifest =head1 AUTHORS Mark Dootson Emdootson@cpan.orgE =head1 COPYRIGHT & LICENSE Copyright 2010 by Mark Dootson Emdootson@cpan.orgE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Win32-Exe-0.17/lib/Win32/Exe/Manifest.pm000664000000000000 11725511567442026 17312 0ustar00Mark Dootson000000000000############################################################################# # Package Win32::Exe::Manifest # Description: Handle Win32 PE Manifests # Created Mon Apr 19 17:15:24 2010 # SVN Id $Id: Manifest.pm 2 2010-11-30 16:40:31Z mark.dootson $ # Copyright: Copyright (c) 2010 Mark Dootson # Licence: This program is free software; you can redistribute it # and/or modify it under the same terms as Perl itself ############################################################################# package Win32::Exe::Manifest; ############################################################################# # References # http://msdn.microsoft.com/en-us/library/dd371711(VS.85).aspx # http://msdn.microsoft.com/en-us/library/aa374191(VS.85).aspx # http://msdn.microsoft.com/en-us/library/aa374219(v=VS.85).aspx # http://msdn.microsoft.com/en-us/library/aa376607(v=VS.85).aspx #---------------------------------------------------------------------------- use strict; use warnings; use Win32::Exe::Manifest::Parser; use Exporter; use base qw( Exporter ); use Carp; our $VERSION = '0.15'; =head1 NAME Win32::Exe::Manifest - MSWin Application and Assembly manifest handling =head1 VERSION This document describes version 0.15 of Win32::Exe::Manifest, released November 30, 2010. =head1 SYNOPSIS use Win32::Exe my $exe = Win32:::Exe->new('somefilepath'); my $manifest = $exe->get_manifest if $exe->has_manifest; # Get themed controls $manifest->add_common_controls; # Change name $manifest->set_assembly_name('My.App.Name'); # Require Admin permissions $manifest->set_execution_level('requireAdministrator'); # write it out $exe->set_manifest($manifest); $exe->write; #roll your own use Win32::Exe::Manifest my $xml = $handmademanifest; ...... my $manifest = Win32::Exe::Manifest->new($xml, 'application'); $exe->set_manifest($manifest); $exe->write; #get formated $xml my $xml = $manifest->output; #try merge (experimental) my $mfest1 = $exe->get_manifest; my $mfest2 = Win32::Exe::Manifest->new($xml, 'application'); $mfest1->merge_manifest($mfest2); $exe->set_manifest($mfest1); $exe->write; #add a dependency my $info = { type => 'win32', name => 'Dependency.Prog.Id', version => 1.0.0.0, language => '*', processorArchitecture => '*', publicKeyToken => 'hjdajhahdsa7sadhaskl', }; $manifest->add_dependency($info); $exe->set_manifest($manifest); $exe->write; =head1 DESCRIPTION This module parses and manipulates application and assembly manifests used in MS Windows executables and DLLs. It is part of the Win32::Exe distribution. =head1 METHODS =head2 Constructors =head3 new Win32::Exe::Manifest->new($xml, $type); Create a new manifest instance from the manifest xml in $xml. The $type param is optional and may contain 'application' (the default), or 'assembly'. Manifest objects can also be created using Win32::Exe my $exe = Win32:::Exe->new('somefilepath'); my $manifest = $exe->get_manifest if $exe->has_manifest; =cut sub new { my ($class, $xml, $type) = @_; my $self = bless {}, $class; $xml = $self->get_default_manifest() if !$xml; $type = 'application' if !$type; $type =~ /^(application|assembly)$/ or croak(qq(Invalid manifest type : $type : valid types are 'application', 'assembly')); $self->{_w32_exe_schema} = $self->get_default_schema; $self->{_w32_exe_datatype} = $type; $self->{_w32_exe_manifestid} = 1; my $handler = Win32::Exe::Manifest::Parser->new( $self->get_parser_config ); while( $xml =~ s/""/"/g ) { carp qq(Manifest has badly formed value quotes); } $self->{_w32_exe_dataref} = $handler->xml_in( $xml ); $self->_compress_schema(); my $errors = $self->validate_errors; croak('Manifest XML had errors: ' . $errors) if $errors; return $self; } =head2 Output =head3 output my $xml = $manifest->output; Returns a formated $xml string containing all edits and changes made using Win32::Exe::Manifest =cut sub output { my $self = shift; my $handler = Win32::Exe::Manifest::Parser->new( $self->get_parser_config ); my $ref = $self->refhash; $self->_expand_schema(); my $xml = $handler->xml_out( $ref ); $self->_compress_schema(); return $xml; } =head2 Application Identity =head3 set_assembly_name $manifest->set_assembly_name('My.Application.Name'); Set the application or assembly name. The name should take the form of a progid and should not include any spaces. =head3 get_assembly_name my $appname = $manifest->get_assembly_name; Return the assembly or application name from the manifest. =cut sub set_assembly_name { my($self, $name) = @_; $self->refhash()->{assembly}->[0]->{assemblyIdentity}->[0]->{name} = $name; my $errors = $self->validate_errors; croak('Manifest XML had errors following set name: ' . $errors) if $errors; } sub get_assembly_name { my($self) = @_; my $ref = $self->refhash(); return (exists($ref->{assembly}->[0]->{assemblyIdentity}->[0]->{name})) ? $ref->{assembly}->[0]->{assemblyIdentity}->[0]->{name} : undef; } =head3 set_assembly_description $manifest->set_assembly_description('My Application Description'); Set the application description. The description is an informative string. =head3 get_assembly_decription my $desc = $manifest->get_assembly_description; Return the assembly description from the manifest. =cut sub set_assembly_description { my($self, $desc) = @_; my $valuename = $self->default_content; $self->refhash()->{assembly}->[0]->{description}->[0]->{$valuename} = $desc; my $errors = $self->validate_errors; croak('Manifest XML had errors following set description: ' . $errors) if $errors; } sub get_assembly_description { my($self) = @_; my $valuename = $self->default_content; my $ref = $self->refhash(); return (exists($ref->{assembly}->[0]->{description}->[0]->{$valuename})) ? $ref->{assembly}->[0]->{description}->[0]->{$valuename} : undef; } =head3 set_assembly_version $manifest->set_assembly_version('1.7.8.34456'); Set the application or assembly version. The version should take the form of 'n.n.n.n' where each n is a number between 0-65535 inclusive. =head3 get_assembly_version my $version = $manifest->get_assembly_version; Return the assembly or application version from the manifest. =cut sub set_assembly_version { my($self, $version) = @_; $self->refhash()->{assembly}->[0]->{assemblyIdentity}->[0]->{version} = $version; my $errors = $self->validate_errors; croak('Manifest XML had errors following set version: ' . $errors) if $errors; } sub get_assembly_version { my($self) = @_; my $ref = $self->refhash(); return (exists($ref->{assembly}->[0]->{assemblyIdentity}->[0]->{version})) ? $ref->{assembly}->[0]->{assemblyIdentity}->[0]->{version} : undef; } =head3 set_assembly_language $manifest->set_assembly_language($langid); Set the application or assembly language. The language id is the DHTML language code. If you want to set 'language neutral' then pass '*' for the value. see : L =head3 get_assembly_language my $langid = $manifest->get_assembly_language; Return the assembly or application language from the manifest. If there is no language id in the manifest, the method will return '*' =cut sub set_assembly_language { my($self, $newval) = @_; $self->refhash()->{assembly}->[0]->{assemblyIdentity}->[0]->{language} = $newval; my $errors = $self->validate_errors; croak('Manifest XML had errors following set language: ' . $errors) if $errors; } sub get_assembly_language { my($self) = @_; my $ref = $self->refhash(); return (exists($ref->{assembly}->[0]->{assemblyIdentity}->[0]->{language})) ? $ref->{assembly}->[0]->{assemblyIdentity}->[0]->{language} : '*'; } =head3 set_assembly_architecture $manifest->set_assembly_architecture($arch); Set the application or assembly architecture. Accepted values are : x86 msil ia64 amd64 *. Note the lowercase format. If you want your manifest to be architecture neutral, set architecture to '*'. =head3 get_assembly_architecture my $arch = $manifest->get_assembly_architecture; Return the assembly or application architecture from the manifest. =cut sub set_assembly_architecture { my($self, $newval) = @_; $self->refhash()->{assembly}->[0]->{assemblyIdentity}->[0]->{processorArchitecture} = $newval; my $errors = $self->validate_errors; croak('Manifest XML had errors following set processorArchitecture: ' . $errors) if $errors; } sub get_assembly_architecture { my($self) = @_; my $ref = $self->refhash(); return (exists($ref->{assembly}->[0]->{assemblyIdentity}->[0]->{processorArchitecture})) ? $ref->{assembly}->[0]->{assemblyIdentity}->[0]->{processorArchitecture} : '*'; } =head2 Trust and Security =head3 set_execution_level $manifest->set_execution_level($level); Set the application execution level. Accepted values are : asInvoker, highestAvailable, requireAdministrator, none. If you pass the value 'none', any trustInfo section will be removed from the manifest. See L =head3 get_execution_level my $level = $manifest->get_execution_level; Return the application execution level. =cut sub set_execution_level { my($self, $level) = @_; $level =~ /^(asInvoker|requireAdministrator|highestAvailable|none)$/ or croak(qq(Invalid exec level '$level'. Valid levels are 'asInvoker', 'requireAdministrator', 'highestAvailable', 'none')); my $ref = $self->refhash()->{assembly}->[0]; my $schema = $self->get_current_schema; my $xmlns = $schema->{elementtypes}->{trustInfo}->{attributes}->{xmlns}->{default}; if($level eq 'none') { # delete element and collapse tree if empty $self->_delete_collapse_tree($ref, [ qw(trustInfo security requestedPrivileges requestedExecutionLevel) ] ); } else { # create value if it does not exist my $writeref = $self->_get_first_tree_node($ref, [ qw(trustInfo security requestedPrivileges requestedExecutionLevel) ], undef ); $writeref->{level} = $level; $writeref->{uiAccess} = 'false' if not exists($writeref->{uiAccess}); } # in all cases, dump any namespace definitions - which cause crashes on some OS / namespace combos # and fix trustInfo namespace decl $self->_fixup_namespace( $ref, 'trustInfo', $xmlns ); my $errors = $self->validate_errors; croak('Manifest XML had errors following set execution level: ' . $errors) if $errors; } sub get_execution_level { my $self = shift; my $ref = $self->refhash()->{assembly}->[0]; return 'none' if not exists($ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}->[0]->{level}); return $ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}->[0]->{level}; } =head3 set_uiaccess $manifest->set_uiaccess($needed); Set the application uiAccess requirement in the trustInfo manifest section. Accepted values are 'true', 'false'. If no trustInfo section exists, one is created with the execution level set to 'asInvoker'. See L =head3 get_uiaccess my $accessneeded = $manifest->get_uiaccess; Return the uiAccess setting from the trustInfo structure. If no trustInfo structure exists, method returns undef. =cut sub set_uiaccess { my ($self, $access) = @_; $access =~ /^(true|false)$/ or croak(qq(Invalid uiAccess setting '$access'. Valid settings are 'true', 'false')); my $ref = $self->refhash()->{assembly}->[0]; if(exists($ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}->[0]->{uiAccess})) { $ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}->[0]->{uiAccess} = $access; } else { my $schema = $self->get_current_schema; my $xmlns = $schema->{elementtypes}->{trustInfo}->{attributes}->{xmlns}->{default}; $ref->{trustInfo} = [ { xmlns => $xmlns, security => [ { requestedPrivileges => [ { requestedExecutionLevel => [ { level => 'asInvoker', uiAccess => $access } ] } ] } ] } ]; } my $errors = $self->validate_errors; croak('Manifest XML had errors following set uiAccess: ' . $errors) if $errors; } sub get_uiaccess { my $self = shift; my $ref = $self->refhash()->{assembly}->[0]; return undef if not exists($ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}); return $ref->{trustInfo}->[0]->{security}->[0]->{requestedPrivileges}->[0]->{requestedExecutionLevel}->[0]->{uiAccess}; } =head2 Application Dependencies =head3 set_resource_id $manifest->set_resource_id($id); Set the resource Id for the manifest. Valid id's are 1, 2 and 3. The default is 1. Don't set this unless you are fully aware of the effects. See L =head3 get_resource_id my $id = $manifest->get_resource_id(); Return the resource Id for the manifest. =cut sub get_resource_id { $_[0]->{_w32_exe_manifestid} } sub set_resource_id { my ($self, $id) = @_; $id =~ /^(1|2|3)$/ or croak(qq(invalid manifest resource id $id. Valid values are 1,2,3)); $self->{_w32_exe_manifestid} = $id; } =head3 add_common_controls $manifest->add_common_controls(); Add a dependency on minimum version 6.0.0.0 of the Microsoft.Windows.Common-Controls shared library. This is normally done with GUI applications to use themed controls on Windows XP and above. =cut sub add_common_controls { $_[0]->add_template_dependency('Microsoft.Windows.Common-Controls'); } sub add_template_dependency { my($self, $assemblyname) = @_; my $tmpl = $self->get_dependency_template($assemblyname); croak(qq(No template found for dependency $assemblyname)) if !$tmpl; $self->add_dependency($tmpl); } =head3 add_dependency $manifest->add_dependency($info); Add a dependency on the assembly detailed in the $info hash reference. The contents of $info should be of the form: my $info = { type => 'win32', name => 'Dependency.Prog.Id', version => 1.0.0.0, language => '*', processorArchitecture => '*', publicKeyToken => 'hjdajhahdsa7sadhaskl', }; Note that the version should be the least specific that your application requires. For example, a version of '2.0.0.0' would mean the system loads the first matching assembly it finds with a version of at least '2.0.0.0'. See: L =cut sub add_dependency { my($self, $proto) = @_; my $name = $proto->{name}; $proto->{type} = 'win32'; $proto->{version} ||= '0.0.0.0'; $proto->{language} ||= '*'; $proto->{processorArchitecture} ||= '*'; my %vals = %$proto; if( defined(my $depindex = $self->_get_dependendency_index($name)) ) { $self->refhash()->{assembly}->[0]->{dependency}->[$depindex]->{dependentAssembly}->[0]->{assemblyIdentity}->[0] = \%vals; } else { $self->refhash()->{assembly}->[0]->{dependency} = [] if not exists $self->refhash()->{assembly}->[0]->{dependency}; my $newdep = { dependentAssembly => [ { assemblyIdentity => [ \%vals ] } ] }; push @{ $self->refhash()->{assembly}->[0]->{dependency} } , $newdep; } my $errors = $self->validate_errors; croak('Manifest XML had errors following dependency addition: ' . $errors) if $errors; } =head3 remove_dependency $manifest->remove_dependency($progid); Remove a dependency with the $progid. For example, passing a $progid of 'Microsoft.Windows.Common-Controls' will remove the dependency added via 'add_common_controls' from the manifest. =cut sub remove_dependency { my($self, $depname) = @_; if( defined(my $depindex = $self->_get_dependendency_index($depname)) ) { my $ref = $self->refhash()->{assembly}->[0]->{dependency}; my @depends = @$ref; splice(@depends, $depindex, 1); $self->refhash()->{assembly}->[0]->{dependency} = \@depends; return 1; } else { return 0; } } =head3 get_dependency my $info = $manifest->get_dependency($progid); Return a dependency info hash for a dependency in the manifest with the 'name' $progid. The info hash is a reference to a hash with the format: { type => 'win32', name => 'Dependency.Prog.Id', version => 1.0.0.0, language => '*', processorArchitecture => '*', publicKeyToken => 'hjdajhahdsa7sadhaskl', }; If there is no dependency with the name $progid, returns undef. =cut sub get_dependency { my($self, $depname) = @_; if( defined(my $depindex = $self->_get_dependendency_index($depname)) ) { my $ref = $self->refhash()->{assembly}->[0]->{dependency}->[$depindex]->{dependentAssembly}->[0]->{assemblyIdentity}->[0]; my %vals = %$ref; return \%vals; } else { return undef; } } =head3 get_dependencies my @deps = $manifest->get_dependencies($progid); Return an array of hash references, one for each dependency in the manifest. Each member is a reference to a hash with the format: { type => 'win32', name => 'Dependency.Prog.Id', version => 1.0.0.0, language => '*', processorArchitecture => '*', publicKeyToken => 'hjdajhahdsa7sadhaskl', }; If there are no dependencies, returns an empty array. =cut sub get_dependencies { my $self = shift; my @depends = (); return (@depends) if not exists $self->refhash()->{assembly}->[0]->{dependency}; for my $dependency ( @{ $self->refhash()->{assembly}->[0]->{dependency} } ) { my $dep = $dependency->{dependentAssembly}->[0]->{assemblyIdentity}->[0]; my %vals = %$dep; push(@depends, \%vals); } return ( @depends ); } =head2 Compatibility Settings =head3 set_compatibility $manifest->set_compatibility( ('Windows Vista') ); Set the operating system feature compatibility flags. Parameter is a list of operating systems that the application targets. In addition to the opertating system identifier keys, this method also accepts the shorthand strings 'Windows Vista' and 'Windows 7'. See : L =head3 get_compatibility my @osids = $manifest->get_compatibility(); Returns a list of operating system identifier keys that the manifest notes as targetted operating systems. You can convert these os ids to the shorthand strings 'Windows Vista' and 'Windows 7' using the method my $shortstring = $manifest->get_osname_from_osid($osid); There is a reverse method my $osid = $manifest->get_osid_from_osname($shortstring); NOTE: Don't set this unless you fully understand the effects. See : L =cut sub set_compatibility { my($self, @vals) = @_; return if ! scalar(@vals); my @osblock = (); for my $val ( @vals ) { my $compat = $val; $compat = '{e2011457-1546-43c5-a5fe-008deee3d3f0}' if(lc($compat) eq 'windows vista'); $compat = '{35138b9a-5d96-4fbd-8e2d-a2440225f93a}' if(lc($compat) eq 'windows 7'); croak(qq(Invalid OS key '$val' for compatibility)) if !Win32::Exe::Manifest::Parser->validate_osid($compat); push(@osblock, { Id => $compat }); } my $ref = $self->refhash()->{assembly}->[0]; my $schema = $self->get_current_schema; my $xmlns = $schema->{elementtypes}->{compatibility}->{attributes}->{xmlns}->{default}; $ref->{compatibility} = [ { xmlns => $xmlns, application => [ { supportedOS => \@osblock, }, ], }, ]; my $errors = $self->validate_errors; croak('Manifest XML had errors following set compatibility: ' . $errors) if $errors; } sub get_compatibility { my $self = shift; my @compats = (); my $ref = $self->refhash()->{assembly}->[0]; if(exists($ref->{compatibility})) { my @oids = @{ $ref->{compatibility}->[0]->{application}->[0]->{supportedOS} }; for my $oidref ( @oids ) { my $oskey = $oidref->{Id}; push(@compats, $oskey); } } return (@compats); } =head3 set_dpiaware $manifest->set_dpdaware( 'true' ); Set section in the manifest if the application is dpi aware. Accepts values true, false, and none. If the value 'none' is passed, the application\windowsSettings section is removed from the manifest entirely. See : L =head3 get_dpiaware $manifest->set_dpdaware( 'true' ); Return the dpiAware setting from the manifest, if any. If there is no setting, the method returns undef. See : L =cut sub set_dpiaware { my ($self, $setval) = @_; $setval =~ /^(true|false|none)$/i or croak(qq(Invalid value for set_dpiaware '$setval'. Valid values are true:false:none)); $setval = lc($setval); my $ref = $self->refhash()->{assembly}->[0]; my $elementvaluename = $self->default_content; my $schema = $self->get_current_schema; my $namealias = $schema->{namespace}->{'urn:schemas-microsoft-com:asm.v3'}; # handle remove value if($setval eq 'none') { # delete element and collapse tree if empty $self->_delete_collapse_tree($ref, [ qw(application windowSettings dpiAware) ] ); } else { # create value if it does not exist my $writeref = $self->_get_first_tree_node($ref, [ qw(application windowsSettings) ], $namealias ); $writeref->{dpiAware} = [ { $elementvaluename => $setval } ]; # add xmlns for windowsSettings my $xmlns = $schema->{elementtypes}->{windowsSettings}->{attributes}->{xmlns}->{default}; $ref->{application}->[0]->{windowsSettings}->[0]->{xmlns} = $xmlns; } my $errors = $self->validate_errors; croak('Manifest XML had errors after dpiAware setting: ' . $errors) if $errors; } sub get_dpiaware { my $self = shift; my $ref = $self->refhash()->{assembly}->[0]; my $elementvaluename = $self->default_content; return 'none' if(not exists($ref->{application}->[0]->{windowsSettings}->[0]->{dpiAware}->[0]->{$elementvaluename})); return $ref->{application}->[0]->{windowsSettings}->[0]->{dpiAware}->[0]->{$elementvaluename}; } =head2 Manifest Information =head3 get_manifest_type my $type = $manifest->get_manifest_type; Returns the manifest type ( 'application' or 'assembly' ); =cut sub get_manifest_type { $_[0]->{_w32_exe_datatype}; } sub get_current_schema { $_[0]->{_w32_exe_schema}; } sub set_current_schema { my($self, $schema) = @_; $self->{_w32_exe_schema} = $schema; my $errors = $self->validate_errors; croak('Manifest XML had errors following set schema: ' . $errors) if $errors; } sub default_xmldecl { '' } sub default_content { 'elementValue' } sub get_parser_config { my $self = shift; my %config = ( KeepRoot => 1, ForceArray => 1, KeyAttr => {}, XMLDecl => $self->default_xmldecl, ForceContent => 1, ContentKey => $self->default_content, # AttrIndent => 1, ); return %config; } sub refhash { $_[0]->{_w32_exe_dataref}; } sub merge_manifest { my($self, $xml) = @_; my $mergefest; my $class = ref($self); eval { $mergefest = $class->new($xml, $self->get_manifest_type); }; croak(qq(Merging $@)) if $@; my $newref = $mergefest->refhash()->{assembly}->[0]; my $oldref = $self->refhash()->{assembly}->[0]; $self->_merge_element_merge('assembly', $oldref, $newref); my $errors = $self->validate_errors; croak('Manifest had errors after merging: ' . $errors) if $errors; } sub get_osname_from_osid { my($self, $osid) = @_; my $name = 'Unknown Windows Version'; $name = 'Windows Vista' if $osid =~ /e2011457-1546-43c5-a5fe-008deee3d3f0/; $name = 'Windows 7' if $osid =~ /35138b9a-5d96-4fbd-8e2d-a2440225f93a/; return $name; } sub get_osid_from_osname { my($self, $name) = @_; my $osid = undef; $osid = '{e2011457-1546-43c5-a5fe-008deee3d3f0}' if(lc($name) eq 'windows vista'); $osid = '{35138b9a-5d96-4fbd-8e2d-a2440225f93a}' if(lc($name) eq 'windows 7'); return $osid; } sub _get_dependendency_index { my($self, $name) = @_; my $exref = $self->refhash()->{assembly}->[0]; return undef if not exists $exref->{dependency}; my $rval = undef; my @existing = @{ $exref->{dependency} }; for(my $i = 0; $i < @existing; $i++) { my $depname = $existing[$i]->{dependentAssembly}->[0]->{assemblyIdentity}->[0]->{name}; if($depname eq $name) { $rval = $i; last; } } return $rval; } sub _get_first_tree_node { my ($self, $ref, $paths, $namealias ) = @_; my $newref = $ref; while(my $path = shift(@$paths) ) { $newref->{$path} = [{}] if(not exists($newref->{$path})); $newref = $newref->{$path}->[0]; $newref->{elementnamespace} = $namealias if $namealias; } return $newref; } sub _delete_collapse_tree { my ($self, $ref, $paths ) = @_; my $rootkey = $paths->[0]; my $deletekey = pop(@$paths); my $delref = $ref; my $dodelete = 1; while(my $checkpath = shift @$paths) { if(exists($delref->{$checkpath}->[0])) { $delref = $delref->{$checkpath}->[0]; } else { $dodelete = 0; last; } } delete($delref->{$deletekey}) if($dodelete && exists($delref->{$deletekey})); delete($delref->{elementnamespace}) if($dodelete && exists($delref->{elementnamespace})); $self->_delete_if_empty($ref, $rootkey); } sub _merge_element_merge { my($self, $elementname, $exref, $mergeref) = @_; my $schema = $self->get_current_schema; my $elementvaluename = $self->default_content; my $elementdef = $schema->{elementtypes}->{$elementname}; my @keynames = (sort keys(%$mergeref)); my %elementnames = (); my %attributenames = (); my $valuepresent = 0; for my $kname(@keynames) { if( $kname eq $elementvaluename ) { $valuepresent = 1; } elsif(ref($mergeref->{$kname})) { $elementnames{$kname} = 1; } else { $attributenames{$kname} = 1; } } # merge value if($valuepresent) { $exref->{$elementvaluename} = $mergeref->{$elementvaluename}; } # merge attributes for my $aname (sort keys( %attributenames )) { $exref->{$aname} = $mergeref->{$aname}; } # merge elements for my $ename (sort keys( %elementnames )) { if(not exists($exref->{$ename})) { # simple addition $exref->{$ename} = $mergeref->{$ename}; next; } if($ename eq 'dependency') { # handle dependency merge $self->_merge_dependencies( $exref, $mergeref ); next; } my $maxallowed = $elementdef->{elements}->{$ename}->{max}; if($maxallowed == 1) { $self->_merge_element_merge($ename, $exref->{$ename}->[0], $mergeref->{$ename}->[0]); } else { push(@{ $exref->{$ename} }, @{ $mergeref->{$ename} }); } } } sub _merge_dependencies { my($self, $exref, $mergeref) = @_; my %existingdepends = (); my %mergingdepends = (); my @existing = @{ $exref->{dependency} }; my @merging = @{ $mergeref->{dependency} }; my @merged = (); for(my $i = 0; $i < @existing; $i++) { my $depname = $existing[$i]->{dependentAssembly}->[0]->{assemblyIdentity}->[0]->{name}; $existingdepends{$depname} = $i; } for(my $i = 0; $i < @merging; $i++) { my $depname = $merging[$i]->{dependentAssembly}->[0]->{assemblyIdentity}->[0]->{name}; $mergingdepends{$depname} = $i; } foreach my $classname (sort keys(%existingdepends)) { push(@merged, $existing[$existingdepends{$classname}]) if not exists $mergingdepends{$classname} } push(@merged, @merging); $exref->{dependency} = \@merged; } sub validate_errors { my $self = shift; eval { $self->validate_data; }; return ($@) ? $@ : undef; } sub _fixup_namespace { my( $self, $ref, $keyname, $xmlns ) = @_; for my $element( @{ $ref->{$keyname} } ) { $element->{xmlns} = $xmlns if $xmlns; delete($element->{elementnamespace}) if(exists($element->{elementnamespace})); my @keynames = (sort keys(%$element)); for my $subkeyname( @keynames ) { if(ref($element->{$subkeyname})) { # a sub-element $self->_fixup_namespace($element, $subkeyname, undef ); } } } } sub _delete_if_empty { my($self, $ref, $refname) = @_; # this element array is empty if it only contains namespace attributes # and all it's elements are similarly empty; my $candelete = 1; for my $element ( @{ $ref->{$refname} }) { my @keynames = (sort keys(%$element)); for my $keyname( @keynames ) { next if $keyname eq 'elementnamespace'; next if $keyname =~ /^xmlns/; my $value = $element->{$keyname}; if(ref($value)) { # this is an element array $candelete = 0 if !$self->_delete_if_empty($element, $keyname); } else { # we have a none-namespace attribute $candelete = 0; } } } delete($ref->{$refname}) if $candelete; return $candelete; } sub _compress_schema { my $self = shift; my $ref = $self->refhash; $self->_compress_element_reference($ref); } sub _compress_element_reference { my($self, $hashref) = @_; my $schema = $self->get_current_schema; my @attributes; my @elements; for my $keyname ( sort keys(%$hashref) ) { my $value = $hashref->{$keyname}; if(ref($value)) { push(@elements, $keyname); } else { push(@attributes, $keyname); } } for my $keyname ( @attributes ) { #next if $keyname eq 'elementnamespace'; # - should never appear my $value = $hashref->{$keyname}; if($keyname =~ /^xmlns:(.+)$/) { # this is a namespace declaration # record it in the current schema # and delete it from the record my $replacerequired = 0; my $namespacesname = $1; if(exists($schema->{namespace}->{$value})) { # namespace exists my $alias = $schema->{namespace}->{$value}; if($namespacesname ne $alias) { $schema->{nstranslation}->{$namespacesname} = $alias; $namespacesname = $alias; $replacerequired = 1; } } else { # make sure namespace name is unique before adding values while(exists($schema->{nstranslation}->{$namespacesname})) { $namespacesname .= 'n'; } $schema->{namespace}->{$value} = $namespacesname; $schema->{nstranslation}->{$namespacesname} = $namespacesname; $replacerequired = 1; } # delete the declaration delete($hashref->{$keyname}); } } for my $keyname ( @elements ) { my $value = $hashref->{$keyname}; if($keyname =~ /^(.+):(.+)$/) { # element has a namespace my $namespace = $1; my $shortname = $2; my $nsalias = $schema->{nstranslation}->{$namespace} || $namespace; $hashref->{$shortname} = $value; delete($hashref->{$keyname}); $_->{elementnamespace} = $nsalias for( @$value ); } $self->_compress_element_reference($_) for ( @$value ); } } sub _expand_schema { my $self = shift; $self->{parser}->{namespaces} = {}; my $ref = $self->refhash; $self->_expand_element_reference($ref); # add namespace keys to my $assembly = $ref->{assembly}->[0]; if($assembly) { foreach my $key (sort keys(%{ $self->{parser}->{namespaces} })) { my $xmlns = $self->{parser}->{namespaces}->{$key}; my $xmlnsname = qq(xmlns:$key); $assembly->{$xmlnsname} = $xmlns; } } $self->{parser}->{namespaces} = {}; } sub _expand_element_reference { # prepend saved namespace prefixes to elements my($self, $hashref) = @_; my $schema = $self->get_current_schema; my @keynames = ( sort keys(%$hashref) ); for my $keyname ( @keynames ) { my $value = $hashref->{$keyname}; if(ref($value)) { # an array # get namespace if any my $namespace = undef; for my $element(@$value) { if(exists($element->{elementnamespace})) { $namespace = $element->{elementnamespace}; delete($element->{elementnamespace}); } } if($namespace) { my $newname = qq($namespace:$keyname); $hashref->{$newname} = $value; delete($hashref->{$keyname}); my $xmlns = $schema->{namespacelookup}->{$namespace}; $self->{parser}->{namespaces}->{$namespace} = $xmlns; } $self->_expand_element_reference($_) for ( @$value ); } } } sub validate_data { my($self) = @_; # top level element must be assembly # grab that and validate onwards my $schema = $self->get_current_schema; my $ref = $self->refhash; my @levels = sort keys(%$ref); croak('Too many top level elements : ' . join(', ', @levels)) if (scalar(@levels) != 1); croak(qq(Unexpected top level element $levels[0])) if $levels[0] ne 'assembly'; my $elementname = 'assembly'; my $elementdef = exists($schema->{elementtypes}->{$elementname}) ? $schema->{elementtypes}->{$elementname} : undef; croak(qq(no definition found for element type $elementname)) if !defined($elementdef); my $min = 1; my $max = 1; my $raw = $ref->{assembly}; $self->validate_element_array('assembly', $min, $max, $raw); } sub validate_element_array { my($self, $elementname, $min, $max, $ref) = @_; my $schema = $self->get_current_schema; my $elementvaluename = $self->default_content; # get element definition my $elementdef = exists($schema->{elementtypes}->{$elementname}) ? $schema->{elementtypes}->{$elementname} : undef; croak(qq(no definition found for element type $elementname)) if !defined($elementdef); # check if this manifest type accepts element type my $currenttype = $self->get_manifest_type; my $exclusive = $elementdef->{exclusive}; if(($exclusive ne 'none') && ($currenttype ne $exclusive)) { croak(qq(element type $elementname cannot appear in $currenttype manifests)); } # check that numbers are OK my $numelements = scalar @$ref; croak (qq(not enough $elementname elements - count = $numelements - minimum = $min)) if(($min > 0) && ($numelements < $min)); croak (qq(too many $elementname elements - count = $numelements - maximum = $max)) if(($max > 0) && ($numelements > $max)); # validate each element item $self->validate_element($elementname, $elementdef, $_) for (@$ref); } sub validate_element { my($self, $ename, $elementdef, $ref) = @_; # ref contains elements, and attributes # any value is present as attribute 'elementvalue' # elements are arrayrefs # attributes are values my $schema = $self->get_current_schema; my $elementvaluename = $self->default_content; my @keynames = (sort keys(%$ref)); my %elementnames = (); my %attributenames = (); my $valuepresent = 0; for my $kname(@keynames) { next if $kname eq 'elementnamespace'; if( $kname eq $elementvaluename ) { $valuepresent = 1; } elsif(ref($ref->{$kname})) { if(not exists($elementdef->{elements}->{$kname})) { croak(qq(Unexpected element $kname in $ename)); } $elementnames{$kname} = 1; } else { # allow no value namespace attributes to pass next if $kname =~ /^xmlns:.+$/; next if $kname eq 'xmlns'; if(not exists($elementdef->{attributes}->{$kname})) { croak(qq(Unexpected attribute $kname in $ename)); } $attributenames{$kname} = 1; } } # check we have all required elements foreach my $ekey (sort keys(%{ $elementdef->{elements} })) { if( $elementdef->{elements}->{$ekey}->{min} > 0 ) { croak qq(required element $ekey not found) if !exists($elementnames{$ekey}); } } # check we have all required attributes foreach my $akey (sort keys(%{ $elementdef->{attributes} })) { next if $akey eq 'xmlns'; if( $elementdef->{attributes}->{$akey}->{required} == 1 ) { croak qq(required attribute $akey not found) if !exists($attributenames{$akey}); } } # check we have correct value / novalue my $valuerequired = $elementdef->{content}->{value}; if($valuerequired != $valuepresent) { croak qq( unexpected value in $ename - value required = $valuerequired : value present = $valuepresent); } # validate any value if($valuerequired) { my $validator = $elementdef->{value_validator}; Win32::Exe::Manifest::Parser->$validator($ref->{$elementvaluename}) or croak(qq(Invalid Value $ref->{$elementvaluename} for element $ename)); } # validate attributes foreach my $aname (sort keys( %attributenames ) ) { next if $aname eq 'xmlns'; my $avalue = $ref->{$aname}; my $validator = $schema->{attributes}->{$aname}; Win32::Exe::Manifest::Parser->$validator($avalue) or croak(qq(Invalid value $avalue for attribute $aname in $ename)); } # validate elements foreach my $sub_ename (sort keys( %elementnames ) ) { my $elearryref = $ref->{$sub_ename}; my $min = $elementdef->{elements}->{$sub_ename}->{min}; my $max = $elementdef->{elements}->{$sub_ename}->{max}; $self->validate_element_array($sub_ename, $min, $max, $elearryref); } } sub get_dependency_template { my ($self, $name) = @_; my $dependencytemplates = $self->get_dependency_template_hash; if(exists($dependencytemplates->{$name})) { return $dependencytemplates->{$name}; } else { return undef; } } sub get_dependency_template_hash { my $self = shift; my $dependencytemplates = { 'Microsoft.Windows.Common-Controls' => { name => 'Microsoft.Windows.Common-Controls', type => 'win32', version => '6.0.0.0', publicKeyToken => '6595b64144ccf1df', language => '*', processorArchitecture => '*', }, }; return $dependencytemplates; } sub get_default_manifest { Win32::Exe::Manifest::Parser->get_default_manifest(); } sub get_default_schema { Win32::Exe::Manifest::Parser->get_default_schema(); } 1; __END__ =head1 SEE ALSO Modules that use Win32::Exe::Manifest Win32::Exe =head1 AUTHORS Mark Dootson Emdootson@cpan.orgE =head1 COPYRIGHT & LICENSE Copyright 2010 by Mark Dootson Emdootson@cpan.orgE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Win32-Exe-0.17/lib/Win32/Exe/PE/000775000000000000 011611376476 15364 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/PE/Header/000775000000000000 011611376476 16554 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/PE/Header/PE32.pm000664000000000000 321611567442025 17637 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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)); } sub ExpectedOptHeaderSize { 224 }; 1; Win32-Exe-0.17/lib/Win32/Exe/PE/Header/PE32Plus.pm000664000000000000 354211567442025 20505 0ustar00Mark Dootson000000000000#-------------------------------------------------------------------- # 64 bit PE+ header as per 'Microsoft PE and COFF Specification' from # http://www.microsoft.com/whdc/system/platform/firmware/PECOFF.mspx #-------------------------------------------------------------------- package Win32::Exe::PE::Header::PE32Plus; use strict; use base 'Win32::Exe::PE::Header'; use constant SUBFORMAT => ( ImageBase => 'a8', 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 => 'a8', StackCommit => 'a8', HeapReserve => 'a8', HeapCommit => 'a8', 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)); } sub ExpectedOptHeaderSize { 240 }; 1; Win32-Exe-0.17/lib/Win32/Exe/PE/Header.pm000664000000000000 107211567442025 17164 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/PE.pm000664000000000000 73311567442026 15760 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Resource/000775000000000000 011611376476 16647 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/Resource/GroupIcon.pm000664000000000000 277411567442025 21176 0ustar00Mark Dootson000000000000# Copyright 2004, 2010 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Resource/Icon.pm000664000000000000 204611567442025 20151 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Resource/Manifest.pm000664000000000000 361711567442025 21034 0ustar00Mark Dootson000000000000package 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' Perl.Win32.Application W32EXEDEFAULTMANIFEST ; return $defman; } 1; Win32-Exe-0.17/lib/Win32/Exe/Resource/Version.pm000664000000000000 2102311567442025 20722 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Resource.pm000664000000000000 104111567442026 17254 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/ResourceData.pm000664000000000000 216311567442026 20054 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/ResourceEntry/000775000000000000 011611376476 17671 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/ResourceEntry/Id.pm000664000000000000 216011567442026 20635 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/ResourceEntry/Name.pm000664000000000000 152711567442026 21167 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/ResourceEntry.pm000664000000000000 240511567442026 20303 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/ResourceTable.pm000664000000000000 125211567442026 20230 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Section/000775000000000000 011611376476 16464 5ustar00Mark Dootson000000000000Win32-Exe-0.17/lib/Win32/Exe/Section/Code.pm000664000000000000 21011567442025 17717 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::Section::Code; use strict; use base 'Win32::Exe::Section'; 1; Win32-Exe-0.17/lib/Win32/Exe/Section/Data.pm000664000000000000 21011567442025 17716 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::Section::Data; use strict; use base 'Win32::Exe::Section'; 1; Win32-Exe-0.17/lib/Win32/Exe/Section/Debug.pm000664000000000000 21111567442025 20074 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::Section::Debug; use strict; use base 'Win32::Exe::Section'; 1; Win32-Exe-0.17/lib/Win32/Exe/Section/Exports.pm000664000000000000 21311567442025 20514 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::Section::Exports; use strict; use base 'Win32::Exe::Section'; 1; Win32-Exe-0.17/lib/Win32/Exe/Section/Imports.pm000664000000000000 21311567442025 20505 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang package Win32::Exe::Section::Imports; use strict; use base 'Win32::Exe::Section'; 1; Win32-Exe-0.17/lib/Win32/Exe/Section/Resources.pm000664000000000000 1403711567442025 21073 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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; Win32-Exe-0.17/lib/Win32/Exe/Section.pm000664000000000000 1046311567442026 17121 0ustar00Mark Dootson000000000000# Copyright 2004 by Audrey Tang 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 && ( $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; my $act_headersize = $exe->OptHeaderSize; my $exp_headersize = $exe->ExpectedOptHeaderSize; ($act_headersize && ( $act_headersize == $exp_headersize )) or die "Unsupported binary format: headersize $act_headersize ne $exp_headersize"; 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; Win32-Exe-0.17/lib/Win32/Exe.pm000664000000000000 5673011611376043 15517 0ustar00Mark Dootson000000000000package Win32::Exe; $Win32::Exe::VERSION = '0.17'; =head1 NAME Win32::Exe - Manipulate Win32 executable files =head1 VERSION This document describes version 0.17 of Win32::Exe, released July 19, 2011. =head1 SYNOPSIS use Win32::Exe; my $exe = Win32::Exe->new('c:/windows/notepad.exe'); # add a default resource structure if none exists # create_resource_section only works on MSWin and # does not work on Windows XP - requires Vista or # above $exe = $exe->create_resource_section if $exe->can_create_resource_section; # Get version information my $info = $exe->get_version_info; print qq($_ = $info->{$_}\n) for (sort keys(%$info)); # Extract icons from an executable my @iconnames = $exe->get_group_icon_names; for ( my $i = 0; $i < @iconnames; $i++ ) { my $filename = 'icon' . $i . '.ico'; my $iconname = $iconnames[$i]; $exe->extract_group_icon($iconname,$filename); } # Import icons from a .exe or .ico file and write back the file $exe->update( icon => '/c/windows/taskman.exe' ); $exe->update( icon => 'myicon.ico' ); # Change it to a console application, then save to another .exe $exe->set_subsystem_console; $exe->write('c:/windows/another.exe'); # Add a manifest section $exe->update( manifest => $mymanifestxml ); # or a default $exe->update( defaultmanifest => 1 ); # or specify manifest args $exe->update( manifestargs => { ExecLevel => 'requireAdministrator' } ); # Get manifest object $manifest = $exe->get_manifest if $exe->has_manifest; # change execution level $manifest->set_execution_level('requireAdministrator'); $exe->set_manifest($manifest); $exe->write; =head1 DESCRIPTION This module parses and manipulating Win32 PE/COFF executable headers, including version information, icons, manifest and other resources. The module Win32::Exe::Manifest can be used for manifest handling. A script exe_update.pl is provided for simple file updates. Also, please see the test files in the source distributions F directory for examples of using this module. =head1 METHODS =head2 new my $exe = Win32::Exe->new($filename); Create a Win32::Exe object from $filename. Filename can be an executable or a DLL. =head2 update $exe->update( icon => 'c:/my/icon.ico', gui => 1, info => [ 'FileDescription=My File', 'FileVersion=1.4.3.3567' ], manifest => 'c:/my/manifest.xml', manifestargs => [ 'ExecLevel=asInvoker', 'CommonControls=1' ], ); The B method provides a convenience method for the most common actions. It writes the information you provide to the file opened by Win32::Exe->new($filename). You do not have to call $exe->write - the method automatically updates the opened file. Param detail: B Pass the name of an executable, dll or ico file to extract the icon and make it the main icon for the Win32 executable. B Pass a reference to an array of strings containing key - value pairs separated by '='. e.g. info => [ 'FileDescription=My File', 'FileVersion=1.4.3.3567' ] Recognised keys are Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename ProductName ProductVersion B Use parameter 'gui' or 'console' to set the executable subsystem to Windows or Console. You can, of course, only use one or the other of gui / console, not both. B Specify a manifest file to add to the executable resources. B As an alternative to specifying a manifest file, pass a reference to an array of strings containing key - value pairs separated by '='. e.g. manifestargs => [ 'ExecLevel=asInvoker', 'CommonControls=1' ] Recognised keys are ExecutionLevel UIAccess ExecName Description CommonControls Version =head2 create_resource_section $exe = $exe->create_resource_section if $exe->can_create_resource_section; If an executable file does not have an existing resource section, you must create one before attempting to add version, icon or manifest resources. The method create_resource_section is only available on MSWin platforms. Also, the method will fail if your windows version is Windows XP or below. You can check if it is possible to call create_resource_section by calling $exe->can_create_resource_section. After calling create_resource_section, the original Win32::Exe object does not reference the updated data. The method therefore returns a reference to a new Win32::Exe object that references the updated data. Always call as : $exe = $exe->create_resource_section if $exe->can_create_resource_section; if the $exe already has a resource section, this call will safely return a reference to the original object without updating the original exe. =head2 can_create_resource_section $exe = $exe->create_resource_section if $exe->can_create_resource_section; Check if the operating system and version allow addition of a resource section when none exists in the target executable. =head2 get_manifest my $manifest = $exe->get_manifest; Retrieves a Win32::Exe::Manifest object. (See docs for Win32::Exe::Manifest) =head2 set_manifest $exe->set_manifest($manifest); $exe->write; Takes a Win32::Exe::Manifest object. You must explicitly call 'write' to commit changes to file. Also takes a filepath to an xml file containing raw manifest information. =head2 set_manifest_args $exe->set_manifest_args($argref); $exe->write; Accepts a reference to a hash with one or more of the the keys ExecutionLevel UIAccess ExecName Description CommonControls Version Also accepts a reference to an array of strings of the format: [ 'key1=value1', 'key2=value2' ] Example Values: ExecutionLevel=asInvoker UIAccess=false CommonControls=1 Version=6.8.67.334534 ExecName=My.Application Description=My Application The CommonControls argument can be specified to add a dependency on Common Controls Library version 6.0.0.0 =head2 get_version_info my $inforef = $exe->get_version_info; Returns a reference to a hash with the keys: Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename ProductName ProductVersion =head2 set_version_info $exe->set_version_info($inforef); $exe->write; Accepts a reference to a hash with one or more of the the keys Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename ProductName ProductVersion Also accepts a reference to an array of strings of the format: [ 'key1=value1', 'key2=value2' ] =head2 set_subsystem_windows $exe->set_subsystem_windows; $exe->write; Sets the executable system as 'windows'. (GUI). You may also call $exe->SetSubsystem('windows); This is the equivalent of $exe->update( gui => 1); =head2 set_subsystem_console $exe->set_subsystem_console; $exe->write; Sets the executable system as 'console'. You may also call $exe->SetSubsystem('console); This is the equivalent of $exe->update( console => 1); =head2 get_subsystem my $subsys = $exe->get_subsystem; Returns a descriptive string for the subsystem. Possible values: windows | console | posix | windowsce | native You can usefully update executables with the windows or console subsystem =head2 set_single_group_icon $exe->set_single_group_icon($iconfile); $exe->write; Accepts the path to an icon file. Replaces all the icons in the exec with the icons from the file. =head2 get_group_icon_names my @iconnames = $exe->get_group_icon_names; Returns a list of the names of all the group icons in the executable or dll. If there are no group icons, returns an empty list. The names returned can be used as parameters to other icon handling methods. =head2 get_group_icon $exe->get_group_icon($groupiconname); Accepts a group icon name as returned by get_group_icon_names. Returns the Wx::Exe::Resource::GroupIcon object for the named GroupIcon =head2 add_group_icon $exe->add_group_icon($groupiconname, $iconfilepath); $exe->write; Accepts a group icon name and a path to an icon file. Adds the icon to the exec without affecting existing icons. The group icon name must not already exist. =head2 replace_group_icon $exe->replace_group_icon($groupiconname, $iconfilepath); $exe->write; Accepts a group icon name and a path to an icon file. Replaces the groupicon named with the contents of the icon file. =head2 remove_group_icon $exe->remove_group_icon($groupiconname); $exe->write; Accepts a group icon name. Removes the group icon with that name from the exec or dll. =head2 export_group_icon $exe->export_group_icon($groupiconname, $iconfilepath); Accepts a group icon name and a .ico filepath. Writes the named icon group to the file in filepath. =cut use strict; use base 'Win32::Exe::Base'; use constant FORMAT => ( Magic => 'a2', # "MZ" _ => 'a58', PosPE => 'V', _ => 'a{($PosPE > 64) ? $PosPE - 64 : "*"}', PESig => 'a4', Data => 'a*', ); use constant DELEGATE_SUBS => ( 'IconFile' => [ 'dump_iconfile', 'write_iconfile' ], ); use constant DISPATCH_FIELD => 'PESig'; use constant DISPATCH_TABLE => ( "PE\0\0" => "PE", '*' => sub { die "Incorrect PE header -- not a valid .exe file" }, ); use constant DEBUG_INDEX => 6; use constant DEBUG_ENTRY_SIZE => 28; use File::Basename (); use Win32::Exe::IconFile; use Win32::Exe::DebugTable; use Win32::Exe::Manifest; sub is_application { ( $_[0]->is_assembly ) ? 0 : 1; } sub is_assembly { $_[0]->Characteristics & 0x2000; } sub has_resource_section { my ($self) = @_; my $section = $self->first_member('Resources'); return( $section ) ? 1 : 0; } sub can_create_resource_section { my $self = shift; return 0 if ($^O !~ /^mswin/i ); require Win32; my ($winstring, $winmajor, $winminor, $winbuild, $winid) = Win32::GetOSVersion(); return ( $winmajor > 5 ) ? 1 : 0; } sub create_resource_section { my $self = shift; return $self if($self->has_resource_section || ( $^O !~ /^mswin/i ) ); if(!$self->can_create_resource_section) { die('Cannot create resource section on this version of Windows'); } require Win32::Exe::InsertResourceSection; my $filename = (exists($self->{filename}) && (-f $self->{filename} )) ? $self->{filename} : undef; return $self if !$filename; if(my $newref = Win32::Exe::InsertResourceSection::insert_pe_resource_section($filename)) { return $newref; } else { return $self; } } sub resource_section { my ($self) = @_; my $section = $self->first_member('Resources'); return $section if $section; my $wmsg = 'No resource section found in file '; $wmsg .= $self->{filename} if(exists($self->{filename}) && $self->{filename}); warn $wmsg; return undef; } sub sections { my ($self) = @_; my $method = (wantarray ? 'members' : 'first_member'); return $self->members('Section'); } sub data_directories { my ($self) = @_; return $self->members('DataDirectory'); } sub update_debug_directory { my ($self, $boundary, $extra) = @_; $self->SetSymbolTable( $self->SymbolTable + $extra ) if ($boundary <= $self->SymbolTable); my @dirs = $self->data_directories; return if DEBUG_INDEX > $#dirs; my $dir = $dirs[DEBUG_INDEX] or return; my $size = $dir->Size; my $addr = $dir->VirtualAddress; return unless $size or $addr; my $count = $size / DEBUG_ENTRY_SIZE or return; (($size % DEBUG_ENTRY_SIZE) == 0) or return; foreach my $section ($self->sections) { my $offset = $section->FileOffset; my $f_size = $section->FileSize; my $v_addr = $section->VirtualAddress; next unless $v_addr <= $addr; next unless $addr < ($v_addr + $f_size); next unless ($addr + $size) < ($v_addr + $f_size); $offset += $addr - $v_addr; my $data = $self->substr($offset, $size); my $table = Win32::Exe::DebugTable->new(\$data); foreach my $dir ($table->members) { next unless $boundary <= $dir->Offset; $dir->SetOffset($dir->Offset + $extra); $dir->SetVirtualAddress($dir->VirtualAddress + $extra) if $dir->VirtualAddress > 0; } $self->substr($offset, $size, $table->dump); last; } } sub default_info { my $self = shift; my $filename = File::Basename::basename($self->filename); return join(';', "CompanyName= ", "FileDescription= ", "FileVersion=0.0.0.0", "InternalName=$filename", "LegalCopyright= ", "LegalTrademarks= ", "OriginalFilename=$filename", "ProductName= ", "ProductVersion=0.0.0.0", ); } sub update { my ($self, %args) = @_; if ($args{defaultmanifest}) { $self->add_default_manifest(); } if (my $manifest = $args{manifest}) { $self->set_manifest($manifest); } if (my $manifestargs = $args{manifestargs}) { $self->set_manifest_args($manifestargs); } if (my $icon = $args{icon}) { my @icons = Win32::Exe::IconFile->new($icon)->icons; $self->set_icons(\@icons) if @icons; } if (my $info = $args{info}) { $self->set_version_info( $info); } die "'gui' and 'console' cannot both be true" if $args{gui} and $args{console}; $self->SetSubsystem("windows") if $args{gui}; $self->SetSubsystem("console") if $args{console}; $self->write; } sub icons { my ($self) = @_; my $rsrc = $self->resource_section or return; my @icons = map $_->members, $rsrc->objects('GroupIcon'); wantarray ? @icons : \@icons; } sub set_icons { my ($self, $icons) = @_; my $rsrc = $self->resource_section; my $name = eval { $rsrc->first_object('GroupIcon')->PathName } || '/#RT_GROUP_ICON/#1/#0'; $rsrc->remove('/#RT_GROUP_ICON'); $rsrc->remove('/#RT_ICON'); my $group = $self->require_class('Resource::GroupIcon')->new; $group->SetPathName($name); $group->set_parent($rsrc); $rsrc->insert($group->PathName, $group); $group->set_icons($icons); $group->refresh; } sub version_info { my ($self) = @_; my $rsrc = $self->resource_section or return; # XXX - return a hash in list context? return $rsrc->first_object('Version'); } sub get_version_info { my $self = shift; my $vinfo = $self->version_info or return; my @keys = qw( Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename ProductName ProductVersion ); my $rval = {}; for my $key (@keys) { my $val = $vinfo->get($key); $val =~ s/,/\./g if(defined($val) && ( $key =~ /version/i ) ); $rval->{$key} = $val if defined($val); } return $rval } sub set_version_info { my ($self, $inputpairs) = @_; my $inputref; if(ref($inputpairs) eq 'HASH') { my @newinput = (); push(@newinput, qq($_=$inputpairs->{$_})) for (sort keys(%$inputpairs)); $inputref = \@newinput; } else { $inputref = $inputpairs; } my @info = ($self->default_info, @$inputref); my @pairs; foreach my $pairs (map split(/\s*;\s*(?=[\w\\\/]+\s*=)/, $_), @info) { my ($key, $val) = split(/\s*=\s*/, $pairs, 2); next if $key =~ /language/i; if ($key =~ /^(product|file)version$/i) { $key = "\u$1Version"; $val =~ /^(?:\d+\.)+\d+$/ or die "$key cannot be '$val'"; $val .= '.0' while $val =~ y/.,// < 3; push(@pairs, [ $key => $val ], [ "/StringFileInfo/#1/$key", $val ]); } else { push(@pairs, [ $key => $val ]); } } my $rsrc = $self->resource_section or return; my $version = $rsrc->first_object('Version') or return; $version->set(@$_) for @pairs; $version->refresh; } sub manifest { my ($self) = @_; my $rsrc = $self->resource_section or return; if( my $obj = $rsrc->first_object('Manifest') ) { return $obj; } else { return $self->require_class('Resource::Manifest')->new; } } sub has_manifest { my ($self) = @_; my $rsrc = $self->resource_section or return 0; if( my $obj = $rsrc->first_object('Manifest') ) { return 1; } else { return 0; } } sub set_manifest { my ($self, $input) = @_; # support code that passes xml, filepaths and objects my $resid = 0; my $xml; if(ref($input) && $input->isa('Win32::Exe::Manifest')) { $resid = $input->get_resource_id; $xml = $input->output ; } else { my $filecontent; eval { my $paramisfile = 0; { no warnings qw( io ); $paramisfile = (-f $input); } if($paramisfile) { open my $fh, '<', $input; $filecontent = do { local $/; <$fh> }; my $errors = $@; close($fh); die $errors if $errors; } else { $filecontent = $input; } }; $xml = ( $@ ) ? $input : $filecontent; } $resid ||= 1; my $rsrc = $self->resource_section; my $name = '/#RT_MANIFEST/#' . $resid . '/#0'; $rsrc->remove("/#RT_MANIFEST"); my $manifest = $self->require_class('Resource::Manifest')->new; $manifest->SetPathName( $name ); $manifest->set_parent( $rsrc ); $manifest->update_manifest( $xml ); $rsrc->insert($manifest->PathName, $manifest); $rsrc->refresh; } sub set_manifest_args { my ($self, $inputpairs) = @_; my $inputref; if(ref($inputpairs eq 'HASH')) { my @newinput = (); push(@newinput, qq($_ = $inputpairs->{$_})) for (sort keys(%$inputpairs)); $inputref = \@newinput; } else { $inputref = $inputpairs; } my @manifestargs = @$inputpairs; my %arghash; foreach my $pairs (map split(/\s*;\s*(?=[\w\\\/]+\s*=)/, $_), @manifestargs) { my ($key, $val) = split(/\s*=\s*/, $pairs, 2); my $addkey = lc($key); $arghash{$addkey} = $val; } my $manifest = $self->get_manifest; $manifest->set_execution_level($arghash{executionlevel}) if exists($arghash{executionlevel}); $manifest->set_uiaccess($arghash{uiaccess}) if exists($arghash{uiaccess}); $manifest->set_assembly_name($arghash{execname}) if exists($arghash{execname}); $manifest->set_assembly_description($arghash{description}) if exists($arghash{description}); $manifest->set_assembly_version($arghash{version}) if exists($arghash{version}); $manifest->add_common_controls() if $arghash{commoncontrols}; $self->set_manifest($manifest); } sub get_manifest { my ($self) = @_; my $mtype = ($self->is_assembly) ? 'assembly' : 'application'; my $mfestxml = $self->manifest->get_manifest; my $mfest = Win32::Exe::Manifest->new($mfestxml, $mtype); $mfest->set_resource_id( $self->manifest->get_manifest_id ); return $mfest; } sub add_default_manifest { my ($self) = @_; my $rsrc = $self->resource_section; my $name = '/#RT_MANIFEST/#1/#0'; $rsrc->remove("/#RT_MANIFEST"); my $manifest = $self->require_class('Resource::Manifest')->new; my $xml = $manifest->default_manifest; $manifest->SetPathName( $name ); $manifest->set_parent( $rsrc ); $manifest->update_manifest( $xml ); $rsrc->insert($manifest->PathName, $manifest); $rsrc->refresh; } sub merge_manifest { my ($self, $mnf) = @_; return if !(ref($mnf) && $mnf->isa('Win32::Exe::Manifest')); my $main = $self->get_manifest; $main->merge_manifest($mnf); $self->set_manifest($main); } sub set_subsystem_windows { my $self = shift; return if !$self->is_application; $self->SetSubsystem("windows") } sub set_subsystem_console { my $self = shift; return if !$self->is_application; $self->SetSubsystem("console") } sub get_subsystem { $_[0]->Subsystem; } sub get_group_icon_names { my $self = shift; my @names = (); my $section = $self->resource_section or return @names; for my $resource ( $section->objects('GroupIcon')) { my $path = $resource->PathName; my($_null, $_rtgi, $name, $_langid) = split(/\//, $path); push(@names, $name);# if $resource->isa('Win32::Exe::Resource::GroupIcon'); } return @names; } sub set_single_group_icon { my($self, $iconfile) = @_; my @icons = Win32::Exe::IconFile->new($iconfile)->icons; $self->set_icons(\@icons) if @icons; } sub get_group_icon { my ($self, $getname) = @_; return undef if !$getname; my $res = undef; my $section = $self->resource_section or return $res; $res = $self->_exists_group_icon($getname); return $res; } sub add_group_icon { my ($self, $newname, $filename) = @_; my $exists = 0; my $section = $self->resource_section or return; my ($res, $langid) = $self->_exists_group_icon($newname); return undef if $res; # it already exists my @icons = Win32::Exe::IconFile->new($filename)->icons; return if !(scalar @icons); my $group = $self->require_class('Resource::GroupIcon')->new; my $pathname = '/#RT_GROUP_ICON/' . $newname . '/' . $langid; $group->SetPathName($pathname); $group->set_parent($section); $section->insert($group->PathName, $group); $group->set_icons(\@icons); $group->refresh; } sub replace_group_icon { my ($self, $getname, $filename) = @_; my $section = $self->resource_section or return; my @icons = Win32::Exe::IconFile->new($filename)->icons; return if !(scalar @icons); my $group = $self->get_group_icon($getname) or return; my $pathname = $group->PathName; $section->remove($pathname); my $newgroup = $self->require_class('Resource::GroupIcon')->new; $newgroup->SetPathName($pathname); $newgroup->set_parent($section); $section->insert($newgroup->PathName, $newgroup); $newgroup->set_icons(\@icons); $newgroup->refresh; } sub remove_group_icon { my ($self, $matchname) = @_; my $section = $self->resource_section or return; my $existing = $self->get_group_icon($matchname) or return; $section->remove($existing->PathName); $section->refresh; } sub _exists_group_icon { my ($self, $matchname) = @_; my $section = $self->resource_section or return; my $langid = '#0'; my $res = undef; for my $resource ( $section->objects('GroupIcon')) { my $path = $resource->PathName; my($_null, $_rtgi, $name, $_langid) = split(/\//, $path); $langid = $_langid; if($name eq $matchname) { $res = $resource; last; } } return ( wantarray ) ? ( $res, $langid ) : $res; } sub export_group_icon { my ($self, $matchname, $filename) = @_; my $existing = $self->get_group_icon($matchname) or return; my $iconobject = Win32::Exe::IconFile->new(); my @icons = $existing->icons; $iconobject->set_icons(\@icons); $iconobject->write_file($filename, $iconobject->dump); } 1; __END__ =head1 AUTHORS Audrey Tang Ecpan@audreyt.orgE Mark Dootson Emdootson@cpan.orgE Steffen Mueller Esmueller@cpan.orgE =head1 COPYRIGHT Copyright 2004-2007, 2010 by Audrey Tang Ecpan@audreyt.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Win32-Exe-0.17/Makefile.PL000775000000000000 136611567442027 14726 0ustar00Mark Dootson000000000000#!/usr/bin/env perl # Copyright 2004, 2007, 2010 by Audrey Tang use ExtUtils::MakeMaker 6.46; WriteMakefile( NAME => 'Win32::Exe', VERSION_FROM => 'lib/Win32/Exe.pm', AUTHOR => 'Audrey Tang ', ABSTRACT => 'Manipulate Win32 executable files', LICENSE => 'perl', EXE_FILES => [ 'script/exe_update.pl' ], MIN_PERL_VERSION => '5.6.0', PREREQ_PM => { 'Parse::Binary' => 0.11, 'XML::Simple' => 2.18, 'XML::Parser' => 2.36, }, BUILD_REQUIRES => { 'Test::More' => 0, 'File::Copy' => 0 }, NORECURS => ( $^O =~ /^mswin/i ) ? 0 : 1, ); Win32-Exe-0.17/MANIFEST000664000000000000 234511567442026 14077 0ustar00Mark Dootson000000000000Changes insert/InsertResourceSection.xs insert/Makefile.PL insert/typemap insert/t/0-load.t insert/t/1-basic.t lib/Win32/Exe.pm lib/Win32/Exe/Base.pm lib/Win32/Exe/DataDirectory.pm lib/Win32/Exe/DebugDirectory.pm lib/Win32/Exe/DebugTable.pm lib/Win32/Exe/IconFile.pm lib/Win32/Exe/InsertResourceSection.pm lib/Win32/Exe/Manifest.pm lib/Win32/Exe/Manifest/Parser.pm lib/Win32/Exe/PE.pm lib/Win32/Exe/PE/Header.pm lib/Win32/Exe/PE/Header/PE32.pm lib/Win32/Exe/PE/Header/PE32Plus.pm lib/Win32/Exe/Resource.pm lib/Win32/Exe/Resource/GroupIcon.pm lib/Win32/Exe/Resource/Icon.pm lib/Win32/Exe/Resource/Manifest.pm lib/Win32/Exe/Resource/Version.pm lib/Win32/Exe/ResourceData.pm lib/Win32/Exe/ResourceEntry.pm lib/Win32/Exe/ResourceEntry/Id.pm lib/Win32/Exe/ResourceEntry/Name.pm lib/Win32/Exe/ResourceTable.pm lib/Win32/Exe/Section.pm lib/Win32/Exe/Section/Code.pm lib/Win32/Exe/Section/Data.pm lib/Win32/Exe/Section/Debug.pm lib/Win32/Exe/Section/Exports.pm lib/Win32/Exe/Section/Imports.pm lib/Win32/Exe/Section/Resources.pm Makefile.PL MANIFEST This list of files META.yml README script/exe_update.pl t/0-pod.t t/1-basic.t t/2-icon.t t/3-manifest.t t/4-execupdate.t t/hd.ico t/par.ico t/winexe32.exe t/winexe64.exe t/application.xml t/empty.xml Win32-Exe-0.17/META.yml000664000000000000 123111611376477 14216 0ustar00Mark Dootson000000000000--- #YAML:1.0 name: Win32-Exe version: 0.17 abstract: Manipulate Win32 executable files author: - Audrey Tang license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: File::Copy: 0 Test::More: 0 requires: Parse::Binary: 0.11 perl: 5.006000 XML::Parser: 2.36 XML::Simple: 2.18 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Win32-Exe-0.17/README000664000000000000 114611567442027 13625 0ustar00Mark Dootson000000000000This is the README file for Win32::Exe, a module for manipulating Win32 PE/COFF executable headers. Please type "perldoc Win32::Exe" after installation to see the module usage information. * Installation Win32::Exe uses the standard perl module install process: cpansign -v # optional; see SIGNATURE for details perl Makefile.PL make # or 'nmake' on Win32 make test make install * Copyright Copyright 2004-2010 by Audrey Tang . All rights reserved. You can redistribute and/or modify this bundle under the same terms as Perl itself. See . Win32-Exe-0.17/script/000775000000000000 011611376476 14173 5ustar00Mark Dootson000000000000Win32-Exe-0.17/script/exe_update.pl000775000000000000 1010111567442024 16740 0ustar00Mark Dootson000000000000#!/usr/local/bin/perl # Copyright 2004, 2006, 2010 by Audrey Tang use strict; use File::Basename; use Win32::Exe; use Getopt::Long; =head1 NAME exe_update.pl - Modify windows executable files =head1 SYNOPSIS B S<[ B<--gui> | B<--console> ]> S<[ B<--icon> I ]> S<[ B<--manifest> I ]> S<[ B<--info> I ]> I =head1 DESCRIPTION This program rewrites PE headers in a Windows executable file. It can change whether the executable runs with a console window, as well as setting the icons, manifest and version information associated with it. In general, a PE file must have an existing resource section or you cannot add icons, manifests or version info. However, on Win32 platforms a new resource section will be created if none exists. =head1 OPTIONS Options are available in a I form and a I form. For example, the three lines below are all equivalent: % exe_update.pl -i new.ico input.exe % exe_update.pl --icon new.ico input.exe % exe_update.pl --icon=new.ico input.exe =over 4 =item B<-c>, B<--console> Set the executable to always display a console window. =item B<-g>, B<--gui> Set the executable so it does not have a console window. =item B<-i>, B<--icon>=I Specify an icon file (in F<.ico>, F<.exe> or F<.dll> format) for the executable. =item B<-m>, B<--manifest>=I Specify a manifest file in F<.xml> format for the executable. =item B<-N>, B<--info>=I Attach version information for the executable. The name/value pair is joined by C<=>. You may specify C<-N> multiple times, or use C<;> to link several pairs. These special C names are recognized: Comments CompanyName FileDescription FileVersion InternalName LegalCopyright LegalTrademarks OriginalFilename ProductName ProductVersion =item B<-A>, B<--manifestargs>=I As an alternative to specifying a manifest file, specify manifest attributes. The name/value pair is joined by C<=>. You may specify C<-A> multiple times, or use C<;> to link several pairs. This option may be preferable to using a manifest file as these attributes will be combined with any existing manifest that may be in the executable. These special C names are recognized: ExecutionLevel UIAccess ExecName Description CommonControls Version The CommonControls key is a simple boolean value to indicate that the Common Controls Version 6.0.0.0 dependency should be added to the manifest. e.g --manifestargs="ExecutionLevel=requireAdministrator;ExecName=My.App;CommonControls=1" --manifestargs="Version=1.3.6.7895;UIAccess=false" =back =cut my $Options = {}; Getopt::Long::GetOptions( $Options, 'g|gui', # No console window 'c|console', # Use console window 'i|icon:s', # Icon file 'm|manifest:s', # manifest file 'N|info:s@', # Executable header info 'A|manifestargs:s@' # manifest arguments ); my $exe = shift or die "Usage: " . basename($0) . " [--gui | --console] [--icon file.ico] [--manifest file.xml] [--info key=value] [--manifestargs key=value ] file.exe\n"; my $exec = Win32::Exe->new($exe) or die "Unable to open file $exe"; if(!$exec->has_resource_section) { die("Cannot create new resource section on this platform. Requires Win32") if $^O !~ /^mswin/i; $exec->create_resource_section or die("Failed to create new resource section"); $exec = Win32::Exe->new($exe) or die "Unable to open file $exe"; } $exec->update( gui => $Options->{g}, console => $Options->{c}, icon => $Options->{i}, info => $Options->{N}, manifest => $Options->{m}, manifestargs => $Options->{A}, ) or die "Update of $exe failed!\n"; __END__ =head1 AUTHORS Audrey Tang Ecpan@audreyt.orgE =head1 COPYRIGHT Copyright 2004, 2006, 2010 by Audrey Tang Ecpan@audreyt.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Win32-Exe-0.17/t/000775000000000000 011611376476 13132 5ustar00Mark Dootson000000000000Win32-Exe-0.17/t/0-pod.t000664000000000000 20211567442024 14261 0ustar00Mark Dootson000000000000use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Win32-Exe-0.17/t/1-basic.t000775000000000000 523511567442024 14617 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use FindBin; #use lib "$FindBin::Bin/../inc"; #use lib "$FindBin::Bin/../lib"; #use lib "$FindBin::Bin/../../Parse-Binary/lib"; use Test::More tests => 43; $SIG{__DIE__} = sub { use Carp; Carp::confess(@_) }; $SIG{__WARN__} = sub { use Carp; Carp::cluck(@_) }; use_ok('Win32::Exe'); for ( qw( 32 64 ) ) { my $PEtype = $_; my $file = "$FindBin::Bin/winexe$PEtype.exe"; my @expectedsections = ( $PEtype == 32 ) ? qw( .text .data .rdata .bss .idata .rsrc ) : qw( .text .data .rdata .bss .idata .CRT .tls .rsrc); my $expectedheadersize = ( $PEtype == 32 ) ? 224 : 240; ok(my $orig = Win32::Exe->read_file($file), 'read_file'); my $exe = Win32::Exe->new($file); is($exe->ExpectedOptHeaderSize, $expectedheadersize, qq(Type $PEtype expected headersize)); isa_ok($exe, 'Win32::Exe'); is($exe->dump, $orig, qq(rountrip PE type $PEtype)); is($exe->Subsystem, 'console', 'Subsystem'); $exe->SetSubsystem('windows'); is($exe->Subsystem, 'windows', 'SetSubsystem'); $exe->SetSubsystem('CONSOLE'); is($exe->Subsystem, 'console', 'SetSubsystem with uppercase string'); is_deeply( [map $_->Name, $exe->sections], [ @expectedsections ], 'sections' ); $exe->refresh; is($exe->dump, $orig, qq(roundtrip after refresh 1 $PEtype)); my ($sections) = $exe->sections; isa_ok($sections, 'Win32::Exe::Section'); $sections->refresh; is($exe->dump, $orig, qq(roundtrip after refresh 2 $PEtype)); my $rsrc = $exe->resource_section; isa_ok($rsrc, 'Win32::Exe::Section::Resources'); $rsrc->refresh; is($exe->dump, $orig, qq(roundtrip after refresh 3 $PEtype)); my @expectresources = ('/#RT_GROUP_ICON/#1/#0', '/#RT_ICON/#1/#0', '/#RT_ICON/#2/#0', '/#RT_MANIFEST/#1/#0', '/#RT_VERSION/#1/#0',); is_deeply( [$rsrc->names], [ @expectresources ], qq(resource names : $PEtype) ); my $group = $rsrc->first_object('GroupIcon'); my $expectginame = '/#RT_GROUP_ICON/#1/#0'; is($group->PathName, $expectginame, 'group pathname'); my $version = $rsrc->first_object('Version'); is($version->info->[0], 'VS_VERSION_INFO', 'version->info'); is($version->get('FileVersion'), '0,0,0,0', 'version->get'); $version->set('FileVersion', '1,0,0,0'); is($version->get('FileVersion'), '1,0,0,0', 'version->set took effect'); $version->refresh; is($version->get('FileVersion'), '1,0,0,0', 'version->set remains after refresh'); isnt(($exe->dump), $orig, qq(dump changed after resource refresh 4 $PEtype)); $orig = $exe->dump; is(($exe->dump), $orig, qq(roundtrip after refresh 5 $PEtype)); } 1; Win32-Exe-0.17/t/2-icon.t000775000000000000 350511567442024 14465 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use FindBin; #use lib "$FindBin::Bin/../inc"; #use lib "$FindBin::Bin/../lib"; #use lib "$FindBin::Bin/../../Parse-Binary/lib"; use Test::More tests => 27; $SIG{__DIE__} = sub { use Carp; Carp::confess(@_) }; $SIG{__WARN__} = sub { use Carp; Carp::cluck(@_) }; use_ok('Win32::Exe::IconFile'); for ( qw( 32 64) ) { my $PEtype = $_; my $hd_icon = "$FindBin::Bin/hd.ico"; my $par_icon = "$FindBin::Bin/par.ico"; my $exe_file = "$FindBin::Bin/winexe$PEtype.exe"; ok(my $par_orig = Win32::Exe::IconFile->read_file($par_icon), 'read_file'); my $ico = Win32::Exe::IconFile->new($par_icon); isa_ok($ico, 'Win32::Exe::IconFile'); is($ico->dump, $par_orig, 'roundtrip'); is($ico->dump_iconfile, $par_orig, 'roundtrip with dump_iconfile'); my ($icon1, $icon2) = $ico->icons; is(length($icon1->Data), $icon1->ImageSize, 'Image1 size fits'); is(length($icon2->Data), $icon2->ImageSize, 'Image2 size fits'); my $exe = Win32::Exe::IconFile->new($exe_file); isa_ok($exe, 'Win32::Exe'); is($exe->dump_iconfile, $par_orig, 'roundtrip with dump_iconfile'); $exe->set_icons(scalar $ico->icons); is($exe->dump_iconfile, $par_orig, 'roundtrip after set_icons'); ok(my $hd_orig = Win32::Exe::IconFile->read_file($hd_icon), 'read_file'); my $ico_hd = Win32::Exe::IconFile->new($hd_icon); $exe->set_icons(scalar $ico_hd->icons); if($_ == 32) { is(length($exe->dump), 13824, 'dump size correct after set_icons'); } else { is(length($exe->dump), 20992, 'dump size correct after set_icons'); } my $bad_icon = eval { Win32::Exe->new($par_icon) }; is($bad_icon, undef, 'Win32::Exe->new($icon) should raise an exception'); like($@, qr/Incorrect PE header -- not a valid \.exe file/, 'exception wording is correct'); } Win32-Exe-0.17/t/3-manifest.t000775000000000000 2222211567442024 15361 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use FindBin; #use lib "$FindBin::Bin/../inc"; #use lib "$FindBin::Bin/../lib"; #use lib "$FindBin::Bin/../../Parse-Binary/lib"; use Test::More tests => 136; use File::Copy; use Config; $SIG{__DIE__} = sub { use Carp; Carp::confess(@_) }; $SIG{__WARN__} = sub { use Carp; Carp::cluck(@_) }; use_ok('Win32::Exe'); use_ok('Win32::Exe::Manifest'); for ( qw( 32 64 ) ) { my $PEtype = $_; my $cansafelyexecute = ($^O !~ /^mswin/i) ? 0 : ($PEtype == 32) ? 1 : ( exists($ENV{PROCESSOR_ARCHITECTURE}) && $ENV{PROCESSOR_ARCHITECTURE} =~ /64/ ) ? 1 : 0; my $bindir = $FindBin::Bin; my $parexe = "$bindir/winexe$_.exe"; my $testexe = "$bindir/testexe$_.exe"; my $extendedexe = "$bindir/extendedexe$_.exe"; File::Copy::copy($parexe, $testexe); my $exe = Win32::Exe->new($testexe); isa_ok($exe, 'Win32::Exe', qq(Win32::Exe $PEtype)); my $manifest = $exe->manifest(); isa_ok($manifest, 'Win32::Exe::Resource::Manifest', qq(Win32::Exe::Resource::Manifest $PEtype)); my $xml = $manifest->default_manifest; ok($exe->update( 'manifest' => $xml ), qq(update $PEtype)); unlink $testexe; File::Copy::copy($parexe, $extendedexe); my $testexecname = qq($bindir/manifesttest.exe); # get the xml file content open my $fh, '<', qq($bindir/application.xml); my $appxml = do { local $/; <$fh> }; close($fh); open $fh, '<', qq($bindir/empty.xml); my $emptyxml = do { local $/; <$fh> }; close($fh); $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe'); ok($exe->has_manifest, qq($PEtype has manifest)); my $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest $PEtype)); is( $mnf->get_resource_id, 1, qq(First check resource id $PEtype) ); is( $mnf->get_assembly_name, 'Win32.Exe.Test', qq(First check manifest name $PEtype) ); is( $mnf->get_assembly_version, '1.0.0.0', qq(First check manifest version $PEtype) ); is( $mnf->get_assembly_language, '*', qq(First check manifest language $PEtype) ); is( $mnf->get_assembly_architecture, '*', qq(First check manifest architecture $PEtype) ); is( $mnf->get_execution_level, 'asInvoker', qq(First check execution level $PEtype) ); is( $mnf->get_uiaccess, 'false', qq(First check ui access $PEtype) ); my @deps = $mnf->get_dependencies; is_deeply( \@deps, [ { type => 'win32', name => 'Microsoft.Windows.Common-Controls', version => '6.0.0.0', processorArchitecture => '*', publicKeyToken => '6595b64144ccf1df', language => '*' } ], qq($PEtype get dependencies) ); my $newmnf = Win32::Exe::Manifest->new($emptyxml, 'application'); $newmnf->set_resource_id(2); $exe->set_manifest($newmnf); $exe->write; undef $exe; $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe', 'AFTER WRITE'); ok($exe->has_manifest, qq($PEtype has manifest after write)); $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest after write $PEtype)); is( $mnf->get_resource_id, 2, qq(Empty check resource id $PEtype) ); is( $mnf->get_assembly_name, 'My.Empty.Application', qq(Empty check manifest name $PEtype) ); is( $mnf->get_assembly_version, '2.0.0.0', qq(Empty check manifest version $PEtype) ); is( $mnf->get_assembly_language, '*', qq(Empty check manifest language $PEtype) ); is( $mnf->get_assembly_architecture, '*', qq(Empty check manifest architecture $PEtype) ); is( $mnf->get_execution_level, 'none', qq(Empty check execution level $PEtype) ); is( $mnf->get_uiaccess, undef, qq(Empty check ui access $PEtype) ); @deps = $mnf->get_dependencies; is(scalar(@deps), 0, qq(Empty check dependencies $PEtype) ); my $arch = ( $PEtype == 64 ) ? 'amd64' : 'x86'; $mnf->set_execution_level('requireAdministrator'); $mnf->add_common_controls; $mnf->set_assembly_name('Enhanced.App'); $mnf->set_assembly_version('1.2.3.4'); $mnf->set_assembly_architecture($arch); $mnf->set_resource_id(3); $mnf->set_compatibility('Windows Vista'); $exe->set_manifest($mnf); $exe->write; undef $exe; $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe', 'AFTER UPDATE'); ok($exe->has_manifest, qq($PEtype has manifest after update)); $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest after update $PEtype)); is( $mnf->get_resource_id, 3, qq(Write check resource id $PEtype) ); is( $mnf->get_assembly_name, 'Enhanced.App', qq(Write check manifest name $PEtype) ); is( $mnf->get_assembly_version, '1.2.3.4', qq(Write check manifest version $PEtype) ); is( $mnf->get_assembly_language, '*', qq(Write check manifest language $PEtype) ); is( $mnf->get_assembly_architecture, $arch, qq(Write check manifest architecture $PEtype) ); is( $mnf->get_execution_level, 'requireAdministrator', qq(Write check execution level $PEtype) ); is( $mnf->get_uiaccess, 'false', qq(Write check ui access $PEtype) ); @deps = $mnf->get_dependencies; is_deeply( \@deps, [ { type => 'win32', name => 'Microsoft.Windows.Common-Controls', version => '6.0.0.0', processorArchitecture => '*', publicKeyToken => '6595b64144ccf1df', language => '*' } ], qq($PEtype get dependencies after update) ); my @compat = $mnf->get_compatibility; is_deeply( \@compat, [ qw( {e2011457-1546-43c5-a5fe-008deee3d3f0} ) ], qq($PEtype get compatibility after update) ); $mnf->remove_dependency('Microsoft.Windows.Common-Controls'); $mnf->set_resource_id(1); $mnf->set_execution_level('asInvoker'); $exe->set_manifest($mnf); $exe->write; undef $exe; $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe', 'AFTER CHANGE'); ok($exe->has_manifest, qq($PEtype has manifest after change)); $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest after change $PEtype)); is( $mnf->get_resource_id, 1, qq(Changed check resource id $PEtype) ); is( $mnf->get_execution_level, 'asInvoker', qq(Changed check execution level $PEtype) ); is( $mnf->get_uiaccess, 'false', qq(Changed check ui access $PEtype) ); @deps = $mnf->get_dependencies; is(scalar(@deps), 0, qq(Changed check dependencies $PEtype) ); $mnf->set_execution_level('none'); $mnf->set_dpiaware('false'); $mnf->set_assembly_description('Some Descriptive String For Application'); $exe->set_manifest($mnf); $exe->write; undef $exe; $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe', 'AFTER DPIWARE'); ok($exe->has_manifest, qq($PEtype has manifest after dpiaware)); $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest after dpiaware $PEtype)); is( $mnf->get_resource_id, 1, qq(dpiaware check resource id $PEtype) ); is( $mnf->get_execution_level, 'none', qq(dpiaware check execution level $PEtype) ); is( $mnf->get_uiaccess, undef, qq(dpiaware check ui access $PEtype) ); is( $mnf->get_dpiaware, 'false', qq(dpiaware check dpiaware $PEtype) ); is( $mnf->get_assembly_description, 'Some Descriptive String For Application', qq(dpiaware check description $PEtype) ); my $mrsrc = $exe->manifest; ok($mrsrc, qq($PEtype got manifest resource)); my $mtext = $mrsrc->get_manifest; ok( ($mtext !~/trustInfo/), qq($PEtype no trustInfo)); ok( ($mtext =~/asmv3:application/), qq($PEtype application namespace)); ok( ($mtext =~/asmv3:windowsSettings/), qq($PEtype windowsSettings namespace)); #--- $exe->set_manifest_args(['ExecutionLevel=asInvoker;ExecName=A.New.Name;Description=A New Name;Version=100.200.300.400;CommonControls=1']); $exe->write; undef $exe; $exe = Win32::Exe->new($extendedexe); isa_ok($exe, 'Win32::Exe', 'Starting manifest args check'); ok($exe->has_manifest, qq($PEtype has manifest after margs)); $mrsrc = $exe->manifest; ok($mrsrc, qq($PEtype got manifest resource)); $mtext = $mrsrc->get_manifest; $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest after margs $PEtype)); is( $mnf->get_execution_level, 'asInvoker', qq(margs check execution level $PEtype) ); is( $mnf->get_uiaccess, 'false', qq(margs check ui access $PEtype) ); is( $mnf->get_assembly_description, 'A New Name', qq(margs check description $PEtype) ); is( $mnf->get_assembly_name, 'A.New.Name', qq(margs check description $PEtype) ); is( $mnf->get_assembly_version, '100.200.300.400', qq(margs check description $PEtype) ); ok( ($mtext =~ /6595b64144ccf1df/), qq($PEtype has common controls)); SKIP: { skip qq(Cannot Execute $PEtype bit Windows application on this architecture), 1 if !$cansafelyexecute; like( qx($extendedexe 2>&1), qr/^Win32::Exe Test Executable$/, qq(Execute $PEtype bit executable) ); } unlink($extendedexe); } 1; Win32-Exe-0.17/t/4-execupdate.t000775000000000000 1002611567442024 15702 0ustar00Mark Dootson000000000000#!/usr/bin/perl -w use strict; use FindBin; #use lib "$FindBin::Bin/../inc"; #use lib "$FindBin::Bin/../lib"; #use lib "$FindBin::Bin/../../Parse-Binary/lib"; use Test::More tests => 46; use File::Copy; use Config; $SIG{__DIE__} = sub { use Carp; Carp::confess(@_) }; $SIG{__WARN__} = sub { use Carp; Carp::cluck(@_) }; use_ok('Win32::Exe'); use_ok('Win32::Exe::Manifest'); use Win32::Exe; my $perl = $^X; my $exeupdate = qq($FindBin::Bin/../blib/script/exe_update.pl); for ( qw( 32 64 ) ) { my $PEtype = $_; my $cansafelyexecute = ($^O !~ /^mswin/i) ? 0 : ($PEtype == 32) ? 1 : ( exists($ENV{PROCESSOR_ARCHITECTURE}) && $ENV{PROCESSOR_ARCHITECTURE} =~ /64/ ) ? 1 : 0; my $bindir = $FindBin::Bin; my $parexe = "$bindir/winexe$_.exe"; my $testexe = "$bindir/updatetestexe$_.exe"; File::Copy::copy($parexe, $testexe); my $testinfo = { Comments => 'Some Test Comments', CompanyName => 'Test Company', FileDescription => 'A file description', FileVersion => '7.8.9.10', InternalName => 'falsename.exe', LegalCopyright => 'Copyright Me', LegalTrademarks => 'Trademark Hopeful', OriginalFilename => 'anotherfalsename.exe', ProductName => 'Win32-Exe-Update', ProductVersion => '21.22.23.24', }; my $manifestargs = { ExecName => 'My.Test.Application', Description => 'My App Description', ExecutionLevel => 'asInvoker', CommonControls => 1, Version => '5.4.3.2', }; my $iconfile = "$FindBin::Bin/hd.ico"; my $pathquote = ($^O =~ /^mswin/i) ? '"' : ''; my $iconparam = '--icon=' . $pathquote . $iconfile . $pathquote; my @args = ( $exeupdate, '--console', $iconparam); foreach my $infoarg ( sort keys (%$testinfo)) { push(@args, '--info=' . $infoarg . '=' . $testinfo->{$infoarg}); } foreach my $marg ( sort keys (%$manifestargs)) { push(@args, '--manifestargs=' . $marg . '=' . $manifestargs->{$marg}); } push(@args, $testexe); my $result = system($perl, @args); is( $result, '0', qq(Check exec $PEtype bit)); my $exe = Win32::Exe->new($testexe); isa_ok($exe, 'Win32::Exe'); ok($exe->has_manifest, qq($PEtype has manifest)); my $mnf = $exe->get_manifest; isa_ok($mnf, 'Win32::Exe::Manifest', qq(ISA Win32::Exe::Manifest $PEtype)); my $inforef = $exe->get_version_info; foreach my $infoarg ( sort keys (%$testinfo)) { # 10 tests is($inforef->{$infoarg}, $testinfo->{$infoarg}, qq($PEtype bit info $infoarg)); } is($exe->get_subsystem, 'console', qq($PEtype bit subsystem)); is( $mnf->get_assembly_name, $manifestargs->{ExecName}, qq(manifest name $PEtype bit) ); is( $mnf->get_assembly_version, $manifestargs->{Version}, qq(manifest version $PEtype bit) ); is( $mnf->get_assembly_description, $manifestargs->{Description}, qq(manifest description $PEtype bit) ); is( $mnf->get_execution_level, $manifestargs->{ExecutionLevel}, qq(manifest execution level $PEtype bit) ); is( $mnf->get_uiaccess, 'false', qq(manifest ui access $PEtype bit) ); my $dep = $mnf->get_dependency('Microsoft.Windows.Common-Controls'); is_deeply( $dep, { type => 'win32', name => 'Microsoft.Windows.Common-Controls', version => '6.0.0.0', processorArchitecture => '*', publicKeyToken => '6595b64144ccf1df', language => '*' } , qq($PEtype bit Common Controls) ); SKIP: { skip qq(Cannot Execute $PEtype bit Windows application on this architecture), 1 if !$cansafelyexecute; like( qx($testexe 2>&1), qr/^Win32::Exe Test Executable$/, qq(Execute $PEtype bit executable) ); } unlink $testexe; } 1; Win32-Exe-0.17/t/application.xml000664000000000000 302511567442024 16230 0ustar00Mark Dootson000000000000 My Test Application false Win32-Exe-0.17/t/empty.xml000664000000000000 34611567442024 15046 0ustar00Mark Dootson000000000000 Win32-Exe-0.17/t/hd.ico000664000000000000 1307611567442024 14321 0ustar00Mark Dootson000000000000@@((@B!!)!!!!!!!)!!1!!J1!!)))))1))9))B))J1)B9)cB))11111911B11J1191kB1199999B99J99R99BB9B9B9BBBBBJBBRBBcBBkJBBJJJJJRJJZJJ{ZJRRRZRRcRRRRZRZRRZRZZZZZcZZkZZkcZcZkZcsZcccccckccsccskckcksck{ckkkkskk{kkkk{sksksk{kssss{ssssss{s{ss{{{{{{{{1{Ƶƽν"""!""""""""""""()(())))(()))//))//0,,///00//0000000 BKQYK;))())))"#07BCCJBBB()7;()))))))))(,BCCBJOIJJJKYZB:BKKKC!!":CB;BBBCJCKJ)":))))))JJJQJJCJQY;:CJKNB!6;::;BBBCCCJJJJ!)):!)/!-/-/JJJWl%PJJJQYB:CCKNB )6667:;BBBCJJCJKJ!)):/!,!,!/!,!)JKKRO>QNKJJQZB:CJQQB)0677;:BBBBBCJDJJ!)):/!/!-!/"0!/KJJRQQQQNJCKZB!:JJQT:1)167:::BBBCCJKJKJ!/):0!0!0!0!0!/JKJYQQQRQJCKYJ(111: "#))B;;;C) )))"""KQLNQK6776)17+#ijAQ{v|vttrrssqsqqqpppoppnpmnnnnkmmjjjjiigggggfggffcffdmgd`BBwYcrsttsstssqqqqpqponidcZ_ZZ`cfjjjiigggggfddedfdc`1)Xd76{qtvtttssqrqssqndg|vddgigggfgdffeffcced5/t{qwuttvqtrsssjq|idgggggfggdddcdf`d/"{wwwwwtutttttkvgfmnppppnmjg`_n||udggggfdfdeffddd(wwwwwutvvtvtjohpqqqqnnnnpnnmjmjnjdgw|`iiggfffdfdcd qw{{wwwutuswjqsrqsqqqnonnnnnmjjmjmjjjdvndggggfffdd`jw{wwwwwunisttrtqqqsqpoqnnqnnmnmkkkjjjic|cggfgfeedY g{{xww{unnusttstrsqssqqonppnnnnmmmjjjjjjdq|dgiffdffQ`|{wwwws|vwwutvtrsqrqqsqqqpponnmnnnmmmmjiiig|wghgiffdJX|{xww|wtwwtttttststrqqqppqnopnmnnnkmjjjjijgrnghgifgBJ{{{{ww{wwwwvvtvtvstrqqqpqqppnnnpnmmmjkjmjijjniigggi:A|{||v|w{w{vuvvuttvvstsqsqsqpnnnpnnpnmnkjkjjjijjdjiggj66||||k|{{x{w{twtttvvtvtqigjjfhnpnoppnnnnnmnjmjjj`fgiij0)||{g`|{wwwwwwwvvttusqnnnnnopnnnmnkjjjmjYBjjgj((||Bn|{{x{{{{uwwvwvp|mm{jppnnpmnnnkmmmii/qggg!t||/|||w{x{w{vwvuvjssstsqj|ppnnpnmmnnkmjjq!sggfn||"|{|wxwx{{wwwvtqtvssqsqqptspponpnpnmnmmnjtsig`j |||||||{wwuvnivvttstsqqsqt`Jppononnnpnmnmv sjiYd|/||{|||wwwwwvtI|wttttsrrqrt"coqqpnnnnpnnkmtqjjQ_|fp||||||x{{{wX|wutvtttstr|/{qppponnnnnmmjgAmjjJQ6||||xxw{w||qwtustttqp|vqqqqpnnnnmnnnj0qjjnAIP||||{{||wxww{tvqvtttqqnstqqqqpqppnnpmqPnjjq9AI}||||{|www{{vttqptqqqqqppoopnnnncpmmnq56|t|||||{|www{wwvwtssttssqqtspqqqqppnnv wnqmo/5YPt||||{{{ww{{{wwwwtuttttqssqqqqqqpqnn{qJ tn#/v{m5{||}|||||{xxw{{wwwuvutttttqqqpqqqop{v)Ijj(q|||||{{w{{w{wwwwtutsstrsqtqqpqoqpwtmmmfk||||||||||w{{{wwwwuvwwvtrqqsspqpqqtvnnm`g|||||{{|{{wwwvwvvwvtttttstsqsppiqnnnYd||||||{|x|w{{wuwwvvvvvttssqqspf5qpnpQ_||{{|{xwxwwwvvt|stvttrqrqqqcIqpqqIQ||||wtvqwvttrsttqqJYpqos:J|}|||{w{wx{wwwwwtsptssttttqs/fopnw6A}||{{{{w|{wwwwvtnwttstrtqv!jnpnu09||{||w||{wwvttppvtsttttvwpppq./wwttttttr| |pqpn(tntttssspppi)ptwutwvtttqppdj0  wwttvvttsqq_f99A  IAAAA5{wwvvttvs{ttsX`Y/55!///5/ A_99w{{vttts|vsqvPYgsccm5vpsIfvfmcXfpfm9w{vvvvtrp)utt{BQdnI!(/ !!()!"(( !)@/!6{wwwwvvt_wttq{:I}|||||{{{wvvttw|swwq{6I"|||{|{||{{wvvwts{0{v("|||{{{|||{{|{{vwvwvts( wq@|||||ww{wvtwvvtqppqp ?????????Win32-Exe-0.17/t/par.ico000664000000000000 706611567442024 14472 0ustar00Mark Dootson000000000000h& ( BBBnnnsssXXXkkkFFF qqq444555ZZZ mmm ///MMMDDDPPP<<<ddd222 AAAAAAAAAAAAAA5@#A1CAADE.<&5&"1  ".!. !"##%&'%EA   1A( @  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~444<<<<<<<<<<<<<<<<<<<<<, \Դ4Qd4QQd4QQQd4QQQQd쬌Ĕܼ4QQQQQdQdL4,\Qܼ4QQQQQQdQtlltܼ4dQԌtܤQܼ4d܌||ltܴ4\Ԝ\size == sizeof(W32_EH_SHARED)../../gcc-3.4.5/gcc/config/i386/w32-shared-ptr.cGetAtomNameA (atom, s, sizeof(s)) != 0PPRPhPRPPS,Q8QDQPQ`QrQQQQQQQQQQQQRRR"R,R6R>RHRTRbR8QDQPQ`QrQQQQQQQQQQQQRRR"R,R6R>RHRTRbRAddAtomAFindAtomAGetAtomNameAVirtualProtect!VirtualQuery7__getmainargsM__p__environO__p__fmodec__set_app_type_assert_cexit _iob_onexit_setmodeGabortNatexitqfreeyfwritemallocmemcpymemsetputssignalvfprintfExitProcessSetUnhandledExceptionFilterPPPPPKERNEL32.dllPPPPPPPPPPPPPPPPPPPmsvcrt.dll(P(PKERNEL32.dll0Ph 0P@`a"ahfoYr@h ( BBBnnnsssXXXkkkFFF qqq444555ZZZ mmm ///MMMDDDPPP<<<ddd222 AAAAAAAAAAAAAA5@#A1CAADE.<&5&"1  ".!. !"##%&'%EA   1A( @  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~444<<<<<<<<<<<<<<<<<<<<<, \Դ4Qd4QQd4QQQd4QQQQd쬌Ĕܼ4QQQQQdQdL4,\Qܼ4QQQQQQdQtlltܼ4dQԌtܤQܼ4d܌||ltܴ4\Ԝ\ Win32.Exe.Test @4VS_VERSION_INFO?StringFileInfo|040904E4$CompanyName ,FileDescription $FileVersion $InternalName (LegalCopyright ,LegalTrademarks ,OriginalFilename $ProductName (ProductVersion DVarFileInfo$Translation Win32-Exe-0.17/t/winexe64.exe000664000000000000 4500011567442024 15376 0ustar00Mark Dootson000000000000MZ@ !L!This program cannot be run in DOS mode. $PEd~K/ * 0@ `08.text P`.data0 @P.rdata@"@P@.bss P`.idata0` &@0.CRThp0@@.tlsH2@`.rsrc84@0HHH8&@D L?H?H ??H?HD$ ?H8H(f=MZ????ty1 ??tWMH?HHHHHZR_ ?t ?t{1H(@@Hc%HH8PEiPHHf tSf OBDE/fDH Q ?1H(fy\1DAU1 ATUWVSHD%>HT$ EHHeH%0HX1HGHt5H9YH=P1 H9EHHjGHuߋgG1ۃ0VGn=>G%u 1HGHHt E11H PH^= H J-HOHHY-HlOHt H D~=EttHP1H„t.t*H ~˃"DDH uD$\HHF H!F F-<11MHcHI1H=<~AH hDhMcLaIHMHHR9HcHHD<IH OL%&< <HL<H<"D<;ED ;Eu ;HĘ[^_]A\A]DD$` fD:EEHy[H b[DHM!Hi[H J[DSzH #+HfH +HH +_MHfDH(2; H(d@H(; H(D@VSHH(H=w;=rt1ҹH)Ht7иH([^Ð===tH:1HtH(H[^@===u1ҹ HHt H([^=th=u1ҹHHeH([^1=t=@-f.fDat  <f!H( H )1H(Ð%VK%FK%J%J%J%JH1HDH(ttH(f H(ÐVSH(=t tt?H([^ÐHiXH5bXH9tHHtHH9uH([^9 뺐HHJHHHH@HHHÐSHH0H AHHD$(tvH @H @HD$(HT$(LD$ HHD$ HL$(HHL$ H@uH@tHH0[H>JHH0H[fDH(GHH(ÐHhH\$@Ht$HH|$PHl$XLd$`9vnH'HqLa HiHyH'HH`IILd$0Hl$(H|$ 1H\$@Ht$HH|$PHl$XLd$`HhfDH'HcHH&@H&t@Hi&d@H&T@H&D@H&4H1HÐVSHH8HD$XHT$XLD$`LL$hHD$(H 2'LH`AHt$(HH`HIHxMH\$`Ht$hLH|$pHHuH\$`Ht$hH|$pHxHT$ A0GHtgD$DuHHf5tHH>H=5nH HH55uH HH 5uH >5H5fffff.H4tH4Hf.H(H HHtH HPH@H Hu4t'H 4Htx4=H_4H(ÐHHV4H\$(Ht$0H|$8Hl$@uH\$(Ht$0H|$8Hl$@HHDH 94=HT4Ht;H==H5-=f HօuHt HCHH[HuH1=H\$(H 3Ht$0H|$8Hl$@HH@H(tGru+H(ft3uH 3^3\<fDJ3t<3H(fH I3<ېSH 3u1H [H 3;H 43Ht9u>9t)HHIHuH 2,<1H [HAHBCHAH2@H82H\$ Ht$(HH|$0΅uH\$ Ht$(H|$0H8f.HǸHtH M27H_-;Hb2H 32H=T2HGn;1됐Hf9MZt1HHcAcallocGexitUfprintf[freecfwritemallocmemcpyputssignalstrlenstrncmpvfprintf```````````````````````````KERNEL32.dll````````````````````````````msvcrt.dll@`@0@@@A@D@PP@@p@0Ph 0P@`"hY@h ( BBBnnnsssXXXkkkFFF qqq444555ZZZ mmm ///MMMDDDPPP<<<ddd222 AAAAAAAAAAAAAA5@#A1CAADE.<&5&"1  ".!. !"##%&'%EA   1A( @  !!!"""###$$$%%%&&&'''((()))***+++,,,---...///000111222333444555666777888999:::;;;<<<===>>>???@@@AAABBBCCCDDDEEEFFFGGGHHHIIIJJJKKKLLLMMMNNNOOOPPPQQQRRRSSSTTTUUUVVVWWWXXXYYYZZZ[[[\\\]]]^^^___```aaabbbcccdddeeefffggghhhiiijjjkkklllmmmnnnooopppqqqrrrssstttuuuvvvwwwxxxyyyzzz{{{|||}}}~~~444<<<<<<<<<<<<<<<<<<<<<, \Դ4Qd4QQd4QQQd4QQQQd쬌Ĕܼ4QQQQQdQdL4,\Qܼ4QQQQQQdQtlltܼ4dQԌtܤQܼ4d܌||ltܴ4\Ԝ\ Win32.Exe.Test @4VS_VERSION_INFO?StringFileInfo|040904E4$CompanyName ,FileDescription $FileVersion $InternalName (LegalCopyright ,LegalTrademarks ,OriginalFilename $ProductName (ProductVersion DVarFileInfo$Translation