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 };
  18
  19 BEGIN {
  20   # we know we start from 5.8.1
  21   if ( (_PERLVERSION =~ /^5\.(\d{3})/)[0] % 2 ) {
  22     die "@{[ __PACKAGE__ ]} does not function on development perl versions (by design)\n";
  23   }
  24   elsif (_PERLVERSION < 5.010) {
  25     constant->import({
  26       _SV_SIZE => PTR_SIZE + 4 + 4,  # SvANY + 32bit refcnt + 32bit flags
  27       _XPV_SIZE => PTR_SIZE + $Config{sizesize} + $Config{sizesize}, # PVX ptr + cur + len
  28       _SVU_OFFSET => 0,
  29     });
  30   }
  31   elsif (_PERLVERSION < 5.016) {
  32     constant->import({
  33       _SV_SIZE => PTR_SIZE + 4 + 4 + $Config{ivsize},  # SvANY + 32bit refcnt + 32bit flags + SV_U
  34       _XPV_SIZE => undef, # it isn't really undefined, we just do not care
  35       _SVU_OFFSET => PTR_SIZE + 4 + 4,
  36     });
  37   }
  38   else {
  39     # do not take any chanes with not-yet-released perls - things may change
  40     die "@{[ __PACKAGE__ ]} does not *yet* support this perl $], please file a bugreport (it is very very easy to fix)\n";
  41   }
  42 }
  43
  44 sub _pack_address {
  45   my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/)
  46     or croak "Invalid address '$_[0]' - expecting an integer";
  47
  48   my $p = pack(PTR_PACK_TYPE, $_[0]);
  49
  50   # FIXME - is there a saner way to check for overflows?
  51   no warnings 'portable'; # hex() with a 64bit value
  52   croak "Your system does not support addresses larger than 0x@{[ _MAX_ADDR ]}, you supplied $digits"
  53     if ( $_[0] > hex(_MAX_ADDR) or uc(unpack('H*', $p)) eq _MAX_ADDR );
  54
  55   return $p;
  56 }
  57
  58 sub peek {
  59   #my($location, $len_bytes) = @_;
  60   croak "Peek where and how much?" unless (defined $_[0]) and $_[1];
  61   unpack "P$_[1]", _pack_address($_[0]);
  62 }
  63
  64 # this implementation is based on (a portably written version of)
  65 # http://www.perlmonks.org/?node_id=379428
  66 # there should be a much simpler way according to Reini Urban, but I
  67 # was not able to make it work: https://gist.github.com/1151345
  68 sub poke {
  69   my($location, $bytes) = @_;
  70   croak "Poke where and what?" unless (defined $location) and (defined $bytes);
  71
  72   # sanity check and properly pack address
  73   my $addr = _pack_address($location);
  74
  75   # sanity check is (imho) warranted as described here:
  76   # http://blogs.perl.org/users/aristotle/2011/08/utf8-flag.html#comment-36499
  77   if (utf8::is_utf8($bytes) and $bytes  =~ /([^\x00-\x7F])/) {
  78     croak( ord($1) > 255
  79       ? "Expecting a byte string, but received characters"
  80       : "Expecting a byte string, but received what looks like *possible* characters, please utf8_downgrade the input"
  81     );
  82   }
  83
  84   # this should be constant once we pass the regex check above... right?
  85   my $len = length($bytes);
  86
  87   # construct a B::PV object, backed by a SV/SvPV to a dummy string length($bytes)
  88   # long, and substitute $location as the actual string storage
  89   # we specifically use the same length so we do not have to deal with resizing
  90   my $dummy = 'X' x $len;
  91   my $dummy_addr = \$dummy + 0;
  92
  93   my $ghost_sv_contents = peek($dummy_addr, _SV_SIZE);
  94
  95   if (_XPV_SIZE) {  # 5.8 xpv stuff
  96     my $xpv_addr = unpack(PTR_PACK_TYPE, peek($dummy_addr, PTR_SIZE) );
  97     my $xpv_contents = peek( $xpv_addr, _XPV_SIZE ); # we do not care about cur/len (they will be the same)
  98
  99     substr( $xpv_contents, 0, PTR_SIZE ) = $addr;  # replace pvx in xpv with the "string buffer" location
 100     substr( $ghost_sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents );  # replace xpv in sv
 101   }
 102   else { # new style 5.10+ SVs
 103     substr( $ghost_sv_contents, _SVU_OFFSET, PTR_SIZE ) = $addr;
 104   }
 105
 106   my $ghost_string_ref = bless( \ unpack(
 107     PTR_PACK_TYPE,
 108     # it is crucial to create a copy of $sv_contents, and work with a temporary
 109     # memory location. Otherwise perl memory allocation will kick in and wreak
 110     # considerable havoc culminating with an inevitable segfault
 111     do { no warnings 'pack'; pack( 'P', $ghost_sv_contents.'' ) },
 112   ), 'B::PV' )->object_2svref;
 113
 114   # now when we write to the newly created "string" we are actually writing
 115   # to $location
 116   # note we HAVE to use lvalue substr - a plain assignment will add a \0
 117   #
 118   # Also in order to keep threading on perl 5.8.x happy we *have* to perform this
 119   # in a string eval. I don't have the slightest idea why :)
 120   eval 'substr($$ghost_string_ref, 0, $len) = $bytes';
 121
 122   return $len;
 123 }
 124
 125 1;