qpdf/copy_dlls

#!/usr/bin/env perl

require 5.008;
BEGIN { $^W = 1; }
use strict;
use File::Basename;

my $whoami = basename($0);

usage() unless @ARGV == 3;
my ($file, $destdir, $objdump) = @ARGV;
my $filedir = dirname($file);

my %dlls = ();
my $format = undef;
open(O, "$objdump -p $file|") or die "$whoami: can't run objdump\n";
while (<O>)
{
    if (m/^\s+DLL Name:\s+(.+\.dll)/i)
    {
	my $dll = $1;
	$dll =~ tr/A-Z/a-z/;
	next if $dll =~ m/^(kernel32|user32|msvcrt)\.dll$/;
	$dlls{$dll} = 1;
    }
    elsif (m/^Magic.*\((PE.+?)\)/)
    {
        $format = $1;
    }
}
close(O);
if (! defined $format)
{
    die "$whoami: can't determine format of $file\n";
}

# Search the directories named in the file's manifest (if present),
# the file's directory, the current directory, and the path for dlls
# since that's what Windows does.  Be sure to only capture compatible
# DLLs.
my $sep = ($^O eq 'MSWin32' ? ';' : ':');
my @path = ($filedir, '.', split($sep, $ENV{'PATH'}));
if (-f "$file.manifest")
{
    unshift(@path, get_manifest_dirs("$file.manifest"));
}
my @final = ();
my @notfound = ();
dll_loop:
foreach my $dll (sort keys %dlls)
{
    my $found = 0;
    foreach my $dir (@path)
    {
	if ((-f "$dir/$dll") && is_format("$dir/$dll", $format))
	{
	    push(@final, "$dir/$dll");
	    $found = 1;
	    last;
	}
    }
    if (! $found)
    {
	push(@notfound, $dll);
    }
}

if (@notfound)
{
    die "$whoami: can't find the following dlls: " .
	join(', ', @notfound), "\n";
}

foreach my $f (@final)
{
    $f =~ s,\\,/,g;
    print "Copying $f to $destdir\n";
    system("cp -p $f $destdir") == 0 or
	die "$whoami: copy $f to $destdir failed\n";
}

sub is_format
{
    my ($file, $format) = @_;
    $file =~ s,\\,/,g;
    # Special case: msvc*.dll seem to be able to behave both as 32-bit
    # and 64-bit DLLs.  Either that, or this logic is wrong for those
    # DLLs and it doesn't matter because they're already installed on
    # my test system (which doesn't have msvc installed on it).
    if ($file =~ m,/msvc,i)
    {
        return 1;
    }
    my $result = 0;
    my $file_format = `file $file`;
    print "$file $format $file_format\n";
    if ($? == 0)
    {
        if ($file_format =~ m/\Q${format}\E executable/)
        {
            $result = 1;
        }
    }
    $result;
}

sub get_manifest_dirs
{
    # Find all system directories in which to search for DLLs based on
    # the contents of a Visual Studio manifest file.

    my $manifest_file = shift;

    require XML::Parser;
    my $sysroot = $ENV{'SYSTEMROOT'} or die "$whoami: can't get \$SYSTEMROOT\n";
    $sysroot =~ s,\\,/,g;
    if ($^O eq 'cygwin')
    {
	chop($sysroot = `cygpath $sysroot`);
	die "$whoami: can't get system root" unless $? == 0;
    }
    my $winsxs = "$sysroot/WinSxS";
    opendir(D, $winsxs) or die "$whoami: can't opendir $winsxs: $!\n";
    my @entries = readdir(D);
    closedir(D);

    my @candidates = ();

    my $readAssemblyIdentity = sub
    {
	my ($parser, $element, %attrs) = @_;
	return unless $element eq 'assemblyIdentity';
	my $type = $attrs{'type'};
	my $name = $attrs{'name'};
	my $version = $attrs{'version'};
	my $processorArchitecture = $attrs{'processorArchitecture'};
	my $publicKeyToken = $attrs{'publicKeyToken'};

	my $dir_start = join('_',
			     $processorArchitecture,
			     $name,
			     $publicKeyToken,
			     $version);
	push(@candidates, $dir_start);
    };

    my $p = new XML::Parser(Handlers => {'Start' => $readAssemblyIdentity});
    $p->parsefile($manifest_file);

    my @dirs = ();
    foreach my $c (@candidates)
    {
	push(@dirs, map { "$winsxs/$_" } (grep { m/^\Q$c\E/i } @entries));
    }

    @dirs;
}

sub usage
{
    die "Usage: $whoami {exe|dll} destdir\n";
}