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