use Devel::PeekPoke::Constants qw/PTR_SIZE PTR_PACK_TYPE/;
use B (); # for B::PV
-# we do not support every perl, as we rely on the implementation of SV/SvPV
-BEGIN { eval "sub __PERLVER () { $] }" };
-
-my ($svsize, $svu_offset, $xpv_size);
-# we know we start from 5.8.1
-if ( (__PERLVER =~ /^5\.(\d{3})/)[0] % 2 ) {
- die "@{[ __PACKAGE__ ]} does not function on development perl versions (by design)\n";
-}
-elsif (__PERLVER < 5.010) {
- $svsize = PTR_SIZE + 4 + 4; # SvANY + 32bit refcnt + 32bit flags
- $xpv_size = PTR_SIZE + $Config{sizesize} + $Config{sizesize}; # PVX ptr + cur + len
-}
-elsif (__PERLVER < 5.016) {
- $svsize = PTR_SIZE + 4 + 4 + $Config{ivsize}; # SvANY + 32bit refcnt + 32bit flags + SV_U
- $svu_offset = PTR_SIZE + 4 + 4;
-}
-else {
- # do not take any chanes with not-yet-released perls - things may change
- die "@{[ __PACKAGE__ ]} does not *yet* support this perl $], please file a bugreport (it is very very easy to fix)\n";
-}
-
-my $max_addr = ('FF' x PTR_SIZE);
+use constant {
+ _MAX_ADDR => 'FF' x PTR_SIZE,
+ _PERLVERSION => "$]", # we do not support every perl, as we rely on the implementation of SV/SvPV
+ _PERLVERSION_MIN => ($] =~ /^5\.(\d{3})/)[0],
+};
sub _pack_address {
my ($digits) = (defined $_[0] and $_[0] =~ /^(\d+)$/)
# FIXME - is there a saner way to check for overflows?
no warnings 'portable'; # hex() with a 64bit value
- croak "Your system does not support addresses larger than 0x$max_addr, you supplied $_[0]"
- if ( $_[0] > hex($max_addr) or uc(unpack('H*', $p)) eq $max_addr );
+ croak "Your system does not support addresses larger than 0x@{[ _MAX_ADDR ]}, you supplied $digits"
+ if ( $_[0] > hex(_MAX_ADDR) or uc(unpack('H*', $p)) eq _MAX_ADDR );
return $p;
}
+BEGIN {
+ # we know we start from 5.8.1
+ if (_PERLVERSION_MIN == 9 ) {
+ die "@{[ __PACKAGE__ ]} does not function on 5.@{[_PERLVERSION_MIN]}_xxx development perls (by design)\n";
+ }
+ elsif (_PERLVERSION < 5.010) {
+ constant->import({
+ _SV_SIZE => PTR_SIZE + 4 + 4, # SvANY + 32bit refcnt + 32bit flags
+ _XPV_SIZE => PTR_SIZE + $Config{sizesize} + $Config{sizesize}, # PVX ptr + cur + len
+ _XPV_ADDR_OFFSET => undef, # it isn't really undefined, we just do not care
+ });
+ }
+ elsif (_PERLVERSION < 5.018) {
+ # The xpv address is written to the svu_pv, however we may get in trouble
+ # due to padding/alignment when ivsize (thus svu) is larger than PTR_SIZE
+ constant->import( _XPV_IN_SVU_OFFSET => $Config{ivsize} == PTR_SIZE ? 0 : do {
+ my $str = 'foo';
+ my $packed_pv_addr = pack('p', $str);
+ my $svu_contents = unpack('P' . $Config{ivsize}, _pack_address(\$str + PTR_SIZE + 4 + 4) );
+
+ my $i = index $svu_contents, $packed_pv_addr;
+ if ($i < 0) {
+ require Devel::Peek;
+ printf STDERR
+ 'Unable to locate the XPV address 0x%X within SVU value 0x%s - '
+ . "this can't be right. Please file a bug including this message and "
+ . "a full `perl -V` output (important).\n",
+ unpack(PTR_PACK_TYPE, $packed_pv_addr),
+ join('', map { sprintf '%X', $_ } unpack(PTR_PACK_TYPE . '*', $svu_contents ) ),
+ ;
+ Devel::Peek::Dump($str);
+ exit 1;
+ }
+
+ $i;
+ });
+
+ constant->import({
+ _SV_SIZE => PTR_SIZE + 4 + 4 + $Config{ivsize}, # SvANY + 32bit refcnt + 32bit flags + SV_U
+ _XPV_SIZE => undef, # it isn't really undefined, we just do not care
+ _XPV_ADDR_OFFSET => PTR_SIZE + 4 + 4 + _XPV_IN_SVU_OFFSET(), # so we know where to write directly
+ });
+ }
+ else {
+ # do not take any chances with not-yet-released perls - things may change
+ die "@{[ __PACKAGE__ ]} does not *yet* support this perl $], please file a bugreport (it is very very easy to fix)\n";
+ }
+}
+
sub peek {
#my($location, $len_bytes) = @_;
croak "Peek where and how much?" unless (defined $_[0]) and $_[1];
my($location, $bytes) = @_;
croak "Poke where and what?" unless (defined $location) and (defined $bytes);
+ # sanity check and properly pack address
+ my $addr = _pack_address($location);
+
# sanity check is (imho) warranted as described here:
# http://blogs.perl.org/users/aristotle/2011/08/utf8-flag.html#comment-36499
if (utf8::is_utf8($bytes) and $bytes =~ /([^\x00-\x7F])/) {
# this should be constant once we pass the regex check above... right?
my $len = length($bytes);
- # construct a B::PV object, backed by a SV/SvPV to a dummy string lenth($bytes)
- # long, and subtitute $location as the actual string storage
+ # construct a B::PV object, backed by a SV/SvPV to a dummy string length($bytes)
+ # long, and substitute $location as the actual string storage
# we specifically use the same length so we do not have to deal with resizing
- my $sv_ref = \( 'X' x $len );
- my $sv_contents = peek($sv_ref+0, $svsize);
- my $xpv_contents;
+ my $dummy = 'X' x $len;
+ my $dummy_addr = \$dummy + 0;
- if (defined $svu_offset) { # new style 5.10+ SVs
- substr( $sv_contents, $svu_offset, PTR_SIZE ) = _pack_address($location);
- }
- else { # 5.8 xpv stuff
- my $xpv_addr = unpack(PTR_PACK_TYPE, peek($sv_ref+0, PTR_SIZE) );
- my $xpv_contents = peek( $xpv_addr, $xpv_size ); # we do not care about cur/len
+ my $ghost_sv_contents = peek($dummy_addr, _SV_SIZE);
+
+ if (_XPV_SIZE) { # 5.8 xpv stuff
+ my $xpv_addr = unpack(PTR_PACK_TYPE, peek($dummy_addr, PTR_SIZE) );
+ my $xpv_contents = peek( $xpv_addr, _XPV_SIZE ); # we do not care about cur/len (they will be the same)
- substr( $xpv_contents, 0, PTR_SIZE ) = _pack_address($location); # replace pvx in xpv with sanity-checked $location
- substr( $sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents ); # replace xpv in sv
+ substr( $xpv_contents, 0, PTR_SIZE ) = $addr; # replace pvx in xpv with the "string buffer" location
+ substr( $ghost_sv_contents, 0, PTR_SIZE) = pack ('P', $xpv_contents ); # replace xpv in sv
+ }
+ else { # new style 5.10+ SVs
+ substr( $ghost_sv_contents, _XPV_ADDR_OFFSET, PTR_SIZE ) = $addr;
}
- my $new_sv_ref = \ unpack( PTR_PACK_TYPE, pack( 'P', $sv_contents ) );
- my $artificial_string = bless( $new_sv_ref, 'B::PV' )->object_2svref;
+ my $ghost_string_ref = bless( \ unpack(
+ PTR_PACK_TYPE,
+ # it is crucial to create a copy of $sv_contents, and work with a temporary
+ # memory location. Otherwise perl memory allocation will kick in and wreak
+ # considerable havoc culminating with an inevitable segfault
+ do { no warnings 'pack'; pack( 'P', $ghost_sv_contents.'' ) },
+ ), 'B::PV' )->object_2svref;
# now when we write to the newly created "string" we are actually writing
# to $location
# note we HAVE to use lvalue substr - a plain assignment will add a \0
- substr($$artificial_string, 0, $len) = $bytes;
+ #
+ # Also in order to keep threading on perl 5.8.x happy we *have* to perform this
+ # in a string eval. I don't have the slightest idea why :)
+ eval 'substr($$ghost_string_ref, 0, $len) = $bytes';
+
return $len;
}
projects / p5sagit/Devel-PeekPoke.git / blobdiff