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];
34 if (open(OUT,">peek$$")) {
35 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
37 print STDERR "*****\n";
38 Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
39 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
41 if (open(IN, "peek$$")) {
43 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
44 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
45 # handle DEBUG_LEAKING_SCALARS prefix
46 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
48 # Need some clear generic mechanism to eliminate (or add) lines
49 # of dump output dependant on perl version. The (previous) use of
50 # things like $IVNV gave the illusion that the string passed in was
51 # a regexp into which variables were interpolated, but this wasn't
52 # actually true as those 'variables' actually also ate the
53 # whitespace on the line. So it seems better to mark lines that
54 # need to be eliminated. I considered (?# ... ) and (?{ ... }),
55 # but whilst embedded code or comment syntax would keep it as a
56 # legitimate regexp, it still isn't true. Seems easier and clearer
57 # things that look like comments.
59 # Could do this is in a s///mge but seems clearer like this:
60 $pattern = join '', map {
61 # If we identify the version condition, take *it* out whatever
64 : $_ # Didn't match, so this line is in
65 } split /^/, $pattern;
67 $pattern =~ s/\$PADMY/
68 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
70 $pattern =~ s/\$PADTMP/
71 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
74 ($] < 5.011) ? 'RV' : 'IV';
77 print $pattern, "\n" if $DEBUG;
78 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
79 print $dump, "\n" if $DEBUG;
80 like( $dump, qr/\A$pattern\Z/ms, $_[0])
81 or note("line " . (caller)[2]);
83 local $TODO = $repeat_todo;
84 is($dump2, $dump, "$_[0] (unchanged by dump)")
85 or note("line " . (caller)[2]);
91 die "$0: failed to open peek$$: !\n";
94 die "$0: failed to create peek$$: $!\n";
104 1 while unlink("peek$$");
107 do_test('assignment of immediate constant (string)',
109 'SV = PV\\($ADDR\\) at $ADDR
111 FLAGS = \\(POK,pPOK\\)
117 do_test('immediate constant (string)',
119 'SV = PV\\($ADDR\\) at $ADDR
121 FLAGS = \\(.*POK,READONLY,pPOK\\)
126 do_test('assignment of immediate constant (integer)',
128 'SV = IV\\($ADDR\\) at $ADDR
130 FLAGS = \\(IOK,pIOK\\)
133 do_test('immediate constant (integer)',
135 'SV = IV\\($ADDR\\) at $ADDR
137 FLAGS = \\(.*IOK,READONLY,pIOK\\)
140 do_test('assignment of immediate constant (integer)',
142 'SV = IV\\($ADDR\\) at $ADDR
144 FLAGS = \\($PADMY,IOK,pIOK\\)
147 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
148 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
149 # maths is done in floating point always, and this scalar will be an NV.
150 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
151 # building subsequent regexps.
152 my $type = do_test('result of addition',
154 'SV = ([NI])V\\($ADDR\\) at $ADDR
156 FLAGS = \\(PADTMP,\1OK,p\1OK\\)
161 do_test('floating point value',
163 'SV = PVNV\\($ADDR\\) at $ADDR
165 FLAGS = \\(NOK,pNOK\\)
167 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
172 do_test('integer constant',
174 'SV = IV\\($ADDR\\) at $ADDR
176 FLAGS = \\(.*IOK,READONLY,pIOK\\)
181 'SV = NULL\\(0x0\\) at $ADDR
185 do_test('reference to scalar',
187 'SV = $RV\\($ADDR\\) at $ADDR
191 SV = PV\\($ADDR\\) at $ADDR
193 FLAGS = \\(POK,pPOK\\)
201 SV = PVNV\\($ADDR\\) at $ADDR
203 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
209 SV = IV\\($ADDR\\) at $ADDR
211 FLAGS = \\(IOK,pIOK\\)
214 do_test('reference to array',
216 'SV = $RV\\($ADDR\\) at $ADDR
220 SV = PVAV\\($ADDR\\) at $ADDR
231 SV = IV\\($ADDR\\) at $ADDR
233 FLAGS = \\(IOK,pIOK\\)
235 Elt No. 1' . $c_pattern);
237 do_test('reference to hash',
239 'SV = $RV\\($ADDR\\) at $ADDR
243 SV = PVHV\\($ADDR\\) at $ADDR
245 FLAGS = \\(SHAREKEYS\\)
247 NV = $FLOAT # $] < 5.009
248 ARRAY = $ADDR \\(0:7, 1:1\\)
249 hash quality = 100.0%
255 Elt "123" HASH = $ADDR' . $c_pattern,
257 $] > 5.009 && $] < 5.015
258 && 'The hash iterator used in dump.c sets the OOK flag');
260 do_test('reference to anon sub with empty prototype',
262 'SV = $RV\\($ADDR\\) at $ADDR
266 SV = PVCV\\($ADDR\\) at $ADDR
268 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
269 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
273 COMP_STASH = $ADDR\\t"main"
274 START = $ADDR ===> \\d+
276 XSUB = 0x0 # $] < 5.009
277 XSUBANY = 0 # $] < 5.009
278 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
279 FILE = ".*\\b(?i:peek\\.t)"
283 FLAGS = 0x404 # $] < 5.009
284 FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr)
285 FLAGS = 0x1490 # $] >= 5.015 && thr
288 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
289 OUTSIDE = $ADDR \\(MAIN\\)');
291 do_test('reference to named subroutine without prototype',
293 'SV = $RV\\($ADDR\\) at $ADDR
297 SV = PVCV\\($ADDR\\) at $ADDR
299 FLAGS = \\(\\) # $] < 5.015 || !thr
300 FLAGS = \\(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" :: "do_test"
309 FILE = ".*\\b(?i:peek\\.t)"
313 FLAGS = 0x0 # $] < 5.015 || !thr
314 FLAGS = 0x1000 # $] >= 5.015 && thr
317 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
318 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
319 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
320 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
321 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009
322 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009
323 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
324 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
325 OUTSIDE = $ADDR \\(MAIN\\)');
328 do_test('reference to regexp',
330 'SV = $RV\\($ADDR\\) at $ADDR
334 SV = REGEXP\\($ADDR\\) at $ADDR
336 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
337 PV = $ADDR "\\(\\?\\^:tic\\)"
340 STASH = $ADDR\\t"Regexp"'
343 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
363 do_test('reference to regexp',
365 'SV = $RV\\($ADDR\\) at $ADDR
369 SV = PVMG\\($ADDR\\) at $ADDR
371 FLAGS = \\(OBJECT,SMG\\)
377 MG_TYPE = PERL_MAGIC_qr\(r\)
379 PAT = "\(\?^:tic\)" # $] >= 5.009
380 REFCNT = 2 # $] >= 5.009
381 STASH = $ADDR\\t"Regexp"');
384 do_test('reference to blessed hash',
386 'SV = $RV\\($ADDR\\) at $ADDR
390 SV = PVHV\\($ADDR\\) at $ADDR
392 FLAGS = \\(OBJECT,SHAREKEYS\\)
395 STASH = $ADDR\\t"Tac"
405 : 'The hash iterator used in dump.c sets the OOK flag'
406 : "Something causes the HV's array to become allocated");
410 'SV = PVGV\\($ADDR\\) at $ADDR
412 FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009
413 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009
417 MAGIC = $ADDR # $] < 5.009
418 MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009
419 MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009
420 MG_OBJ = $ADDR # $] < 5.009
423 GvSTASH = $ADDR\\t"main"
433 GPFLAGS = 0x0 # $] < 5.009
435 FILE = ".*\\b(?i:peek\\.t)"
439 if (ord('A') == 193) {
440 do_test('string with Unicode',
441 chr(256).chr(0).chr(512),
442 'SV = PV\\($ADDR\\) at $ADDR
444 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
445 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
449 do_test('string with Unicode',
450 chr(256).chr(0).chr(512),
451 'SV = PV\\($ADDR\\) at $ADDR
453 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
454 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
459 if (ord('A') == 193) {
460 do_test('reference to hash containing Unicode',
461 {chr(256)=>chr(512)},
462 'SV = $RV\\($ADDR\\) at $ADDR
466 SV = PVHV\\($ADDR\\) at $ADDR
468 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
470 NV = $FLOAT # $] < 5.009
471 ARRAY = $ADDR \\(0:7, 1:1\\)
472 hash quality = 100.0%
478 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
479 SV = PV\\($ADDR\\) at $ADDR
481 FLAGS = \\(POK,pPOK,UTF8\\)
482 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
488 : 'The hash iterator used in dump.c sets the OOK flag'
489 : 'sv_length has been called on the element, and cached the result in MAGIC');
491 do_test('reference to hash containing Unicode',
492 {chr(256)=>chr(512)},
493 'SV = $RV\\($ADDR\\) at $ADDR
497 SV = PVHV\\($ADDR\\) at $ADDR
499 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
502 ARRAY = $ADDR \\(0:7, 1:1\\)
503 hash quality = 100.0%
509 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
510 SV = PV\\($ADDR\\) at $ADDR
512 FLAGS = \\(POK,pPOK,UTF8\\)
513 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
519 : 'The hash iterator used in dump.c sets the OOK flag'
520 : 'sv_length has been called on the element, and cached the result in MAGIC');
525 do_test('scalar with pos magic',
527 'SV = PVMG\\($ADDR\\) at $ADDR
529 FLAGS = \\($PADMY,SMG,POK,pPOK\\)
536 MG_VIRTUAL = &PL_vtbl_mglob
537 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
542 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
543 # environment variables may be invisibly case-forced, hence the (?i:PATH)
544 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
545 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
546 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
547 # VMS is setting FAKE and READONLY flags. What VMS uses for storing
548 # ENV hashes is also not always null terminated.
550 do_test('tainted value in %ENV',
551 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
552 'SV = PVMG\\($ADDR\\) at $ADDR
554 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
561 MG_VIRTUAL = &PL_vtbl_envelem
562 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
566 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
567 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
569 FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
571 )? PV = $ADDR "(?i:PATH)"(?:\\\0)?
575 MG_VIRTUAL = &PL_vtbl_taint
576 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
578 do_test('blessed reference',
579 bless(\\undef, 'Foobar'),
580 'SV = $RV\\($ADDR\\) at $ADDR
584 SV = PVMG\\($ADDR\\) at $ADDR
586 FLAGS = \\(OBJECT,ROK\\)
590 SV = NULL\\(0x0\\) at $ADDR
592 FLAGS = \\(READONLY\\)
596 STASH = $ADDR\s+"Foobar"');
602 do_test('constant subroutine',
604 'SV = $RV\\($ADDR\\) at $ADDR
608 SV = PVCV\\($ADDR\\) at $ADDR
610 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
611 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
616 ROOT = 0x0 # $] < 5.009
618 XSUBANY = $ADDR \\(CONST SV\\)
619 SV = PV\\($ADDR\\) at $ADDR
621 FLAGS = \\(.*POK,READONLY,pPOK\\)
622 PV = $ADDR "Perl rules"\\\0
625 GVGV::GV = $ADDR\\t"main" :: "const"
626 FILE = ".*\\b(?i:peek\\.t)"
630 FLAGS = 0x200 # $] < 5.009
631 FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013
632 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
633 FLAGS = 0x100c # $] >= 5.015
636 OUTSIDE = 0x0 \\(null\\)');
638 do_test('isUV should show on PVMG',
639 do { my $v = $1; $v = ~0; $v },
640 'SV = PVMG\\($ADDR\\) at $ADDR
642 FLAGS = \\(IOK,pIOK,IsUV\\)
649 'SV = $RV\\($ADDR\\) at $ADDR
653 SV = PVIO\\($ADDR\\) at $ADDR
658 STASH = $ADDR\s+"IO::File"
669 SUBPROCESS = 0 # $] < 5.009
675 'SV = $RV\\($ADDR\\) at $ADDR
679 SV = PVFM\\($ADDR\\) at $ADDR
681 FLAGS = \\(\\) # $] < 5.015 || !thr
682 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
687 START = $ADDR ===> \\d+
689 XSUB = 0x0 # $] < 5.009
690 XSUBANY = 0 # $] < 5.009
691 GVGV::GV = $ADDR\\t"main" :: "PIE"
692 FILE = ".*\\b(?i:peek\\.t)"(?:
696 FLAGS = 0x0 # $] < 5.015 || !thr
697 FLAGS = 0x1000 # $] >= 5.015 && thr
699 LINES = 0 # $] < 5.017_003
701 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
702 OUTSIDE = $ADDR \\(MAIN\\)');
704 do_test('blessing to a class with embedded NUL characters',
705 (bless {}, "\0::foo::\n::baz::\t::\0"),
706 'SV = $RV\\($ADDR\\) at $ADDR
710 SV = PVHV\\($ADDR\\) at $ADDR
712 FLAGS = \\(OBJECT,SHAREKEYS\\)
715 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
725 : 'The hash iterator used in dump.c sets the OOK flag'
726 : "Something causes the HV's array to become allocated");
728 do_test('ENAME on a stash',
730 'SV = $RV\\($ADDR\\) at $ADDR
734 SV = PVHV\\($ADDR\\) at $ADDR
736 FLAGS = \\(OOK,SHAREKEYS\\)
738 NV = $FLOAT # $] < 5.009
746 ENAME = "RWOM" # $] > 5.012
751 do_test('ENAMEs on a stash',
753 'SV = $RV\\($ADDR\\) at $ADDR
757 SV = PVHV\\($ADDR\\) at $ADDR
759 FLAGS = \\(OOK,SHAREKEYS\\)
761 NV = $FLOAT # $] < 5.009
769 NAMECOUNT = 2 # $] > 5.012
770 ENAME = "RWOM", "KLANK" # $] > 5.012
775 do_test('ENAMEs on a stash with no NAME',
777 'SV = $RV\\($ADDR\\) at $ADDR
781 SV = PVHV\\($ADDR\\) at $ADDR
783 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
784 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017
786 NV = $FLOAT # $] < 5.009
793 NAMECOUNT = -3 # $] > 5.012
794 ENAME = "RWOM", "KLANK" # $] > 5.012
798 skip "Not built with usemymalloc", 1
799 unless $Config{usemymalloc} eq 'y';
801 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
805 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
806 # prowess, but short of duplicating all the gubbins of this file, I can't see
807 # a way to make a better place for it:
814 unless ($Config{useithreads}) {
815 # These end up as copies in pads under ithreads, which rather defeats the
816 # the point of what we're trying to test here.
818 do_test('regular string constant', perl,
819 'SV = PV\\($ADDR\\) at $ADDR
821 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
822 PV = $ADDR "rules"\\\0
827 eval 'index "", perl';
829 # FIXME - really this shouldn't say EVALED. It's a false posistive on
830 # 0x40000000 being used for several things, not a flag for "I'm in a string
833 do_test('string constant now an FBM', perl,
834 'SV = PVMG\\($ADDR\\) at $ADDR
836 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
837 PV = $ADDR "rules"\\\0
841 MG_VIRTUAL = &PL_vtbl_regexp
842 MG_TYPE = PERL_MAGIC_bm\\(B\\)
844 MG_PTR = $ADDR "(?:\\\\\d){256}"
850 is(study perl, '', "Not allowed to study an FBM");
852 do_test('string constant still an FBM', perl,
853 'SV = PVMG\\($ADDR\\) at $ADDR
855 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
856 PV = $ADDR "rules"\\\0
860 MG_VIRTUAL = &PL_vtbl_regexp
861 MG_TYPE = PERL_MAGIC_bm\\(B\\)
863 MG_PTR = $ADDR "(?:\\\\\d){256}"
869 do_test('regular string constant', beer,
870 'SV = PV\\($ADDR\\) at $ADDR
872 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
873 PV = $ADDR "foamy"\\\0
878 is(study beer, 1, "Our studies were successful");
880 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
882 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
883 PV = $ADDR "foamy"\\\0
888 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
890 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
891 PV = $ADDR "foamy"\\\0
895 MG_VIRTUAL = &PL_vtbl_regexp
896 MG_TYPE = PERL_MAGIC_bm\\(B\\)
898 MG_PTR = $ADDR "(?:\\\\\d){256}"
904 is (eval 'index "not too foamy", beer', 8, 'correct index');
906 do_test('string constant now FBMed', beer, $want);
910 is(study $pie, 1, "Our studies were successful");
912 do_test('string constant still FBMed', beer, $want);
914 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
916 FLAGS = \\(PADMY,POK,pPOK\\)
917 PV = $ADDR "good"\\\0
923 # (One block of study tests removed when study was made a no-op.)
926 open(OUT,">peek$$") or die "Failed to open peek $$: $!";
927 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
929 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
930 pass "no crash with DeadCode";