[klibc] testers sought for script to interpret ELF/klibc executables

[Erik van Konijnenburg]

Here's a small test program to find out where a klibc executable
expects its shared library (or interpreter to be precise) to be.
It should work regardless of 32/64 bit, little- or big-endian,
but only on native executables.

If you have access to a 64-bit or big endian machine, I would
appreciate feedback on whether it produces correct answers on your
machine.  To run the test, cut the program from this E-mail,
and run, for example as follows:

	$ perl ttt.pl /etc/hosts /bin/bash ./t.shared
	/etc/hosts: bad magic
	/bin/bash: good /lib/ld-linux.so.2
	./t.shared: good /tst/lib/klibc-rJTpPWKhpZdMA2Y6kbuFRmWuj6U.so
	$

If you find a way to make the program say 'perl problem' for an executable
that could go on an initramfs image, that's especially relevant.

Background: I'm working on yaird, a tool to build initramfs images;
one of the things this does is to examine executables that go on the
image to determine which shared libraries are needed.  Until now,
that's based on ldd, but ldd only works on executables compiled
with glibc.  Thus, to support executables generated with 'klcc -shared',
a different way to find the interpreter is needed.

The tricky part is that perl unpacking of 64-bit integers has
limitations: only available on 64-bit machines, only if configured in.
If it turns out this causes problems in practise, I'll have to rework
this to unpack 64-bit ints as two longs; something I'd rather avoid.

Thanks for your help,
Erik

#
# ttt.pl -- test program: prints the interp of an ELF executable,
# if any.  It's intended to be incorporated in a tool to generate
# initramfs images to determine automatically which .so files are
# needed if an executable is placed on the image.
#
# The approach is based on the linux kernel file fs/binfmt_elf.c:
# - read first few bytes and look for magic word plus 32/64 bit indicator
# - read elf-header in 32 or 64 bit format, this tells where private
#   headers are.
# - read the private headers (32 or 64 bit)
# - the first private header with type PT_INTERP gives offset and
#   size of the interpreter filename in the executable
# - extract that filename and strip trailing null byte.
#
use warnings;
use strict;
sub PATH_MAX () {4096;}

sub SZ_ELF32HDR () {52;}
sub SZ_ELF64HDR () {64;}

# Elf32_Ehdr->e_ident[4]: are variables 32 or 64 bit
sub ELFCLASS32 () {1;}
sub ELFCLASS64 () {2;}

# Elf32_Ehdr->e_type: whether it's an executable, core, object
# file or something else entirely.
sub ET_EXEC () {2;}
sub ET_DYN () {3;}

#
# ELF Private header
#
sub SZ_ELF32PHDR {32;}
sub SZ_ELF64PHDR {56;}

# Elf32_Phdr->p_type.
sub PT_INTERP () {3;}			# Program interpreter


sub readStruct ($$$$$) {
	my ($fh, $off, $size, $pattern, $fieldNames) = @_;
	my @values;

	if (! seek ($fh, $off, 0)) {
		print "bad seek\n";
		return undef;
	}

	my $data;
	my $rc = read ($fh, $data, $size);
	if (! defined ($rc) || $rc != $size) {
		print "short read\n";
		return undef;
	}
	eval {
		@values = unpack ($pattern, $data);
	};
	if ($@) {
		# perl only supports Q on 64 bit machines,
		# if appropriate compile time options given.
		print "perl problem\n";
		return undef;
	}

	if ($#values != $#{$fieldNames}) {
		print "internal error\n";
		return undef;
	}
	my $result = {};
	for my $key (@{$fieldNames}) {
		$result->{$key} = shift @values;
	}
	return $result;
}

#
# snif -- find interp in an ELF object file.
#
sub snif ($) {
	my ($path) = @_;

	my $fh;
	if (! open ($fh, "<", "$path")) {
		print "$path: cant open\n";
		return;
	}

        my $magic;
        my $rc = read ($fh, $magic, 10);
        if (! defined ($rc) || $rc != 10) {
		print "$path: short header\n";
		return;
        }

	if ($magic !~ /^\x7fELF(.)/) {
		print "$path: bad magic\n";
		return;
	}
	my $class = ord($1);

	my ($ehdrPat, $ehdrSize, $phdrPat, $phdrSize, $phdrFields);
	my $ehdrFields = [qw{
			ident type machine version entry
			phoff shoff flags ehsize
			phentsize phnum shentsize
			shnum shstrndx
			}];
	if ($class == ELFCLASS32) {
		$ehdrSize = SZ_ELF32HDR;
		$ehdrPat = "a[16] SS LL LL L SSSSSS";
		$phdrSize = SZ_ELF32PHDR;
		$phdrPat = "LL LL LL LL";
		$phdrFields = [qw{
			type offset vaddr paddr
			filesz memsz flags align
			}];
	}
	elsif ($class == ELFCLASS64) {
		$ehdrPat = "a[16] SS LQ QQ L SSSSSS";
		$ehdrSize = SZ_ELF64HDR;
		$phdrPat = "LL QQ QQ QQ";
		$phdrSize = SZ_ELF64PHDR;
		$phdrFields = [qw{
			type flags offset vaddr paddr
			filesz memsz align
			}];
	}
	else {
		print "$path: bad class\n";
		return;
	}

	my $ehdr = readStruct ($fh, 0, $ehdrSize, $ehdrPat, $ehdrFields);
	if (! defined ($ehdr)) {
		return;
	}

	if (! ($ehdr->{type} == ET_EXEC || $ehdr->{type} == ET_DYN)) {
		print "$path: bad type\n";
		return;
	}

	if ($ehdr->{ehsize} != $ehdrSize) {
		print "$path: bad ehsize\n";
		return;
	}

	if ($ehdr->{phentsize} != $phdrSize) {
		print "$path: bad phentsize\n";
		return;
	}

	# mind your overflows, dont multiply phnum*entsize
	if ($ehdr->{phnum} < 1 || $ehdr->{phnum} > (65336/$phdrSize)) {
		print "$path: bad phnum\n";
		return;
	}

	my $interp_offset;
	my $interp_size;
	for my $i (0 .. $ehdr->{phnum} - 1) {
		my $phdr = readStruct ($fh,
			$ehdr->{phoff} + ($i * $phdrSize),
			$phdrSize, $phdrPat, $phdrFields);

		if ($phdr->{type} == PT_INTERP) {
			$interp_offset = $phdr->{offset};
			$interp_size = $phdr->{filesz};
			last;
		}
	}

	if (! defined ($interp_offset)) {
		print "$path: no interpreter\n";
		return;
	}

	if ($interp_size < 2 || $interp_size > PATH_MAX) {
		print "$path: bad sized interpreter\n";
		return;
	}
        if (! seek ($fh, $interp_offset, 0)) {
                print "$path: cant seek to interp\n";
		return;
        }
	my $interpName;
        $rc = read ($fh, $interpName, $interp_size);
        if (! defined ($rc) || $rc != $interp_size) {
		print "$path: cant read interp\n";
		return;
        }
	if ($interpName !~ /\0$/) {
		print "$path: missing null in interp\n";
		return;
	}
	$interpName =~ s/.$//;

	if (!close ($fh)) {
		print "$path: close failed\n";
		return;
	}
	print "$path: good $interpName\n";
}

for my $object (@ARGV) {
	snif $object;
}