This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Peek.t needs to know about the prev. change
[perl5.git] / ext / Devel-Peek / t / Peek.t
1 #!./perl -T
2
3 BEGIN {
4     require Config; import Config;
5     if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
6         print "1..0 # Skip: Devel::Peek was not built\n";
7         exit 0;
8     }
9     {
10     package t;
11        my $core = !!$ENV{PERL_CORE};
12        require($core ? '../../t/test.pl' : './t/test.pl');
13     }
14 }
15
16 use Test::More;
17
18 use Devel::Peek;
19
20 our $DEBUG = 0;
21 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
22
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
25 # maintain that.
26 format PIE =
27 Pie     @<<<<<
28 $::type
29 Good    @>>>>>
30 $::mmmm
31 .
32
33 use constant thr => $Config{useithreads};
34
35 sub do_test {
36     my $todo = $_[3];
37     my $repeat_todo = $_[4];
38     my $pattern = $_[2];
39     my $do_eval = $_[5];
40     if (open(OUT,">peek$$")) {
41         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
42         if ($do_eval) {
43             my $sub = eval "sub { Dump $_[1] }";
44             $sub->();
45             print STDERR "*****\n";
46             # second dump to compare with the first to make sure nothing
47             # changed.
48             $sub->();
49         }
50         else {
51             Dump($_[1]);
52             print STDERR "*****\n";
53             # second dump to compare with the first to make sure nothing
54             # changed.
55             Dump($_[1]);
56         }
57         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
58         close(OUT);
59         if (open(IN, "peek$$")) {
60             local $/;
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;
65
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.
76
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
80                 s/\s*# (\$].*)$//
81                     ? (eval $1 ? $_ : '')
82                     : $_ # Didn't match, so this line is in
83             } split /^/, $pattern;
84             
85             $pattern =~ s/\$PADMY/
86                 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
87             /mge;
88             $pattern =~ s/\$PADTMP/
89                 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
90             /mge;
91             $pattern =~ s/\$RV/
92                 ($] < 5.011) ? 'RV' : 'IV';
93             /mge;
94             $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
95                 if $Config{ccflags} =~
96                         /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)/
97                             || $] < 5.019003;
98             print $pattern, "\n" if $DEBUG;
99             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
100             print $dump, "\n"    if $DEBUG;
101             like( $dump, qr/\A$pattern\Z/ms, $_[0])
102               or note("line " . (caller)[2]);
103
104             local $TODO = $repeat_todo;
105             is($dump2, $dump, "$_[0] (unchanged by dump)")
106               or note("line " . (caller)[2]);
107
108             close(IN);
109
110             return $1;
111         } else {
112             die "$0: failed to open peek$$: !\n";
113         }
114     } else {
115         die "$0: failed to create peek$$: $!\n";
116     }
117 }
118
119 our   $a;
120 our   $b;
121 my    $c;
122 local $d = 0;
123
124 END {
125     1 while unlink("peek$$");
126 }
127
128 do_test('assignment of immediate constant (string)',
129         $a = "foo",
130 'SV = PV\\($ADDR\\) at $ADDR
131   REFCNT = 1
132   FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
133   PV = $ADDR "foo"\\\0
134   CUR = 3
135   LEN = \\d+
136   COW_REFCNT = 1
137 ');
138
139 do_test('immediate constant (string)',
140         "bar",
141 'SV = PV\\($ADDR\\) at $ADDR
142   REFCNT = 1
143   FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
144   PV = $ADDR "bar"\\\0
145   CUR = 3
146   LEN = \\d+
147   COW_REFCNT = 0
148 ');
149
150 do_test('assignment of immediate constant (integer)',
151         $b = 123,
152 'SV = IV\\($ADDR\\) at $ADDR
153   REFCNT = 1
154   FLAGS = \\(IOK,pIOK\\)
155   IV = 123');
156
157 do_test('immediate constant (integer)',
158         456,
159 'SV = IV\\($ADDR\\) at $ADDR
160   REFCNT = 1
161   FLAGS = \\(.*IOK,READONLY,pIOK\\)
162   IV = 456');
163
164 do_test('assignment of immediate constant (integer)',
165         $c = 456,
166 'SV = IV\\($ADDR\\) at $ADDR
167   REFCNT = 1
168   FLAGS = \\($PADMY,IOK,pIOK\\)
169   IV = 456');
170
171 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
172 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
173 # maths is done in floating point always, and this scalar will be an NV.
174 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
175 # building subsequent regexps.
176 my $type = do_test('result of addition',
177         $c + $d,
178 'SV = ([NI])V\\($ADDR\\) at $ADDR
179   REFCNT = 1
180   FLAGS = \\(PADTMP,\1OK,p\1OK\\)               # $] < 5.019003
181   FLAGS = \\(\1OK,p\1OK\\)                      # $] >=5.019003
182   \1V = 456');
183
184 ($d = "789") += 0.1;
185
186 do_test('floating point value',
187        $d,
188        $] < 5.019003
189         || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)/
190        ?
191 'SV = PVNV\\($ADDR\\) at $ADDR
192   REFCNT = 1
193   FLAGS = \\(NOK,pNOK\\)
194   IV = \d+
195   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
196   PV = $ADDR "789"\\\0
197   CUR = 3
198   LEN = \\d+'
199        :
200 'SV = PVNV\\($ADDR\\) at $ADDR
201   REFCNT = 1
202   FLAGS = \\(NOK,pNOK\\)
203   IV = \d+
204   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
205   PV = 0');
206
207 do_test('integer constant',
208         0xabcd,
209 'SV = IV\\($ADDR\\) at $ADDR
210   REFCNT = 1
211   FLAGS = \\(.*IOK,READONLY,pIOK\\)
212   IV = 43981');
213
214 do_test('undef',
215         undef,
216 'SV = NULL\\(0x0\\) at $ADDR
217   REFCNT = \d+
218   FLAGS = \\(READONLY\\)');
219
220 do_test('reference to scalar',
221         \$a,
222 'SV = $RV\\($ADDR\\) at $ADDR
223   REFCNT = 1
224   FLAGS = \\(ROK\\)
225   RV = $ADDR
226   SV = PV\\($ADDR\\) at $ADDR
227     REFCNT = 2
228     FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
229     PV = $ADDR "foo"\\\0
230     CUR = 3
231     LEN = \\d+
232     COW_REFCNT = 1
233 ');
234
235 my $c_pattern;
236 if ($type eq 'N') {
237   $c_pattern = '
238     SV = PVNV\\($ADDR\\) at $ADDR
239       REFCNT = 1
240       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
241       IV = 456
242       NV = 456
243       PV = 0';
244 } else {
245   $c_pattern = '
246     SV = IV\\($ADDR\\) at $ADDR
247       REFCNT = 1
248       FLAGS = \\(IOK,pIOK\\)
249       IV = 456';
250 }
251 do_test('reference to array',
252        [$b,$c],
253 'SV = $RV\\($ADDR\\) at $ADDR
254   REFCNT = 1
255   FLAGS = \\(ROK\\)
256   RV = $ADDR
257   SV = PVAV\\($ADDR\\) at $ADDR
258     REFCNT = 1
259     FLAGS = \\(\\)
260     IV = 0                                      # $] < 5.009
261     NV = 0                                      # $] < 5.009
262     ARRAY = $ADDR
263     FILL = 1
264     MAX = 1
265     ARYLEN = 0x0
266     FLAGS = \\(REAL\\)
267     Elt No. 0
268     SV = IV\\($ADDR\\) at $ADDR
269       REFCNT = 1
270       FLAGS = \\(IOK,pIOK\\)
271       IV = 123
272     Elt No. 1' . $c_pattern);
273
274 do_test('reference to hash',
275        {$b=>$c},
276 'SV = $RV\\($ADDR\\) at $ADDR
277   REFCNT = 1
278   FLAGS = \\(ROK\\)
279   RV = $ADDR
280   SV = PVHV\\($ADDR\\) at $ADDR
281     REFCNT = [12]
282     FLAGS = \\(SHAREKEYS\\)
283     IV = 1                                      # $] < 5.009
284     NV = $FLOAT                                 # $] < 5.009
285     ARRAY = $ADDR  \\(0:7, 1:1\\)
286     hash quality = 100.0%
287     KEYS = 1
288     FILL = 1
289     MAX = 7
290     Elt "123" HASH = $ADDR' . $c_pattern,
291         '',
292         $] > 5.009 && $] < 5.015
293          && 'The hash iterator used in dump.c sets the OOK flag');
294
295 do_test('reference to anon sub with empty prototype',
296         sub(){@_},
297 'SV = $RV\\($ADDR\\) at $ADDR
298   REFCNT = 1
299   FLAGS = \\(ROK\\)
300   RV = $ADDR
301   SV = PVCV\\($ADDR\\) at $ADDR
302     REFCNT = 2
303     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
304     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
305     IV = 0                                      # $] < 5.009
306     NV = 0                                      # $] < 5.009
307     PROTOTYPE = ""
308     COMP_STASH = $ADDR\\t"main"
309     START = $ADDR ===> \\d+
310     ROOT = $ADDR
311     XSUB = 0x0                                  # $] < 5.009
312     XSUBANY = 0                                 # $] < 5.009
313     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
314     FILE = ".*\\b(?i:peek\\.t)"
315     DEPTH = 0(?:
316     MUTEXP = $ADDR
317     OWNER = $ADDR)?
318     FLAGS = 0x404                               # $] < 5.009
319     FLAGS = 0x490               # $] >= 5.009 && ($] < 5.015 || !thr)
320     FLAGS = 0x1490                              # $] >= 5.015 && thr
321     OUTSIDE_SEQ = \\d+
322     PADLIST = $ADDR
323     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
324     OUTSIDE = $ADDR \\(MAIN\\)');
325
326 do_test('reference to named subroutine without prototype',
327         \&do_test,
328 'SV = $RV\\($ADDR\\) at $ADDR
329   REFCNT = 1
330   FLAGS = \\(ROK\\)
331   RV = $ADDR
332   SV = PVCV\\($ADDR\\) at $ADDR
333     REFCNT = (3|4)
334     FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\)       # $] < 5.015 || !thr
335     FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
336     IV = 0                                      # $] < 5.009
337     NV = 0                                      # $] < 5.009
338     COMP_STASH = $ADDR\\t"main"
339     START = $ADDR ===> \\d+
340     ROOT = $ADDR
341     XSUB = 0x0                                  # $] < 5.009
342     XSUBANY = 0                                 # $] < 5.009
343     NAME = "do_test"                            # $] >=5.021004
344     GVGV::GV = $ADDR\\t"main" :: "do_test"      # $] < 5.021004
345     FILE = ".*\\b(?i:peek\\.t)"
346     DEPTH = 1(?:
347     MUTEXP = $ADDR
348     OWNER = $ADDR)?
349     FLAGS = 0x(?:[c4]00)?0                      # $] < 5.015 || !thr
350     FLAGS = 0x[cd145]000                        # $] >= 5.015 && thr
351     OUTSIDE_SEQ = \\d+
352     PADLIST = $ADDR
353     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
354        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
355        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
356        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
357        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
358       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
359       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
360       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
361       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
362       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
363     OUTSIDE = $ADDR \\(MAIN\\)');
364
365 if ($] >= 5.011) {
366 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
367 do_test('reference to regexp',
368         qr(tic),
369 'SV = $RV\\($ADDR\\) at $ADDR
370   REFCNT = 1
371   FLAGS = \\(ROK\\)
372   RV = $ADDR
373   SV = REGEXP\\($ADDR\\) at $ADDR
374     REFCNT = 1
375     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)          # $] < 5.017006
376     FLAGS = \\(OBJECT,FAKE\\)                   # $] >= 5.017006
377     PV = $ADDR "\\(\\?\\^:tic\\)"
378     CUR = 8
379     LEN = 0                                     # $] < 5.017006
380     STASH = $ADDR\\t"Regexp"'
381 . ($] < 5.013 ? '' :
382 '
383     COMPFLAGS = 0x0 \(\)
384     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
385 (?:    ENGINE = $ADDR \(STANDARD\)
386 )?    INTFLAGS = 0x0(?: \(\))?
387     NPARENS = 0
388     LASTPAREN = 0
389     LASTCLOSEPAREN = 0
390     MINLEN = 3
391     MINLENRET = 3
392     GOFS = 0
393     PRE_PREFIX = 4
394     SUBLEN = 0
395     SUBOFFSET = 0
396     SUBCOFFSET = 0
397     SUBBEG = 0x0
398 (?:    ENGINE = $ADDR
399 )?    MOTHER_RE = $ADDR'
400 . ($] < 5.019003 ? '' : '
401     SV = REGEXP\($ADDR\) at $ADDR
402       REFCNT = 2
403       FLAGS = \(\)
404       PV = $ADDR "\(\?\^:tic\)"
405       CUR = 8
406       COMPFLAGS = 0x0 \(\)
407       EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
408 (?:      ENGINE = $ADDR \(STANDARD\)
409 )?      INTFLAGS = 0x0(?: \(\))?
410       NPARENS = 0
411       LASTPAREN = 0
412       LASTCLOSEPAREN = 0
413       MINLEN = 3
414       MINLENRET = 3
415       GOFS = 0
416       PRE_PREFIX = 4
417       SUBLEN = 0
418       SUBOFFSET = 0
419       SUBCOFFSET = 0
420       SUBBEG = 0x0
421 (?:    ENGINE = $ADDR
422 )?      MOTHER_RE = 0x0
423       PAREN_NAMES = 0x0
424       SUBSTRS = $ADDR
425       PPRIVATE = $ADDR
426       OFFS = $ADDR
427       QR_ANONCV = 0x0(?:
428       SAVED_COPY = 0x0)?') . '
429     PAREN_NAMES = 0x0
430     SUBSTRS = $ADDR
431     PPRIVATE = $ADDR
432     OFFS = $ADDR
433     QR_ANONCV = 0x0(?:
434     SAVED_COPY = 0x0)?'
435 ));
436 } else {
437 do_test('reference to regexp',
438         qr(tic),
439 'SV = $RV\\($ADDR\\) at $ADDR
440   REFCNT = 1
441   FLAGS = \\(ROK\\)
442   RV = $ADDR
443   SV = PVMG\\($ADDR\\) at $ADDR
444     REFCNT = 1
445     FLAGS = \\(OBJECT,SMG\\)
446     IV = 0
447     NV = 0
448     PV = 0
449     MAGIC = $ADDR
450       MG_VIRTUAL = $ADDR
451       MG_TYPE = PERL_MAGIC_qr\(r\)
452       MG_OBJ = $ADDR
453         PAT = "\(\?^:tic\)"                     # $] >= 5.009
454         REFCNT = 2                              # $] >= 5.009
455     STASH = $ADDR\\t"Regexp"');
456 }
457
458 do_test('reference to blessed hash',
459         (bless {}, "Tac"),
460 'SV = $RV\\($ADDR\\) at $ADDR
461   REFCNT = 1
462   FLAGS = \\(ROK\\)
463   RV = $ADDR
464   SV = PVHV\\($ADDR\\) at $ADDR
465     REFCNT = [12]
466     FLAGS = \\(OBJECT,SHAREKEYS\\)
467     IV = 0                                      # $] < 5.009
468     NV = 0                                      # $] < 5.009
469     STASH = $ADDR\\t"Tac"
470     ARRAY = 0x0
471     KEYS = 0
472     FILL = 0
473     MAX = 7', '',
474         $] > 5.009
475         ? $] >= 5.015
476              ? 0
477              : 'The hash iterator used in dump.c sets the OOK flag'
478         : "Something causes the HV's array to become allocated");
479
480 do_test('typeglob',
481         *a,
482 'SV = PVGV\\($ADDR\\) at $ADDR
483   REFCNT = 5
484   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
485   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
486   IV = 0                                        # $] < 5.009
487   NV = 0                                        # $] < 5.009
488   PV = 0                                        # $] < 5.009
489   MAGIC = $ADDR                                 # $] < 5.009
490     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
491     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
492     MG_OBJ = $ADDR                              # $] < 5.009
493   NAME = "a"
494   NAMELEN = 1
495   GvSTASH = $ADDR\\t"main"
496   FLAGS = $ADDR                                 # $] >=5.021004
497   GP = $ADDR
498     SV = $ADDR
499     REFCNT = 1
500     IO = 0x0
501     FORM = 0x0  
502     AV = 0x0
503     HV = 0x0
504     CV = 0x0
505     CVGEN = 0x0
506     GPFLAGS = 0x0                               # $] < 5.009
507     LINE = \\d+
508     FILE = ".*\\b(?i:peek\\.t)"
509     FLAGS = $ADDR                               # $] < 5.021004
510     EGV = $ADDR\\t"a"');
511
512 if (ord('A') == 193) {
513 do_test('string with Unicode',
514         chr(256).chr(0).chr(512),
515 'SV = PV\\($ADDR\\) at $ADDR
516   REFCNT = 1
517   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
518   FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)   # $] >=5.019003
519   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
520   CUR = 5
521   LEN = \\d+
522   COW_REFCNT = 1                                        # $] < 5.019007
523 ');
524 } else {
525 do_test('string with Unicode',
526         chr(256).chr(0).chr(512),
527 'SV = PV\\($ADDR\\) at $ADDR
528   REFCNT = 1
529   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
530   FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)   # $] >=5.019003
531   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
532   CUR = 5
533   LEN = \\d+
534   COW_REFCNT = 1                                        # $] < 5.019007
535 ');
536 }
537
538 if (ord('A') == 193) {
539 do_test('reference to hash containing Unicode',
540         {chr(256)=>chr(512)},
541 'SV = $RV\\($ADDR\\) at $ADDR
542   REFCNT = 1
543   FLAGS = \\(ROK\\)
544   RV = $ADDR
545   SV = PVHV\\($ADDR\\) at $ADDR
546     REFCNT = [12]
547     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
548     UV = 1                                      # $] < 5.009
549     NV = $FLOAT                                 # $] < 5.009
550     ARRAY = $ADDR  \\(0:7, 1:1\\)
551     hash quality = 100.0%
552     KEYS = 1
553     FILL = 1
554     MAX = 7
555     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
556     SV = PV\\($ADDR\\) at $ADDR
557       REFCNT = 1
558       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
559       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
560       CUR = 2
561       LEN = \\d+
562       COW_REFCNT = 1                            # $] < 5.019007
563 ',      '',
564         $] > 5.009
565         ? $] >= 5.015
566             ?  0
567             : 'The hash iterator used in dump.c sets the OOK flag'
568         : 'sv_length has been called on the element, and cached the result in MAGIC');
569 } else {
570 do_test('reference to hash containing Unicode',
571         {chr(256)=>chr(512)},
572 'SV = $RV\\($ADDR\\) at $ADDR
573   REFCNT = 1
574   FLAGS = \\(ROK\\)
575   RV = $ADDR
576   SV = PVHV\\($ADDR\\) at $ADDR
577     REFCNT = [12]
578     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
579     UV = 1                                      # $] < 5.009
580     NV = 0                                      # $] < 5.009
581     ARRAY = $ADDR  \\(0:7, 1:1\\)
582     hash quality = 100.0%
583     KEYS = 1
584     FILL = 1
585     MAX = 7
586     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
587     SV = PV\\($ADDR\\) at $ADDR
588       REFCNT = 1
589       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
590       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
591       CUR = 2
592       LEN = \\d+
593       COW_REFCNT = 1                            # $] < 5.019007
594 ',      '',
595         $] > 5.009
596         ? $] >= 5.015
597             ?  0
598             : 'The hash iterator used in dump.c sets the OOK flag'
599         : 'sv_length has been called on the element, and cached the result in MAGIC');
600 }
601
602 my $x="";
603 $x=~/.??/g;
604 do_test('scalar with pos magic',
605         $x,
606 'SV = PVMG\\($ADDR\\) at $ADDR
607   REFCNT = 1
608   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
609   IV = \d+
610   NV = 0
611   PV = $ADDR ""\\\0
612   CUR = 0
613   LEN = \d+
614   COW_REFCNT = [12]
615   MAGIC = $ADDR
616     MG_VIRTUAL = &PL_vtbl_mglob
617     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
618     MG_FLAGS = 0x01                                     # $] < 5.019003
619     MG_FLAGS = 0x41                                     # $] >=5.019003
620       MINMATCH
621       BYTES                                             # $] >=5.019003
622 ');
623
624 #
625 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
626 # environment variables may be invisibly case-forced, hence the (?i:PATH)
627 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
628 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
629 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
630 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
631 # ENV hashes is also not always null terminated.
632 #
633 if (${^TAINT}) {
634   # Save and restore PATH, since fresh_perl ends up using that in Windows.
635   my $path = $ENV{PATH};
636   do_test('tainted value in %ENV',
637           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
638 'SV = PVMG\\($ADDR\\) at $ADDR
639   REFCNT = 1
640   FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
641   IV = 0
642   NV = 0
643   PV = $ADDR "0"\\\0
644   CUR = 1
645   LEN = \d+
646   MAGIC = $ADDR
647     MG_VIRTUAL = &PL_vtbl_envelem
648     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
649 (?:    MG_FLAGS = 0x01
650       TAINTEDDIR
651 )?    MG_LEN = -?\d+
652     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
653     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
654       REFCNT = \d+
655       FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
656 (?:      IV = 0
657 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
658       CUR = \d+
659       LEN = \d+)
660   MAGIC = $ADDR
661     MG_VIRTUAL = &PL_vtbl_taint
662     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
663     $ENV{PATH} = $path;
664 }
665
666 do_test('blessed reference',
667         bless(\\undef, 'Foobar'),
668 'SV = $RV\\($ADDR\\) at $ADDR
669   REFCNT = 1
670   FLAGS = \\(ROK\\)
671   RV = $ADDR
672   SV = PVMG\\($ADDR\\) at $ADDR
673     REFCNT = 2
674     FLAGS = \\(OBJECT,ROK\\)
675     IV = -?\d+
676     NV = $FLOAT
677     RV = $ADDR
678     SV = NULL\\(0x0\\) at $ADDR
679       REFCNT = \d+
680       FLAGS = \\(READONLY\\)
681     PV = $ADDR ""
682     CUR = 0
683     LEN = 0
684     STASH = $ADDR\s+"Foobar"');
685
686 sub const () {
687     "Perl rules";
688 }
689
690 do_test('constant subroutine',
691         \&const,
692 'SV = $RV\\($ADDR\\) at $ADDR
693   REFCNT = 1
694   FLAGS = \\(ROK\\)
695   RV = $ADDR
696   SV = PVCV\\($ADDR\\) at $ADDR
697     REFCNT = (2)
698     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)         # $] < 5.015
699     FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
700     IV = 0                                      # $] < 5.009
701     NV = 0                                      # $] < 5.009
702     PROTOTYPE = ""
703     COMP_STASH = 0x0                            # $] < 5.021004
704     COMP_STASH = $ADDR  "main"                  # $] >=5.021004
705     ROOT = 0x0                                  # $] < 5.009
706     XSUB = $ADDR
707     XSUBANY = $ADDR \\(CONST SV\\)
708     SV = PV\\($ADDR\\) at $ADDR
709       REFCNT = 1
710       FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
711       PV = $ADDR "Perl rules"\\\0
712       CUR = 10
713       LEN = \\d+
714       COW_REFCNT = 0
715     GVGV::GV = $ADDR\\t"main" :: "const"
716     FILE = ".*\\b(?i:peek\\.t)"
717     DEPTH = 0(?:
718     MUTEXP = $ADDR
719     OWNER = $ADDR)?
720     FLAGS = 0x200                               # $] < 5.009
721     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
722     FLAGS = 0xc                                 # $] >= 5.013 && $] < 5.015
723     FLAGS = 0x100c                              # $] >= 5.015
724     OUTSIDE_SEQ = 0
725     PADLIST = 0x0
726     OUTSIDE = 0x0 \\(null\\)'); 
727
728 do_test('isUV should show on PVMG',
729         do { my $v = $1; $v = ~0; $v },
730 'SV = PVMG\\($ADDR\\) at $ADDR
731   REFCNT = 1
732   FLAGS = \\(IOK,pIOK,IsUV\\)
733   UV = \d+
734   NV = 0
735   PV = 0');
736
737 do_test('IO',
738         *STDOUT{IO},
739 'SV = $RV\\($ADDR\\) at $ADDR
740   REFCNT = 1
741   FLAGS = \\(ROK\\)
742   RV = $ADDR
743   SV = PVIO\\($ADDR\\) at $ADDR
744     REFCNT = 3
745     FLAGS = \\(OBJECT\\)
746     IV = 0                                      # $] < 5.011
747     NV = 0                                      # $] < 5.011
748     STASH = $ADDR\s+"IO::File"
749     IFP = $ADDR
750     OFP = $ADDR
751     DIRP = 0x0
752     LINES = 0
753     PAGE = 0
754     PAGE_LEN = 60
755     LINES_LEFT = 0
756     TOP_GV = 0x0
757     FMT_GV = 0x0
758     BOTTOM_GV = 0x0
759     SUBPROCESS = 0                              # $] < 5.009
760     TYPE = \'>\'
761     FLAGS = 0x4');
762
763 do_test('FORMAT',
764         *PIE{FORMAT},
765 'SV = $RV\\($ADDR\\) at $ADDR
766   REFCNT = 1
767   FLAGS = \\(ROK\\)
768   RV = $ADDR
769   SV = PVFM\\($ADDR\\) at $ADDR
770     REFCNT = 2
771     FLAGS = \\(\\)                              # $] < 5.015 || !thr
772     FLAGS = \\(DYNFILE\\)                       # $] >= 5.015 && thr
773     IV = 0                                      # $] < 5.009
774     NV = 0                                      # $] < 5.009
775 (?:    PV = 0
776 )?    COMP_STASH = 0x0
777     START = $ADDR ===> \\d+
778     ROOT = $ADDR
779     XSUB = 0x0                                  # $] < 5.009
780     XSUBANY = 0                                 # $] < 5.009
781     GVGV::GV = $ADDR\\t"main" :: "PIE"
782     FILE = ".*\\b(?i:peek\\.t)"(?:
783     DEPTH = 0)?(?:
784     MUTEXP = $ADDR
785     OWNER = $ADDR)?
786     FLAGS = 0x0                                 # $] < 5.015 || !thr
787     FLAGS = 0x1000                              # $] >= 5.015 && thr
788     OUTSIDE_SEQ = \\d+
789     LINES = 0                                   # $] < 5.017_003
790     PADLIST = $ADDR
791     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
792     OUTSIDE = $ADDR \\(MAIN\\)');
793
794 do_test('blessing to a class with embedded NUL characters',
795         (bless {}, "\0::foo::\n::baz::\t::\0"),
796 'SV = $RV\\($ADDR\\) at $ADDR
797   REFCNT = 1
798   FLAGS = \\(ROK\\)
799   RV = $ADDR
800   SV = PVHV\\($ADDR\\) at $ADDR
801     REFCNT = [12]
802     FLAGS = \\(OBJECT,SHAREKEYS\\)
803     IV = 0                                      # $] < 5.009
804     NV = 0                                      # $] < 5.009
805     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
806     ARRAY = $ADDR
807     KEYS = 0
808     FILL = 0
809     MAX = 7', '',
810         $] > 5.009
811         ? $] >= 5.015
812             ?  0
813             : 'The hash iterator used in dump.c sets the OOK flag'
814         : "Something causes the HV's array to become allocated");
815
816 do_test('ENAME on a stash',
817         \%RWOM::,
818 'SV = $RV\\($ADDR\\) at $ADDR
819   REFCNT = 1
820   FLAGS = \\(ROK\\)
821   RV = $ADDR
822   SV = PVHV\\($ADDR\\) at $ADDR
823     REFCNT = 2
824     FLAGS = \\(OOK,SHAREKEYS\\)
825     IV = 1                                      # $] < 5.009
826     NV = $FLOAT                                 # $] < 5.009
827     AUX_FLAGS = 0                               # $] > 5.019008
828     ARRAY = $ADDR
829     KEYS = 0
830     FILL = 0 \(cached = 0\)
831     MAX = 7
832     RITER = -1
833     EITER = 0x0
834     RAND = $ADDR
835     NAME = "RWOM"
836     ENAME = "RWOM"                              # $] > 5.012
837 ');
838
839 *KLANK:: = \%RWOM::;
840
841 do_test('ENAMEs on a stash',
842         \%RWOM::,
843 'SV = $RV\\($ADDR\\) at $ADDR
844   REFCNT = 1
845   FLAGS = \\(ROK\\)
846   RV = $ADDR
847   SV = PVHV\\($ADDR\\) at $ADDR
848     REFCNT = 3
849     FLAGS = \\(OOK,SHAREKEYS\\)
850     IV = 1                                      # $] < 5.009
851     NV = $FLOAT                                 # $] < 5.009
852     AUX_FLAGS = 0                               # $] > 5.019008
853     ARRAY = $ADDR
854     KEYS = 0
855     FILL = 0 \(cached = 0\)
856     MAX = 7
857     RITER = -1
858     EITER = 0x0
859     RAND = $ADDR
860     NAME = "RWOM"
861     NAMECOUNT = 2                               # $] > 5.012
862     ENAME = "RWOM", "KLANK"                     # $] > 5.012
863 ');
864
865 undef %RWOM::;
866
867 do_test('ENAMEs on a stash with no NAME',
868         \%RWOM::,
869 'SV = $RV\\($ADDR\\) at $ADDR
870   REFCNT = 1
871   FLAGS = \\(ROK\\)
872   RV = $ADDR
873   SV = PVHV\\($ADDR\\) at $ADDR
874     REFCNT = 3
875     FLAGS = \\(OOK,SHAREKEYS\\)                 # $] < 5.017
876     FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\)        # $] >=5.017
877     IV = 1                                      # $] < 5.009
878     NV = $FLOAT                                 # $] < 5.009
879     AUX_FLAGS = 0                               # $] > 5.019008
880     ARRAY = $ADDR
881     KEYS = 0
882     FILL = 0 \(cached = 0\)
883     MAX = 7
884     RITER = -1
885     EITER = 0x0
886     RAND = $ADDR
887     NAMECOUNT = -3                              # $] > 5.012
888     ENAME = "RWOM", "KLANK"                     # $] > 5.012
889 ');
890
891 my %small = ("Perl", "Rules", "Beer", "Foamy");
892 my $b = %small;
893 do_test('small hash',
894         \%small,
895 'SV = $RV\\($ADDR\\) at $ADDR
896   REFCNT = 1
897   FLAGS = \\(ROK\\)
898   RV = $ADDR
899   SV = PVHV\\($ADDR\\) at $ADDR
900     REFCNT = 2
901     FLAGS = \\(PADMY,SHAREKEYS\\)
902     IV = 1                                      # $] < 5.009
903     NV = $FLOAT                                 # $] < 5.009
904     ARRAY = $ADDR  \\(0:[67],.*\\)
905     hash quality = [0-9.]+%
906     KEYS = 2
907     FILL = [12]
908     MAX = 7
909 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
910     SV = PV\\($ADDR\\) at $ADDR
911       REFCNT = 1
912       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
913       PV = $ADDR "(?:Rules|Foamy)"\\\0
914       CUR = \d+
915       LEN = \d+
916       COW_REFCNT = 1
917 ){2}');
918
919 $b = keys %small;
920
921 do_test('small hash after keys',
922         \%small,
923 'SV = $RV\\($ADDR\\) at $ADDR
924   REFCNT = 1
925   FLAGS = \\(ROK\\)
926   RV = $ADDR
927   SV = PVHV\\($ADDR\\) at $ADDR
928     REFCNT = 2
929     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
930     IV = 1                                      # $] < 5.009
931     NV = $FLOAT                                 # $] < 5.009
932     AUX_FLAGS = 0                               # $] > 5.019008
933     ARRAY = $ADDR  \\(0:[67],.*\\)
934     hash quality = [0-9.]+%
935     KEYS = 2
936     FILL = [12] \\(cached = 0\\)
937     MAX = 7
938     RITER = -1
939     EITER = 0x0
940     RAND = $ADDR
941 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
942     SV = PV\\($ADDR\\) at $ADDR
943       REFCNT = 1
944       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
945       PV = $ADDR "(?:Rules|Foamy)"\\\0
946       CUR = \d+
947       LEN = \d+
948       COW_REFCNT = 1
949 ){2}');
950
951 $b = %small;
952
953 do_test('small hash after keys and scalar',
954         \%small,
955 'SV = $RV\\($ADDR\\) at $ADDR
956   REFCNT = 1
957   FLAGS = \\(ROK\\)
958   RV = $ADDR
959   SV = PVHV\\($ADDR\\) at $ADDR
960     REFCNT = 2
961     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
962     IV = 1                                      # $] < 5.009
963     NV = $FLOAT                                 # $] < 5.009
964     AUX_FLAGS = 0                               # $] > 5.019008
965     ARRAY = $ADDR  \\(0:[67],.*\\)
966     hash quality = [0-9.]+%
967     KEYS = 2
968     FILL = ([12]) \\(cached = \1\\)
969     MAX = 7
970     RITER = -1
971     EITER = 0x0
972     RAND = $ADDR
973 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
974     SV = PV\\($ADDR\\) at $ADDR
975       REFCNT = 1
976       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
977       PV = $ADDR "(?:Rules|Foamy)"\\\0
978       CUR = \d+
979       LEN = \d+
980       COW_REFCNT = 1
981 ){2}');
982
983 # This should immediately start with the FILL cached correctly.
984 my %large = (0..1999);
985 $b = %large;
986 do_test('large hash',
987         \%large,
988 'SV = $RV\\($ADDR\\) at $ADDR
989   REFCNT = 1
990   FLAGS = \\(ROK\\)
991   RV = $ADDR
992   SV = PVHV\\($ADDR\\) at $ADDR
993     REFCNT = 2
994     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
995     IV = 1                                      # $] < 5.009
996     NV = $FLOAT                                 # $] < 5.009
997     AUX_FLAGS = 0                               # $] > 5.019008
998     ARRAY = $ADDR  \\(0:\d+,.*\\)
999     hash quality = \d+\\.\d+%
1000     KEYS = 1000
1001     FILL = (\d+) \\(cached = \1\\)
1002     MAX = 1023
1003     RITER = -1
1004     EITER = 0x0
1005     RAND = $ADDR
1006     Elt .*
1007 ');
1008
1009 # Dump with arrays, hashes, and operator return values
1010 @array = 1..3;
1011 do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
1012 SV = PVAV\($ADDR\) at $ADDR
1013   REFCNT = 1
1014   FLAGS = \(\)
1015   ARRAY = $ADDR
1016   FILL = 2
1017   MAX = 3
1018   ARYLEN = 0x0
1019   FLAGS = \(REAL\)
1020   Elt No. 0
1021   SV = IV\($ADDR\) at $ADDR
1022     REFCNT = 1
1023     FLAGS = \(IOK,pIOK\)
1024     IV = 1
1025   Elt No. 1
1026   SV = IV\($ADDR\) at $ADDR
1027     REFCNT = 1
1028     FLAGS = \(IOK,pIOK\)
1029     IV = 2
1030   Elt No. 2
1031   SV = IV\($ADDR\) at $ADDR
1032     REFCNT = 1
1033     FLAGS = \(IOK,pIOK\)
1034     IV = 3
1035 ARRAY
1036
1037 do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1);
1038 SV = PVAV\($ADDR\) at $ADDR
1039   REFCNT = 1
1040   FLAGS = \(\)
1041   ARRAY = $ADDR
1042   FILL = 2
1043   MAX = 3
1044   ARYLEN = 0x0
1045   FLAGS = \(REAL\)
1046   Elt No. 0
1047   SV = IV\($ADDR\) at $ADDR
1048     REFCNT = 1
1049     FLAGS = \(IOK,pIOK\)
1050     IV = 1
1051 ARRAY
1052
1053 %hash = 1..2;
1054 do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
1055 SV = PVHV\($ADDR\) at $ADDR
1056   REFCNT = 1
1057   FLAGS = \(SHAREKEYS\)
1058   ARRAY = $ADDR  \(0:7, 1:1\)
1059   hash quality = 100.0%
1060   KEYS = 1
1061   FILL = 1
1062   MAX = 7
1063   Elt "1" HASH = $ADDR
1064   SV = IV\($ADDR\) at $ADDR
1065     REFCNT = 1
1066     FLAGS = \(IOK,pIOK\)
1067     IV = 2
1068 HASH
1069
1070 $_ = "hello";
1071 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
1072 SV = PV\($ADDR\) at $ADDR
1073   REFCNT = 1
1074   FLAGS = \(PADTMP,POK,pPOK\)
1075   PV = $ADDR "el"\\0
1076   CUR = 2
1077   LEN = \d+
1078 SUBSTR
1079
1080 # Dump with no arguments
1081 eval 'Dump';
1082 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1083 eval 'Dump()';
1084 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1085
1086 SKIP: {
1087     skip "Not built with usemymalloc", 2
1088       unless $Config{usemymalloc} eq 'y';
1089     my $x = __PACKAGE__;
1090     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1091      or diag $@;
1092     my $y;
1093     ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1094 }
1095
1096 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1097 # prowess, but short of duplicating all the gubbins of this file, I can't see
1098 # a way to make a better place for it:
1099
1100 use constant {
1101     perl => 'rules',
1102     beer => 'foamy',
1103 };
1104
1105 unless ($Config{useithreads}) {
1106     # These end up as copies in pads under ithreads, which rather defeats the
1107     # the point of what we're trying to test here.
1108
1109     do_test('regular string constant', perl,
1110 'SV = PV\\($ADDR\\) at $ADDR
1111   REFCNT = 5
1112   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1113   PV = $ADDR "rules"\\\0
1114   CUR = 5
1115   LEN = \d+
1116   COW_REFCNT = 0
1117 ');
1118
1119     eval 'index "", perl';
1120
1121     # FIXME - really this shouldn't say EVALED. It's a false posistive on
1122     # 0x40000000 being used for several things, not a flag for "I'm in a string
1123     # eval"
1124
1125     do_test('string constant now an FBM', perl,
1126 'SV = PVMG\\($ADDR\\) at $ADDR
1127   REFCNT = 5
1128   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1129   PV = $ADDR "rules"\\\0
1130   CUR = 5
1131   LEN = \d+
1132   COW_REFCNT = 0
1133   MAGIC = $ADDR
1134     MG_VIRTUAL = &PL_vtbl_regexp
1135     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1136     MG_LEN = 256
1137     MG_PTR = $ADDR "(?:\\\\\d){256}"
1138   RARE = \d+                                    # $] < 5.019002
1139   PREVIOUS = 1                                  # $] < 5.019002
1140   USEFUL = 100
1141 ');
1142
1143     is(study perl, '', "Not allowed to study an FBM");
1144
1145     do_test('string constant still an FBM', perl,
1146 'SV = PVMG\\($ADDR\\) at $ADDR
1147   REFCNT = 5
1148   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1149   PV = $ADDR "rules"\\\0
1150   CUR = 5
1151   LEN = \d+
1152   COW_REFCNT = 0
1153   MAGIC = $ADDR
1154     MG_VIRTUAL = &PL_vtbl_regexp
1155     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1156     MG_LEN = 256
1157     MG_PTR = $ADDR "(?:\\\\\d){256}"
1158   RARE = \d+                                    # $] < 5.019002
1159   PREVIOUS = 1                                  # $] < 5.019002
1160   USEFUL = 100
1161 ');
1162
1163     do_test('regular string constant', beer,
1164 'SV = PV\\($ADDR\\) at $ADDR
1165   REFCNT = 6
1166   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1167   PV = $ADDR "foamy"\\\0
1168   CUR = 5
1169   LEN = \d+
1170   COW_REFCNT = 0
1171 ');
1172
1173     is(study beer, 1, "Our studies were successful");
1174
1175     do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1176   REFCNT = 6
1177   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1178   PV = $ADDR "foamy"\\\0
1179   CUR = 5
1180   LEN = \d+
1181   COW_REFCNT = 0
1182 ');
1183
1184     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1185   REFCNT = 6
1186   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1187   PV = $ADDR "foamy"\\\0
1188   CUR = 5
1189   LEN = \d+
1190   COW_REFCNT = 0
1191   MAGIC = $ADDR
1192     MG_VIRTUAL = &PL_vtbl_regexp
1193     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1194     MG_LEN = 256
1195     MG_PTR = $ADDR "(?:\\\\\d){256}"
1196   RARE = \d+                                    # $] < 5.019002
1197   PREVIOUS = \d+                                # $] < 5.019002
1198   USEFUL = 100
1199 ';
1200
1201     is (eval 'index "not too foamy", beer', 8, 'correct index');
1202
1203     do_test('string constant now FBMed', beer, $want);
1204
1205     my $pie = 'good';
1206
1207     is(study $pie, 1, "Our studies were successful");
1208
1209     do_test('string constant still FBMed', beer, $want);
1210
1211     do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1212   REFCNT = 1
1213   FLAGS = \\(PADMY,POK,(?:IsCOW,)?pPOK\\)
1214   PV = $ADDR "good"\\\0
1215   CUR = 4
1216   LEN = \d+
1217   COW_REFCNT = 1
1218 ');
1219 }
1220
1221 # (One block of study tests removed when study was made a no-op.)
1222
1223 {
1224     open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1225     open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1226     DeadCode();
1227     open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1228     pass "no crash with DeadCode";
1229     close OUT;
1230 }
1231 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
1232 do_test('UTF-8 in a regular expression',
1233         qr/\x{100}/,
1234 'SV = IV\($ADDR\) at $ADDR
1235   REFCNT = 1
1236   FLAGS = \(ROK\)
1237   RV = $ADDR
1238   SV = REGEXP\($ADDR\) at $ADDR
1239     REFCNT = 1
1240     FLAGS = \(OBJECT,FAKE,UTF8\)
1241     PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1242     CUR = 13
1243     STASH = $ADDR       "Regexp"
1244     COMPFLAGS = 0x0 \(\)
1245     EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1246 (?:    ENGINE = $ADDR \(STANDARD\)
1247 )?    INTFLAGS = 0x0(?: \(\))?
1248     NPARENS = 0
1249     LASTPAREN = 0
1250     LASTCLOSEPAREN = 0
1251     MINLEN = 1
1252     MINLENRET = 1
1253     GOFS = 0
1254     PRE_PREFIX = 5
1255     SUBLEN = 0
1256     SUBOFFSET = 0
1257     SUBCOFFSET = 0
1258     SUBBEG = 0x0
1259 (?:    ENGINE = $ADDR
1260 )?    MOTHER_RE = $ADDR'
1261 . ($] < 5.019003 ? '' : '
1262     SV = REGEXP\($ADDR\) at $ADDR
1263       REFCNT = 2
1264       FLAGS = \(UTF8\)
1265       PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1266       CUR = 13
1267       COMPFLAGS = 0x0 \(\)
1268       EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1269 (?:      ENGINE = $ADDR \(STANDARD\)
1270 )?      INTFLAGS = 0x0(?: \(\))?
1271       NPARENS = 0
1272       LASTPAREN = 0
1273       LASTCLOSEPAREN = 0
1274       MINLEN = 1
1275       MINLENRET = 1
1276       GOFS = 0
1277       PRE_PREFIX = 5
1278       SUBLEN = 0
1279       SUBOFFSET = 0
1280       SUBCOFFSET = 0
1281       SUBBEG = 0x0
1282 (?:    ENGINE = $ADDR
1283 )?      MOTHER_RE = 0x0
1284       PAREN_NAMES = 0x0
1285       SUBSTRS = $ADDR
1286       PPRIVATE = $ADDR
1287       OFFS = $ADDR
1288       QR_ANONCV = 0x0(?:
1289       SAVED_COPY = 0x0)?') . '
1290     PAREN_NAMES = 0x0
1291     SUBSTRS = $ADDR
1292     PPRIVATE = $ADDR
1293     OFFS = $ADDR
1294     QR_ANONCV = 0x0(?:
1295     SAVED_COPY = 0x0)?
1296 ');
1297
1298 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1299   my %hash;
1300   my $base_count = Devel::Peek::SvREFCNT(%hash);
1301   my $ref = \%hash;
1302   is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1303   ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
1304 }
1305 {
1306 # utf8 tests
1307 use utf8;
1308
1309 sub _dump {
1310    open(OUT,">peek$$") or die $!;
1311    open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1312    Dump($_[0]);
1313    open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1314    close(OUT);
1315    open(IN, "peek$$") or die $!;
1316    my $dump = do { local $/; <IN> };
1317    close(IN);
1318    1 while unlink "peek$$";
1319    return $dump;
1320 }
1321
1322 sub _get_coderef {
1323    my $x = $_[0];
1324    utf8::upgrade($x);
1325    eval "sub $x {}; 1" or die $@;
1326    return *{$x}{CODE};
1327 }
1328
1329 like(
1330    _dump(_get_coderef("\x{df}::\xdf")),
1331    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1332    "GVGV's are correctly escaped for latin1 :: latin1",
1333 );
1334
1335 like(
1336    _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1337    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1338    "GVGV's are correctly escaped for UTF8 :: UTF8",
1339 );
1340
1341 like(
1342    _dump(_get_coderef("\x{df}::\x{30cd}")),
1343    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1344    "GVGV's are correctly escaped for latin1 :: UTF8",
1345 );
1346
1347 like(
1348    _dump(_get_coderef("\x{30cd}::\x{df}")),
1349    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1350    "GVGV's are correctly escaped for UTF8 :: latin1",
1351 );
1352
1353 like(
1354    _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1355    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1356    "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1357 );
1358
1359 my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1360
1361 like(
1362    $dump,
1363    qr/NAME = \Q"\x{30dc}"/,
1364    "NAME is correctly escaped for UTF8 globs",
1365 );
1366
1367 like(
1368    $dump,
1369    qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1370    "GvSTASH is correctly escaped for UTF8 globs"
1371 );
1372
1373 like(
1374    $dump,
1375    qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1376    "EGV is correctly escaped for UTF8 globs"
1377 );
1378
1379 $dump = _dump(*{"\x{df}::\x{30cc}"});
1380
1381 like(
1382    $dump,
1383    qr/NAME = \Q"\x{30cc}"/,
1384    "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1385 );
1386
1387 like(
1388    $dump,
1389    qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1390    "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1391 );
1392
1393 like(
1394    $dump,
1395    qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1396    "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1397 );
1398
1399 like(
1400    _dump(bless {}, "\0::\1::\x{30cd}"),
1401    qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1402    "STASH for blessed hashrefs is correct"
1403 );
1404
1405 BEGIN { $::{doof} = "\0\1\x{30cd}" }
1406 like(
1407    _dump(\&doof),
1408    qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1409    "PROTOTYPE is escaped correctly"
1410 );
1411
1412 {
1413     my $coderef = eval <<"EOP";
1414     use feature 'lexical_subs';
1415     no warnings 'experimental::lexical_subs';
1416     my sub bar (\$\x{30cd}) {1}; \\&bar
1417 EOP
1418     like(
1419        _dump($coderef),
1420        qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1421        "PROTOTYPE works on lexical subs"
1422     )
1423 }
1424
1425 sub get_outside {
1426    eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
1427 }
1428 sub basic { my $x; return eval q{sub { eval q{$x} }} }
1429 like(
1430     _dump(basic()),
1431     qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1432     'OUTSIDE works'
1433 );
1434
1435 like(
1436     _dump(get_outside("\x{30ce}")),
1437     qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1438     'OUTSIDE + UTF8 works'
1439 );
1440
1441 # TODO AUTOLOAD = stashname, which requires using a XS autoload
1442 # and calling Dump() on the cv
1443
1444
1445
1446 sub test_utf8_stashes {
1447    my ($stash_name, $test) = @_;
1448
1449    $dump = _dump(\%{"${stash_name}::"});
1450
1451    my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1452    $escaped_stash_name = join "", map {
1453          $_ eq ':' ? $_ : sprintf $format, ord $_
1454    } split //, $stash_name;
1455
1456    like(
1457       $dump,
1458       qr/\QNAME = "$escaped_stash_name"/,
1459       "NAME is correct escaped for $test"
1460    );
1461
1462    like(
1463       $dump,
1464       qr/\QENAME = "$escaped_stash_name"/,
1465       "ENAME is correct escaped for $test"
1466    );
1467 }
1468
1469 for my $test (
1470   [ "\x{30cd}", "UTF8 stashes" ],
1471    [ "\x{df}", "latin 1 stashes" ],
1472    [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1473    [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1474 ) {
1475    test_utf8_stashes(@$test);
1476 }
1477
1478 }
1479
1480 my $runperl_args = { switches => ['-Ilib'] };
1481 sub test_DumpProg {
1482     my ($prog, $expected, $name, $test) = @_;
1483     $test ||= 'like';
1484
1485     my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1486
1487     # Interface between Test::Builder & test.pl
1488     my $builder = Test::More->builder();
1489     t::curr_test($builder->current_test() + 1);
1490
1491     utf8::encode($prog);
1492     
1493     if ( $test eq 'is' ) {
1494         t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
1495     }
1496     else {
1497         t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
1498     }
1499
1500     $builder->current_test(t::curr_test() - 1);
1501 }
1502
1503 my $threads = $Config{'useithreads'};
1504
1505 for my $test (
1506 [
1507     "package test;",
1508     qr/PACKAGE = "test"/,
1509     "DumpProg() + package declaration"
1510 ],
1511 [
1512     "use utf8; package \x{30cd};",
1513     qr/PACKAGE = "\\x\Q{30cd}"/,
1514     "DumpProg() + UTF8 package declaration"
1515 ],
1516 [
1517     "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1518     ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1519 ],
1520 [
1521     "use utf8; \x{30cc}: { last \x{30cc} }",
1522     qr/LABEL = \Q"\x{30cc}"/
1523 ],
1524 )
1525 {
1526    test_DumpProg(@$test);
1527 }
1528
1529 my $e = <<'EODUMP';
1530 dumpindent is 4 at - line 1.
1531 {
1532 1   TYPE = leave  ===> NULL
1533     TARG = 1
1534     FLAGS = (VOID,KIDS,PARENS,SLABBED,LASTSIB)
1535     PRIVATE = (REFC)
1536     REFCNT = 1
1537     {
1538 2       TYPE = enter  ===> 3
1539         FLAGS = (UNKNOWN,SLABBED)
1540     }
1541     {
1542 3       TYPE = nextstate  ===> 4
1543         FLAGS = (VOID,SLABBED)
1544         LINE = 1
1545         PACKAGE = "t"
1546     }
1547     {
1548 5       TYPE = entersub  ===> 1
1549         TARG = 1
1550         FLAGS = (VOID,KIDS,STACKED,SLABBED,LASTSIB)
1551         PRIVATE = (TARG)
1552         {
1553 6           TYPE = null  ===> (5)
1554               (was list)
1555             FLAGS = (UNKNOWN,KIDS,SLABBED,LASTSIB)
1556             {
1557 4               TYPE = pushmark  ===> 7
1558                 FLAGS = (SCALAR,SLABBED)
1559             }
1560             {
1561 8               TYPE = null  ===> (6)
1562                   (was rv2cv)
1563                 FLAGS = (SCALAR,KIDS,SLABBED,LASTSIB)
1564                 PRIVATE = (0x1)
1565                 {
1566 7                   TYPE = gv  ===> 5
1567                     FLAGS = (SCALAR,SLABBED,LASTSIB)
1568                     GV_OR_PADIX
1569                 }
1570             }
1571         }
1572     }
1573 }
1574 EODUMP
1575
1576 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
1577 $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004;
1578
1579 test_DumpProg("package t;", $e, "DumpProg() has no 'Attempt to free X prematurely' warning", "is" );
1580
1581 done_testing();