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