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