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
267 SV = IV\\($ADDR\\) at $ADDR
269 FLAGS = \\(IOK,pIOK\\)
271 Elt No. 1' . $c_pattern);
273 do_test('reference to hash',
275 'SV = $RV\\($ADDR\\) at $ADDR
279 SV = PVHV\\($ADDR\\) at $ADDR
281 FLAGS = \\(SHAREKEYS\\)
282 ARRAY = $ADDR \\(0:7, 1:1\\)
283 hash quality = 100.0%
287 Elt "123" HASH = $ADDR' . $c_pattern,
289 ($] < 5.015) ? 'The hash iterator used in dump.c sets the OOK flag' : undef);
291 do_test('reference to anon sub with empty prototype',
293 'SV = $RV\\($ADDR\\) at $ADDR
297 SV = PVCV\\($ADDR\\) at $ADDR
299 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
300 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
302 COMP_STASH = $ADDR\\t"main"
303 START = $ADDR ===> \\d+
305 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
306 FILE = ".*\\b(?i:peek\\.t)"
310 FLAGS = 0x490 # $] < 5.015 || !thr
311 FLAGS = 0x1490 # $] >= 5.015 && thr
314 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
315 OUTSIDE = $ADDR \\(MAIN\\)');
317 do_test('reference to named subroutine without prototype',
319 'SV = $RV\\($ADDR\\) at $ADDR
323 SV = PVCV\\($ADDR\\) at $ADDR
325 FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr
326 FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
327 COMP_STASH = $ADDR\\t"main"
328 START = $ADDR ===> \\d+
330 NAME = "do_test" # $] >=5.021004
331 GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004
332 FILE = ".*\\b(?i:peek\\.t)"
336 FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr
337 FLAGS = 0x[cd145]000 # $] >= 5.015 && thr
340 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
341 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
342 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
343 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
344 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
345 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
346 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
347 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
348 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
349 OUTSIDE = $ADDR \\(MAIN\\)');
352 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
353 do_test('reference to regexp',
355 'SV = $RV\\($ADDR\\) at $ADDR
359 SV = REGEXP\\($ADDR\\) at $ADDR
361 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
362 PV = $ADDR "\\(\\?\\^:tic\\)"
365 STASH = $ADDR\\t"Regexp"'
369 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
370 (?: ENGINE = $ADDR \(STANDARD\)
371 )? INTFLAGS = 0x0(?: \(\))?
384 )? MOTHER_RE = $ADDR'
385 . ($] < 5.019003 ? '' : '
386 SV = REGEXP\($ADDR\) at $ADDR
389 PV = $ADDR "\(\?\^:tic\)"
393 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
394 (?: ENGINE = $ADDR \(STANDARD\)
395 )? INTFLAGS = 0x0(?: \(\))?
414 SAVED_COPY = 0x0)?') . '
423 do_test('reference to regexp',
425 'SV = $RV\\($ADDR\\) at $ADDR
429 SV = PVMG\\($ADDR\\) at $ADDR
431 FLAGS = \\(OBJECT,SMG\\)
437 MG_TYPE = PERL_MAGIC_qr\(r\)
441 STASH = $ADDR\\t"Regexp"');
444 do_test('reference to blessed hash',
446 'SV = $RV\\($ADDR\\) at $ADDR
450 SV = PVHV\\($ADDR\\) at $ADDR
452 FLAGS = \\(OBJECT,SHAREKEYS\\)
453 STASH = $ADDR\\t"Tac"
460 : 'The hash iterator used in dump.c sets the OOK flag');
464 'SV = PVGV\\($ADDR\\) at $ADDR
466 FLAGS = \\(MULTI(?:,IN_PAD)?\\)
469 GvSTASH = $ADDR\\t"main"
470 FLAGS = $ADDR # $] >=5.021004
480 GPFLAGS = 0x0 \(\) # $] >= 5.021004
482 FILE = ".*\\b(?i:peek\\.t)"
483 FLAGS = $ADDR # $] < 5.021004
486 if (ord('A') == 193) {
487 do_test('string with Unicode',
488 chr(256).chr(0).chr(512),
489 'SV = PV\\($ADDR\\) at $ADDR
491 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
492 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
493 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
496 COW_REFCNT = 1 # $] < 5.019007
499 do_test('string with Unicode',
500 chr(256).chr(0).chr(512),
501 'SV = PV\\($ADDR\\) at $ADDR
503 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
504 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
505 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
508 COW_REFCNT = 1 # $] < 5.019007
512 if (ord('A') == 193) {
513 do_test('reference to hash containing Unicode',
514 {chr(256)=>chr(512)},
515 'SV = $RV\\($ADDR\\) at $ADDR
519 SV = PVHV\\($ADDR\\) at $ADDR
521 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
522 ARRAY = $ADDR \\(0:7, 1:1\\)
523 hash quality = 100.0%
527 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
528 SV = PV\\($ADDR\\) at $ADDR
530 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
531 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
534 COW_REFCNT = 1 # $] < 5.019007
538 : 'The hash iterator used in dump.c sets the OOK flag');
540 do_test('reference to hash containing Unicode',
541 {chr(256)=>chr(512)},
542 'SV = $RV\\($ADDR\\) at $ADDR
546 SV = PVHV\\($ADDR\\) at $ADDR
548 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
549 ARRAY = $ADDR \\(0:7, 1:1\\)
550 hash quality = 100.0%
554 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
555 SV = PV\\($ADDR\\) at $ADDR
557 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
558 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
561 COW_REFCNT = 1 # $] < 5.019007
565 : 'The hash iterator used in dump.c sets the OOK flag');
570 do_test('scalar with pos magic',
572 'SV = PVMG\\($ADDR\\) at $ADDR
574 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
582 MG_VIRTUAL = &PL_vtbl_mglob
583 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
584 MG_FLAGS = 0x01 # $] < 5.019003
585 MG_FLAGS = 0x41 # $] >=5.019003
587 BYTES # $] >=5.019003
591 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
592 # environment variables may be invisibly case-forced, hence the (?i:PATH)
593 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
594 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
595 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
596 # VMS is setting FAKE and READONLY flags. What VMS uses for storing
597 # ENV hashes is also not always null terminated.
600 # Save and restore PATH, since fresh_perl ends up using that in Windows.
601 my $path = $ENV{PATH};
602 do_test('tainted value in %ENV',
603 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
604 'SV = PVMG\\($ADDR\\) at $ADDR
606 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
613 MG_VIRTUAL = &PL_vtbl_envelem
614 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
618 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
619 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
621 FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
623 )? PV = $ADDR "(?i:PATH)"(?:\\\0)?
627 MG_VIRTUAL = &PL_vtbl_taint
628 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
632 do_test('blessed reference',
633 bless(\\undef, 'Foobar'),
634 'SV = $RV\\($ADDR\\) at $ADDR
638 SV = PVMG\\($ADDR\\) at $ADDR
640 FLAGS = \\(OBJECT,ROK\\)
644 SV = NULL\\(0x0\\) at $ADDR
646 FLAGS = \\(READONLY\\) # $] < 5.021005
647 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
651 STASH = $ADDR\s+"Foobar"');
657 do_test('constant subroutine',
659 'SV = $RV\\($ADDR\\) at $ADDR
663 SV = PVCV\\($ADDR\\) at $ADDR
665 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
666 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
668 COMP_STASH = 0x0 # $] < 5.021004
669 COMP_STASH = $ADDR "main" # $] >=5.021004
671 XSUBANY = $ADDR \\(CONST SV\\)
672 SV = PV\\($ADDR\\) at $ADDR
674 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
675 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
676 PV = $ADDR "Perl rules"\\\0
680 GVGV::GV = $ADDR\\t"main" :: "const"
681 FILE = ".*\\b(?i:peek\\.t)"
685 FLAGS = 0xc00 # $] < 5.013
686 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
687 FLAGS = 0x100c # $] >= 5.015
689 PADLIST = 0x0 # $] < 5.021006
690 HSCXT = $ADDR # $] >= 5.021006
691 OUTSIDE = 0x0 \\(null\\)');
693 do_test('isUV should show on PVMG',
694 do { my $v = $1; $v = ~0; $v },
695 'SV = PVMG\\($ADDR\\) at $ADDR
697 FLAGS = \\(IOK,pIOK,IsUV\\)
704 'SV = $RV\\($ADDR\\) at $ADDR
708 SV = PVIO\\($ADDR\\) at $ADDR
713 STASH = $ADDR\s+"IO::File"
729 'SV = $RV\\($ADDR\\) at $ADDR
733 SV = PVFM\\($ADDR\\) at $ADDR
735 FLAGS = \\(\\) # $] < 5.015 || !thr
736 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
739 START = $ADDR ===> \\d+
741 GVGV::GV = $ADDR\\t"main" :: "PIE"
742 FILE = ".*\\b(?i:peek\\.t)"(?:
746 FLAGS = 0x0 # $] < 5.015 || !thr
747 FLAGS = 0x1000 # $] >= 5.015 && thr
749 LINES = 0 # $] < 5.017_003
751 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
752 OUTSIDE = $ADDR \\(MAIN\\)');
754 do_test('blessing to a class with embedded NUL characters',
755 (bless {}, "\0::foo::\n::baz::\t::\0"),
756 'SV = $RV\\($ADDR\\) at $ADDR
760 SV = PVHV\\($ADDR\\) at $ADDR
762 FLAGS = \\(OBJECT,SHAREKEYS\\)
763 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
770 : 'The hash iterator used in dump.c sets the OOK flag');
772 do_test('ENAME on a stash',
774 'SV = $RV\\($ADDR\\) at $ADDR
778 SV = PVHV\\($ADDR\\) at $ADDR
780 FLAGS = \\(OOK,SHAREKEYS\\)
781 AUX_FLAGS = 0 # $] > 5.019008
790 ENAME = "RWOM" # $] > 5.012
795 do_test('ENAMEs on a stash',
797 'SV = $RV\\($ADDR\\) at $ADDR
801 SV = PVHV\\($ADDR\\) at $ADDR
803 FLAGS = \\(OOK,SHAREKEYS\\)
804 AUX_FLAGS = 0 # $] > 5.019008
813 NAMECOUNT = 2 # $] > 5.012
814 ENAME = "RWOM", "KLANK" # $] > 5.012
819 do_test('ENAMEs on a stash with no NAME',
821 'SV = $RV\\($ADDR\\) at $ADDR
825 SV = PVHV\\($ADDR\\) at $ADDR
827 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
828 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005
829 FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005
830 AUX_FLAGS = 0 # $] > 5.019008
838 NAMECOUNT = -3 # $] > 5.012
839 ENAME = "RWOM", "KLANK" # $] > 5.012
842 my %small = ("Perl", "Rules", "Beer", "Foamy");
844 do_test('small hash',
846 'SV = $RV\\($ADDR\\) at $ADDR
850 SV = PVHV\\($ADDR\\) at $ADDR
852 FLAGS = \\($PADMY,SHAREKEYS\\)
853 ARRAY = $ADDR \\(0:[67],.*\\)
854 hash quality = [0-9.]+%
858 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
859 SV = PV\\($ADDR\\) at $ADDR
861 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
862 PV = $ADDR "(?:Rules|Foamy)"\\\0
870 do_test('small hash after keys',
872 'SV = $RV\\($ADDR\\) at $ADDR
876 SV = PVHV\\($ADDR\\) at $ADDR
878 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
879 AUX_FLAGS = 0 # $] > 5.019008
880 ARRAY = $ADDR \\(0:[67],.*\\)
881 hash quality = [0-9.]+%
888 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
889 SV = PV\\($ADDR\\) at $ADDR
891 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
892 PV = $ADDR "(?:Rules|Foamy)"\\\0
900 do_test('small hash after keys and scalar',
902 'SV = $RV\\($ADDR\\) at $ADDR
906 SV = PVHV\\($ADDR\\) at $ADDR
908 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
909 AUX_FLAGS = 0 # $] > 5.019008
910 ARRAY = $ADDR \\(0:[67],.*\\)
911 hash quality = [0-9.]+%
918 (?: Elt "(?:Perl|Beer)" HASH = $ADDR
919 SV = PV\\($ADDR\\) at $ADDR
921 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
922 PV = $ADDR "(?:Rules|Foamy)"\\\0
928 # Dump with arrays, hashes, and operator return values
930 do_test('Dump @array', '@array', <<'ARRAY', '', undef, 1);
931 SV = PVAV\($ADDR\) at $ADDR
939 SV = IV\($ADDR\) at $ADDR
944 SV = IV\($ADDR\) at $ADDR
949 SV = IV\($ADDR\) at $ADDR
955 do_test('Dump @array,1', '@array,1', <<'ARRAY', '', undef, 1);
956 SV = PVAV\($ADDR\) at $ADDR
964 SV = IV\($ADDR\) at $ADDR
971 do_test('Dump %hash', '%hash', <<'HASH', '', undef, 1);
972 SV = PVHV\($ADDR\) at $ADDR
974 FLAGS = \(SHAREKEYS\)
975 ARRAY = $ADDR \(0:7, 1:1\)
976 hash quality = 100.0%
981 SV = IV\($ADDR\) at $ADDR
988 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', undef, 1);
989 SV = PV\($ADDR\) at $ADDR
991 FLAGS = \(PADTMP,POK,pPOK\)
997 # Dump with no arguments
999 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1001 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1004 skip "Not built with usemymalloc", 2
1005 unless $Config{usemymalloc} eq 'y';
1006 my $x = __PACKAGE__;
1007 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1010 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1013 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1014 # prowess, but short of duplicating all the gubbins of this file, I can't see
1015 # a way to make a better place for it:
1019 # The length of the rhs string must be such that if chr() is applied to it
1020 # doesn't yield a character with a backslash mnemonic. For example, if it
1021 # were 'rules' instead of 'rule', it would have 5 characters, and on
1022 # EBCDIC, chr(5) is \t. The dumping code would translate all the 5's in
1023 # MG_PTR into "\t", and this test code would be expecting \5's, so the
1024 # tests would fail. No platform that Perl works on translates chr(4) into
1030 unless ($Config{useithreads}) {
1031 # These end up as copies in pads under ithreads, which rather defeats the
1032 # the point of what we're trying to test here.
1034 do_test('regular string constant', perl,
1035 'SV = PV\\($ADDR\\) at $ADDR
1037 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1038 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1039 PV = $ADDR "rule"\\\0
1045 eval 'index "", perl';
1047 do_test('string constant now an FBM', perl,
1048 'SV = PVMG\\($ADDR\\) at $ADDR
1050 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1051 PV = $ADDR "rule"\\\0
1056 MG_VIRTUAL = &PL_vtbl_regexp
1057 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1059 MG_PTR = $ADDR "(?:\\\\\d){256}"
1060 RARE = \d+ # $] < 5.019002
1061 PREVIOUS = 1 # $] < 5.019002
1065 is(study perl, '', "Not allowed to study an FBM");
1067 do_test('string constant still an FBM', perl,
1068 'SV = PVMG\\($ADDR\\) at $ADDR
1070 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1071 PV = $ADDR "rule"\\\0
1076 MG_VIRTUAL = &PL_vtbl_regexp
1077 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1079 MG_PTR = $ADDR "(?:\\\\\d){256}"
1080 RARE = \d+ # $] < 5.019002
1081 PREVIOUS = 1 # $] < 5.019002
1085 do_test('regular string constant', beer,
1086 'SV = PV\\($ADDR\\) at $ADDR
1088 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1089 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1090 PV = $ADDR "foam"\\\0
1096 is(study beer, 1, "Our studies were successful");
1098 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1100 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
1101 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
1102 PV = $ADDR "foam"\\\0
1108 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1110 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1111 PV = $ADDR "foam"\\\0
1116 MG_VIRTUAL = &PL_vtbl_regexp
1117 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1119 MG_PTR = $ADDR "(?:\\\\\d){256}"
1120 RARE = \d+ # $] < 5.019002
1121 PREVIOUS = \d+ # $] < 5.019002
1125 is (eval 'index "not too foamy", beer', 8, 'correct index');
1127 do_test('string constant now FBMed', beer, $want);
1131 is(study $pie, 1, "Our studies were successful");
1133 do_test('string constant still FBMed', beer, $want);
1135 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1137 FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\)
1138 PV = $ADDR "good"\\\0
1145 # (One block of study tests removed when study was made a no-op.)
1148 open(OUT, '>', "peek$$") or die "Failed to open peek $$: $!";
1149 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1151 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1152 pass "no crash with DeadCode";
1155 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
1156 do_test('UTF-8 in a regular expression',
1158 'SV = IV\($ADDR\) at $ADDR
1162 SV = REGEXP\($ADDR\) at $ADDR
1164 FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\)
1165 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1168 STASH = $ADDR "Regexp"
1169 COMPFLAGS = 0x0 \(\)
1170 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1171 (?: ENGINE = $ADDR \(STANDARD\)
1172 )? INTFLAGS = 0x0(?: \(\))?
1185 )? MOTHER_RE = $ADDR'
1186 . ($] < 5.019003 ? '' : '
1187 SV = REGEXP\($ADDR\) at $ADDR
1189 FLAGS = \(POK,pPOK,UTF8\)
1190 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1193 COMPFLAGS = 0x0 \(\)
1194 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1195 (?: ENGINE = $ADDR \(STANDARD\)
1196 )? INTFLAGS = 0x0(?: \(\))?
1215 SAVED_COPY = 0x0)?') . '
1224 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1226 my $base_count = Devel::Peek::SvREFCNT(%hash);
1228 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1229 ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
1236 open(OUT, '>', "peek$$") or die $!;
1237 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1239 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1241 open(IN, '<', "peek$$") or die $!;
1242 my $dump = do { local $/; <IN> };
1244 1 while unlink "peek$$";
1251 eval "sub $x {}; 1" or die $@;
1256 _dump(_get_coderef("\x{df}::\xdf")),
1257 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1258 "GVGV's are correctly escaped for latin1 :: latin1",
1262 _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1263 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1264 "GVGV's are correctly escaped for UTF8 :: UTF8",
1268 _dump(_get_coderef("\x{df}::\x{30cd}")),
1269 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1270 "GVGV's are correctly escaped for latin1 :: UTF8",
1274 _dump(_get_coderef("\x{30cd}::\x{df}")),
1275 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1276 "GVGV's are correctly escaped for UTF8 :: latin1",
1280 _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1281 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1282 "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1285 my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1289 qr/NAME = \Q"\x{30dc}"/,
1290 "NAME is correctly escaped for UTF8 globs",
1295 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1296 "GvSTASH is correctly escaped for UTF8 globs"
1301 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1302 "EGV is correctly escaped for UTF8 globs"
1305 $dump = _dump(*{"\x{df}::\x{30cc}"});
1309 qr/NAME = \Q"\x{30cc}"/,
1310 "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1315 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1316 "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1321 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1322 "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1326 _dump(bless {}, "\0::\1::\x{30cd}"),
1327 qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1328 "STASH for blessed hashrefs is correct"
1331 BEGIN { $::{doof} = "\0\1\x{30cd}" }
1334 qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1335 "PROTOTYPE is escaped correctly"
1339 my $coderef = eval <<"EOP";
1340 use feature 'lexical_subs';
1341 no warnings 'experimental::lexical_subs';
1342 my sub bar (\$\x{30cd}) {1}; \\&bar
1346 qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1347 "PROTOTYPE works on lexical subs"
1352 eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
1354 sub basic { my $x; return eval q{sub { eval q{$x} }} }
1357 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1362 _dump(get_outside("\x{30ce}")),
1363 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1364 'OUTSIDE + UTF8 works'
1367 # TODO AUTOLOAD = stashname, which requires using a XS autoload
1368 # and calling Dump() on the cv
1372 sub test_utf8_stashes {
1373 my ($stash_name, $test) = @_;
1375 $dump = _dump(\%{"${stash_name}::"});
1377 my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1378 $escaped_stash_name = join "", map {
1379 $_ eq ':' ? $_ : sprintf $format, ord $_
1380 } split //, $stash_name;
1384 qr/\QNAME = "$escaped_stash_name"/,
1385 "NAME is correct escaped for $test"
1390 qr/\QENAME = "$escaped_stash_name"/,
1391 "ENAME is correct escaped for $test"
1396 [ "\x{30cd}", "UTF8 stashes" ],
1397 [ "\x{df}", "latin 1 stashes" ],
1398 [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1399 [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1401 test_utf8_stashes(@$test);
1406 my $runperl_args = { switches => ['-Ilib'] };
1408 my ($prog, $expected, $name, $test) = @_;
1411 my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1413 # Interface between Test::Builder & test.pl
1414 my $builder = Test::More->builder();
1415 t::curr_test($builder->current_test() + 1);
1417 utf8::encode($prog);
1419 if ( $test eq 'is' ) {
1420 t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
1423 t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
1426 $builder->current_test(t::curr_test() - 1);
1429 my $threads = $Config{'useithreads'};
1434 qr/PACKAGE = "test"/,
1435 "DumpProg() + package declaration"
1438 "use utf8; package \x{30cd};",
1439 qr/PACKAGE = "\\x\Q{30cd}"/,
1440 "DumpProg() + UTF8 package declaration"
1443 "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1444 ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1447 "use utf8; \x{30cc}: { last \x{30cc} }",
1448 qr/LABEL = \Q"\x{30cc}"/
1452 test_DumpProg(@$test);
1456 local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
1458 dumpindent is 4 at -e line 1.
1460 1 leave LISTOP(0xNNN) ===> [0x0]
1463 FLAGS = (VOID,KIDS,PARENS,SLABBED)
1467 2 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN]
1468 | FLAGS = (UNKNOWN,SLABBED,MORESIB)
1470 3 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN]
1471 | FLAGS = (VOID,SLABBED,MORESIB)
1475 5 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN]
1477 FLAGS = (VOID,KIDS,STACKED,SLABBED)
1480 6 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN]
1481 FLAGS = (UNKNOWN,KIDS,SLABBED)
1483 4 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN]
1484 | FLAGS = (SCALAR,SLABBED,MORESIB)
1486 8 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN]
1487 FLAGS = (SCALAR,KIDS,SLABBED)
1490 7 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN]
1491 FLAGS = (SCALAR,SLABBED)
1495 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
1496 $e =~ s/SVOP/PADOP/g if $threads;
1497 my $out = t::runperl
1498 switches => ['-Ilib'],
1499 prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
1501 $out =~ s/ *SEQ = .*\n//;
1502 $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g;
1503 $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g;
1504 is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";