elf.pm

内存管理工具Exmap。该工具比 ps 或 top 更精确

#
# (c) John Berthels 2005 <[e-mail]>. See COPYING for license.
#
use strict;
use warnings;
use Range;

# ------------------------------------------------------------
# Examine the contents of an ELF file. Allow the contents of a
# particular page to be examined.
package Elf;

# Static methods and constants
use constant PAGE_SIZE_SHIFT => 12;
use constant PAGE_SIZE => (1 << PAGE_SIZE_SHIFT);
sub page_align_down
{
    my $addr = shift;
    return $addr & ~(PAGE_SIZE-1);
}

sub page_align_up
{
    my $addr = shift;
    return page_align_down($addr + PAGE_SIZE - 1);
}





sub new
{
    my $c = shift;
    $c = ref $c if ref $c;
    my $s = {};
    $s->{_file} = shift;
    $s->{_suppress_warn_on_bad_magic} = shift; # undef is false...
    bless $s, $c;
    unless ($s->file) {
	warn("No file specified");
	return undef;
    }
    return undef unless $s->_open_file;
    return undef unless $s->_load_file_header;
    return undef unless $s->_load_segments;
#    return undef unless $s->_load_sections;
#    return undef unless $s->_correlate;
    return $s;
}

use constant ROOT_UID => 0;

sub _open_file
{
    my $s = shift;

    # If we're root, we may be unable to read the file unless we
    # temporarily become its owner (since it may be on an NFS
    # partition with root_squash). We can revert to our own uid
    # immediately after the open. Sadly, the perl -r and -R tests will
    # suggest that it *is* readable, so we'll simply always shift uid
    # if we are root.

    my $old_euid; # If undef, we haven't shifted uid
    if ($< == ROOT_UID) {
	$old_euid = $>;
	my @statinfo = stat($s->{_file});
	# Change uid to file owner
	$! = 0;
	$> = $statinfo[4];
	warn("Failed to change userid to $statinfo[4] : $!") if $!;
    }

    my $fh;
    unless(open($fh, "< $s->{_file}")) {
	warn("Can't open file $s->{_file} for reading : $!");
	$fh = undef;
    }

    if (defined $old_euid) {
	$! = 0;
	$> = $old_euid;
	warn("Failed to revert userid to $old_euid : $!") if $!;
    }

    $s->{_fh} = $fh if $fh;
    return defined $fh;
}

sub DESTROY
{
    my $s = shift;
    if ($s->{_fh}) {
	close $s->{_fh};
	$s->{_fh} = undef;
    }
}

sub _lazy_load_sections
{
    my $s = shift;
    return 1 if $s->{_lazy_load_sections};
    $s->{_lazy_load_sections} = 1; # Stop possible recursion...
    return undef unless $s->_load_sections;
    return undef unless $s->_correlate;
    return 1;
}

sub _correlate
{
    my $s = shift;

    my @sections = $s->sections;
    my $string_section_index = $s->{_elf_header}->{shstrnxdx};
    unless ($string_section_index <= scalar(@sections)) {
	warn("Invalid string section index : $string_section_index");
	return undef;
    }
    $s->{_string_section} = $s->section($string_section_index);

    unless ($s->{_string_section}->is_string_table) {
	warn("Invalid string section: $string_section_index");
	return undef;
    }

    foreach my $section (@sections) {
	$section->set_string_section($s->{_string_section});
	$section->set_fh($s->{_fh});
	if ($section->is_symbol_table) {
	    $s->{_symbol_table_section} = $section;
	    my $symbol_string_table = $s->section($section->link);
	    # Now load on demand
	    $section->load_symbols($symbol_string_table);
	}
    }
    return 1;
}


sub find_symbols_in_mem_range
{
    my $s = shift;
    my $r = shift;

    $s->_lazy_load_sections;

    my $symtab = $s->{_symbol_table_section};
    return () unless $symtab;
    
    return $symtab->find_symbols_in_mem_range($r);
}

sub defined_symbols
{
    my $s = shift;
    return grep { $_->is_defined } $s->all_symbols;
}

sub all_symbols
{
    my $s = shift;

    $s->_lazy_load_sections;

    my $symtab = $s->{_symbol_table_section};
    return () unless $symtab;
    return $symtab->symbols;
}

sub symbol_by_name
{
    my $s = shift;
    my $name = shift;
    foreach my $sym ($s->all_symbols) {
	return $sym if $sym->name eq $name;
    }
    return undef;
}

sub symbols_in_section
{
    my $s = shift;

    $s->_lazy_load_sections;

    my $section = shift;
    return $s->find_symbols_in_mem_range($section->mem_range);
}

sub file { return $_[0]->{_file}; }

=pod

    The ELF header format (from /usr/include/elf.h)
			   
#define EI_NIDENT (16)
    
typedef struct {
	
    unsigned char	e_ident[NIDENT];	/* Magic number and other info */
    Elf32_Half	e_type;			/* Object file type */
    Elf32_Half	e_machine;		/* Architecture */
    Elf32_Word	e_version;		/* Object file version */
    Elf32_Addr	e_entry;		/* Entry point virtual address */
    Elf32_Off	e_phoff;		/* Program header table file offset */
    Elf32_Off	e_shoff;		/* Section header table file offset */
    Elf32_Word	e_flags;		/* Processor-specific flags */
    Elf32_Half	e_ehsize;		/* ELF header size in bytes */
    Elf32_Half	e_phentsize;		/* Program header table entry size */
    Elf32_Half	e_phnum;		/* Program header table entry count */
    Elf32_Half	e_shentsize;		/* Section header table entry size */
    Elf32_Half	e_shnum;		/* Section header table entry count */
    Elf32_Half	e_shstrndx;		/* Section header string table index */
} Elf32_Ehdr;

=cut
    
sub _load_file_header
{
    my $s = shift;

    my $headerlen = 16 + (2 * 2) + (5 * 4) + (6 * 2);
    my $buffer;
    my $nbytes = sysread($s->{_fh}, $buffer, $headerlen);
    if ($nbytes != $headerlen) {
	warn("Failed to read ELF header - read [$nbytes] instead of [$headerlen]");
	return undef;
    }

    my %elf_header;
    @elf_header{qw(magic type machine version entry phoff shoff flags ehsize
		   phentsize phnum shentsize shnum shstrnxdx
		   )} = unpack('a16s2i5s6', $buffer);

    unless ($elf_header{magic} =~ "^\x7fELF") {
	warn("Bad elf file header magic for: ", $s->file)
	    unless $s->{_suppress_warn_on_bad_magic};
	return undef;
    }

    $s->{_elf_header} = \%elf_header;
    return scalar keys %elf_header;
}



sub _load_sections
{
    my $s = shift;

    my $SHN_UNDEF = 0;
    my @byte_buffers = $s->_load_table("section header table",
				       $s->{_elf_header}->{shoff},
				       $s->{_elf_header}->{shnum},
				       $s->{_elf_header}->{shentsize});

    unless (@byte_buffers) {
	warn "Failed to load buffers for sections";
	return undef;
    }
    
    my @sections;
    @sections = map { Elf::Section->new($_) } @byte_buffers;
    $s->{_sections} = \@sections;

    return scalar @sections;
}

sub _load_segments
{
    my $s = shift;

    my $SHN_UNDEF = 0;
    my @byte_buffers = $s->_load_table("program header table",
				       $s->{_elf_header}->{phoff},
				       $s->{_elf_header}->{phnum},
				       $s->{_elf_header}->{phentsize});

    unless (@byte_buffers) {
	warn "Failed to load buffers for program header segments";
	return undef;
    }
    
    my @segments;
    @segments = map { Elf::Segment->new($_) } @byte_buffers;
    $s->{_segments} = \@segments;

    return scalar @segments;
}

sub _load_table
{
    my $s = shift;
    my $table_name = shift;
    my $offset = shift;
    my $num_chunks = shift;
    my $chunk_size = shift;

    if ($offset == 0) {
	warn("No $table_name");
	return ();
    }

    unless ($num_chunks > 0) {
	warn("Invalid number of chunks in $table_name");
	return ();
    }
    
    my @buffers;
    seek($s->{_fh}, $offset, 0);
    my $big_buffer;
    my $read_size = $chunk_size * $num_chunks;
    my $nbytes = sysread($s->{_fh}, $big_buffer, $read_size);
    
    if ($nbytes != $read_size) {
	warn("Failed to read $read_size at $offset for $table_name");
	return ();
    }
    
    while (length $big_buffer > 0) {
	my $buffer = substr($big_buffer, 0, $chunk_size, "");
	push @buffers, $buffer;
    }
    
    return @buffers;
}

sub num_sections
{
    my $s = shift;
    return scalar $s->sections;
}

sub num_segments
{
    my $s = shift;
    return scalar $s->segments;
}

sub segments
{
    my $s = shift;

    return @{$s->{_segments}};
}

sub loadable_segments
{
    my $s = shift;
    return grep { $_->is_load } $s->segments;
}

sub section
{
    my $s = shift;
    my $index = shift;
    my @sections = $s->sections;
    return $sections[$index];
}

sub section_by_name
{
    my $s = shift;
    my $name = shift;
    foreach my $section ($s->sections) {
	return $section if $section->name eq $name;
    }
    return undef;
}

sub mappable_sections
{
    my $s = shift;
    return grep { $_->addr != 0 } $s->sections;
}

sub sections
{
    my $s = shift;

    $s->_lazy_load_sections;

    return @{$s->{_sections}};
}

=pod

/* Legal values for e_type (object file type).  */

#define ET_NONE		0		/* No file type */
#define ET_REL		1		/* Relocatable file */
#define ET_EXEC		2		/* Executable file */
#define ET_DYN		3		/* Shared object file */
#define ET_CORE		4		/* Core file */
#define	ET_NUM		5		/* Number of defined types */
#define ET_LOOS		0xfe00		/* OS-specific range start */
#define ET_HIOS		0xfeff		/* OS-specific range end */
#define ET_LOPROC	0xff00		/* Processor-specific range start */
#define ET_HIPROC	0xffff		/* Processor-specific range end */

=cut

sub e_type
{
    my $s = shift;
    return undef unless $s->{_elf_header};
    my $type = $s->{_elf_header}->{type};
    my $ET_NUM = 5;
    return undef unless defined $type && $type < $ET_NUM;
    my @types = qw/NONE REL EXEC DYN CORE/;
	
    return $types[$type];
}

sub is_executable
{
    my $s = shift;
    return $s->e_type eq 'EXEC';
}

# ------------------------------------------------------------
# Wrap one ELF section
package Elf::Section;

sub new
{
    my $c = shift;
    $c = ref $c if ref $c;
    my $s = {};
    $s->{_buffer} = shift;
    bless $s, $c;
    return undef unless $s->_unpack_buffer;
    return $s;
}

sub set_string_section
{
    my $s = shift;
    $s->{_string_section} = shift;
}