path: root/ext/Devel-Peek/t/Peek.t

#!./perl -T

BEGIN {
    require Config; import Config;
    if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
        print "1..0 # Skip: Devel::Peek was not built\n";
        exit 0;
    }
}

use Test::More;

use Devel::Peek;

our $DEBUG = 0;
open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";

# If I reference any lexicals in this, I get the entire outer subroutine (or
# MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
# maintain that.
format PIE =
Pie     @<<<<<
$::type
Good    @>>>>>
$::mmmm
.

use constant thr => $Config{useithreads};

sub do_test {
    my $todo = $_[3];
    my $repeat_todo = $_[4];
    my $pattern = $_[2];
    if (open(OUT,">peek$$")) {
	open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
	Dump($_[1]);
        print STDERR "*****\n";
        Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
	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.009) ? 'PADBUSY,PADMY' : 'PADMY';
	    /mge;
	    $pattern =~ s/\$PADTMP/
		($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
	    /mge;
	    $pattern =~ s/\$RV/
		($] < 5.011) ? 'RV' : 'IV';
	    /mge;

	    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 = 1
  FLAGS = \\(POK,pPOK\\)
  PV = $ADDR "foo"\\\0
  CUR = 3
  LEN = \\d+'
       );

do_test('immediate constant (string)',
        "bar",
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(.*POK,READONLY,pPOK\\)
  PV = $ADDR "bar"\\\0
  CUR = 3
  LEN = \\d+');

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

do_test('immediate constant (integer)',
        456,
'SV = IV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(.*IOK,READONLY,pIOK\\)
  IV = 456');

do_test('assignment of immediate constant (integer)',
        $c = 456,
'SV = IV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\($PADMY,IOK,pIOK\\)
  IV = 456');

# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
# maths is done in floating point always, and this scalar will be an NV.
# ([NI]) captures the type, referred to by \1 in this regexp and $type for
# building subsequent regexps.
my $type = do_test('result of addition',
        $c + $d,
'SV = ([NI])V\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(PADTMP,\1OK,p\1OK\\)
  \1V = 456');

($d = "789") += 0.1;

do_test('floating point value',
       $d,
'SV = PVNV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(NOK,pNOK\\)
  IV = \d+
  NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
  PV = $ADDR "789"\\\0
  CUR = 3
  LEN = \\d+');

do_test('integer constant',
        0xabcd,
'SV = IV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(.*IOK,READONLY,pIOK\\)
  IV = 43981');

do_test('undef',
        undef,
'SV = NULL\\(0x0\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(\\)');

do_test('reference to scalar',
        \$a,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PV\\($ADDR\\) at $ADDR
    REFCNT = 2
    FLAGS = \\(POK,pPOK\\)
    PV = $ADDR "foo"\\\0
    CUR = 3
    LEN = \\d+');

my $c_pattern;
if ($type eq 'N') {
  $c_pattern = '
    SV = PVNV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
      IV = 456
      NV = 456
      PV = 0';
} else {
  $c_pattern = '
    SV = IV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(IOK,pIOK\\)
      IV = 456';
}
do_test('reference to array',
       [$b,$c],
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVAV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(\\)
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    ARRAY = $ADDR
    FILL = 1
    MAX = 1
    ARYLEN = 0x0
    FLAGS = \\(REAL\\)
    Elt No. 0
    SV = IV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(IOK,pIOK\\)
      IV = 123
    Elt No. 1' . $c_pattern);

do_test('reference to hash',
       {$b=>$c},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(SHAREKEYS\\)
    IV = 1					# $] < 5.009
    NV = $FLOAT					# $] < 5.009
    ARRAY = $ADDR  \\(0:7, 1:1\\)
    hash quality = 100.0%
    KEYS = 1
    FILL = 1
    MAX = 7
    RITER = -1
    EITER = 0x0
    Elt "123" HASH = $ADDR' . $c_pattern,
	'',
	$] > 5.009 && $] < 5.015
	 && 'The hash iterator used in dump.c sets the OOK flag');

do_test('reference to anon sub with empty prototype',
        sub(){@_},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVCV\\($ADDR\\) at $ADDR
    REFCNT = 2
    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    PROTOTYPE = ""
    COMP_STASH = $ADDR\\t"main"
    START = $ADDR ===> \\d+
    ROOT = $ADDR
    XSUB = 0x0					# $] < 5.009
    XSUBANY = 0					# $] < 5.009
    GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
    FILE = ".*\\b(?i:peek\\.t)"
    DEPTH = 0(?:
    MUTEXP = $ADDR
    OWNER = $ADDR)?
    FLAGS = 0x404				# $] < 5.009
    FLAGS = 0x490		# $] >= 5.009 && ($] < 5.015 || !thr)
    FLAGS = 0x1490				# $] >= 5.015 && thr
    OUTSIDE_SEQ = \\d+
    PADLIST = $ADDR
    PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
    OUTSIDE = $ADDR \\(MAIN\\)');

do_test('reference to named subroutine without prototype',
        \&do_test,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVCV\\($ADDR\\) at $ADDR
    REFCNT = (3|4)
    FLAGS = \\(\\)				# $] < 5.015 || !thr
    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && thr
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    COMP_STASH = $ADDR\\t"main"
    START = $ADDR ===> \\d+
    ROOT = $ADDR
    XSUB = 0x0					# $] < 5.009
    XSUBANY = 0					# $] < 5.009
    GVGV::GV = $ADDR\\t"main" :: "do_test"
    FILE = ".*\\b(?i:peek\\.t)"
    DEPTH = 1(?:
    MUTEXP = $ADDR
    OWNER = $ADDR)?
    FLAGS = 0x0					# $] < 5.015 || !thr
    FLAGS = 0x1000				# $] >= 5.015 && thr
    OUTSIDE_SEQ = \\d+
    PADLIST = $ADDR
    PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
      \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"			# $] < 5.009
      \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0	# $] >= 5.009
      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
    OUTSIDE = $ADDR \\(MAIN\\)');

if ($] >= 5.011) {
do_test('reference to regexp',
        qr(tic),
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = REGEXP\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
    PV = $ADDR "\\(\\?\\^:tic\\)"
    CUR = 8
    LEN = 0
    STASH = $ADDR\\t"Regexp"'
. ($] < 5.013 ? '' :
'
    EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
    INTFLAGS = 0x0
    NPARENS = 0
    LASTPAREN = 0
    LASTCLOSEPAREN = 0
    MINLEN = 3
    MINLENRET = 3
    GOFS = 0
    PRE_PREFIX = 4
    SEEN_EVALS = 0
    SUBLEN = 0
    SUBBEG = 0x0
    ENGINE = $ADDR
    MOTHER_RE = $ADDR
    PAREN_NAMES = 0x0
    SUBSTRS = $ADDR
    PPRIVATE = $ADDR
    OFFS = $ADDR'
));
} else {
do_test('reference to regexp',
        qr(tic),
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVMG\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(OBJECT,SMG\\)
    IV = 0
    NV = 0
    PV = 0
    MAGIC = $ADDR
      MG_VIRTUAL = $ADDR
      MG_TYPE = PERL_MAGIC_qr\(r\)
      MG_OBJ = $ADDR
        PAT = "\(\?^:tic\)"			# $] >= 5.009
        REFCNT = 2				# $] >= 5.009
    STASH = $ADDR\\t"Regexp"');
}

do_test('reference to blessed hash',
        (bless {}, "Tac"),
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(OBJECT,SHAREKEYS\\)
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    STASH = $ADDR\\t"Tac"
    ARRAY = 0x0
    KEYS = 0
    FILL = 0
    MAX = 7
    RITER = -1
    EITER = 0x0', '',
	$] > 5.009
	? $] >= 5.015
	     ? 0
	     : 'The hash iterator used in dump.c sets the OOK flag'
	: "Something causes the HV's array to become allocated");

do_test('typeglob',
	*a,
'SV = PVGV\\($ADDR\\) at $ADDR
  REFCNT = 5
  FLAGS = \\(MULTI(?:,IN_PAD)?\\)		# $] >= 5.009
  FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)	# $] < 5.009
  IV = 0					# $] < 5.009
  NV = 0					# $] < 5.009
  PV = 0					# $] < 5.009
  MAGIC = $ADDR					# $] < 5.009
    MG_VIRTUAL = &PL_vtbl_glob			# $] < 5.009
    MG_TYPE = PERL_MAGIC_glob\(\*\)		# $] < 5.009
    MG_OBJ = $ADDR				# $] < 5.009
  NAME = "a"
  NAMELEN = 1
  GvSTASH = $ADDR\\t"main"
  GP = $ADDR
    SV = $ADDR
    REFCNT = 1
    IO = 0x0
    FORM = 0x0  
    AV = 0x0
    HV = 0x0
    CV = 0x0
    CVGEN = 0x0
    GPFLAGS = 0x0				# $] < 5.009
    LINE = \\d+
    FILE = ".*\\b(?i:peek\\.t)"
    FLAGS = $ADDR
    EGV = $ADDR\\t"a"');

if (ord('A') == 193) {
do_test('string with Unicode',
	chr(256).chr(0).chr(512),
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
  PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
  CUR = 5
  LEN = \\d+');
} else {
do_test('string with Unicode',
	chr(256).chr(0).chr(512),
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
  PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
  CUR = 5
  LEN = \\d+');
}

if (ord('A') == 193) {
do_test('reference to hash containing Unicode',
	{chr(256)=>chr(512)},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
    UV = 1					# $] < 5.009
    NV = $FLOAT					# $] < 5.009
    ARRAY = $ADDR  \\(0:7, 1:1\\)
    hash quality = 100.0%
    KEYS = 1
    FILL = 1
    MAX = 7
    RITER = -1
    EITER = $ADDR
    Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
    SV = PV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(POK,pPOK,UTF8\\)
      PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
      CUR = 2
      LEN = \\d+',
	$] > 5.009
	? $] >= 5.015
	    ?  0
	    : 'The hash iterator used in dump.c sets the OOK flag'
	: 'sv_length has been called on the element, and cached the result in MAGIC');
} else {
do_test('reference to hash containing Unicode',
	{chr(256)=>chr(512)},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
    UV = 1					# $] < 5.009
    NV = 0					# $] < 5.009
    ARRAY = $ADDR  \\(0:7, 1:1\\)
    hash quality = 100.0%
    KEYS = 1
    FILL = 1
    MAX = 7
    RITER = -1
    EITER = $ADDR
    Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
    SV = PV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(POK,pPOK,UTF8\\)
      PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
      CUR = 2
      LEN = \\d+', '',
	$] > 5.009
	? $] >= 5.015
	    ?  0
	    : 'The hash iterator used in dump.c sets the OOK flag'
	: 'sv_length has been called on the element, and cached the result in MAGIC');
}

my $x="";
$x=~/.??/g;
do_test('scalar with pos magic',
        $x,
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\($PADMY,SMG,POK,pPOK\\)
  IV = 0
  NV = 0
  PV = $ADDR ""\\\0
  CUR = 0
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_mglob
    MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
    MG_FLAGS = 0x01
      MINMATCH');

#
# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
# environment variables may be invisibly case-forced, hence the (?i:PATH)
# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
# VMS is setting FAKE and READONLY flags.  What VMS uses for storing
# ENV hashes is also not always null terminated.
#
do_test('tainted value in %ENV',
        $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
  IV = 0
  NV = 0
  PV = $ADDR "0"\\\0
  CUR = 1
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_envelem
    MG_TYPE = PERL_MAGIC_envelem\\(e\\)
(?:    MG_FLAGS = 0x01
      TAINTEDDIR
)?    MG_LEN = -?\d+
    MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
    SV = PV(?:IV)?\\($ADDR\\) at $ADDR
      REFCNT = \d+
      FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
(?:      IV = 0
)?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
      CUR = \d+
      LEN = \d+)
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_taint
    MG_TYPE = PERL_MAGIC_taint\\(t\\)');

do_test('blessed reference',
	bless(\\undef, 'Foobar'),
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVMG\\($ADDR\\) at $ADDR
    REFCNT = 2
    FLAGS = \\(OBJECT,ROK\\)
    IV = -?\d+
    NV = $FLOAT
    RV = $ADDR
    SV = NULL\\(0x0\\) at $ADDR
      REFCNT = \d+
      FLAGS = \\(READONLY\\)
    PV = $ADDR ""
    CUR = 0
    LEN = 0
    STASH = $ADDR\s+"Foobar"');

sub const () {
    "Perl rules";
}

do_test('constant subroutine',
	\&const,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVCV\\($ADDR\\) at $ADDR
    REFCNT = (2)
    FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)		# $] < 5.015
    FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\)	# $] >= 5.015
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    PROTOTYPE = ""
    COMP_STASH = 0x0
    ROOT = 0x0					# $] < 5.009
    XSUB = $ADDR
    XSUBANY = $ADDR \\(CONST SV\\)
    SV = PV\\($ADDR\\) at $ADDR
      REFCNT = 1
      FLAGS = \\(.*POK,READONLY,pPOK\\)
      PV = $ADDR "Perl rules"\\\0
      CUR = 10
      LEN = \\d+
    GVGV::GV = $ADDR\\t"main" :: "const"
    FILE = ".*\\b(?i:peek\\.t)"
    DEPTH = 0(?:
    MUTEXP = $ADDR
    OWNER = $ADDR)?
    FLAGS = 0x200				# $] < 5.009
    FLAGS = 0xc00				# $] >= 5.009 && $] < 5.013
    FLAGS = 0xc					# $] >= 5.013 && $] < 5.015
    FLAGS = 0x100c				# $] >= 5.015
    OUTSIDE_SEQ = 0
    PADLIST = 0x0
    OUTSIDE = 0x0 \\(null\\)');	

do_test('isUV should show on PVMG',
	do { my $v = $1; $v = ~0; $v },
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(IOK,pIOK,IsUV\\)
  UV = \d+
  NV = 0
  PV = 0');

do_test('IO',
	*STDOUT{IO},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVIO\\($ADDR\\) at $ADDR
    REFCNT = 3
    FLAGS = \\(OBJECT\\)
    IV = 0					# $] < 5.011
    NV = 0					# $] < 5.011
    STASH = $ADDR\s+"IO::File"
    IFP = $ADDR
    OFP = $ADDR
    DIRP = 0x0
    LINES = 0
    PAGE = 0
    PAGE_LEN = 60
    LINES_LEFT = 0
    TOP_GV = 0x0
    FMT_GV = 0x0
    BOTTOM_GV = 0x0
    SUBPROCESS = 0				# $] < 5.009
    TYPE = \'>\'
    FLAGS = 0x4');

do_test('FORMAT',
	*PIE{FORMAT},
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVFM\\($ADDR\\) at $ADDR
    REFCNT = 2
    FLAGS = \\(\\)				# $] < 5.015 || !thr
    FLAGS = \\(DYNFILE\\)			# $] >= 5.015 && thr
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
(?:    PV = 0
)?    COMP_STASH = 0x0
    START = $ADDR ===> \\d+
    ROOT = $ADDR
    XSUB = 0x0					# $] < 5.009
    XSUBANY = 0					# $] < 5.009
    GVGV::GV = $ADDR\\t"main" :: "PIE"
    FILE = ".*\\b(?i:peek\\.t)"(?:
    DEPTH = 0
    MUTEXP = $ADDR
    OWNER = $ADDR)?
    FLAGS = 0x0					# $] < 5.015 || !thr
    FLAGS = 0x1000				# $] >= 5.015 && thr
    OUTSIDE_SEQ = \\d+
    LINES = 0
    PADLIST = $ADDR
    PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
    OUTSIDE = $ADDR \\(MAIN\\)');

do_test('blessing to a class with embedded NUL characters',
        (bless {}, "\0::foo::\n::baz::\t::\0"),
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 1
    FLAGS = \\(OBJECT,SHAREKEYS\\)
    IV = 0					# $] < 5.009
    NV = 0					# $] < 5.009
    STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
    ARRAY = $ADDR
    KEYS = 0
    FILL = 0
    MAX = 7
    RITER = -1
    EITER = 0x0', '',
	$] > 5.009
	? $] >= 5.015
	    ?  0
	    : 'The hash iterator used in dump.c sets the OOK flag'
	: "Something causes the HV's array to become allocated");

do_test('ENAME on a stash',
        \%RWOM::,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 2
    FLAGS = \\(OOK,SHAREKEYS\\)
    IV = 1					# $] < 5.009
    NV = $FLOAT					# $] < 5.009
    ARRAY = $ADDR
    KEYS = 0
    FILL = 0
    MAX = 7
    RITER = -1
    EITER = 0x0
    NAME = "RWOM"
    ENAME = "RWOM"				# $] > 5.012
');

*KLANK:: = \%RWOM::;

do_test('ENAMEs on a stash',
        \%RWOM::,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 3
    FLAGS = \\(OOK,SHAREKEYS\\)
    IV = 1					# $] < 5.009
    NV = $FLOAT					# $] < 5.009
    ARRAY = $ADDR
    KEYS = 0
    FILL = 0
    MAX = 7
    RITER = -1
    EITER = 0x0
    NAME = "RWOM"
    NAMECOUNT = 2				# $] > 5.012
    ENAME = "RWOM", "KLANK"			# $] > 5.012
');

undef %RWOM::;

do_test('ENAMEs on a stash with no NAME',
        \%RWOM::,
'SV = $RV\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(ROK\\)
  RV = $ADDR
  SV = PVHV\\($ADDR\\) at $ADDR
    REFCNT = 3
    FLAGS = \\(OOK,SHAREKEYS\\)
    IV = 1					# $] < 5.009
    NV = $FLOAT					# $] < 5.009
    ARRAY = $ADDR
    KEYS = 0
    FILL = 0
    MAX = 7
    RITER = -1
    EITER = 0x0
    NAMECOUNT = -3				# $] > 5.012
    ENAME = "RWOM", "KLANK"			# $] > 5.012
');

SKIP: {
    skip "Not built with usemymalloc", 1
      unless $Config{usemymalloc} eq 'y';
    my $x = __PACKAGE__;
    ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
     or diag $@;
}

# This is more a test of fbm_compile/pp_study (non) interaction than dumping
# prowess, but short of duplicating all the gubbins of this file, I can't see
# a way to make a better place for it:

use constant {
    perl => 'rules',
    beer => 'foamy',
};

unless ($Config{useithreads}) {
    # These end up as copies in pads under ithreads, which rather defeats the
    # the point of what we're trying to test here.

    do_test('regular string constant', perl,
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = 5
  FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
  PV = $ADDR "rules"\\\0
  CUR = 5
  LEN = \d+
');

    eval 'index "", perl';

    # FIXME - really this shouldn't say EVALED. It's a false posistive on
    # 0x40000000 being used for several things, not a flag for "I'm in a string
    # eval"

    do_test('string constant now an FBM', perl,
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 5
  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
  PV = $ADDR "rules"\\\0
  CUR = 5
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_TYPE = PERL_MAGIC_bm\\(B\\)
    MG_LEN = 256
    MG_PTR = $ADDR "(?:\\\\\d){256}"
  RARE = \d+
  PREVIOUS = 1
  USEFUL = 100
');

    is(study perl, '', "Not allowed to study an FBM");

    do_test('string constant still an FBM', perl,
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 5
  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
  PV = $ADDR "rules"\\\0
  CUR = 5
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_TYPE = PERL_MAGIC_bm\\(B\\)
    MG_LEN = 256
    MG_PTR = $ADDR "(?:\\\\\d){256}"
  RARE = \d+
  PREVIOUS = 1
  USEFUL = 100
');

    do_test('regular string constant', beer,
'SV = PV\\($ADDR\\) at $ADDR
  REFCNT = 6
  FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
  PV = $ADDR "foamy"\\\0
  CUR = 5
  LEN = \d+
');

    my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 6
  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
  IV = 0
  NV = 0
  PV = $ADDR "foamy"\\\0
  CUR = 5
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_PRIVATE = 1
    MG_TYPE = PERL_MAGIC_study\\(G\\)
    MG_LEN = 261
    MG_PTR = $ADDR "\\\\377.*"
';

    is(study beer, 1, "Our studies were successful");

    do_test('string constant now studied', beer, $want);

    is (eval 'index "not too foamy", beer', 8, 'correct index');

    do_test('string constant still studied', beer, $want);

    my $pie = 'good';

    is(study $pie, 1, "Our studies were successful");

    do_test('string constant still studied', beer, $want);

    do_test('second string also studied', $pie, 'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(PADMY,SMG,POK,pPOK,SCREAM\\)
  IV = 0
  NV = 0
  PV = $ADDR "good"\\\0
  CUR = 4
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_PRIVATE = 1
    MG_TYPE = PERL_MAGIC_study\\(G\\)
    MG_LEN = 260
    MG_PTR = $ADDR "\\\\377.*"
');
}

{
  my %z;
  foreach (1, 254, 255, 65534, 65535) {
    $z{$_} = "\0" x $_;
    study $z{$_};
  }
  do_test('short studied representation', $z{1},
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(SMG,POK,pPOK,SCREAM\\)
  IV = 0
  NV = 0
  PV = $ADDR "\\\\0"\\\0
  CUR = 1
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_PRIVATE = 1
    MG_TYPE = PERL_MAGIC_study\\(G\\)
    MG_LEN = 257
    MG_PTR = $ADDR "\\\\0(?:\\\\377){256}"
');

  foreach ([254, 1], [255, 2], [65534, 2], [65535, 4]
	  ) {
    my ($length, $bytes) = @$_;
    my $quant = $length <= 32766 ? "{$length}" : '*';
    do_test("studied representation for length $length", $z{$length},
	    sprintf 
'SV = PVMG\\($ADDR\\) at $ADDR
  REFCNT = 1
  FLAGS = \\(SMG,POK,pPOK,SCREAM\\)
  IV = 0
  NV = 0
  PV = $ADDR "(?:\\\\0)%s"\\\0
  CUR = %d
  LEN = \d+
  MAGIC = $ADDR
    MG_VIRTUAL = &PL_vtbl_regexp
    MG_PRIVATE = %d
    MG_TYPE = PERL_MAGIC_study\\(G\\)
    MG_LEN = %d
    MG_PTR = $ADDR "\\\\0.*\\\\377"
', $quant, $length, $bytes, (256 + $length) * $bytes);
  }
}

done_testing();