view release on metacpan or  search on metacpan

lib/B/Disassembler.pm  view on Meta::CPAN

sub GET_none { }

sub GET_op_tr_array {
  my $fh  = shift;
  my $len = unpack "S", $fh->readn(2);
  my @ary = unpack "S*", $fh->readn( $len * 2 );
  return join( ",", $len, @ary );
}

sub GET_IV64 {
  my $fh  = shift;
  my $str = $fh->readn(8);
  croak "reached EOF while reading I32" unless length($str) == 8;

  # Todo: check byteorder
  my $i = unpack( "q", $str );
  return $i > 8 ? sprintf "0x%09llx", $i : $i;
}

sub GET_IV {
  # Check the header settings, not the current settings.
  $B::Disassembler::ivsize == 4 ? &GET_I32 : &GET_IV64;
  # $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
}

sub GET_PADOFFSET {
  # Check the header settings, not the current settings.
  $B::Disassembler::ptrsize == 8 ? &GET_IV64 : &GET_U32;
  # $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
}

sub GET_long {
  # Check the header settings, not the current settings.
  # B::Disassembler::ivsize or longsize if ge xxx?
  if ($B::Disassembler::longsize) {
    return $B::Disassembler::longsize == 8 ? &GET_IV64 : &GET_U32;
  } else {
    # return $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
    return $B::Disassembler::ivsize == 8 ? &GET_IV64 : &GET_U32;
  }
}

sub GET_pmflags {
  my $fh  = shift;
  my $size = 2;
  if ($B::Disassembler::blversion ge '"0.07"') {
    if ($B::Disassembler::perlversion ge '"5.013"') {
      return $fh->GET_U32;
    }
  }
  return $fh->GET_U16;
}

package B::Disassembler;
use Exporter;
@ISA       = qw(Exporter);
our @EXPORT_OK = qw(disassemble_fh get_header print_insn print_insn_bare @opname);
use Carp;
use strict;
use B::Asmdata qw(%insn_data @insn_name);
use Opcode qw(opset_to_ops full_opset);
use Config qw(%Config);
use B::Concise;

BEGIN {
  if ( $] < 5.009 ) {
    B::Asmdata->import(qw(@specialsv_name));
  }
  else {
    B->import(qw(@specialsv_name));
  }
}

my $ix;
my $opname;
our @opname = opset_to_ops(full_opset);
our (
  $magic,   $archname, $blversion, $ivsize,
  $ptrsize, $longsize, $byteorder, $archflag, $perlversion
);
						# >=5.12
our  @svnames = ("NULL");			# 0
push @svnames, "BIND"   if $] >= 5.009 and $] < 5.019002; # 1
push @svnames, ("IV", "NV");			# 2,3
push @svnames, "RV"     if $] < 5.011;		#
push @svnames, "PV";
push @svnames, "INVLIST" if $] >= 5.019002;     # 4
push @svnames, ("PVIV", "PVNV", "PVMG");	# 4-7
push @svnames, "BM"     if $] < 5.009;
push @svnames, "REGEXP" if $] >= 5.011;	# 8
push @svnames, "GV"     if $] >= 5.009;	# 9
push @svnames, ("PVLV", "AV", "HV", "CV");	# 10-13
push @svnames, "GV"     if $] < 5.009;
push @svnames, ("FM", "IO");			# 14,15

sub dis_header($) {
  my ($fh) = @_;
  my $str = $fh->readn(3);
  if ($str eq '#! ')  {
    $str .= $fh->GET_comment_t;
    $str .= $fh->GET_comment_t;
    $magic = $fh->GET_U32;
  } else {
    $str .= $fh->readn(1);
    $magic = unpack( "L", $str );
  }
  warn("bad magic") if $magic != 0x43424c50;
  $archname  = $fh->GET_strconst();
  $blversion = $fh->GET_strconst();
  $ivsize    = $fh->GET_U32();
  $ptrsize   = $fh->GET_U32();
  if ( $blversion ge '"0.06_03"' ) {
    $longsize = $fh->GET_U32();
  }
  if ( $blversion gt '"0.06"' or $blversion eq '"0.04"' ) {
    $byteorder = $fh->GET_strconst();
  }
  if ( $blversion ge '"0.06_05"' ) {
    $archflag = $fh->GET_U16();
  }
  if ( $blversion ge '"0.06_06"' ) {
    $perlversion = $fh->GET_strconst();
  }
}

sub get_header() {
  my @result = (
		$magic,   $archname,  $blversion, $ivsize,
		$ptrsize, $byteorder, $longsize,  $archflag,
		$perlversion
	       );
  if (wantarray) {
    return @result;
  }
  else {
    my $hash = {