Commit | Line | Data |
6be43b56 |
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 | |
42cf0549 |
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 | |
569e5f29 |
19 | sub _pack_address { |
20 | my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/) |
21 | or croak "Invalid address '$_[0]' - expecting an integer"; |
22 | |
23 | my $p = pack(PTR_PACK_TYPE, $_[0]); |
24 | |
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 ); |
29 | |
30 | return $p; |
31 | } |
32 | |
42cf0549 |
33 | BEGIN { |
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"; |
37 | } |
38 | elsif (_PERLVERSION < 5.010) { |
39 | constant->import({ |
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 |
569e5f29 |
42 | _XPV_ADDR_OFFSET => undef, # it isn't really undefined, we just do not care |
42cf0549 |
43 | }); |
44 | } |
45 | elsif (_PERLVERSION < 5.016) { |
569e5f29 |
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 { |
49 | my $str = 'foo'; |
50 | my $packed_pv_addr = pack('p', $str); |
51 | my $svu_contents = unpack('P' . $Config{ivsize}, _pack_address(\$str + PTR_SIZE + 4 + 4) ); |
52 | |
53 | my $i = index $svu_contents, $packed_pv_addr; |
54 | if ($i < 0) { |
55 | require Devel::Peek; |
56 | printf STDERR |
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 ) ), |
62 | ; |
63 | Devel::Peek::Dump($str); |
64 | exit 1; |
65 | } |
66 | |
67 | $i; |
68 | }); |
69 | |
42cf0549 |
70 | constant->import({ |
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 |
569e5f29 |
73 | _XPV_ADDR_OFFSET => PTR_SIZE + 4 + 4 + _XPV_IN_SVU_OFFSET(), # so we know where to write directly |
42cf0549 |
74 | }); |
75 | } |
76 | else { |
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"; |
79 | } |
6be43b56 |
80 | } |
81 | |
6be43b56 |
82 | sub peek { |
83 | #my($location, $len_bytes) = @_; |
84 | croak "Peek where and how much?" unless (defined $_[0]) and $_[1]; |
85 | unpack "P$_[1]", _pack_address($_[0]); |
86 | } |
87 | |
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 |
92 | sub poke { |
93 | my($location, $bytes) = @_; |
94 | croak "Poke where and what?" unless (defined $location) and (defined $bytes); |
95 | |
24538b08 |
96 | # sanity check and properly pack address |
97 | my $addr = _pack_address($location); |
98 | |
6be43b56 |
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])/) { |
102 | croak( ord($1) > 255 |
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" |
105 | ); |
106 | } |
107 | |
108 | # this should be constant once we pass the regex check above... right? |
109 | my $len = length($bytes); |
110 | |
42cf0549 |
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 |
6be43b56 |
113 | # we specifically use the same length so we do not have to deal with resizing |
42cf0549 |
114 | my $dummy = 'X' x $len; |
115 | my $dummy_addr = \$dummy + 0; |
6be43b56 |
116 | |
42cf0549 |
117 | my $ghost_sv_contents = peek($dummy_addr, _SV_SIZE); |
118 | |
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) |
6be43b56 |
122 | |
24538b08 |
123 | substr( $xpv_contents, 0, PTR_SIZE ) = $addr; # replace pvx in xpv with the "string buffer" location |
42cf0549 |
124 | substr( $ghost_sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents ); # replace xpv in sv |
125 | } |
126 | else { # new style 5.10+ SVs |
569e5f29 |
127 | substr( $ghost_sv_contents, _XPV_ADDR_OFFSET, PTR_SIZE ) = $addr; |
6be43b56 |
128 | } |
129 | |
42cf0549 |
130 | my $ghost_string_ref = bless( \ unpack( |
131 | PTR_PACK_TYPE, |
36e403bb |
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 |
42cf0549 |
135 | do { no warnings 'pack'; pack( 'P', $ghost_sv_contents.'' ) }, |
136 | ), 'B::PV' )->object_2svref; |
6be43b56 |
137 | |
138 | # now when we write to the newly created "string" we are actually writing |
139 | # to $location |
140 | # note we HAVE to use lvalue substr - a plain assignment will add a \0 |
24538b08 |
141 | # |
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'; |
36e403bb |
145 | |
6be43b56 |
146 | return $len; |
147 | } |
148 | |
149 | 1; |