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