File Coverage

blib/lib/Disassemble/X86.pm

Criterion	Covered	Total	%
statement	1623	2079	78.0
branch	894	1404	63.6
condition	114	211	54.0
subroutine	337	349	96.5
pod	14	109	12.8
total	2982	4152	71.8

package Disassemble::X86;

use 5.006;
use strict;
use warnings;
use AutoLoader qw( AUTOLOAD );
use integer;
use Disassemble::X86::MemRegion;

use vars qw( $VERSION );
$VERSION = "0.13";

use vars qw( $max_instr_len );
$max_instr_len = 15;

use vars qw( @long_regs @word_regs @byte_regs @seg_regs );
@long_regs = qw( eax ecx edx ebx esp ebp esi edi );
@word_regs = qw(  ax  cx  dx  bx  sp  bp  si  di );
@byte_regs = qw(  al  cl  dl  bl  ah  ch  dh  bh );
@seg_regs  = qw(  es  cs  ss  ds  fs  gs );

use vars qw( @immed_grp @shift_grp @unary_grp @bittst_grp
    @float_op @floatr_op @prefetch_op @cond_code @sse_comp );
@immed_grp   = qw( add or adc sbb and sub xor cmp );
@shift_grp   = qw( rol ror rcl rcr shl shr xxx sar );
@unary_grp   = qw( test xxx not neg mul imul div idiv );
@bittst_grp  = qw( bt bts btr btc );
@float_op    = qw( add mul com comp sub subr div divr );
@floatr_op   = qw( add mul com comp subr sub divr div );
@prefetch_op = qw( nta t0 t1 t2 );
@cond_code   = qw( o no b ae e ne be a s ns pe po l ge le g );
@sse_comp    = qw( eq lt le unord neq nlt nle ord );

use vars qw( $mmx_proc $tdnow_proc $tdnow2_proc $sse_proc $sse2_proc
    %proc_xlat );
$mmx_proc    = 995;
$tdnow_proc  = 996;
$tdnow2_proc = 997;
$sse_proc    = 998;
$sse2_proc   = 999;
%proc_xlat = (
    $mmx_proc    => "mmx",
    $tdnow_proc  => "3dnow",
    $tdnow2_proc => "3dnow-e",
    $sse_proc    => "sse",
    $sse2_proc   => "sse2",
);

sub new {
  my ($class, %args) = @_;
  my $self = bless {
      addr_size => 32,
      data_size => 32,
      asize     => undef, # address size override
      dsize     => undef, # data size override
      seg_pre   => undef,
      mmx_pre   => 0,
      def_proc  => 386,
  } => $class;

  my $text = $args{text};
  unless (ref $text) {
    $text = Disassemble::X86::MemRegion->new(
        mem => $text,
        start => $args{start} || 0,
    );
  }
  $self->{text} = $text;

  $self->addr_size($args{addr_size} || $args{size} || 32);
  $self->data_size($args{data_size} || $args{size} || 32);

  $self->pos( exists($args{pos}) ? $args{pos} : $text->start() );
  $self->set_format($args{format} || "Text");
  return $self;
} # new

sub addr_size {
  my ($self, $size) = @_;
  if ($size) {
    if ($size eq "16" || $size eq "word") { $self->{addr_size} = 16 }
    elsif ($size eq "32" || $size eq "dword" || $size eq "long") {
      $self->{addr_size} = 32;
    }
    else { return }
    $self->set_def_proc();
  }
  return $self->{addr_size};
} # addr_size

sub data_size {
  my ($self, $size) = @_;
  if ($size) {
    if ($size eq "16" || $size eq "word") { $self->{data_size} = 16 }
    elsif ($size eq "32" || $size eq "dword" || $size eq "long") {
      $self->{data_size} = 32;
    }
    else { return }
    $self->set_def_proc();
  }
  return $self->{data_size};
} # data_size

sub set_format {
  my ($self, $fmt) = @_;
  return $self->{format} = $fmt if ref($fmt);
  die "Invalid characters in format name: $fmt" if $fmt =~ /[^\w:]/;
  foreach ("Disassemble::X86::Format$fmt", $fmt) {
    eval "require $_";
    next if $@;
    return $self->{format} = $_;
  }
  die "Invalid format module: $fmt";
} # set_format

sub set_def_proc {
  my ($self) = @_;
  $self->{def_proc} = ($self->{addr_size} == 16
      && $self->{data_size} == 16) ? 86 : 386;
} # set_def_proc

sub text     { $_[0]->{text} }
sub at_end   { $_[0]->{pos} >= $_[0]->{text}->end() }
sub contains { $_[0]->{text}->contains($_[1]) }
sub error    { $_[0]->{error} }
sub op       { $_[0]->{op} }
sub op_start { $_[0]->{op_start} }

sub op_len {
  my $op = $_[0]->{op} or return 0;
  return $op->{len};
} # op_len

sub op_proc {
  my $op = $_[0]->{op} or return 0;
  return $op->{proc};
} # op_len

sub pos {
  my ($self, $pos) = @_;
  if (defined $pos) {
    $self->{pos} = $pos;
    $self->{lim} = $pos + $max_instr_len;
  }
  return $self->{pos};
} # pos

sub disasm {
  my ($self) = @_;
  my $start = $self->{op_start} = $self->{pos};
  $self->{lim} = $start + $max_instr_len;
  $self->{error} = "";

  my $op = $self->_disasm();

  $self->{pos} > $self->{lim}  and $self->{error} = "opcode too long";
  $self->{error} and undef $op;
  $self->{op} = $op;
  if ($op) {
    my $proc     = $op->{proc} || 0;
    my $def_proc = $self->{def_proc};
    $proc = $def_proc if $proc < $def_proc;
    $op->{proc}  = $proc_xlat{$proc} || $proc;
    $op->{start} = $start;
    $op->{len}   = $self->{pos} - $start;
    return $self->{format}->format_instr($op);
  }
  else {
    $self->{pos} = $start; # back off from the bad opcode
    return undef;
  }
} # disasm

sub bad_op {
  my ($self) = @_;
  $self->{error} = "bad opcode";
  return undef;
} # bad_op

sub next_byte {
  my ($self) = @_;
  my $pos = $self->{pos};
  $self->{pos} = $pos + 1;
  return 0 if $pos >= $self->{lim};
  my $byte = $self->{text}->get_byte($pos);
  if (!defined $byte) { $self->{error} = "end of data"; return 0; }
  return $byte;
} # next_byte

sub split_next_byte {
  my ($self) = @_;
  my $pos = $self->{pos};
  $self->{pos} = $pos + 1;
  return (0,0,0) if $pos >= $self->{lim};
  my $byte = $self->{text}->get_byte($pos);
  if (!defined $byte) { $self->{error} = "end of data"; return (0,0,0); }
  return ( ($byte >> 6) & 3, ($byte >> 3) & 7, $byte & 7 );
} # split_next_byte

sub next_word {
  my ($self) = @_;
  my $pos = $self->{pos};
  my $newpos = $self->{pos} = $pos + 2;
  return 0 if $newpos > $self->{lim};
  my $word = $self->{text}->get_word($pos);
  if (!defined $word) { $self->{error} = "end of data"; return 0; }
  return $word;
} # next_word

sub next_long {
  my ($self) = @_;
  my $pos = $self->{pos};
  my $newpos = $self->{pos} = $pos + 4;
  return 0 if $newpos > $self->{lim};
  my $long = $self->{text}->get_long($pos);
  if (!defined $long) { $self->{error} = "end of data"; return 0; }
  return $long;
} # next_long

sub get_byteval {
  my ($self, $size) = @_;
  $size ||= $self->dsize();
  my $b = $self->next_byte();
  if ($b & 0x80) {
    if    ($size == 32) { $b |= 0xffffff00 }
    elsif ($size == 16) { $b |=     0xff00 }
  }
  return { op=>"lit", arg=>[$b], size=>$size };
} # get_byteval

sub get_val {
  my ($self, $size) = @_;
  $size ||= $self->dsize();
  my $val;
  if    ($size == 32) { $val = $self->next_long() }
  elsif ($size == 16) { $val = $self->next_word() }
  elsif ($size == 8)  { $val = $self->next_byte() }
  else { die "can't happen" }
  return { op=>"lit", arg=>[$val], size=>$size };
} # get_val

sub iflong_op {
  my ($self, $if, $else, $proc) = @_;
  return { op=>($self->dsize() == 32 ? $if : $else), proc=>$proc }
} # iflong_op

sub op_r_rm {
  my ($self, $op, $size, $proc) = @_;
  $size ||= $self->dsize();
  my ($mod, $reg, $rm) = $self->split_next_byte();
  my $src  = $self->modrm($mod, $rm, $size);
  my $dest = $self->get_reg($reg, $size);
  return { op=>$op, arg=>[$dest, $src], proc=>$proc };
} # op_r_rm

sub op_rm_r {
  my ($self, $op, $size, $proc) = @_;
  $size ||= $self->dsize();
  my ($mod, $reg, $rm) = $self->split_next_byte();
  my $src  = $self->get_reg($reg, $size);
  my $dest = $self->modrm($mod, $rm, $size);
  return { op=>$op, arg=>[$dest,$src], proc=>$proc };
} # op_rm_r

sub mov_imm {
  my ($self, $size) = @_;
  $size ||= $self->dsize();
  my ($mod, $op, $rm) = $self->split_next_byte();
  return $self->bad_op() unless $op == 0;
  my $dest = $self->modrm($mod, $rm, $size);
  return { op=>"mov", arg=>[$dest, $self->get_val($size)] };
} # mov_imm

sub unary_op {
  my ($self, $size) = @_;
  $size ||= $self->dsize();
  my ($mod, $op, $rm) = $self->split_next_byte();
  my $arg = $self->modrm($mod, $rm, $size);
  if ($op == 0) {
    return { op=>"test", arg=>[$arg, $self->get_val($size)] };
  }
  elsif ($op == 1) { return $self->bad_op() }
  else { return { op=>$unary_grp[$op], arg=>[$arg] } }
} # unary_op

sub abs_addr {
  my ($self, $data_size) = @_;
  $data_size ||= $self->dsize();
  my $addr_size = $self->asize();
  my $addr = $self->get_val($addr_size);
  my $seg  = $self->seg_prefix();
  $addr = { op=>"seg", arg=>[$seg,$addr], size=>$addr_size } if $seg;
  return  { op=>"mem", arg=>[$addr], size=>$data_size };
} # abs_addr

sub eipbyte {
  my ($self) = @_;
  my $off = $self->next_byte();
  $off |= 0xffffff00 if $off & 0x80;
  $off += $self->{pos};
  my $size = $self->dsize();
  if    ($size == 32) { $off &= 0xffffffff }
  elsif ($size == 16) { $off &= 0xffff }
  else { die "can't happen" }
  return { op=>"lit", arg=>[$off], size=>$size };
} # eipbyte

sub eipoff {
  my ($self, $op, $proc) = @_;
  my $size = $self->dsize();
  my $off;
  if ($size == 32) {
    $off = $self->next_long();
    $off = ($off + $self->{pos}) & 0xffffffff;
  }
  elsif ($size == 16) {
    $off = $self->next_word();
    $off = ($off + $self->{pos}) & 0xffff;
  }
  else { die "can't happen" }
  return { op=>"lit", arg=>[$off], size=>$size };
} # eipoff

sub jcond_op {
  my ($self, $cond, $addr, $proc) = @_;
  my $arg = [$addr];
  my $op = { op=>"j".$cond_code[$cond & 0xf], arg=>[$addr] };
  my $seg = $self->{seg_pre};
  if ($seg) {
    # Branch hints. Someone please suggest some better mnemonics.
    if ($seg == 1) {
      $self->{seg_pre} = undef;
      return { op=>"hint_no", prefix=>1, arg=>[$op], proc=>$sse2_proc };
    }
    elsif ($seg == 3) {
      $self->{seg_pre} = undef;
      return { op=>"hint_yes", prefix=>1, arg=>[$op], proc=>$sse2_proc };
    }
  }
  $op->{proc} = $proc;
  return $op;
} # jcond_op

sub seg_prefix {
  my ($self) = @_;
  my $prefix = $self->{seg_pre};
  return undef unless defined $prefix;
  $self->{seg_pre} = undef;
  return $self->seg_reg($prefix);
} # seg_prefix

sub dsize {
  my ($self) = @_;
  my $dsize = $self->{dsize} || $self->{data_size};
  $self->{dsize} = undef;
  return $dsize;
} # dsize

sub asize {
  my ($self) = @_;
  my $asize = $self->{asize} || $self->{addr_size};
  $self->{asize} = undef;
  return $asize;
} # asize

1 # end X86.pm
__END__