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