4 require Config; import Config;
5 if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
6 print "1..0 # Skip: Devel::Peek was not built\n";
11 my $core = !!$ENV{PERL_CORE};
12 require($core ? '../../t/test.pl' : './t/test.pl');
21 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
23 # If I reference any lexicals in this, I get the entire outer subroutine (or
24 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
33 use constant thr => $Config{useithreads};
37 my $repeat_todo = $_[4];
40 if (open(OUT,">peek$$")) {
41 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
43 my $sub = eval "sub { Dump $_[1] }";
45 print STDERR "*****\n";
46 # second dump to compare with the first to make sure nothing
52 print STDERR "*****\n";
53 # second dump to compare with the first to make sure nothing
57 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
59 if (open(IN, "peek$$")) {
61 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
62 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
63 # handle DEBUG_LEAKING_SCALARS prefix
64 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
66 # Need some clear generic mechanism to eliminate (or add) lines
67 # of dump output dependant on perl version. The (previous) use of
68 # things like $IVNV gave the illusion that the string passed in was
69 # a regexp into which variables were interpolated, but this wasn't
70 # actually true as those 'variables' actually also ate the
71 # whitespace on the line. So it seems better to mark lines that
72 # need to be eliminated. I considered (?# ... ) and (?{ ... }),
73 # but whilst embedded code or comment syntax would keep it as a
74 # legitimate regexp, it still isn't true. Seems easier and clearer
75 # things that look like comments.
77 # Could do this is in a s///mge but seems clearer like this:
78 $pattern = join '', map {
79 # If we identify the version condition, take *it* out whatever
82 : $_ # Didn't match, so this line is in
83 } split /^/, $pattern;
85 $pattern =~ s/\$PADMY,/
86 $] < 5.012005 ? 'PADMY,' : '';
89 ($] < 5.011) ? 'RV' : 'IV';
91 $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
92 if $Config{ccflags} =~
93 /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
95 print $pattern, "\n" if $DEBUG;
96 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
97 print $dump, "\n" if $DEBUG;
98 like( $dump, qr/\A$pattern\Z/ms, $_[0])
99 or note("line " . (caller)[2]);
101 local $TODO = $repeat_todo;
102 is($dump2, $dump, "$_[0] (unchanged by dump)")
103 or note("line " . (caller)[2]);
109 die "$0: failed to open peek$$: !\n";
112 die "$0: failed to create peek$$: $!\n";
122 1 while unlink("peek$$");
125 do_test('assignment of immediate constant (string)',
127 'SV = PV\\($ADDR\\) at $ADDR
129 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
136 do_test('immediate constant (string)',
138 'SV = PV\\($ADDR\\) at $ADDR
140 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
141 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
148 do_test('assignment of immediate constant (integer)',
150 'SV = IV\\($ADDR\\) at $ADDR
152 FLAGS = \\(IOK,pIOK\\)
155 do_test('immediate constant (integer)',
157 'SV = IV\\($ADDR\\) at $ADDR
159 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005
160 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005
163 do_test('assignment of immediate constant (integer)',
165 'SV = IV\\($ADDR\\) at $ADDR
167 FLAGS = \\($PADMY,IOK,pIOK\\)
170 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
171 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
172 # maths is done in floating point always, and this scalar will be an NV.
173 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
174 # building subsequent regexps.
175 my $type = do_test('result of addition',
177 'SV = ([NI])V\\($ADDR\\) at $ADDR
179 FLAGS = \\(PADTMP,\1OK,p\1OK\\) # $] < 5.019003
180 FLAGS = \\(\1OK,p\1OK\\) # $] >=5.019003
185 do_test('floating point value',
188 || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/
190 'SV = PVNV\\($ADDR\\) at $ADDR
192 FLAGS = \\(NOK,pNOK\\)
194 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
199 'SV = PVNV\\($ADDR\\) at $ADDR
201 FLAGS = \\(NOK,pNOK\\)
203 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
206 do_test('integer constant',
208 'SV = IV\\($ADDR\\) at $ADDR
210 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005
211 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005
216 'SV = NULL\\(0x0\\) at $ADDR
218 FLAGS = \\(READONLY\\) # $] < 5.021005
219 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
222 do_test('reference to scalar',
224 'SV = $RV\\($ADDR\\) at $ADDR
228 SV = PV\\($ADDR\\) at $ADDR
230 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
240 SV = PVNV\\($ADDR\\) at $ADDR
242 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
248 SV = IV\\($ADDR\\) at $ADDR
250 FLAGS = \\(IOK,pIOK\\)
253 do_test('reference to array',
255 'SV = $RV\\($ADDR\\) at $ADDR
259 SV = PVAV\\($ADDR\\) at $ADDR
268 SV = IV\\($ADDR\\) at $ADDR
270 FLAGS = \\(IOK,pIOK\\)
272 Elt No. 1' . $c_pattern);
274 do_test('reference to hash',
276 'SV = $RV\\($ADDR\\) at $ADDR
280 SV = PVHV\\($ADDR\\) at $ADDR
282 FLAGS = \\(SHAREKEYS\\)
283 ARRAY = $ADDR \\(0:7, 1:1\\)
284 hash quality = 100.0%
288 Elt "123" HASH = $ADDR' . $c_pattern,
291 && 'The hash iterator used in dump.c sets the OOK flag');
293 do_test('reference to anon sub with empty prototype',
295 'SV = $RV\\($ADDR\\) at $ADDR
299 SV = PVCV\\($ADDR\\) at $ADDR
301 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
302 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
304 COMP_STASH = $ADDR\\t"main"
305 START = $ADDR ===> \\d+
307 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
308 FILE = ".*\\b(?i:peek\\.t)"
312 FLAGS = 0x490 # $] < 5.015 || !thr
313 FLAGS = 0x1490 # $] >= 5.015 && thr
316 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
317 OUTSIDE = $ADDR \\(MAIN\\)');
319 do_test('reference to named subroutine without prototype',
321 'SV = $RV\\($ADDR\\) at $ADDR
325 SV = PVCV\\($ADDR\\) at $ADDR
327 FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr
328 FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
329 COMP_STASH = $ADDR\\t"main"
330 START = $ADDR ===> \\d+
332 NAME = "do_test" # $] >=5.021004
333 GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004
334 FILE = ".*\\b(?i:peek\\.t)"
338 FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr
339 FLAGS = 0x[cd145]000 # $] >= 5.015 && thr
342 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
343 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
344 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
345 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
346 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
347 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
348 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
349 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
350 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
351 OUTSIDE = $ADDR \\(MAIN\\)');
354 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
355 do_test('reference to regexp',
357 'SV = $RV\\($ADDR\\) at $ADDR
361 SV = REGEXP\\($ADDR\\) at $ADDR
363 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
364 FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
365 PV = $ADDR "\\(\\?\\^:tic\\)"
367 LEN = 0 # $] < 5.017006
368 STASH = $ADDR\\t"Regexp"'
372 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
373 (?: ENGINE = $ADDR \(STANDARD\)
374 )? INTFLAGS = 0x0(?: \(\))?
387 )? MOTHER_RE = $ADDR'
388 . ($] < 5.019003 ? '' : '
389 SV = REGEXP\($ADDR\) at $ADDR
392 PV = $ADDR "\(\?\^:tic\)"
395 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
396 (?: ENGINE = $ADDR \(STANDARD\)
397 )? INTFLAGS = 0x0(?: \(\))?
416 SAVED_COPY = 0x0)?') . '
425 do_test('reference to regexp',
427 'SV = $RV\\($ADDR\\) at $ADDR
431 SV = PVMG\\($ADDR\\) at $ADDR
433 FLAGS = \\(OBJECT,SMG\\)
439 MG_TYPE = PERL_MAGIC_qr\(r\)
443 STASH = $ADDR\\t"Regexp"');
446 do_test('reference to blessed hash',
448 'SV = $RV\\($ADDR\\) at $ADDR
452 SV = PVHV\\($ADDR\\) at $ADDR
454 FLAGS = \\(OBJECT,SHAREKEYS\\)
455 STASH = $ADDR\\t"Tac"
462 : 'The hash iterator used in dump.c sets the OOK flag');
466 'SV = PVGV\\($ADDR\\) at $ADDR
468 FLAGS = \\(MULTI(?:,IN_PAD)?\\)
471 GvSTASH = $ADDR\\t"main"
472 FLAGS = $ADDR # $] >=5.021004
482 GPFLAGS = 0x0 \(\) # $] >= 5.021004
484 FILE = ".*\\b(?i:peek\\.t)"
485 FLAGS = $ADDR # $] < 5.021004
488 if (ord('A') == 193) {
489 do_test('string with Unicode',
490 chr(256).chr(0).chr(512),
491 'SV = PV\\($ADDR\\) at $ADDR
493 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
494 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
495 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
498 COW_REFCNT = 1 # $] < 5.019007
501 do_test('string with Unicode',
502 chr(256).chr(0).chr(512),
503 'SV = PV\\($ADDR\\) at $ADDR
505 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
506 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
507 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
510 COW_REFCNT = 1 # $] < 5.019007
514 if (ord('A') == 193) {
515 do_test('reference to hash containing Unicode',
516 {chr(256)=>chr(512)},
517 'SV = $RV\\($ADDR\\) at $ADDR
521 SV = PVHV\\($ADDR\\) at $ADDR
523 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
524 ARRAY = $ADDR \\(0:7, 1:1\\)
525 hash quality = 100.0%
529 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
530 SV = PV\\($ADDR\\) at $ADDR
532 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
533 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
536 COW_REFCNT = 1 # $] < 5.019007
540 : 'The hash iterator used in dump.c sets the OOK flag');
542 do_test('reference to hash containing Unicode',
543 {chr(256)=>chr(512)},
544 'SV = $RV\\($ADDR\\) at $ADDR
548 SV = PVHV\\($ADDR\\) at $ADDR
550 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
551 ARRAY = $ADDR \\(0:7, 1:1\\)
552 hash quality = 100.0%
556 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
557 SV = PV\\($ADDR\\) at $ADDR
559 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
560 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
563 COW_REFCNT = 1 # $] < 5.019007
567 : 'The hash iterator used in dump.c sets the OOK flag');
572 do_test('scalar with pos magic',
574 'SV = PVMG\\($ADDR\\) at $ADDR
576 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
584 MG_VIRTUAL = &PL_vtbl_mglob
585 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
586 MG_FLAGS = 0x01 # $] < 5.019003
587 MG_FLAGS = 0x41 # $] >=5.019003
589 BYTES # $] >=5.019003
593 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
594 # environment variables may be invisibly case-forced, hence the (?i:PATH)
595 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
596 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
597 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
598 # VMS is setting FAKE and READONLY flags. What VMS uses for storing
599 # ENV hashes is also not always null terminated.
602 # Save and restore PATH, since fresh_perl ends up using that in Windows.
603 my $path = $ENV{PATH};
604 do_test('tainted value in %ENV',
605 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
606 'SV = PVMG\\($ADDR\\) at $ADDR
608 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
615 MG_VIRTUAL = &PL_vtbl_envelem
616 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
620 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
621 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
623 FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
625 )? PV = $ADDR "(?i:PATH)"(?:\\\0)?
629 MG_VIRTUAL = &PL_vtbl_taint
630 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
634 do_test('blessed reference',
635 bless(\\undef, 'Foobar'),
636 'SV = $RV\\($ADDR\\) at $ADDR
640 SV = PVMG\\($ADDR\\) at $ADDR
642 FLAGS = \\(OBJECT,ROK\\)
646 SV = NULL\\(0x0\\) at $ADDR
648 FLAGS = \\(READONLY\\) # $] < 5.021005
649 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
653 STASH = $ADDR\s+"Foobar"');
659 do_test('constant subroutine',
661 'SV = $RV\\($ADDR\\) at $ADDR
665 SV = PVCV\\($ADDR\\) at $ADDR
667 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
668 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
670 COMP_STASH = 0x0 # $] < 5.021004
671 COMP_STASH = $ADDR "main" # $] >=5.021004
673 XSUBANY = $ADDR \\(CONST SV\\)
674 SV = PV\\($ADDR\\) at $ADDR
676 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
677 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
678 PV = $ADDR "Perl rules"\\\0
682 GVGV::GV = $ADDR\\t"main" :: "const"
683 FILE = ".*\\b(?i:peek\\.t)"
687 FLAGS = 0xc00 # $] < 5.013
688 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
689 FLAGS = 0x100c # $] >= 5.015
691 PADLIST = 0x0 # $] < 5.021006
692 HSCXT = $ADDR # $] >= 5.021006
693 OUTSIDE = 0x0 \\(null\\)');
695 do_test('isUV should show on PVMG',
696 do { my $v = $1; $v = ~0; $v },
697 'SV = PVMG\\($ADDR\\) at $ADDR
699 FLAGS = \\(IOK,pIOK,IsUV\\)
706 'SV = $RV\\($ADDR\\) at $ADDR
710 SV = PVIO\\($ADDR\\) at $ADDR
715 STASH = $ADDR\s+"IO::File"
731 'SV = $RV\\($ADDR\\) at $ADDR
735 SV = PVFM\\($ADDR\\) at $ADDR
737 FLAGS = \\(\\) # $] < 5.015 || !thr
738 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
741 START = $ADDR ===> \\d+
743 GVGV::GV = $ADDR\\t"main" :: "PIE"
744 FILE = ".*\\b(?i:peek\\.t)"(?:
748 FLAGS = 0x0 # $] < 5.015 || !thr
749 FLAGS = 0x1000 # $] >= 5.015 && thr
751 LINES = 0 # $] < 5.017_003
753 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
754 OUTSIDE = $ADDR \\(MAIN\\)');
756 do_test('blessing to a class with embedded NUL characters',
757 (bless {}, "\0::foo::\n::baz::\t::\0"),
758 'SV = $RV\\($ADDR\\) at $ADDR
762 SV = PVHV\\($ADDR\\) at $ADDR
764 FLAGS = \\(OBJECT,SHAREKEYS\\)
765 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
772 : 'The hash iterator used in dump.c sets the OOK flag');
774 do_test('ENAME on a stash',
776 'SV = $RV\\($ADDR\\) at $ADDR
780 SV = PVHV\\($ADDR\\) at $ADDR
782 FLAGS = \\(OOK,SHAREKEYS\\)
783 AUX_FLAGS = 0 # $] > 5.019008
786 FILL = 0 \(cached = 0\)
792 ENAME = "RWOM" # $] > 5.012
797 do_test('ENAMEs on a stash',
799 'SV = $RV\\($ADDR\\) at $ADDR
803 SV = PVHV\\($ADDR\\) at $ADDR
805 FLAGS = \\(OOK,SHAREKEYS\\)
806 AUX_FLAGS = 0 # $] > 5.019008
809 FILL = 0 \(cached = 0\)
815 NAMECOUNT = 2 # $] > 5.012
816 ENAME = "RWOM", "KLANK" # $] > 5.012
821 do_test('ENAMEs on a stash with no NAME',
823 'SV = $RV\\($ADDR\\) at $ADDR
827 SV = PVHV\\($ADDR\\) at $ADDR
829 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
830 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005
831 FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005
832 AUX_FLAGS = 0 # $] > 5.019008
835 FILL = 0 \(cached = 0\)
840 NAMECOUNT = -3 # $] > 5.012
841 ENAME = "RWOM", "KLANK" # $] > 5.012
844 my %small = ("Perl", "Rules", "Beer", "Foamy");
846 do_test('small hash',
848 'SV = $RV\\($ADDR\\) at $ADDR
852 SV = PVHV\\($ADDR\\) at $ADDR
854 FLAGS = \\($PADMY,SHAREKEYS\\)
855 ARRAY = $ADDR \\(0:[67],.*\\)
856 hash quality = [0-9.]+%
860 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
861 SV = PV\\($ADDR\\) at $ADDR
863 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
864 PV = $ADDR "(?:Rules|Foamy)"\\\0
872 do_test('small hash after keys',
874 'SV = $RV\\($ADDR\\) at $ADDR
878 SV = PVHV\\($ADDR\\) at $ADDR
880 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
881 AUX_FLAGS = 0 # $] > 5.019008
882 ARRAY = $ADDR \\(0:[67],.*\\)
883 hash quality = [0-9.]+%
885 FILL = [12] \\(cached = 0\\)
890 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
891 SV = PV\\($ADDR\\) at $ADDR
893 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
894 PV = $ADDR "(?:Rules|Foamy)"\\\0
902 do_test('small hash after keys and scalar',
904 'SV = $RV\\($ADDR\\) at $ADDR
908 SV = PVHV\\($ADDR\\) at $ADDR
910 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
911 AUX_FLAGS = 0 # $] > 5.019008
912 ARRAY = $ADDR \\(0:[67],.*\\)
913 hash quality = [0-9.]+%
915 FILL = ([12]) \\(cached = \1\\)
920 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
921 SV = PV\\($ADDR\\) at $ADDR
923 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
924 PV = $ADDR "(?:Rules|Foamy)"\\\0
930 # This should immediately start with the FILL cached correctly.
931 my %large = (0..1999);
933 do_test('large hash',
935 'SV = $RV\\($ADDR\\) at $ADDR
939 SV = PVHV\\($ADDR\\) at $ADDR
941 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
942 AUX_FLAGS = 0 # $] > 5.019008
943 ARRAY = $ADDR \\(0:\d+,.*\\)
944 hash quality = \d+\\.\d+%
946 FILL = (\d+) \\(cached = \1\\)
954 # Dump with arrays, hashes, and operator return values
956 do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
957 SV = PVAV\($ADDR\) at $ADDR
966 SV = IV\($ADDR\) at $ADDR
971 SV = IV\($ADDR\) at $ADDR
976 SV = IV\($ADDR\) at $ADDR
982 do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1);
983 SV = PVAV\($ADDR\) at $ADDR
992 SV = IV\($ADDR\) at $ADDR
999 do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
1000 SV = PVHV\($ADDR\) at $ADDR
1002 FLAGS = \(SHAREKEYS\)
1003 ARRAY = $ADDR \(0:7, 1:1\)
1004 hash quality = 100.0%
1008 Elt "1" HASH = $ADDR
1009 SV = IV\($ADDR\) at $ADDR
1011 FLAGS = \(IOK,pIOK\)
1016 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
1017 SV = PV\($ADDR\) at $ADDR
1019 FLAGS = \(PADTMP,POK,pPOK\)
1025 # Dump with no arguments
1027 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1029 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1032 skip "Not built with usemymalloc", 2
1033 unless $Config{usemymalloc} eq 'y';
1034 my $x = __PACKAGE__;
1035 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1038 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1041 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1042 # prowess, but short of duplicating all the gubbins of this file, I can't see
1043 # a way to make a better place for it:
1050 unless ($Config{useithreads}) {
1051 # These end up as copies in pads under ithreads, which rather defeats the
1052 # the point of what we're trying to test here.
1054 do_test('regular string constant', perl,
1055 'SV = PV\\($ADDR\\) at $ADDR
1057 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1058 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1059 PV = $ADDR "rules"\\\0
1065 eval 'index "", perl';
1067 # FIXME - really this shouldn't say EVALED. It's a false posistive on
1068 # 0x40000000 being used for several things, not a flag for "I'm in a string
1071 do_test('string constant now an FBM', perl,
1072 'SV = PVMG\\($ADDR\\) at $ADDR
1074 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1075 PV = $ADDR "rules"\\\0
1080 MG_VIRTUAL = &PL_vtbl_regexp
1081 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1083 MG_PTR = $ADDR "(?:\\\\\d){256}"
1084 RARE = \d+ # $] < 5.019002
1085 PREVIOUS = 1 # $] < 5.019002
1089 is(study perl, '', "Not allowed to study an FBM");
1091 do_test('string constant still an FBM', perl,
1092 'SV = PVMG\\($ADDR\\) at $ADDR
1094 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1095 PV = $ADDR "rules"\\\0
1100 MG_VIRTUAL = &PL_vtbl_regexp
1101 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1103 MG_PTR = $ADDR "(?:\\\\\d){256}"
1104 RARE = \d+ # $] < 5.019002
1105 PREVIOUS = 1 # $] < 5.019002
1109 do_test('regular string constant', beer,
1110 'SV = PV\\($ADDR\\) at $ADDR
1112 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1113 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1114 PV = $ADDR "foamy"\\\0
1120 is(study beer, 1, "Our studies were successful");
1122 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1124 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1125 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1126 PV = $ADDR "foamy"\\\0
1132 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1134 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1135 PV = $ADDR "foamy"\\\0
1140 MG_VIRTUAL = &PL_vtbl_regexp
1141 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1143 MG_PTR = $ADDR "(?:\\\\\d){256}"
1144 RARE = \d+ # $] < 5.019002
1145 PREVIOUS = \d+ # $] < 5.019002
1149 is (eval 'index "not too foamy", beer', 8, 'correct index');
1151 do_test('string constant now FBMed', beer, $want);
1155 is(study $pie, 1, "Our studies were successful");
1157 do_test('string constant still FBMed', beer, $want);
1159 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1161 FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\)
1162 PV = $ADDR "good"\\\0
1169 # (One block of study tests removed when study was made a no-op.)
1172 open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1173 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1175 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1176 pass "no crash with DeadCode";
1179 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
1180 do_test('UTF-8 in a regular expression',
1182 'SV = IV\($ADDR\) at $ADDR
1186 SV = REGEXP\($ADDR\) at $ADDR
1188 FLAGS = \(OBJECT,FAKE,UTF8\)
1189 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1191 STASH = $ADDR "Regexp"
1192 COMPFLAGS = 0x0 \(\)
1193 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1194 (?: ENGINE = $ADDR \(STANDARD\)
1195 )? INTFLAGS = 0x0(?: \(\))?
1208 )? MOTHER_RE = $ADDR'
1209 . ($] < 5.019003 ? '' : '
1210 SV = REGEXP\($ADDR\) at $ADDR
1213 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1215 COMPFLAGS = 0x0 \(\)
1216 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1217 (?: ENGINE = $ADDR \(STANDARD\)
1218 )? INTFLAGS = 0x0(?: \(\))?
1237 SAVED_COPY = 0x0)?') . '
1246 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1248 my $base_count = Devel::Peek::SvREFCNT(%hash);
1250 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1251 ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
1258 open(OUT,">peek$$") or die $!;
1259 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1261 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1263 open(IN, "peek$$") or die $!;
1264 my $dump = do { local $/; <IN> };
1266 1 while unlink "peek$$";
1273 eval "sub $x {}; 1" or die $@;
1278 _dump(_get_coderef("\x{df}::\xdf")),
1279 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1280 "GVGV's are correctly escaped for latin1 :: latin1",
1284 _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1285 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1286 "GVGV's are correctly escaped for UTF8 :: UTF8",
1290 _dump(_get_coderef("\x{df}::\x{30cd}")),
1291 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1292 "GVGV's are correctly escaped for latin1 :: UTF8",
1296 _dump(_get_coderef("\x{30cd}::\x{df}")),
1297 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1298 "GVGV's are correctly escaped for UTF8 :: latin1",
1302 _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1303 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1304 "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1307 my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1311 qr/NAME = \Q"\x{30dc}"/,
1312 "NAME is correctly escaped for UTF8 globs",
1317 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1318 "GvSTASH is correctly escaped for UTF8 globs"
1323 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1324 "EGV is correctly escaped for UTF8 globs"
1327 $dump = _dump(*{"\x{df}::\x{30cc}"});
1331 qr/NAME = \Q"\x{30cc}"/,
1332 "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1337 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1338 "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1343 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1344 "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1348 _dump(bless {}, "\0::\1::\x{30cd}"),
1349 qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1350 "STASH for blessed hashrefs is correct"
1353 BEGIN { $::{doof} = "\0\1\x{30cd}" }
1356 qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1357 "PROTOTYPE is escaped correctly"
1361 my $coderef = eval <<"EOP";
1362 use feature 'lexical_subs';
1363 no warnings 'experimental::lexical_subs';
1364 my sub bar (\$\x{30cd}) {1}; \\&bar
1368 qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1369 "PROTOTYPE works on lexical subs"
1374 eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
1376 sub basic { my $x; return eval q{sub { eval q{$x} }} }
1379 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1384 _dump(get_outside("\x{30ce}")),
1385 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1386 'OUTSIDE + UTF8 works'
1389 # TODO AUTOLOAD = stashname, which requires using a XS autoload
1390 # and calling Dump() on the cv
1394 sub test_utf8_stashes {
1395 my ($stash_name, $test) = @_;
1397 $dump = _dump(\%{"${stash_name}::"});
1399 my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1400 $escaped_stash_name = join "", map {
1401 $_ eq ':' ? $_ : sprintf $format, ord $_
1402 } split //, $stash_name;
1406 qr/\QNAME = "$escaped_stash_name"/,
1407 "NAME is correct escaped for $test"
1412 qr/\QENAME = "$escaped_stash_name"/,
1413 "ENAME is correct escaped for $test"
1418 [ "\x{30cd}", "UTF8 stashes" ],
1419 [ "\x{df}", "latin 1 stashes" ],
1420 [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1421 [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1423 test_utf8_stashes(@$test);
1428 my $runperl_args = { switches => ['-Ilib'] };
1430 my ($prog, $expected, $name, $test) = @_;
1433 my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1435 # Interface between Test::Builder & test.pl
1436 my $builder = Test::More->builder();
1437 t::curr_test($builder->current_test() + 1);
1439 utf8::encode($prog);
1441 if ( $test eq 'is' ) {
1442 t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
1445 t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
1448 $builder->current_test(t::curr_test() - 1);
1451 my $threads = $Config{'useithreads'};
1456 qr/PACKAGE = "test"/,
1457 "DumpProg() + package declaration"
1460 "use utf8; package \x{30cd};",
1461 qr/PACKAGE = "\\x\Q{30cd}"/,
1462 "DumpProg() + UTF8 package declaration"
1465 "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1466 ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1469 "use utf8; \x{30cc}: { last \x{30cc} }",
1470 qr/LABEL = \Q"\x{30cc}"/
1474 test_DumpProg(@$test);
1478 local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
1480 dumpindent is 4 at -e line 1.
1482 1 TYPE = leave ===> NULL
1484 FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB)
1488 2 TYPE = enter ===> 3
1489 FLAGS = (UNKNOWN,SLABBED)
1492 3 TYPE = nextstate ===> 4
1493 FLAGS = (VOID,SLABBED)
1498 5 TYPE = entersub ===> 1
1500 FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB)
1503 6 TYPE = null ===> (5)
1505 FLAGS = (UNKNOWN,KIDS,SLABBED,LASTSIB)
1507 4 TYPE = pushmark ===> 7
1508 FLAGS = (SCALAR,SLABBED)
1511 8 TYPE = null ===> (6)
1513 FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB)
1517 FLAGS = (SCALAR,SLABBED,LASTSIB)
1526 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
1527 $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004;
1528 my $out = t::runperl
1529 switches => ['-Ilib'],
1530 prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
1532 $out =~ s/ *SEQ = .*\n//;
1533 is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";