path: root/bin/slxldd

#! /usr/bin/perl -CLADS
# -----------------------------------------------------------------------------
# Copyright (c) 2006, 2007 - OpenSLX GmbH
#
# This program is free software distributed under the GPL version 2.
# See http://openslx.org/COPYING
#
# If you have any feedback please consult http://openslx.org/feedback and
# send your suggestions, praise, or complaints to feedback@openslx.org
#
# General information about OpenSLX can be found at http://openslx.org/
# -----------------------------------------------------------------------------
# slxldd
#	- OpenSLX-rewrite of ldd that works on multiple architectures.
# -----------------------------------------------------------------------------
use strict;
use warnings;

my $abstract = q[
slxldd
    This script reimplements ldd in a way that should work for all
    binary formats supported by the binutils installed on the host system.

    An example: if you have a folder containing an x86_64 system, you can
    invoke this script on a x86_32-host in order to determine all the libraries
    required by a binary of the x86_64 target system.
];

# add the lib-folder to perl's search path for modules:
use FindBin;
use lib "$FindBin::RealBin/../lib";

use File::Glob ':globally';
use Getopt::Long;
use Pod::Usage;

use OpenSLX::Basics;

my (
	$helpReq,
	$manReq,
	$verbose,

	$rootPath,
	$versionReq,

	@filesToDo,

	@libFolders,
	@libs,
	%libInfo,
);

$rootPath = '/';
GetOptions(
	'help|?'      => \$helpReq,
	'man'         => \$manReq,
	'root-path=s' => \$rootPath,
	'verbose'     => \$verbose,
	'version'     => \$versionReq,
  )
  or pod2usage(2);
pod2usage(-msg => $abstract, -verbose => 0, -exitval => 1) if $helpReq;
pod2usage(-verbose => 2) if $manReq;
if ($versionReq) {
	system('slxversion');
	exit 1;
}

openslxInit();

if (!$rootPath) {
	print STDERR _tr("You need to specify the root-path!\n");
	pod2usage(2);
}

$rootPath =~ s[/+$][];
# remove trailing slashes

if (!@ARGV) {
	print STDERR _tr("You need to specify at least one file!\n");
	pod2usage(2);
}

fetchLoaderConfig();

foreach my $file (@ARGV) {
	if (substr($file, 0, 1) ne '/') {
		# force relative paths relative to $rootPath:
		$file = "$rootPath/$file";
	}
	if (!-e $file) {
		print STDERR _tr("slxldd: unable to find file '%s', skipping it\n",
			$file);
		next;
	}
	push @filesToDo, $file;
}

foreach my $file (@filesToDo) {
	addLibsForBinary($file);
}

sub fetchLoaderConfigFile
{
	my $ldConfFile = shift;

	my $ldconfFH;
	if (!open($ldconfFH, '<', $ldConfFile)) {
		warn(_tr("unable to open file '%s' (%s)", $ldConfFile, $!));
		return;
	}
	while (<$ldconfFH>) {
		chomp;
		if (m{^\s*include\s+(.+?)\s*$}i) {
			my @incFiles = glob("$rootPath$1");
			foreach my $incFile (@incFiles) {
				if ($incFile) {
					fetchLoaderConfigFile($incFile);
				}
			}
			next;
		}
		if (m{\S+}i) {
			s[=.+][];
			# remove any lib-type specifications (e.g. '=libc5')
			push @libFolders, "$rootPath$_";
		}
	}
	close $ldconfFH
		or die(_tr("unable to close file '%s' (%s)", $ldConfFile, $!));
	return;
}

sub fetchLoaderConfig
{
	if (!-e "$rootPath/etc") {
		die _tr("'%s'-folder not found, maybe wrong root-path?\n",
			"$rootPath/etc");
	}
	fetchLoaderConfigFile("$rootPath/etc/ld.so.conf");

	# add "trusted" folders /lib and /usr/lib if not already in place:
	if (!grep { m[^$rootPath/lib$] } @libFolders) {
		push @libFolders, "$rootPath/lib";
	}
	if (!grep { m[^$rootPath/usr/lib$] } @libFolders) {
		push @libFolders, "$rootPath/usr/lib";
	}

	# add lib32-folders for 64-bit Debians, as they do not
	# refer those in ld.so.conf (which I find strange...)
	if (-e '/lib32' && !grep { m[^$rootPath/lib32$] } @libFolders) {
		push @libFolders, "$rootPath/lib32";
	}
	if (-e '/usr/lib32'
		&& !grep { m[^$rootPath/usr/lib32$] } @libFolders)
	{
		push @libFolders, "$rootPath/usr/lib32";
	}
	return;
}

sub addLib
{
	my $lib      = shift;
	my $bitwidth = shift;
	my $rpath    = shift;

	if (!exists $libInfo{$lib}) {
		push @libs, $lib;
		my $libPath;
		my @folders = @libFolders;
		if (defined $rpath) {
			# add rpath if given (explicit paths set during link stage)
			push @folders, split ':', $rpath;
		}
		foreach my $folder (@folders) {
			if (-e "$folder/$lib") {
				# have library matching name, now check if the platform is ok, too:
				my $libFileInfo =
				  `file --dereference --brief $folder/$lib 2>/dev/null`;
				if ($?) {
					die _tr("unable to fetch file info for '%s', giving up!\n",
						$folder / $lib);
				}
				my $libBitwidth = ($libFileInfo =~ m[64-bit]i) ? 64 : 32;
				if ($bitwidth != $libBitwidth) {
					vlog(
						0,
						_tr(
							'%s has wrong bitwidth (%s instead of %s)',
							"$folder/$lib", $libBitwidth, $bitwidth
						)
					  )
					  if $verbose;
					next;
				}
				$libPath = "$folder/$lib";
				last;
			}
		}
		if (!defined $libPath) {
			die _tr("unable to find lib %s!\n", $lib);
		}
		print "$libPath\n";
		$libInfo{$lib} = $libPath;
		push @filesToDo, $libPath;
	}
	return;
}

sub addLibsForBinary
{
	my $binary = shift;

	# first do some checks:
	print STDERR _tr("analyzing '%s'...\n", $binary) if $verbose;
	my $fileInfo = `file --dereference --brief --mime $binary 2>/dev/null`;
	if ($?) {
		die _tr("unable to fetch file info for '%s', giving up!\n", $binary);
	}
	chomp $fileInfo;
	print STDERR _tr("\tinfo is: '%s'...\n", $fileInfo) if $verbose;
	if ($fileInfo !~ m[^application/(x-executable|x-shared)]i) {
		# ignore anything that's not an executable or a shared library
		print STDERR _tr(
			"%s: ignored, as it isn't an executable or a shared library\n",
			$binary);
		next;
	}

	# fetch file info again, this time without '--mime' in order to get the architecture
	# bitwidth:
	$fileInfo = `file --dereference --brief $binary 2>/dev/null`;
	if ($?) {
		die _tr("unable to fetch file info for '%s', giving up!\n", $binary);
	}
	chomp $fileInfo;
	print STDERR _tr("\tinfo is: '%s'...\n", $fileInfo) if $verbose;
	my $bitwidth = ($fileInfo =~ m[64-bit]i) ? 64 : 32;
	# determine whether binary is 32- or 64-bit platform

	# now find out about needed libs, we first try objdump...
	if ($verbose) {
		print STDERR _tr("\ttrying objdump...\n");
	}
	my $res = `objdump -p $binary 2>/dev/null`;
	if (!$?) {
		# find out if rpath is set for binary:
		my $rpath;
		if ($res =~ m[^\s*RPATH\s*(\S+)]im) {
			$rpath = $1;
			if ($verbose) {
				print STDERR _tr("\trpath='%s'\n", $rpath);
			}
		}
		while ($res =~ m[^\s*NEEDED\s*(.+?)\s*$]gm) {
			addLib($1, $bitwidth, $rpath);
		}
	} else {
		# ...objdump failed, so we try readelf instead:
		if ($verbose) {
			print STDERR _tr("\ttrying readelf...\n");
		}
		$res = `readelf -d $binary 2>/dev/null`;
		if ($?) {
			die _tr(
				"neither objdump nor readelf seems to be installed, giving up!\n"
			);
		}
		# find out if rpath is set for binary:
		my $rpath;
		if ($res =~ m{Library\s*rpath:\s*\[([^\]]+)}im) {
			$rpath = $1;
			if ($verbose) {
				print STDERR _tr("\trpath='%s'\n", $rpath);
			}
		}
		while ($res =~ m{\(NEEDED\)[^\[]+\[(.+?)\]\s*$}gm) {
			addLib($1, $bitwidth, $rpath);
		}
	}
	return;
}

=head1 NAME

slxldd - OpenSLX-script to determine the libraries required by any given
binary file.

=head1 SYNOPSIS

slxldd [options] file [...more files]

  Options:
      --help                   brief help message
      --man                    show full documentation
      --root-path=<string>     path to the root folder for library search
      --verbose                show what's going on during execution
      --version                show version

=head1 OPTIONS

=over 8

=item B<--help>

Prints a brief help message and exits.

=item B<--man>

Prints the manual page and exits.

=item B<--root-path=<string>>

Sets the root folder that is used when searching for libraries. In order to
collect the loader-settings, etc/ld.so.conf is read relative to this path and
all libraries are sought relative to this path, too (a.k.a. a virtual chroot).

Defaults to '/'.

=item B<--verbose>

Prints info about the files as they are being scanned.

=item B<--version>

Prints the version and exits.

=back

=cut