This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow PADTMPs’ strings to be swiped
[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
11 use Test::More;
12
13 use Devel::Peek;
14
15 our $DEBUG = 0;
16 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
17
18 # If I reference any lexicals in this, I get the entire outer subroutine (or
19 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
20 # maintain that.
21 format PIE =
22 Pie     @<<<<<
23 $::type
24 Good    @>>>>>
25 $::mmmm
26 .
27
28 use constant thr => $Config{useithreads};
29
30 sub do_test {
31     my $todo = $_[3];
32     my $repeat_todo = $_[4];
33     my $pattern = $_[2];
34     my $do_eval = $_[5];
35     if (open(OUT,">peek$$")) {
36         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
37         if ($do_eval) {
38             my $sub = eval "sub { Dump $_[1] }";
39             $sub->();
40             print STDERR "*****\n";
41             # second dump to compare with the first to make sure nothing
42             # changed.
43             $sub->();
44         }
45         else {
46             Dump($_[1]);
47             print STDERR "*****\n";
48             # second dump to compare with the first to make sure nothing
49             # changed.
50             Dump($_[1]);
51         }
52         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
53         close(OUT);
54         if (open(IN, "peek$$")) {
55             local $/;
56             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
57             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
58             # handle DEBUG_LEAKING_SCALARS prefix
59             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
60
61             # Need some clear generic mechanism to eliminate (or add) lines
62             # of dump output dependant on perl version. The (previous) use of
63             # things like $IVNV gave the illusion that the string passed in was
64             # a regexp into which variables were interpolated, but this wasn't
65             # actually true as those 'variables' actually also ate the
66             # whitespace on the line. So it seems better to mark lines that
67             # need to be eliminated. I considered (?# ... ) and (?{ ... }),
68             # but whilst embedded code or comment syntax would keep it as a
69             # legitimate regexp, it still isn't true. Seems easier and clearer
70             # things that look like comments.
71
72             # Could do this is in a s///mge but seems clearer like this:
73             $pattern = join '', map {
74                 # If we identify the version condition, take *it* out whatever
75                 s/\s*# (\$].*)$//
76                     ? (eval $1 ? $_ : '')
77                     : $_ # Didn't match, so this line is in
78             } split /^/, $pattern;
79             
80             $pattern =~ s/\$PADMY/
81                 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
82             /mge;
83             $pattern =~ s/\$PADTMP/
84                 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
85             /mge;
86             $pattern =~ s/\$RV/
87                 ($] < 5.011) ? 'RV' : 'IV';
88             /mge;
89             $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
90                 if $Config{ccflags} =~
91                         /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)/
92                             || $] < 5.019003;
93             print $pattern, "\n" if $DEBUG;
94             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
95             print $dump, "\n"    if $DEBUG;
96             like( $dump, qr/\A$pattern\Z/ms, $_[0])
97               or note("line " . (caller)[2]);
98
99             local $TODO = $repeat_todo;
100             is($dump2, $dump, "$_[0] (unchanged by dump)")
101               or note("line " . (caller)[2]);
102
103             close(IN);
104
105             return $1;
106         } else {
107             die "$0: failed to open peek$$: !\n";
108         }
109     } else {
110         die "$0: failed to create peek$$: $!\n";
111     }
112 }
113
114 our   $a;
115 our   $b;
116 my    $c;
117 local $d = 0;
118
119 END {
120     1 while unlink("peek$$");
121 }
122
123 do_test('assignment of immediate constant (string)',
124         $a = "foo",
125 'SV = PV\\($ADDR\\) at $ADDR
126   REFCNT = 1
127   FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
128   PV = $ADDR "foo"\\\0
129   CUR = 3
130   LEN = \\d+
131   COW_REFCNT = 1
132 ');
133
134 do_test('immediate constant (string)',
135         "bar",
136 'SV = PV\\($ADDR\\) at $ADDR
137   REFCNT = 1
138   FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
139   PV = $ADDR "bar"\\\0
140   CUR = 3
141   LEN = \\d+
142   COW_REFCNT = 0
143 ');
144
145 do_test('assignment of immediate constant (integer)',
146         $b = 123,
147 'SV = IV\\($ADDR\\) at $ADDR
148   REFCNT = 1
149   FLAGS = \\(IOK,pIOK\\)
150   IV = 123');
151
152 do_test('immediate constant (integer)',
153         456,
154 'SV = IV\\($ADDR\\) at $ADDR
155   REFCNT = 1
156   FLAGS = \\(.*IOK,READONLY,pIOK\\)
157   IV = 456');
158
159 do_test('assignment of immediate constant (integer)',
160         $c = 456,
161 'SV = IV\\($ADDR\\) at $ADDR
162   REFCNT = 1
163   FLAGS = \\($PADMY,IOK,pIOK\\)
164   IV = 456');
165
166 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
167 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
168 # maths is done in floating point always, and this scalar will be an NV.
169 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
170 # building subsequent regexps.
171 my $type = do_test('result of addition',
172         $c + $d,
173 'SV = ([NI])V\\($ADDR\\) at $ADDR
174   REFCNT = 1
175   FLAGS = \\(PADTMP,\1OK,p\1OK\\)               # $] < 5.019003
176   FLAGS = \\(\1OK,p\1OK\\)                      # $] >=5.019003
177   \1V = 456');
178
179 ($d = "789") += 0.1;
180
181 do_test('floating point value',
182        $d,
183        $] < 5.019003
184         || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)/
185        ?
186 'SV = PVNV\\($ADDR\\) at $ADDR
187   REFCNT = 1
188   FLAGS = \\(NOK,pNOK\\)
189   IV = \d+
190   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
191   PV = $ADDR "789"\\\0
192   CUR = 3
193   LEN = \\d+'
194        :
195 'SV = PVNV\\($ADDR\\) at $ADDR
196   REFCNT = 1
197   FLAGS = \\(NOK,pNOK\\)
198   IV = \d+
199   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
200   PV = 0');
201
202 do_test('integer constant',
203         0xabcd,
204 'SV = IV\\($ADDR\\) at $ADDR
205   REFCNT = 1
206   FLAGS = \\(.*IOK,READONLY,pIOK\\)
207   IV = 43981');
208
209 do_test('undef',
210         undef,
211 'SV = NULL\\(0x0\\) at $ADDR
212   REFCNT = \d+
213   FLAGS = \\(READONLY\\)');
214
215 do_test('reference to scalar',
216         \$a,
217 'SV = $RV\\($ADDR\\) at $ADDR
218   REFCNT = 1
219   FLAGS = \\(ROK\\)
220   RV = $ADDR
221   SV = PV\\($ADDR\\) at $ADDR
222     REFCNT = 2
223     FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
224     PV = $ADDR "foo"\\\0
225     CUR = 3
226     LEN = \\d+
227     COW_REFCNT = 1
228 ');
229
230 my $c_pattern;
231 if ($type eq 'N') {
232   $c_pattern = '
233     SV = PVNV\\($ADDR\\) at $ADDR
234       REFCNT = 1
235       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
236       IV = 456
237       NV = 456
238       PV = 0';
239 } else {
240   $c_pattern = '
241     SV = IV\\($ADDR\\) at $ADDR
242       REFCNT = 1
243       FLAGS = \\(IOK,pIOK\\)
244       IV = 456';
245 }
246 do_test('reference to array',
247        [$b,$c],
248 'SV = $RV\\($ADDR\\) at $ADDR
249   REFCNT = 1
250   FLAGS = \\(ROK\\)
251   RV = $ADDR
252   SV = PVAV\\($ADDR\\) at $ADDR
253     REFCNT = 1
254     FLAGS = \\(\\)
255     IV = 0                                      # $] < 5.009
256     NV = 0                                      # $] < 5.009
257     ARRAY = $ADDR
258     FILL = 1
259     MAX = 1
260     ARYLEN = 0x0
261     FLAGS = \\(REAL\\)
262     Elt No. 0
263     SV = IV\\($ADDR\\) at $ADDR
264       REFCNT = 1
265       FLAGS = \\(IOK,pIOK\\)
266       IV = 123
267     Elt No. 1' . $c_pattern);
268
269 do_test('reference to hash',
270        {$b=>$c},
271 'SV = $RV\\($ADDR\\) at $ADDR
272   REFCNT = 1
273   FLAGS = \\(ROK\\)
274   RV = $ADDR
275   SV = PVHV\\($ADDR\\) at $ADDR
276     REFCNT = [12]
277     FLAGS = \\(SHAREKEYS\\)
278     IV = 1                                      # $] < 5.009
279     NV = $FLOAT                                 # $] < 5.009
280     ARRAY = $ADDR  \\(0:7, 1:1\\)
281     hash quality = 100.0%
282     KEYS = 1
283     FILL = 1
284     MAX = 7
285     Elt "123" HASH = $ADDR' . $c_pattern,
286         '',
287         $] > 5.009 && $] < 5.015
288          && 'The hash iterator used in dump.c sets the OOK flag');
289
290 do_test('reference to anon sub with empty prototype',
291         sub(){@_},
292 'SV = $RV\\($ADDR\\) at $ADDR
293   REFCNT = 1
294   FLAGS = \\(ROK\\)
295   RV = $ADDR
296   SV = PVCV\\($ADDR\\) at $ADDR
297     REFCNT = 2
298     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
299     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
300     IV = 0                                      # $] < 5.009
301     NV = 0                                      # $] < 5.009
302     PROTOTYPE = ""
303     COMP_STASH = $ADDR\\t"main"
304     START = $ADDR ===> \\d+
305     ROOT = $ADDR
306     XSUB = 0x0                                  # $] < 5.009
307     XSUBANY = 0                                 # $] < 5.009
308     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
309     FILE = ".*\\b(?i:peek\\.t)"
310     DEPTH = 0(?:
311     MUTEXP = $ADDR
312     OWNER = $ADDR)?
313     FLAGS = 0x404                               # $] < 5.009
314     FLAGS = 0x490               # $] >= 5.009 && ($] < 5.015 || !thr)
315     FLAGS = 0x1490                              # $] >= 5.015 && thr
316     OUTSIDE_SEQ = \\d+
317     PADLIST = $ADDR
318     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
319     OUTSIDE = $ADDR \\(MAIN\\)');
320
321 do_test('reference to named subroutine without prototype',
322         \&do_test,
323 'SV = $RV\\($ADDR\\) at $ADDR
324   REFCNT = 1
325   FLAGS = \\(ROK\\)
326   RV = $ADDR
327   SV = PVCV\\($ADDR\\) at $ADDR
328     REFCNT = (3|4)
329     FLAGS = \\((?:HASEVAL)?\\)                  # $] < 5.015 || !thr
330     FLAGS = \\(DYNFILE(?:,HASEVAL)?\\)          # $] >= 5.015 && thr
331     IV = 0                                      # $] < 5.009
332     NV = 0                                      # $] < 5.009
333     COMP_STASH = $ADDR\\t"main"
334     START = $ADDR ===> \\d+
335     ROOT = $ADDR
336     XSUB = 0x0                                  # $] < 5.009
337     XSUBANY = 0                                 # $] < 5.009
338     GVGV::GV = $ADDR\\t"main" :: "do_test"
339     FILE = ".*\\b(?i:peek\\.t)"
340     DEPTH = 1(?:
341     MUTEXP = $ADDR
342     OWNER = $ADDR)?
343     FLAGS = 0x(?:400)?0                         # $] < 5.015 || !thr
344     FLAGS = 0x[145]000                          # $] >= 5.015 && thr
345     OUTSIDE_SEQ = \\d+
346     PADLIST = $ADDR
347     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
348        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
349        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
350        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
351        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
352       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
353       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
354       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
355       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
356       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
357     OUTSIDE = $ADDR \\(MAIN\\)');
358
359 if ($] >= 5.011) {
360 do_test('reference to regexp',
361         qr(tic),
362 'SV = $RV\\($ADDR\\) at $ADDR
363   REFCNT = 1
364   FLAGS = \\(ROK\\)
365   RV = $ADDR
366   SV = REGEXP\\($ADDR\\) at $ADDR
367     REFCNT = 1
368     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)          # $] < 5.017006
369     FLAGS = \\(OBJECT,FAKE\\)                   # $] >= 5.017006
370     PV = $ADDR "\\(\\?\\^:tic\\)"
371     CUR = 8
372     LEN = 0                                     # $] < 5.017006
373     STASH = $ADDR\\t"Regexp"'
374 . ($] < 5.013 ? '' :
375 '
376     COMPFLAGS = 0x0 \(\)
377     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
378     INTFLAGS = 0x0
379     NPARENS = 0
380     LASTPAREN = 0
381     LASTCLOSEPAREN = 0
382     MINLEN = 3
383     MINLENRET = 3
384     GOFS = 0
385     PRE_PREFIX = 4
386     SUBLEN = 0
387     SUBOFFSET = 0
388     SUBCOFFSET = 0
389     SUBBEG = 0x0
390     ENGINE = $ADDR
391     MOTHER_RE = $ADDR'
392 . ($] < 5.019003 ? '' : '
393     SV = REGEXP\($ADDR\) at $ADDR
394       REFCNT = 2
395       FLAGS = \(\)
396       PV = $ADDR "\(\?\^:tic\)"
397       CUR = 8
398       COMPFLAGS = 0x0 \(\)
399       EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
400       INTFLAGS = 0x0
401       NPARENS = 0
402       LASTPAREN = 0
403       LASTCLOSEPAREN = 0
404       MINLEN = 3
405       MINLENRET = 3
406       GOFS = 0
407       PRE_PREFIX = 4
408       SUBLEN = 0
409       SUBOFFSET = 0
410       SUBCOFFSET = 0
411       SUBBEG = 0x0
412       ENGINE = $ADDR
413       MOTHER_RE = 0x0
414       PAREN_NAMES = 0x0
415       SUBSTRS = $ADDR
416       PPRIVATE = $ADDR
417       OFFS = $ADDR
418       QR_ANONCV = 0x0(?:
419       SAVED_COPY = 0x0)?') . '
420     PAREN_NAMES = 0x0
421     SUBSTRS = $ADDR
422     PPRIVATE = $ADDR
423     OFFS = $ADDR
424     QR_ANONCV = 0x0(?:
425     SAVED_COPY = 0x0)?'
426 ));
427 } else {
428 do_test('reference to regexp',
429         qr(tic),
430 'SV = $RV\\($ADDR\\) at $ADDR
431   REFCNT = 1
432   FLAGS = \\(ROK\\)
433   RV = $ADDR
434   SV = PVMG\\($ADDR\\) at $ADDR
435     REFCNT = 1
436     FLAGS = \\(OBJECT,SMG\\)
437     IV = 0
438     NV = 0
439     PV = 0
440     MAGIC = $ADDR
441       MG_VIRTUAL = $ADDR
442       MG_TYPE = PERL_MAGIC_qr\(r\)
443       MG_OBJ = $ADDR
444         PAT = "\(\?^:tic\)"                     # $] >= 5.009
445         REFCNT = 2                              # $] >= 5.009
446     STASH = $ADDR\\t"Regexp"');
447 }
448
449 do_test('reference to blessed hash',
450         (bless {}, "Tac"),
451 'SV = $RV\\($ADDR\\) at $ADDR
452   REFCNT = 1
453   FLAGS = \\(ROK\\)
454   RV = $ADDR
455   SV = PVHV\\($ADDR\\) at $ADDR
456     REFCNT = [12]
457     FLAGS = \\(OBJECT,SHAREKEYS\\)
458     IV = 0                                      # $] < 5.009
459     NV = 0                                      # $] < 5.009
460     STASH = $ADDR\\t"Tac"
461     ARRAY = 0x0
462     KEYS = 0
463     FILL = 0
464     MAX = 7', '',
465         $] > 5.009
466         ? $] >= 5.015
467              ? 0
468              : 'The hash iterator used in dump.c sets the OOK flag'
469         : "Something causes the HV's array to become allocated");
470
471 do_test('typeglob',
472         *a,
473 'SV = PVGV\\($ADDR\\) at $ADDR
474   REFCNT = 5
475   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
476   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
477   IV = 0                                        # $] < 5.009
478   NV = 0                                        # $] < 5.009
479   PV = 0                                        # $] < 5.009
480   MAGIC = $ADDR                                 # $] < 5.009
481     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
482     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
483     MG_OBJ = $ADDR                              # $] < 5.009
484   NAME = "a"
485   NAMELEN = 1
486   GvSTASH = $ADDR\\t"main"
487   GP = $ADDR
488     SV = $ADDR
489     REFCNT = 1
490     IO = 0x0
491     FORM = 0x0  
492     AV = 0x0
493     HV = 0x0
494     CV = 0x0
495     CVGEN = 0x0
496     GPFLAGS = 0x0                               # $] < 5.009
497     LINE = \\d+
498     FILE = ".*\\b(?i:peek\\.t)"
499     FLAGS = $ADDR
500     EGV = $ADDR\\t"a"');
501
502 if (ord('A') == 193) {
503 do_test('string with Unicode',
504         chr(256).chr(0).chr(512),
505 'SV = PV\\($ADDR\\) at $ADDR
506   REFCNT = 1
507   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
508   FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)   # $] >=5.019003
509   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
510   CUR = 5
511   LEN = \\d+
512   COW_REFCNT = 1                                        # $] < 5.019006
513 ');
514 } else {
515 do_test('string with Unicode',
516         chr(256).chr(0).chr(512),
517 'SV = PV\\($ADDR\\) at $ADDR
518   REFCNT = 1
519   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
520   FLAGS = \\((?:$PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)   # $] >=5.019003
521   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
522   CUR = 5
523   LEN = \\d+
524   COW_REFCNT = 1                                        # $] < 5.019006
525 ');
526 }
527
528 if (ord('A') == 193) {
529 do_test('reference to hash containing Unicode',
530         {chr(256)=>chr(512)},
531 'SV = $RV\\($ADDR\\) at $ADDR
532   REFCNT = 1
533   FLAGS = \\(ROK\\)
534   RV = $ADDR
535   SV = PVHV\\($ADDR\\) at $ADDR
536     REFCNT = [12]
537     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
538     UV = 1                                      # $] < 5.009
539     NV = $FLOAT                                 # $] < 5.009
540     ARRAY = $ADDR  \\(0:7, 1:1\\)
541     hash quality = 100.0%
542     KEYS = 1
543     FILL = 1
544     MAX = 7
545     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
546     SV = PV\\($ADDR\\) at $ADDR
547       REFCNT = 1
548       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
549       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
550       CUR = 2
551       LEN = \\d+
552       COW_REFCNT = 1                            # $] < 5.019006
553 ',      '',
554         $] > 5.009
555         ? $] >= 5.015
556             ?  0
557             : 'The hash iterator used in dump.c sets the OOK flag'
558         : 'sv_length has been called on the element, and cached the result in MAGIC');
559 } else {
560 do_test('reference to hash containing Unicode',
561         {chr(256)=>chr(512)},
562 'SV = $RV\\($ADDR\\) at $ADDR
563   REFCNT = 1
564   FLAGS = \\(ROK\\)
565   RV = $ADDR
566   SV = PVHV\\($ADDR\\) at $ADDR
567     REFCNT = [12]
568     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
569     UV = 1                                      # $] < 5.009
570     NV = 0                                      # $] < 5.009
571     ARRAY = $ADDR  \\(0:7, 1:1\\)
572     hash quality = 100.0%
573     KEYS = 1
574     FILL = 1
575     MAX = 7
576     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
577     SV = PV\\($ADDR\\) at $ADDR
578       REFCNT = 1
579       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
580       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
581       CUR = 2
582       LEN = \\d+
583       COW_REFCNT = 1                            # $] < 5.019006
584 ',      '',
585         $] > 5.009
586         ? $] >= 5.015
587             ?  0
588             : 'The hash iterator used in dump.c sets the OOK flag'
589         : 'sv_length has been called on the element, and cached the result in MAGIC');
590 }
591
592 my $x="";
593 $x=~/.??/g;
594 do_test('scalar with pos magic',
595         $x,
596 'SV = PVMG\\($ADDR\\) at $ADDR
597   REFCNT = 1
598   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
599   IV = \d+
600   NV = 0
601   PV = $ADDR ""\\\0
602   CUR = 0
603   LEN = \d+
604   COW_REFCNT = [12]
605   MAGIC = $ADDR
606     MG_VIRTUAL = &PL_vtbl_mglob
607     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
608     MG_FLAGS = 0x01                                     # $] < 5.019003
609     MG_FLAGS = 0x41                                     # $] >=5.019003
610       MINMATCH
611       BYTES                                             # $] >=5.019003
612 ');
613
614 #
615 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
616 # environment variables may be invisibly case-forced, hence the (?i:PATH)
617 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
618 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
619 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
620 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
621 # ENV hashes is also not always null terminated.
622 #
623 if (${^TAINT}) {
624   do_test('tainted value in %ENV',
625           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
626 'SV = PVMG\\($ADDR\\) at $ADDR
627   REFCNT = 1
628   FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
629   IV = 0
630   NV = 0
631   PV = $ADDR "0"\\\0
632   CUR = 1
633   LEN = \d+
634   MAGIC = $ADDR
635     MG_VIRTUAL = &PL_vtbl_envelem
636     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
637 (?:    MG_FLAGS = 0x01
638       TAINTEDDIR
639 )?    MG_LEN = -?\d+
640     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
641     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
642       REFCNT = \d+
643       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
644 (?:      IV = 0
645 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
646       CUR = \d+
647       LEN = \d+)
648   MAGIC = $ADDR
649     MG_VIRTUAL = &PL_vtbl_taint
650     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
651 }
652
653 do_test('blessed reference',
654         bless(\\undef, 'Foobar'),
655 'SV = $RV\\($ADDR\\) at $ADDR
656   REFCNT = 1
657   FLAGS = \\(ROK\\)
658   RV = $ADDR
659   SV = PVMG\\($ADDR\\) at $ADDR
660     REFCNT = 2
661     FLAGS = \\(OBJECT,ROK\\)
662     IV = -?\d+
663     NV = $FLOAT
664     RV = $ADDR
665     SV = NULL\\(0x0\\) at $ADDR
666       REFCNT = \d+
667       FLAGS = \\(READONLY\\)
668     PV = $ADDR ""
669     CUR = 0
670     LEN = 0
671     STASH = $ADDR\s+"Foobar"');
672
673 sub const () {
674     "Perl rules";
675 }
676
677 do_test('constant subroutine',
678         \&const,
679 'SV = $RV\\($ADDR\\) at $ADDR
680   REFCNT = 1
681   FLAGS = \\(ROK\\)
682   RV = $ADDR
683   SV = PVCV\\($ADDR\\) at $ADDR
684     REFCNT = (2)
685     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)         # $] < 5.015
686     FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
687     IV = 0                                      # $] < 5.009
688     NV = 0                                      # $] < 5.009
689     PROTOTYPE = ""
690     COMP_STASH = 0x0
691     ROOT = 0x0                                  # $] < 5.009
692     XSUB = $ADDR
693     XSUBANY = $ADDR \\(CONST SV\\)
694     SV = PV\\($ADDR\\) at $ADDR
695       REFCNT = 1
696       FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)
697       PV = $ADDR "Perl rules"\\\0
698       CUR = 10
699       LEN = \\d+
700       COW_REFCNT = 0
701     GVGV::GV = $ADDR\\t"main" :: "const"
702     FILE = ".*\\b(?i:peek\\.t)"
703     DEPTH = 0(?:
704     MUTEXP = $ADDR
705     OWNER = $ADDR)?
706     FLAGS = 0x200                               # $] < 5.009
707     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
708     FLAGS = 0xc                                 # $] >= 5.013 && $] < 5.015
709     FLAGS = 0x100c                              # $] >= 5.015
710     OUTSIDE_SEQ = 0
711     PADLIST = 0x0
712     OUTSIDE = 0x0 \\(null\\)'); 
713
714 do_test('isUV should show on PVMG',
715         do { my $v = $1; $v = ~0; $v },
716 'SV = PVMG\\($ADDR\\) at $ADDR
717   REFCNT = 1
718   FLAGS = \\(IOK,pIOK,IsUV\\)
719   UV = \d+
720   NV = 0
721   PV = 0');
722
723 do_test('IO',
724         *STDOUT{IO},
725 'SV = $RV\\($ADDR\\) at $ADDR
726   REFCNT = 1
727   FLAGS = \\(ROK\\)
728   RV = $ADDR
729   SV = PVIO\\($ADDR\\) at $ADDR
730     REFCNT = 3
731     FLAGS = \\(OBJECT\\)
732     IV = 0                                      # $] < 5.011
733     NV = 0                                      # $] < 5.011
734     STASH = $ADDR\s+"IO::File"
735     IFP = $ADDR
736     OFP = $ADDR
737     DIRP = 0x0
738     LINES = 0
739     PAGE = 0
740     PAGE_LEN = 60
741     LINES_LEFT = 0
742     TOP_GV = 0x0
743     FMT_GV = 0x0
744     BOTTOM_GV = 0x0
745     SUBPROCESS = 0                              # $] < 5.009
746     TYPE = \'>\'
747     FLAGS = 0x4');
748
749 do_test('FORMAT',
750         *PIE{FORMAT},
751 'SV = $RV\\($ADDR\\) at $ADDR
752   REFCNT = 1
753   FLAGS = \\(ROK\\)
754   RV = $ADDR
755   SV = PVFM\\($ADDR\\) at $ADDR
756     REFCNT = 2
757     FLAGS = \\(\\)                              # $] < 5.015 || !thr
758     FLAGS = \\(DYNFILE\\)                       # $] >= 5.015 && thr
759     IV = 0                                      # $] < 5.009
760     NV = 0                                      # $] < 5.009
761 (?:    PV = 0
762 )?    COMP_STASH = 0x0
763     START = $ADDR ===> \\d+
764     ROOT = $ADDR
765     XSUB = 0x0                                  # $] < 5.009
766     XSUBANY = 0                                 # $] < 5.009
767     GVGV::GV = $ADDR\\t"main" :: "PIE"
768     FILE = ".*\\b(?i:peek\\.t)"(?:
769     DEPTH = 0)?(?:
770     MUTEXP = $ADDR
771     OWNER = $ADDR)?
772     FLAGS = 0x0                                 # $] < 5.015 || !thr
773     FLAGS = 0x1000                              # $] >= 5.015 && thr
774     OUTSIDE_SEQ = \\d+
775     LINES = 0                                   # $] < 5.017_003
776     PADLIST = $ADDR
777     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
778     OUTSIDE = $ADDR \\(MAIN\\)');
779
780 do_test('blessing to a class with embedded NUL characters',
781         (bless {}, "\0::foo::\n::baz::\t::\0"),
782 'SV = $RV\\($ADDR\\) at $ADDR
783   REFCNT = 1
784   FLAGS = \\(ROK\\)
785   RV = $ADDR
786   SV = PVHV\\($ADDR\\) at $ADDR
787     REFCNT = [12]
788     FLAGS = \\(OBJECT,SHAREKEYS\\)
789     IV = 0                                      # $] < 5.009
790     NV = 0                                      # $] < 5.009
791     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
792     ARRAY = $ADDR
793     KEYS = 0
794     FILL = 0
795     MAX = 7', '',
796         $] > 5.009
797         ? $] >= 5.015
798             ?  0
799             : 'The hash iterator used in dump.c sets the OOK flag'
800         : "Something causes the HV's array to become allocated");
801
802 do_test('ENAME on a stash',
803         \%RWOM::,
804 'SV = $RV\\($ADDR\\) at $ADDR
805   REFCNT = 1
806   FLAGS = \\(ROK\\)
807   RV = $ADDR
808   SV = PVHV\\($ADDR\\) at $ADDR
809     REFCNT = 2
810     FLAGS = \\(OOK,SHAREKEYS\\)
811     IV = 1                                      # $] < 5.009
812     NV = $FLOAT                                 # $] < 5.009
813     ARRAY = $ADDR
814     KEYS = 0
815     FILL = 0 \(cached = 0\)
816     MAX = 7
817     RITER = -1
818     EITER = 0x0
819     RAND = $ADDR
820     NAME = "RWOM"
821     ENAME = "RWOM"                              # $] > 5.012
822 ');
823
824 *KLANK:: = \%RWOM::;
825
826 do_test('ENAMEs on a stash',
827         \%RWOM::,
828 'SV = $RV\\($ADDR\\) at $ADDR
829   REFCNT = 1
830   FLAGS = \\(ROK\\)
831   RV = $ADDR
832   SV = PVHV\\($ADDR\\) at $ADDR
833     REFCNT = 3
834     FLAGS = \\(OOK,SHAREKEYS\\)
835     IV = 1                                      # $] < 5.009
836     NV = $FLOAT                                 # $] < 5.009
837     ARRAY = $ADDR
838     KEYS = 0
839     FILL = 0 \(cached = 0\)
840     MAX = 7
841     RITER = -1
842     EITER = 0x0
843     RAND = $ADDR
844     NAME = "RWOM"
845     NAMECOUNT = 2                               # $] > 5.012
846     ENAME = "RWOM", "KLANK"                     # $] > 5.012
847 ');
848
849 undef %RWOM::;
850
851 do_test('ENAMEs on a stash with no NAME',
852         \%RWOM::,
853 'SV = $RV\\($ADDR\\) at $ADDR
854   REFCNT = 1
855   FLAGS = \\(ROK\\)
856   RV = $ADDR
857   SV = PVHV\\($ADDR\\) at $ADDR
858     REFCNT = 3
859     FLAGS = \\(OOK,SHAREKEYS\\)                 # $] < 5.017
860     FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\)        # $] >=5.017
861     IV = 1                                      # $] < 5.009
862     NV = $FLOAT                                 # $] < 5.009
863     ARRAY = $ADDR
864     KEYS = 0
865     FILL = 0 \(cached = 0\)
866     MAX = 7
867     RITER = -1
868     EITER = 0x0
869     RAND = $ADDR
870     NAMECOUNT = -3                              # $] > 5.012
871     ENAME = "RWOM", "KLANK"                     # $] > 5.012
872 ');
873
874 my %small = ("Perl", "Rules", "Beer", "Foamy");
875 my $b = %small;
876 do_test('small hash',
877         \%small,
878 'SV = $RV\\($ADDR\\) at $ADDR
879   REFCNT = 1
880   FLAGS = \\(ROK\\)
881   RV = $ADDR
882   SV = PVHV\\($ADDR\\) at $ADDR
883     REFCNT = 2
884     FLAGS = \\(PADMY,SHAREKEYS\\)
885     IV = 1                                      # $] < 5.009
886     NV = $FLOAT                                 # $] < 5.009
887     ARRAY = $ADDR  \\(0:[67],.*\\)
888     hash quality = [0-9.]+%
889     KEYS = 2
890     FILL = [12]
891     MAX = 7
892 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
893     SV = PV\\($ADDR\\) at $ADDR
894       REFCNT = 1
895       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
896       PV = $ADDR "(?:Rules|Foamy)"\\\0
897       CUR = \d+
898       LEN = \d+
899       COW_REFCNT = 1
900 ){2}');
901
902 $b = keys %small;
903
904 do_test('small hash after keys',
905         \%small,
906 'SV = $RV\\($ADDR\\) at $ADDR
907   REFCNT = 1
908   FLAGS = \\(ROK\\)
909   RV = $ADDR
910   SV = PVHV\\($ADDR\\) at $ADDR
911     REFCNT = 2
912     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
913     IV = 1                                      # $] < 5.009
914     NV = $FLOAT                                 # $] < 5.009
915     ARRAY = $ADDR  \\(0:[67],.*\\)
916     hash quality = [0-9.]+%
917     KEYS = 2
918     FILL = [12] \\(cached = 0\\)
919     MAX = 7
920     RITER = -1
921     EITER = 0x0
922     RAND = $ADDR
923 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
924     SV = PV\\($ADDR\\) at $ADDR
925       REFCNT = 1
926       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
927       PV = $ADDR "(?:Rules|Foamy)"\\\0
928       CUR = \d+
929       LEN = \d+
930       COW_REFCNT = 1
931 ){2}');
932
933 $b = %small;
934
935 do_test('small hash after keys and scalar',
936         \%small,
937 'SV = $RV\\($ADDR\\) at $ADDR
938   REFCNT = 1
939   FLAGS = \\(ROK\\)
940   RV = $ADDR
941   SV = PVHV\\($ADDR\\) at $ADDR
942     REFCNT = 2
943     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
944     IV = 1                                      # $] < 5.009
945     NV = $FLOAT                                 # $] < 5.009
946     ARRAY = $ADDR  \\(0:[67],.*\\)
947     hash quality = [0-9.]+%
948     KEYS = 2
949     FILL = ([12]) \\(cached = \1\\)
950     MAX = 7
951     RITER = -1
952     EITER = 0x0
953     RAND = $ADDR
954 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
955     SV = PV\\($ADDR\\) at $ADDR
956       REFCNT = 1
957       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
958       PV = $ADDR "(?:Rules|Foamy)"\\\0
959       CUR = \d+
960       LEN = \d+
961       COW_REFCNT = 1
962 ){2}');
963
964 # This should immediately start with the FILL cached correctly.
965 my %large = (0..1999);
966 $b = %large;
967 do_test('large hash',
968         \%large,
969 'SV = $RV\\($ADDR\\) at $ADDR
970   REFCNT = 1
971   FLAGS = \\(ROK\\)
972   RV = $ADDR
973   SV = PVHV\\($ADDR\\) at $ADDR
974     REFCNT = 2
975     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
976     IV = 1                                      # $] < 5.009
977     NV = $FLOAT                                 # $] < 5.009
978     ARRAY = $ADDR  \\(0:\d+,.*\\)
979     hash quality = \d+\\.\d+%
980     KEYS = 1000
981     FILL = (\d+) \\(cached = \1\\)
982     MAX = 1023
983     RITER = -1
984     EITER = 0x0
985     RAND = $ADDR
986     Elt .*
987 ');
988
989 # Dump with arrays, hashes, and operator return values
990 @array = 1..3;
991 do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
992 SV = PVAV\($ADDR\) at $ADDR
993   REFCNT = 1
994   FLAGS = \(\)
995   ARRAY = $ADDR
996   FILL = 2
997   MAX = 3
998   ARYLEN = 0x0
999   FLAGS = \(REAL\)
1000   Elt No. 0
1001   SV = IV\($ADDR\) at $ADDR
1002     REFCNT = 1
1003     FLAGS = \(IOK,pIOK\)
1004     IV = 1
1005   Elt No. 1
1006   SV = IV\($ADDR\) at $ADDR
1007     REFCNT = 1
1008     FLAGS = \(IOK,pIOK\)
1009     IV = 2
1010   Elt No. 2
1011   SV = IV\($ADDR\) at $ADDR
1012     REFCNT = 1
1013     FLAGS = \(IOK,pIOK\)
1014     IV = 3
1015 ARRAY
1016 %hash = 1..2;
1017 do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
1018 SV = PVHV\($ADDR\) at $ADDR
1019   REFCNT = 1
1020   FLAGS = \(SHAREKEYS\)
1021   ARRAY = $ADDR  \(0:7, 1:1\)
1022   hash quality = 100.0%
1023   KEYS = 1
1024   FILL = 1
1025   MAX = 7
1026   Elt "1" HASH = $ADDR
1027   SV = IV\($ADDR\) at $ADDR
1028     REFCNT = 1
1029     FLAGS = \(IOK,pIOK\)
1030     IV = 2
1031 HASH
1032 $_ = "hello";
1033 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
1034 SV = PV\($ADDR\) at $ADDR
1035   REFCNT = 1
1036   FLAGS = \(PADTMP,POK,pPOK\)
1037   PV = $ADDR "el"\\0
1038   CUR = 2
1039   LEN = \d+
1040 SUBSTR
1041
1042 # Dump with no arguments
1043 eval 'Dump';
1044 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1045 eval 'Dump()';
1046 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1047
1048 SKIP: {
1049     skip "Not built with usemymalloc", 2
1050       unless $Config{usemymalloc} eq 'y';
1051     my $x = __PACKAGE__;
1052     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1053      or diag $@;
1054     my $y;
1055     ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1056 }
1057
1058 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1059 # prowess, but short of duplicating all the gubbins of this file, I can't see
1060 # a way to make a better place for it:
1061
1062 use constant {
1063     perl => 'rules',
1064     beer => 'foamy',
1065 };
1066
1067 unless ($Config{useithreads}) {
1068     # These end up as copies in pads under ithreads, which rather defeats the
1069     # the point of what we're trying to test here.
1070
1071     do_test('regular string constant', perl,
1072 'SV = PV\\($ADDR\\) at $ADDR
1073   REFCNT = 5
1074   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1075   PV = $ADDR "rules"\\\0
1076   CUR = 5
1077   LEN = \d+
1078   COW_REFCNT = 0
1079 ');
1080
1081     eval 'index "", perl';
1082
1083     # FIXME - really this shouldn't say EVALED. It's a false posistive on
1084     # 0x40000000 being used for several things, not a flag for "I'm in a string
1085     # eval"
1086
1087     do_test('string constant now an FBM', perl,
1088 'SV = PVMG\\($ADDR\\) at $ADDR
1089   REFCNT = 5
1090   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1091   PV = $ADDR "rules"\\\0
1092   CUR = 5
1093   LEN = \d+
1094   COW_REFCNT = 0
1095   MAGIC = $ADDR
1096     MG_VIRTUAL = &PL_vtbl_regexp
1097     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1098     MG_LEN = 256
1099     MG_PTR = $ADDR "(?:\\\\\d){256}"
1100   RARE = \d+                                    # $] < 5.019002
1101   PREVIOUS = 1                                  # $] < 5.019002
1102   USEFUL = 100
1103 ');
1104
1105     is(study perl, '', "Not allowed to study an FBM");
1106
1107     do_test('string constant still an FBM', perl,
1108 'SV = PVMG\\($ADDR\\) at $ADDR
1109   REFCNT = 5
1110   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1111   PV = $ADDR "rules"\\\0
1112   CUR = 5
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 = 1                                  # $] < 5.019002
1122   USEFUL = 100
1123 ');
1124
1125     do_test('regular string constant', beer,
1126 'SV = PV\\($ADDR\\) at $ADDR
1127   REFCNT = 6
1128   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1129   PV = $ADDR "foamy"\\\0
1130   CUR = 5
1131   LEN = \d+
1132   COW_REFCNT = 0
1133 ');
1134
1135     is(study beer, 1, "Our studies were successful");
1136
1137     do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1138   REFCNT = 6
1139   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)
1140   PV = $ADDR "foamy"\\\0
1141   CUR = 5
1142   LEN = \d+
1143   COW_REFCNT = 0
1144 ');
1145
1146     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1147   REFCNT = 6
1148   FLAGS = \\(PADMY,SMG,POK,READONLY,(?:IsCOW,)?pPOK,VALID,EVALED\\)
1149   PV = $ADDR "foamy"\\\0
1150   CUR = 5
1151   LEN = \d+
1152   COW_REFCNT = 0
1153   MAGIC = $ADDR
1154     MG_VIRTUAL = &PL_vtbl_regexp
1155     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1156     MG_LEN = 256
1157     MG_PTR = $ADDR "(?:\\\\\d){256}"
1158   RARE = \d+                                    # $] < 5.019002
1159   PREVIOUS = \d+                                # $] < 5.019002
1160   USEFUL = 100
1161 ';
1162
1163     is (eval 'index "not too foamy", beer', 8, 'correct index');
1164
1165     do_test('string constant now FBMed', beer, $want);
1166
1167     my $pie = 'good';
1168
1169     is(study $pie, 1, "Our studies were successful");
1170
1171     do_test('string constant still FBMed', beer, $want);
1172
1173     do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1174   REFCNT = 1
1175   FLAGS = \\(PADMY,POK,(?:IsCOW,)?pPOK\\)
1176   PV = $ADDR "good"\\\0
1177   CUR = 4
1178   LEN = \d+
1179   COW_REFCNT = 1
1180 ');
1181 }
1182
1183 # (One block of study tests removed when study was made a no-op.)
1184
1185 {
1186     open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1187     open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1188     DeadCode();
1189     open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1190     pass "no crash with DeadCode";
1191     close OUT;
1192 }
1193
1194 do_test('UTF-8 in a regular expression',
1195         qr/\x{100}/,
1196 'SV = IV\($ADDR\) at $ADDR
1197   REFCNT = 1
1198   FLAGS = \(ROK\)
1199   RV = $ADDR
1200   SV = REGEXP\($ADDR\) at $ADDR
1201     REFCNT = 1
1202     FLAGS = \(OBJECT,FAKE,UTF8\)
1203     PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1204     CUR = 13
1205     STASH = $ADDR       "Regexp"
1206     COMPFLAGS = 0x0 \(\)
1207     EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1208     INTFLAGS = 0x0
1209     NPARENS = 0
1210     LASTPAREN = 0
1211     LASTCLOSEPAREN = 0
1212     MINLEN = 1
1213     MINLENRET = 1
1214     GOFS = 0
1215     PRE_PREFIX = 5
1216     SUBLEN = 0
1217     SUBOFFSET = 0
1218     SUBCOFFSET = 0
1219     SUBBEG = 0x0
1220     ENGINE = $ADDR
1221     MOTHER_RE = $ADDR'
1222 . ($] < 5.019003 ? '' : '
1223     SV = REGEXP\($ADDR\) at $ADDR
1224       REFCNT = 2
1225       FLAGS = \(UTF8\)
1226       PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1227       CUR = 13
1228       COMPFLAGS = 0x0 \(\)
1229       EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1230       INTFLAGS = 0x0
1231       NPARENS = 0
1232       LASTPAREN = 0
1233       LASTCLOSEPAREN = 0
1234       MINLEN = 1
1235       MINLENRET = 1
1236       GOFS = 0
1237       PRE_PREFIX = 5
1238       SUBLEN = 0
1239       SUBOFFSET = 0
1240       SUBCOFFSET = 0
1241       SUBBEG = 0x0
1242       ENGINE = $ADDR
1243       MOTHER_RE = 0x0
1244       PAREN_NAMES = 0x0
1245       SUBSTRS = $ADDR
1246       PPRIVATE = $ADDR
1247       OFFS = $ADDR
1248       QR_ANONCV = 0x0(?:
1249       SAVED_COPY = 0x0)?') . '
1250     PAREN_NAMES = 0x0
1251     SUBSTRS = $ADDR
1252     PPRIVATE = $ADDR
1253     OFFS = $ADDR
1254     QR_ANONCV = 0x0(?:
1255     SAVED_COPY = 0x0)?
1256 ');
1257
1258 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1259   my %hash;
1260   my $base_count = Devel::Peek::SvREFCNT(%hash);
1261   my $ref = \%hash;
1262   is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1263 }
1264
1265 done_testing();