4 require Config; import Config;
5 if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
6 print "1..0 # Skip: Devel::Peek was not built\n";
16 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
18 # If I reference any lexicals in this, I get the entire outer subroutine (or
19 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
28 use constant thr => $Config{useithreads};
32 my $repeat_todo = $_[4];
35 if (open(OUT,">peek$$")) {
36 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
38 my $sub = eval "sub { Dump $_[1] }";
40 print STDERR "*****\n";
41 # second dump to compare with the first to make sure nothing
47 print STDERR "*****\n";
48 # second dump to compare with the first to make sure nothing
52 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
54 if (open(IN, "peek$$")) {
56 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
57 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
58 # handle DEBUG_LEAKING_SCALARS prefix
59 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
61 # Need some clear generic mechanism to eliminate (or add) lines
62 # of dump output dependant on perl version. The (previous) use of
63 # things like $IVNV gave the illusion that the string passed in was
64 # a regexp into which variables were interpolated, but this wasn't
65 # actually true as those 'variables' actually also ate the
66 # whitespace on the line. So it seems better to mark lines that
67 # need to be eliminated. I considered (?# ... ) and (?{ ... }),
68 # but whilst embedded code or comment syntax would keep it as a
69 # legitimate regexp, it still isn't true. Seems easier and clearer
70 # things that look like comments.
72 # Could do this is in a s///mge but seems clearer like this:
73 $pattern = join '', map {
74 # If we identify the version condition, take *it* out whatever
77 : $_ # Didn't match, so this line is in
78 } split /^/, $pattern;
80 $pattern =~ s/\$PADMY/
81 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
83 $pattern =~ s/\$PADTMP/
84 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
87 ($] < 5.011) ? 'RV' : 'IV';
89 $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
90 if $Config{ccflags} =~
91 /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)/;
93 print $pattern, "\n" if $DEBUG;
94 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
95 print $dump, "\n" if $DEBUG;
96 like( $dump, qr/\A$pattern\Z/ms, $_[0])
97 or note("line " . (caller)[2]);
99 local $TODO = $repeat_todo;
100 is($dump2, $dump, "$_[0] (unchanged by dump)")
101 or note("line " . (caller)[2]);
107 die "$0: failed to open peek$$: !\n";
110 die "$0: failed to create peek$$: $!\n";
120 1 while unlink("peek$$");
123 do_test('assignment of immediate constant (string)',
125 'SV = PV\\($ADDR\\) at $ADDR
127 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
131 COW_REFCNT = 1 # $] >=5.019003
134 do_test('immediate constant (string)',
136 'SV = PV\\($ADDR\\) at $ADDR
138 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
142 COW_REFCNT = 0 # $] >=5.019003
145 do_test('assignment of immediate constant (integer)',
147 'SV = IV\\($ADDR\\) at $ADDR
149 FLAGS = \\(IOK,pIOK\\)
152 do_test('immediate constant (integer)',
154 'SV = IV\\($ADDR\\) at $ADDR
156 FLAGS = \\(.*IOK,READONLY,pIOK\\)
159 do_test('assignment of immediate constant (integer)',
161 'SV = IV\\($ADDR\\) at $ADDR
163 FLAGS = \\($PADMY,IOK,pIOK\\)
166 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
167 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
168 # maths is done in floating point always, and this scalar will be an NV.
169 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
170 # building subsequent regexps.
171 my $type = do_test('result of addition',
173 'SV = ([NI])V\\($ADDR\\) at $ADDR
175 FLAGS = \\(PADTMP,\1OK,p\1OK\\) # $] < 5.019003
176 FLAGS = \\(\1OK,p\1OK\\) # $] >=5.019003
181 do_test('floating point value',
184 || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)/
186 'SV = PVNV\\($ADDR\\) at $ADDR
188 FLAGS = \\(NOK,pNOK\\)
190 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
195 'SV = PVNV\\($ADDR\\) at $ADDR
197 FLAGS = \\(NOK,pNOK\\)
199 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
202 do_test('integer constant',
204 'SV = IV\\($ADDR\\) at $ADDR
206 FLAGS = \\(.*IOK,READONLY,pIOK\\)
211 'SV = NULL\\(0x0\\) at $ADDR
213 FLAGS = \\(READONLY\\)');
215 do_test('reference to scalar',
217 'SV = $RV\\($ADDR\\) at $ADDR
221 SV = PV\\($ADDR\\) at $ADDR
223 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
227 COW_REFCNT = 1 # $] >=5.019003
233 SV = PVNV\\($ADDR\\) at $ADDR
235 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
241 SV = IV\\($ADDR\\) at $ADDR
243 FLAGS = \\(IOK,pIOK\\)
246 do_test('reference to array',
248 'SV = $RV\\($ADDR\\) at $ADDR
252 SV = PVAV\\($ADDR\\) at $ADDR
263 SV = IV\\($ADDR\\) at $ADDR
265 FLAGS = \\(IOK,pIOK\\)
267 Elt No. 1' . $c_pattern);
269 do_test('reference to hash',
271 'SV = $RV\\($ADDR\\) at $ADDR
275 SV = PVHV\\($ADDR\\) at $ADDR
277 FLAGS = \\(SHAREKEYS\\)
279 NV = $FLOAT # $] < 5.009
280 ARRAY = $ADDR \\(0:7, 1:1\\)
281 hash quality = 100.0%
285 Elt "123" HASH = $ADDR' . $c_pattern,
287 $] > 5.009 && $] < 5.015
288 && 'The hash iterator used in dump.c sets the OOK flag');
290 do_test('reference to anon sub with empty prototype',
292 'SV = $RV\\($ADDR\\) at $ADDR
296 SV = PVCV\\($ADDR\\) at $ADDR
298 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
299 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
303 COMP_STASH = $ADDR\\t"main"
304 START = $ADDR ===> \\d+
306 XSUB = 0x0 # $] < 5.009
307 XSUBANY = 0 # $] < 5.009
308 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
309 FILE = ".*\\b(?i:peek\\.t)"
313 FLAGS = 0x404 # $] < 5.009
314 FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr)
315 FLAGS = 0x1490 # $] >= 5.015 && thr
318 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
319 OUTSIDE = $ADDR \\(MAIN\\)');
321 do_test('reference to named subroutine without prototype',
323 'SV = $RV\\($ADDR\\) at $ADDR
327 SV = PVCV\\($ADDR\\) at $ADDR
329 FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr
330 FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr
333 COMP_STASH = $ADDR\\t"main"
334 START = $ADDR ===> \\d+
336 XSUB = 0x0 # $] < 5.009
337 XSUBANY = 0 # $] < 5.009
338 GVGV::GV = $ADDR\\t"main" :: "do_test"
339 FILE = ".*\\b(?i:peek\\.t)"
343 FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr
344 FLAGS = 0x[145]000 # $] >= 5.015 && thr
347 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
348 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
349 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
350 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
351 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
352 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
353 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009
354 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009
355 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
356 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
357 OUTSIDE = $ADDR \\(MAIN\\)');
360 do_test('reference to regexp',
362 'SV = $RV\\($ADDR\\) at $ADDR
366 SV = REGEXP\\($ADDR\\) at $ADDR
368 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
369 FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
370 PV = $ADDR "\\(\\?\\^:tic\\)"
372 LEN = 0 # $] < 5.017006
373 STASH = $ADDR\\t"Regexp"'
377 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
392 . ($] < 5.019003 ? '' : '
393 SV = REGEXP\($ADDR\) at $ADDR
396 PV = $ADDR "\(\?\^:tic\)"
399 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
419 SAVED_COPY = 0x0)?') . '
428 do_test('reference to regexp',
430 'SV = $RV\\($ADDR\\) at $ADDR
434 SV = PVMG\\($ADDR\\) at $ADDR
436 FLAGS = \\(OBJECT,SMG\\)
442 MG_TYPE = PERL_MAGIC_qr\(r\)
444 PAT = "\(\?^:tic\)" # $] >= 5.009
445 REFCNT = 2 # $] >= 5.009
446 STASH = $ADDR\\t"Regexp"');
449 do_test('reference to blessed hash',
451 'SV = $RV\\($ADDR\\) at $ADDR
455 SV = PVHV\\($ADDR\\) at $ADDR
457 FLAGS = \\(OBJECT,SHAREKEYS\\)
460 STASH = $ADDR\\t"Tac"
468 : 'The hash iterator used in dump.c sets the OOK flag'
469 : "Something causes the HV's array to become allocated");
473 'SV = PVGV\\($ADDR\\) at $ADDR
475 FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009
476 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009
480 MAGIC = $ADDR # $] < 5.009
481 MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009
482 MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009
483 MG_OBJ = $ADDR # $] < 5.009
486 GvSTASH = $ADDR\\t"main"
496 GPFLAGS = 0x0 # $] < 5.009
498 FILE = ".*\\b(?i:peek\\.t)"
502 if (ord('A') == 193) {
503 do_test('string with Unicode',
504 chr(256).chr(0).chr(512),
505 'SV = PV\\($ADDR\\) at $ADDR
507 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
508 FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
509 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
512 COW_REFCNT = 1 # $] >=5.019003
515 do_test('string with Unicode',
516 chr(256).chr(0).chr(512),
517 'SV = PV\\($ADDR\\) at $ADDR
519 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
520 FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
521 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
524 COW_REFCNT = 1 # $] >=5.019003
528 if (ord('A') == 193) {
529 do_test('reference to hash containing Unicode',
530 {chr(256)=>chr(512)},
531 'SV = $RV\\($ADDR\\) at $ADDR
535 SV = PVHV\\($ADDR\\) at $ADDR
537 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
539 NV = $FLOAT # $] < 5.009
540 ARRAY = $ADDR \\(0:7, 1:1\\)
541 hash quality = 100.0%
545 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
546 SV = PV\\($ADDR\\) at $ADDR
548 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
549 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
552 COW_REFCNT = 1 # $] < 5.009
557 : 'The hash iterator used in dump.c sets the OOK flag'
558 : 'sv_length has been called on the element, and cached the result in MAGIC');
560 do_test('reference to hash containing Unicode',
561 {chr(256)=>chr(512)},
562 'SV = $RV\\($ADDR\\) at $ADDR
566 SV = PVHV\\($ADDR\\) at $ADDR
568 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
571 ARRAY = $ADDR \\(0:7, 1:1\\)
572 hash quality = 100.0%
576 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
577 SV = PV\\($ADDR\\) at $ADDR
579 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
580 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
583 COW_REFCNT = 1 # $] >= 5.019003
588 : 'The hash iterator used in dump.c sets the OOK flag'
589 : 'sv_length has been called on the element, and cached the result in MAGIC');
594 do_test('scalar with pos magic',
596 'SV = PVMG\\($ADDR\\) at $ADDR
598 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
606 MG_VIRTUAL = &PL_vtbl_mglob
607 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
612 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
613 # environment variables may be invisibly case-forced, hence the (?i:PATH)
614 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
615 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
616 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
617 # VMS is setting FAKE and READONLY flags. What VMS uses for storing
618 # ENV hashes is also not always null terminated.
621 do_test('tainted value in %ENV',
622 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
623 'SV = PVMG\\($ADDR\\) at $ADDR
625 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
632 MG_VIRTUAL = &PL_vtbl_envelem
633 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
637 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
638 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
640 FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
642 )? PV = $ADDR "(?i:PATH)"(?:\\\0)?
646 MG_VIRTUAL = &PL_vtbl_taint
647 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
650 do_test('blessed reference',
651 bless(\\undef, 'Foobar'),
652 'SV = $RV\\($ADDR\\) at $ADDR
656 SV = PVMG\\($ADDR\\) at $ADDR
658 FLAGS = \\(OBJECT,ROK\\)
662 SV = NULL\\(0x0\\) at $ADDR
664 FLAGS = \\(READONLY\\)
668 STASH = $ADDR\s+"Foobar"');
674 do_test('constant subroutine',
676 'SV = $RV\\($ADDR\\) at $ADDR
680 SV = PVCV\\($ADDR\\) at $ADDR
682 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
683 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
688 ROOT = 0x0 # $] < 5.009
690 XSUBANY = $ADDR \\(CONST SV\\)
691 SV = PV\\($ADDR\\) at $ADDR
693 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
694 PV = $ADDR "Perl rules"\\\0
697 COW_REFCNT = 0 # $] >=5.019003
698 GVGV::GV = $ADDR\\t"main" :: "const"
699 FILE = ".*\\b(?i:peek\\.t)"
703 FLAGS = 0x200 # $] < 5.009
704 FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013
705 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
706 FLAGS = 0x100c # $] >= 5.015
709 OUTSIDE = 0x0 \\(null\\)');
711 do_test('isUV should show on PVMG',
712 do { my $v = $1; $v = ~0; $v },
713 'SV = PVMG\\($ADDR\\) at $ADDR
715 FLAGS = \\(IOK,pIOK,IsUV\\)
722 'SV = $RV\\($ADDR\\) at $ADDR
726 SV = PVIO\\($ADDR\\) at $ADDR
731 STASH = $ADDR\s+"IO::File"
742 SUBPROCESS = 0 # $] < 5.009
748 'SV = $RV\\($ADDR\\) at $ADDR
752 SV = PVFM\\($ADDR\\) at $ADDR
754 FLAGS = \\(\\) # $] < 5.015 || !thr
755 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
760 START = $ADDR ===> \\d+
762 XSUB = 0x0 # $] < 5.009
763 XSUBANY = 0 # $] < 5.009
764 GVGV::GV = $ADDR\\t"main" :: "PIE"
765 FILE = ".*\\b(?i:peek\\.t)"(?:
769 FLAGS = 0x0 # $] < 5.015 || !thr
770 FLAGS = 0x1000 # $] >= 5.015 && thr
772 LINES = 0 # $] < 5.017_003
774 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
775 OUTSIDE = $ADDR \\(MAIN\\)');
777 do_test('blessing to a class with embedded NUL characters',
778 (bless {}, "\0::foo::\n::baz::\t::\0"),
779 'SV = $RV\\($ADDR\\) at $ADDR
783 SV = PVHV\\($ADDR\\) at $ADDR
785 FLAGS = \\(OBJECT,SHAREKEYS\\)
788 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
796 : 'The hash iterator used in dump.c sets the OOK flag'
797 : "Something causes the HV's array to become allocated");
799 do_test('ENAME on a stash',
801 'SV = $RV\\($ADDR\\) at $ADDR
805 SV = PVHV\\($ADDR\\) at $ADDR
807 FLAGS = \\(OOK,SHAREKEYS\\)
809 NV = $FLOAT # $] < 5.009
812 FILL = 0 \(cached = 0\)
818 ENAME = "RWOM" # $] > 5.012
823 do_test('ENAMEs on a stash',
825 'SV = $RV\\($ADDR\\) at $ADDR
829 SV = PVHV\\($ADDR\\) at $ADDR
831 FLAGS = \\(OOK,SHAREKEYS\\)
833 NV = $FLOAT # $] < 5.009
836 FILL = 0 \(cached = 0\)
842 NAMECOUNT = 2 # $] > 5.012
843 ENAME = "RWOM", "KLANK" # $] > 5.012
848 do_test('ENAMEs on a stash with no NAME',
850 'SV = $RV\\($ADDR\\) at $ADDR
854 SV = PVHV\\($ADDR\\) at $ADDR
856 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
857 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017
859 NV = $FLOAT # $] < 5.009
862 FILL = 0 \(cached = 0\)
867 NAMECOUNT = -3 # $] > 5.012
868 ENAME = "RWOM", "KLANK" # $] > 5.012
871 my %small = ("Perl", "Rules", "Beer", "Foamy");
873 do_test('small hash',
875 'SV = $RV\\($ADDR\\) at $ADDR
879 SV = PVHV\\($ADDR\\) at $ADDR
881 FLAGS = \\(PADMY,SHAREKEYS\\)
883 NV = $FLOAT # $] < 5.009
884 ARRAY = $ADDR \\(0:[67],.*\\)
885 hash quality = [0-9.]+%
889 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
890 SV = PV\\($ADDR\\) at $ADDR
892 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
893 PV = $ADDR "(?:Rules|Foamy)"\\\0
896 COW_REFCNT = 1 # $] >=5.019003
901 do_test('small hash after keys',
903 'SV = $RV\\($ADDR\\) at $ADDR
907 SV = PVHV\\($ADDR\\) at $ADDR
909 FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
911 NV = $FLOAT # $] < 5.009
912 ARRAY = $ADDR \\(0:[67],.*\\)
913 hash quality = [0-9.]+%
915 FILL = [12] \\(cached = 0\\)
920 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
921 SV = PV\\($ADDR\\) at $ADDR
923 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
924 PV = $ADDR "(?:Rules|Foamy)"\\\0
927 COW_REFCNT = 1 # $] >=5.019003
932 do_test('small hash after keys and scalar',
934 'SV = $RV\\($ADDR\\) at $ADDR
938 SV = PVHV\\($ADDR\\) at $ADDR
940 FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
942 NV = $FLOAT # $] < 5.009
943 ARRAY = $ADDR \\(0:[67],.*\\)
944 hash quality = [0-9.]+%
946 FILL = ([12]) \\(cached = \1\\)
951 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
952 SV = PV\\($ADDR\\) at $ADDR
954 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
955 PV = $ADDR "(?:Rules|Foamy)"\\\0
958 COW_REFCNT = 1 # $] >=5.019003
961 # This should immediately start with the FILL cached correctly.
962 my %large = (0..1999);
964 do_test('large hash',
966 'SV = $RV\\($ADDR\\) at $ADDR
970 SV = PVHV\\($ADDR\\) at $ADDR
972 FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
974 NV = $FLOAT # $] < 5.009
975 ARRAY = $ADDR \\(0:\d+,.*\\)
976 hash quality = \d+\\.\d+%
978 FILL = (\d+) \\(cached = \1\\)
986 # Dump with arrays, hashes, and operator return values
988 do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
989 SV = PVAV\($ADDR\) at $ADDR
998 SV = IV\($ADDR\) at $ADDR
1000 FLAGS = \(IOK,pIOK\)
1003 SV = IV\($ADDR\) at $ADDR
1005 FLAGS = \(IOK,pIOK\)
1008 SV = IV\($ADDR\) at $ADDR
1010 FLAGS = \(IOK,pIOK\)
1014 do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
1015 SV = PVHV\($ADDR\) at $ADDR
1017 FLAGS = \(SHAREKEYS\)
1018 ARRAY = $ADDR \(0:7, 1:1\)
1019 hash quality = 100.0%
1023 Elt "1" HASH = $ADDR
1024 SV = IV\($ADDR\) at $ADDR
1026 FLAGS = \(IOK,pIOK\)
1030 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
1031 SV = PV\($ADDR\) at $ADDR
1033 FLAGS = \(PADTMP,POK,pPOK\)
1040 skip "Not built with usemymalloc", 2
1041 unless $Config{usemymalloc} eq 'y';
1042 my $x = __PACKAGE__;
1043 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1046 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1049 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1050 # prowess, but short of duplicating all the gubbins of this file, I can't see
1051 # a way to make a better place for it:
1058 unless ($Config{useithreads}) {
1059 # These end up as copies in pads under ithreads, which rather defeats the
1060 # the point of what we're trying to test here.
1062 do_test('regular string constant', perl,
1063 'SV = PV\\($ADDR\\) at $ADDR
1065 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1066 PV = $ADDR "rules"\\\0
1069 COW_REFCNT = 0 # $] >=5.019003
1072 eval 'index "", perl';
1074 # FIXME - really this shouldn't say EVALED. It's a false posistive on
1075 # 0x40000000 being used for several things, not a flag for "I'm in a string
1078 do_test('string constant now an FBM', perl,
1079 'SV = PVMG\\($ADDR\\) at $ADDR
1081 FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1082 PV = $ADDR "rules"\\\0
1085 COW_REFCNT = 0 # $] >=5.019003
1087 MG_VIRTUAL = &PL_vtbl_regexp
1088 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1090 MG_PTR = $ADDR "(?:\\\\\d){256}"
1091 RARE = \d+ # $] < 5.019002
1092 PREVIOUS = 1 # $] < 5.019002
1096 is(study perl, '', "Not allowed to study an FBM");
1098 do_test('string constant still an FBM', perl,
1099 'SV = PVMG\\($ADDR\\) at $ADDR
1101 FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1102 PV = $ADDR "rules"\\\0
1105 COW_REFCNT = 0 # $] >=5.019003
1107 MG_VIRTUAL = &PL_vtbl_regexp
1108 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1110 MG_PTR = $ADDR "(?:\\\\\d){256}"
1111 RARE = \d+ # $] < 5.019002
1112 PREVIOUS = 1 # $] < 5.019002
1116 do_test('regular string constant', beer,
1117 'SV = PV\\($ADDR\\) at $ADDR
1119 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1120 PV = $ADDR "foamy"\\\0
1123 COW_REFCNT = 0 # $] >=5.019003
1126 is(study beer, 1, "Our studies were successful");
1128 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1130 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1131 PV = $ADDR "foamy"\\\0
1134 COW_REFCNT = 0 # $] >=5.019003
1137 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1139 FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1140 PV = $ADDR "foamy"\\\0
1143 COW_REFCNT = 0 # $] >=5.019003
1145 MG_VIRTUAL = &PL_vtbl_regexp
1146 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1148 MG_PTR = $ADDR "(?:\\\\\d){256}"
1149 RARE = \d+ # $] < 5.019002
1150 PREVIOUS = \d+ # $] < 5.019002
1154 is (eval 'index "not too foamy", beer', 8, 'correct index');
1156 do_test('string constant now FBMed', beer, $want);
1160 is(study $pie, 1, "Our studies were successful");
1162 do_test('string constant still FBMed', beer, $want);
1164 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1166 FLAGS = \\(PADMY,POK,(?:IsCOW,)?pPOK\\)
1167 PV = $ADDR "good"\\\0
1174 # (One block of study tests removed when study was made a no-op.)
1177 open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1178 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1180 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1181 pass "no crash with DeadCode";
1185 do_test('UTF-8 in a regular expression',
1187 'SV = IV\($ADDR\) at $ADDR
1191 SV = REGEXP\($ADDR\) at $ADDR
1193 FLAGS = \(OBJECT,FAKE,UTF8\)
1194 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1196 STASH = $ADDR "Regexp"
1197 COMPFLAGS = 0x0 \(\)
1198 EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1213 . ($] < 5.019003 ? '' : '
1214 SV = REGEXP\($ADDR\) at $ADDR
1217 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1219 COMPFLAGS = 0x0 \(\)
1220 EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1240 SAVED_COPY = 0x0)?') . '
1249 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1251 my $base_count = Devel::Peek::SvREFCNT(%hash);
1253 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");