package Win32::Exe;
$Win32::Exe::VERSION = '0.11';
=head1 NAME
Win32::Exe - Manipulate Win32 executable files
=head1 VERSION
This document describes version 0.10 of Win32::Exe, released
January 14, 2007.
=head1 SYNOPSIS
use Win32::Exe;
my $exe = Win32::Exe->new('c:/windows/notepad.exe');
# Get version information
print $exe->version_info->get('FileDescription'), ": ",
$exe->version_info->get('LegalCopyright'), "\n";
# Dump icons in an executable
foreach my $icon ($exe->icons) {
printf "Icon: %s x %s (%s colors)\n",
$icon->Width, $icon->Height, 2 ** $icon->BitCount;
}
# Import icons from a .exe or .ico file and writes back the file
$exe->update( icon => '/c/windows/taskman.exe' );
# Change it to a console application, then save to another .exe
$exe->SetSubsystem('console');
$exe->write('c:/windows/another.exe');
# Add a manifest section
$exe->update( manifest => $mymanifestxml );
# or a default
$exe->update( defaultmanifest => 1 );
=head1 DESCRIPTION
This module parses and manipulating Win32 PE/COFF executable headers,
including version information, icons and other resources.
More documentation will be provided in due time. For now, please look
at the test files in the source distributions F directory for examples
of using this module.
=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;
sub resource_section {
my ($self) = @_;
$self->first_member('Resources');
}
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 $icon = $args{icon}) {
my @icons = Win32::Exe::IconFile->new($icon)->icons;
$self->set_icons(\@icons) if @icons;
}
if (my $info = $args{info}) {
my @info = ($self->default_info, @$info);
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 ]);
}
}
$self->set_version_info(\@pairs) if @pairs;
}
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 set_version_info {
my ($self, $pairs) = @_;
my $rsrc = $self->resource_section or return;
my $version = $rsrc->first_object('Version');
$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 set_manifest {
my ($self, $xml) = @_;
my $rsrc = $self->resource_section;
my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0';
$rsrc->remove( $name );
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 add_default_manifest {
my ($self) = @_;
my $rsrc = $self->resource_section;
my $name = eval { $rsrc->first_object('Manifest')->PathName } || '/#RT_MANIFEST/#1/#0';
$rsrc->remove( $name );
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;
$self->write;
}
1;
__END__
=head1 AUTHORS
Audrey Tang Ecpan@audreyt.orgE
Mark Dootson
Steffen Mueller Esmueller@cpan.orgE
=head1 COPYRIGHT
Copyright 2004-2007 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