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