Win32::Exe - Manipulate Win32 executable files

    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)

    $exe = $exe->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;

    my $exe = Win32::Exe->new($filename);

    $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' ],
                  );

    Comments        CompanyName     FileDescription FileVersion
    InternalName    LegalCopyright  LegalTrademarks OriginalFilename
    ProductName     ProductVersion

    ExecutionLevel  UIAccess     ExecName   Description
    CommonControls  Version

    $exe = $exe->create_resource_section if !$exe->has_resource_section;

    my $manifest = $exe->get_manifest;

    $exe->set_manifest($manifest);
    $exe->write;

    $exe->set_manifest_args($argref);
    $exe->write;

    ExecutionLevel  UIAccess     ExecName   Description
    CommonControls  Version

    ExecutionLevel=asInvoker
    UIAccess=false
    CommonControls=1
    Version=6.8.67.334534
    ExecName=My.Application
    Description=My Application

    my $inforef = $exe->get_version_info;

    Comments        CompanyName     FileDescription FileVersion
    InternalName    LegalCopyright  LegalTrademarks OriginalFilename
    ProductName     ProductVersion

    $exe->set_version_info($inforef);
    $exe->write;

    Comments        CompanyName     FileDescription FileVersion
    InternalName    LegalCopyright  LegalTrademarks OriginalFilename
    ProductName     ProductVersion

    $exe->set_subsystem_windows;
    $exe->write;

    $exe->set_subsystem_console;
    $exe->write;

    my $subsys = $exe->get_subsystem;

    $exe->set_single_group_icon($iconfile);
    $exe->write;

    my @iconnames = $exe->get_group_icon_names;

    $exe->get_group_icon($groupiconname);

    $exe->add_group_icon($groupiconname, $iconfilepath);
    $exe->write;

    $exe->replace_group_icon($groupiconname, $iconfilepath);
    $exe->write;

    $exe->remove_group_icon($groupiconname);
    $exe->write;

    $exe->export_group_icon($groupiconname, $iconfilepath);

package Win32::Exe;
$Win32::Exe::VERSION = '0.16';

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 create_resource_section {
    my $self = shift;
    return $self if($self->has_resource_section || ( $^O !~ /^mswin/i ) );
    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, @$inputpairs);
    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__