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