822 lines
24 KiB
Perl
822 lines
24 KiB
Perl
package 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<t/> 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<update> 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<icon> 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<info> 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<gui or console> 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<manifest> Specify a manifest file to add to the executable resources.
|
|
|
|
B<manifestargs> 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 E<lt>cpan@audreyt.orgE<gt>
|
|
|
|
Mark Dootson E<lt>mdootson@cpan.orgE<gt>
|
|
|
|
Steffen Mueller E<lt>smueller@cpan.orgE<gt>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright 2004-2007, 2010 by Audrey Tang E<lt>cpan@audreyt.orgE<gt>.
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the same terms as Perl itself.
|
|
|
|
See L<http://www.perl.com/perl/misc/Artistic.html>
|
|
|
|
=cut
|