lib/Devel/PeekPoke/PP.pm

   1 package # hide hide not just from PAUSE but from everyone - shoo shoo shooooo!
   2   Devel::PeekPoke::PP;
   3
   4 use strict;
   5 use warnings;
   6
   7 use 5.008001; # because 5.6 doesn't have B::PV::object_2svref
   8
   9 use Carp;
  10 use Config;
  11 use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE/;
  12 use B (); # for B::PV
  13
  14 use constant {
  15   _MAX_ADDR => 'FF' x PTR_SIZE,
  16   _PERLVERSION => "$]", # we do not support every perl, as we rely on the implementation of SV/SvPV
  17   _PERLVERSION_MIN => ($] =~ /^5\.(\d{3})/)[0],
  18 };
  19
  20 sub _pack_address {
  21   my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/)
  22     or croak "Invalid address '$_[0]' - expecting an integer";
  23
  24   my $p = pack(PTR_PACK_TYPE, $_[0]);
  25
  26   # FIXME - is there a saner way to check for overflows?
  27   no warnings 'portable'; # hex() with a 64bit value
  28   croak "Your system does not support addresses larger than 0x@{[ _MAX_ADDR ]}, you supplied $digits"
  29     if ( $_[0] > hex(_MAX_ADDR) or uc(unpack('H*', $p)) eq _MAX_ADDR );
  30
  31   return $p;
  32 }
  33
  34 BEGIN {
  35   # we know we start from 5.8.1
  36   if (_PERLVERSION_MIN == 9 ) {
  37     die "@{[ __PACKAGE__ ]} does not function on 5.@{[_PERLVERSION_MIN]}_xxx development perls (by design)\n";
  38   }
  39   elsif (_PERLVERSION < 5.010) {
  40     constant->import({
  41       _SV_SIZE => PTR_SIZE + 4 + 4,  # SvANY + 32bit refcnt + 32bit flags
  42       _XPV_SIZE => PTR_SIZE + $Config{sizesize} + $Config{sizesize}, # PVX ptr + cur + len
  43       _XPV_ADDR_OFFSET => undef, # it isn't really undefined, we just do not care
  44     });
  45   }
  46   elsif (_PERLVERSION < 5.018) {
  47     # The xpv address is written to the svu_pv, however we may get in trouble
  48     # due to padding/alignment when ivsize (thus svu) is larger than PTR_SIZE
  49     constant->import( _XPV_IN_SVU_OFFSET => $Config{ivsize} == PTR_SIZE ? 0 : do {
  50       my $str = 'foo';
  51       my $packed_pv_addr = pack('p', $str);
  52       my $svu_contents = unpack('P' . $Config{ivsize}, _pack_address(\$str + PTR_SIZE + 4 + 4) );
  53
  54       my $i = index $svu_contents, $packed_pv_addr;
  55       if ($i < 0) {
  56         require Devel::Peek;
  57         printf STDERR
  58           'Unable to locate the XPV address 0x%X within SVU value 0x%s - '
  59         . "this can't be right. Please file a bug including this message and "
  60         . "a full `perl -V` output (important).\n",
  61           unpack(PTR_PACK_TYPE, $packed_pv_addr),
  62           join('', map { sprintf '%X', $_ } unpack(PTR_PACK_TYPE . '*', $svu_contents ) ),
  63         ;
  64         Devel::Peek::Dump($str);
  65         exit 1;
  66       }
  67
  68       $i;
  69     });
  70
  71     constant->import({
  72       _SV_SIZE => PTR_SIZE + 4 + 4 + $Config{ivsize},  # SvANY + 32bit refcnt + 32bit flags + SV_U
  73       _XPV_SIZE => undef, # it isn't really undefined, we just do not care
  74       _XPV_ADDR_OFFSET => PTR_SIZE + 4 + 4 + _XPV_IN_SVU_OFFSET(), # so we know where to write directly
  75     });
  76   }
  77   else {
  78     # do not take any chances with not-yet-released perls - things may change
  79     die "@{[ __PACKAGE__ ]} does not *yet* support this perl $], please file a bugreport (it is very very easy to fix)\n";
  80   }
  81 }
  82
  83 sub peek {
  84   #my($location, $len_bytes) = @_;
  85   croak "Peek where and how much?" unless (defined $_[0]) and $_[1];
  86   unpack "P$_[1]", _pack_address($_[0]);
  87 }
  88
  89 # this implementation is based on (a portably written version of)
  90 # http://www.perlmonks.org/?node_id=379428
  91 # there should be a much simpler way according to Reini Urban, but I
  92 # was not able to make it work: https://gist.github.com/1151345
  93 sub poke {
  94   my($location, $bytes) = @_;
  95   croak "Poke where and what?" unless (defined $location) and (defined $bytes);
  96
  97   # sanity check and properly pack address
  98   my $addr = _pack_address($location);
  99
 100   # sanity check is (imho) warranted as described here:
 101   # http://blogs.perl.org/users/aristotle/2011/08/utf8-flag.html#comment-36499
 102   if (utf8::is_utf8($bytes) and $bytes  =~ /([^\x00-\x7F])/) {
 103     croak( ord($1) > 255
 104       ? "Expecting a byte string, but received characters"
 105       : "Expecting a byte string, but received what looks like *possible* characters, please utf8_downgrade the input"
 106     );
 107   }
 108
 109   # this should be constant once we pass the regex check above... right?
 110   my $len = length($bytes);
 111
 112   # construct a B::PV object, backed by a SV/SvPV to a dummy string length($bytes)
 113   # long, and substitute $location as the actual string storage
 114   # we specifically use the same length so we do not have to deal with resizing
 115   my $dummy = 'X' x $len;
 116   my $dummy_addr = \$dummy + 0;
 117
 118   my $ghost_sv_contents = peek($dummy_addr, _SV_SIZE);
 119
 120   if (_XPV_SIZE) {  # 5.8 xpv stuff
 121     my $xpv_addr = unpack(PTR_PACK_TYPE, peek($dummy_addr, PTR_SIZE) );
 122     my $xpv_contents = peek( $xpv_addr, _XPV_SIZE ); # we do not care about cur/len (they will be the same)
 123
 124     substr( $xpv_contents, 0, PTR_SIZE ) = $addr;  # replace pvx in xpv with the "string buffer" location
 125     substr( $ghost_sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents );  # replace xpv in sv
 126   }
 127   else { # new style 5.10+ SVs
 128     substr( $ghost_sv_contents, _XPV_ADDR_OFFSET, PTR_SIZE ) = $addr;
 129   }
 130
 131   my $ghost_string_ref = bless( \ unpack(
 132     PTR_PACK_TYPE,
 133     # it is crucial to create a copy of $sv_contents, and work with a temporary
 134     # memory location. Otherwise perl memory allocation will kick in and wreak
 135     # considerable havoc culminating with an inevitable segfault
 136     do { no warnings 'pack'; pack( 'P', $ghost_sv_contents.'' ) },
 137   ), 'B::PV' )->object_2svref;
 138
 139   # now when we write to the newly created "string" we are actually writing
 140   # to $location
 141   # note we HAVE to use lvalue substr - a plain assignment will add a \0
 142   #
 143   # Also in order to keep threading on perl 5.8.x happy we *have* to perform this
 144   # in a string eval. I don't have the slightest idea why :)
 145   eval 'substr($$ghost_string_ref, 0, $len) = $bytes';
 146
 147   return $len;
 148 }
 149
 150 1;