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 | |
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 $_[0]" |
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 $new_sv_ref = \ unpack( PTR_PACK_TYPE, pack( 'P', $sv_contents ) ); |
96 | my $artificial_string = bless( $new_sv_ref, 'B::PV' )->object_2svref; |
97 | |
98 | # now when we write to the newly created "string" we are actually writing |
99 | # to $location |
100 | # note we HAVE to use lvalue substr - a plain assignment will add a \0 |
101 | substr($$artificial_string, 0, $len) = $bytes; |
102 | return $len; |
103 | } |
104 | |
105 | 1; |