view release on metacpan or  search on metacpan

ext/Devel-Peek/t/Peek.t  view on Meta::CPAN

            die $@ if $@;
            $setup_stderr->();
            $sub->();
            print STDERR "*****\n";
            # second dump to compare with the first to make sure nothing
            # changed.
            $sub->();
        }
        else {
            $setup_stderr->();
            Dump($_[1]);
            print STDERR "*****\n";
            # second dump to compare with the first to make sure nothing
            # changed.
            Dump($_[1]);
        }
	open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
	close(OUT);
	if (open(IN, '<', "peek$$")) {
	    local $/;
	    $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
	    $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
	    # handle DEBUG_LEAKING_SCALARS prefix
	    $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;

	    # Need some clear generic mechanism to eliminate (or add) lines
	    # of dump output dependant on perl version. The (previous) use of
	    # things like $IVNV gave the illusion that the string passed in was
	    # a regexp into which variables were interpolated, but this wasn't
	    # actually true as those 'variables' actually also ate the
	    # whitespace on the line. So it seems better to mark lines that
	    # need to be eliminated. I considered (?# ... ) and (?{ ... }),
	    # but whilst embedded code or comment syntax would keep it as a
	    # legitimate regexp, it still isn't true. Seems easier and clearer
	    # things that look like comments.

	    # Could do this is in a s///mge but seems clearer like this:
	    $pattern = join '', map {
		# If we identify the version condition, take *it* out whatever
		s/\s*# (\$\].*)$//
		    ? (eval $1 ? $_ : '')
		    : $_ # Didn't match, so this line is in
	    } split /^/, $pattern;
	    
	    $pattern =~ s/\$PADMY,/
		$] < 5.012005 ? 'PADMY,' : '';
	    /mge;
	    $pattern =~ s/\$RV/
		($] < 5.011) ? 'RV' : 'IV';
	    /mge;
	    $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
		if $Config{ccflags} =~
			/-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
			    || $] < 5.019003;
            if ($Config::Config{ccflags} =~ /-DNODEFAULT_SHAREKEYS\b/) {
                $pattern =~ s/,SHAREKEYS\b//g;
                $pattern =~ s/\bSHAREKEYS,//g;
                $pattern =~ s/\bSHAREKEYS\b//g;
            }
	    print $pattern, "\n" if $DEBUG;
	    my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
	    print $dump, "\n"    if $DEBUG;
	    like( $dump, qr/\A$pattern\Z/ms, $_[0])
	      or note("line " . (caller)[2]);

            local $TODO = $repeat_todo;
            is($dump2, $dump, "$_[0] (unchanged by dump)")
	      or note("line " . (caller)[2]);

	    close(IN);

            return $1;
	} else {
	    die "$0: failed to open peek$$: !\n";
	}
    } else {
	die "$0: failed to create peek$$: $!\n";
    }
}

our   $a;
our   $b;
my    $c;
local $d = 0;

END {
    1 while unlink("peek$$");
}

do_test('assignment of immediate constant (string)',
	$a = "foo",
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = \d+
  FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
  PV = $ADDR "foo"\\\0
  CUR = 3
  LEN = \\d+
  COW_REFCNT = 1
');

do_test('immediate constant (string)',
        "bar",
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = \d+
  FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)		# $] < 5.021005
  FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\)	# $] >=5.021005
  PV = $ADDR "bar"\\\0
  CUR = 3
  LEN = \\d+
  COW_REFCNT = 0
');

do_test('assignment of immediate constant (integer)',
        $b = 123,
'SV = IV\\($ADDR\\) at $ADDR
  REFCNT = \d+
  FLAGS = \\(IOK,pIOK\\)
  IV = 123');

do_test('immediate constant (integer)',
        456,