This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Replace references to PL_vtbl_{bm,fm} in the code with PL_vtbl_regexp.
[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 && 'The hash iterator used in dump.c sets the OOK flag');
257
258 do_test('reference to anon sub with empty prototype',
259         sub(){@_},
260 'SV = $RV\\($ADDR\\) at $ADDR
261   REFCNT = 1
262   FLAGS = \\(ROK\\)
263   RV = $ADDR
264   SV = PVCV\\($ADDR\\) at $ADDR
265     REFCNT = 2
266     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
267     IV = 0                                      # $] < 5.009
268     NV = 0                                      # $] < 5.009
269     PROTOTYPE = ""
270     COMP_STASH = $ADDR\\t"main"
271     START = $ADDR ===> \\d+
272     ROOT = $ADDR
273     XSUB = 0x0                                  # $] < 5.009
274     XSUBANY = 0                                 # $] < 5.009
275     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
276     FILE = ".*\\b(?i:peek\\.t)"
277     DEPTH = 0(?:
278     MUTEXP = $ADDR
279     OWNER = $ADDR)?
280     FLAGS = 0x404                               # $] < 5.009
281     FLAGS = 0x490                               # $] >= 5.009
282     OUTSIDE_SEQ = \\d+
283     PADLIST = $ADDR
284     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
285     OUTSIDE = $ADDR \\(MAIN\\)');
286
287 do_test('reference to named subroutine without prototype',
288         \&do_test,
289 'SV = $RV\\($ADDR\\) at $ADDR
290   REFCNT = 1
291   FLAGS = \\(ROK\\)
292   RV = $ADDR
293   SV = PVCV\\($ADDR\\) at $ADDR
294     REFCNT = (3|4)
295     FLAGS = \\(\\)
296     IV = 0                                      # $] < 5.009
297     NV = 0                                      # $] < 5.009
298     COMP_STASH = $ADDR\\t"main"
299     START = $ADDR ===> \\d+
300     ROOT = $ADDR
301     XSUB = 0x0                                  # $] < 5.009
302     XSUBANY = 0                                 # $] < 5.009
303     GVGV::GV = $ADDR\\t"main" :: "do_test"
304     FILE = ".*\\b(?i:peek\\.t)"
305     DEPTH = 1
306 (?:    MUTEXP = $ADDR
307     OWNER = $ADDR
308 )?    FLAGS = 0x0
309     OUTSIDE_SEQ = \\d+
310     PADLIST = $ADDR
311     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
312        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
313        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
314        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
315       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
316       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
317       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
318       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
319       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
320     OUTSIDE = $ADDR \\(MAIN\\)');
321
322 if ($] >= 5.011) {
323 do_test('reference to regexp',
324         qr(tic),
325 'SV = $RV\\($ADDR\\) at $ADDR
326   REFCNT = 1
327   FLAGS = \\(ROK\\)
328   RV = $ADDR
329   SV = REGEXP\\($ADDR\\) at $ADDR
330     REFCNT = 1
331     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
332     PV = $ADDR "\\(\\?\\^:tic\\)"
333     CUR = 8
334     LEN = 0
335     STASH = $ADDR\\t"Regexp"'
336 . ($] < 5.013 ? '' :
337 '
338     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
339     INTFLAGS = 0x0
340     NPARENS = 0
341     LASTPAREN = 0
342     LASTCLOSEPAREN = 0
343     MINLEN = 3
344     MINLENRET = 3
345     GOFS = 0
346     PRE_PREFIX = 4
347     SEEN_EVALS = 0
348     SUBLEN = 0
349     SUBBEG = 0x0
350     ENGINE = $ADDR
351     MOTHER_RE = $ADDR
352     PAREN_NAMES = 0x0
353     SUBSTRS = $ADDR
354     PPRIVATE = $ADDR
355     OFFS = $ADDR'
356 ));
357 } else {
358 do_test('reference to regexp',
359         qr(tic),
360 'SV = $RV\\($ADDR\\) at $ADDR
361   REFCNT = 1
362   FLAGS = \\(ROK\\)
363   RV = $ADDR
364   SV = PVMG\\($ADDR\\) at $ADDR
365     REFCNT = 1
366     FLAGS = \\(OBJECT,SMG\\)
367     IV = 0
368     NV = 0
369     PV = 0
370     MAGIC = $ADDR
371       MG_VIRTUAL = $ADDR
372       MG_TYPE = PERL_MAGIC_qr\(r\)
373       MG_OBJ = $ADDR
374         PAT = "\(\?^:tic\)"                     # $] >= 5.009
375         REFCNT = 2                              # $] >= 5.009
376     STASH = $ADDR\\t"Regexp"');
377 }
378
379 do_test('reference to blessed hash',
380         (bless {}, "Tac"),
381 'SV = $RV\\($ADDR\\) at $ADDR
382   REFCNT = 1
383   FLAGS = \\(ROK\\)
384   RV = $ADDR
385   SV = PVHV\\($ADDR\\) at $ADDR
386     REFCNT = 1
387     FLAGS = \\(OBJECT,SHAREKEYS\\)
388     IV = 0                                      # $] < 5.009
389     NV = 0                                      # $] < 5.009
390     STASH = $ADDR\\t"Tac"
391     ARRAY = 0x0
392     KEYS = 0
393     FILL = 0
394     MAX = 7
395     RITER = -1
396     EITER = 0x0', '',
397         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
398         : "Something causes the HV's array to become allocated");
399
400 do_test('typeglob',
401         *a,
402 'SV = PVGV\\($ADDR\\) at $ADDR
403   REFCNT = 5
404   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
405   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
406   IV = 0                                        # $] < 5.009
407   NV = 0                                        # $] < 5.009
408   PV = 0                                        # $] < 5.009
409   MAGIC = $ADDR                                 # $] < 5.009
410     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
411     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
412     MG_OBJ = $ADDR                              # $] < 5.009
413   NAME = "a"
414   NAMELEN = 1
415   GvSTASH = $ADDR\\t"main"
416   GP = $ADDR
417     SV = $ADDR
418     REFCNT = 1
419     IO = 0x0
420     FORM = 0x0  
421     AV = 0x0
422     HV = 0x0
423     CV = 0x0
424     CVGEN = 0x0
425     GPFLAGS = 0x0                               # $] < 5.009
426     LINE = \\d+
427     FILE = ".*\\b(?i:peek\\.t)"
428     FLAGS = $ADDR
429     EGV = $ADDR\\t"a"');
430
431 if (ord('A') == 193) {
432 do_test('string with Unicode',
433         chr(256).chr(0).chr(512),
434 'SV = PV\\($ADDR\\) at $ADDR
435   REFCNT = 1
436   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
437   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
438   CUR = 5
439   LEN = \\d+');
440 } else {
441 do_test('string with Unicode',
442         chr(256).chr(0).chr(512),
443 'SV = PV\\($ADDR\\) at $ADDR
444   REFCNT = 1
445   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
446   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
447   CUR = 5
448   LEN = \\d+');
449 }
450
451 if (ord('A') == 193) {
452 do_test('reference to hash containing Unicode',
453         {chr(256)=>chr(512)},
454 'SV = $RV\\($ADDR\\) at $ADDR
455   REFCNT = 1
456   FLAGS = \\(ROK\\)
457   RV = $ADDR
458   SV = PVHV\\($ADDR\\) at $ADDR
459     REFCNT = 1
460     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
461     UV = 1                                      # $] < 5.009
462     NV = $FLOAT                                 # $] < 5.009
463     ARRAY = $ADDR  \\(0:7, 1:1\\)
464     hash quality = 100.0%
465     KEYS = 1
466     FILL = 1
467     MAX = 7
468     RITER = -1
469     EITER = $ADDR
470     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
471     SV = PV\\($ADDR\\) at $ADDR
472       REFCNT = 1
473       FLAGS = \\(POK,pPOK,UTF8\\)
474       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
475       CUR = 2
476       LEN = \\d+',
477         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
478         : 'sv_length has been called on the element, and cached the result in MAGIC');
479 } else {
480 do_test('reference to hash containing Unicode',
481         {chr(256)=>chr(512)},
482 'SV = $RV\\($ADDR\\) at $ADDR
483   REFCNT = 1
484   FLAGS = \\(ROK\\)
485   RV = $ADDR
486   SV = PVHV\\($ADDR\\) at $ADDR
487     REFCNT = 1
488     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
489     UV = 1                                      # $] < 5.009
490     NV = 0                                      # $] < 5.009
491     ARRAY = $ADDR  \\(0:7, 1:1\\)
492     hash quality = 100.0%
493     KEYS = 1
494     FILL = 1
495     MAX = 7
496     RITER = -1
497     EITER = $ADDR
498     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
499     SV = PV\\($ADDR\\) at $ADDR
500       REFCNT = 1
501       FLAGS = \\(POK,pPOK,UTF8\\)
502       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
503       CUR = 2
504       LEN = \\d+', '',
505         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
506         : 'sv_length has been called on the element, and cached the result in MAGIC');
507 }
508
509 my $x="";
510 $x=~/.??/g;
511 do_test('scalar with pos magic',
512         $x,
513 'SV = PVMG\\($ADDR\\) at $ADDR
514   REFCNT = 1
515   FLAGS = \\($PADMY,SMG,POK,pPOK\\)
516   IV = 0
517   NV = 0
518   PV = $ADDR ""\\\0
519   CUR = 0
520   LEN = \d+
521   MAGIC = $ADDR
522     MG_VIRTUAL = &PL_vtbl_mglob
523     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
524     MG_FLAGS = 0x01
525       MINMATCH');
526
527 #
528 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
529 # environment variables may be invisibly case-forced, hence the (?i:PATH)
530 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
531 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
532 # ENV hashes is also not always null terminated.
533 #
534 do_test('tainted value in %ENV',
535         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
536 'SV = PVMG\\($ADDR\\) at $ADDR
537   REFCNT = 1
538   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
539   IV = 0
540   NV = 0
541   PV = $ADDR "0"\\\0
542   CUR = 1
543   LEN = \d+
544   MAGIC = $ADDR
545     MG_VIRTUAL = &PL_vtbl_envelem
546     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
547 (?:    MG_FLAGS = 0x01
548       TAINTEDDIR
549 )?    MG_LEN = -?\d+
550     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
551     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
552       REFCNT = \d+
553       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
554 (?:      IV = 0
555 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
556       CUR = \d+
557       LEN = \d+)
558   MAGIC = $ADDR
559     MG_VIRTUAL = &PL_vtbl_taint
560     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
561
562 do_test('blessed reference',
563         bless(\\undef, 'Foobar'),
564 'SV = $RV\\($ADDR\\) at $ADDR
565   REFCNT = 1
566   FLAGS = \\(ROK\\)
567   RV = $ADDR
568   SV = PVMG\\($ADDR\\) at $ADDR
569     REFCNT = 2
570     FLAGS = \\(OBJECT,ROK\\)
571     IV = -?\d+
572     NV = $FLOAT
573     RV = $ADDR
574     SV = NULL\\(0x0\\) at $ADDR
575       REFCNT = \d+
576       FLAGS = \\(READONLY\\)
577     PV = $ADDR ""
578     CUR = 0
579     LEN = 0
580     STASH = $ADDR\s+"Foobar"');
581
582 sub const () {
583     "Perl rules";
584 }
585
586 do_test('constant subroutine',
587         \&const,
588 'SV = $RV\\($ADDR\\) at $ADDR
589   REFCNT = 1
590   FLAGS = \\(ROK\\)
591   RV = $ADDR
592   SV = PVCV\\($ADDR\\) at $ADDR
593     REFCNT = (2)
594     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
595     IV = 0                                      # $] < 5.009
596     NV = 0                                      # $] < 5.009
597     PROTOTYPE = ""
598     COMP_STASH = 0x0
599     ROOT = 0x0                                  # $] < 5.009
600     XSUB = $ADDR
601     XSUBANY = $ADDR \\(CONST SV\\)
602     SV = PV\\($ADDR\\) at $ADDR
603       REFCNT = 1
604       FLAGS = \\(.*POK,READONLY,pPOK\\)
605       PV = $ADDR "Perl rules"\\\0
606       CUR = 10
607       LEN = \\d+
608     GVGV::GV = $ADDR\\t"main" :: "const"
609     FILE = ".*\\b(?i:peek\\.t)"
610     DEPTH = 0(?:
611     MUTEXP = $ADDR
612     OWNER = $ADDR)?
613     FLAGS = 0x200                               # $] < 5.009
614     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
615     FLAGS = 0xc                                 # $] >= 5.013
616     OUTSIDE_SEQ = 0
617     PADLIST = 0x0
618     OUTSIDE = 0x0 \\(null\\)'); 
619
620 do_test('isUV should show on PVMG',
621         do { my $v = $1; $v = ~0; $v },
622 'SV = PVMG\\($ADDR\\) at $ADDR
623   REFCNT = 1
624   FLAGS = \\(IOK,pIOK,IsUV\\)
625   UV = \d+
626   NV = 0
627   PV = 0');
628
629 do_test('IO',
630         *STDOUT{IO},
631 'SV = $RV\\($ADDR\\) at $ADDR
632   REFCNT = 1
633   FLAGS = \\(ROK\\)
634   RV = $ADDR
635   SV = PVIO\\($ADDR\\) at $ADDR
636     REFCNT = 3
637     FLAGS = \\(OBJECT\\)
638     IV = 0                                      # $] < 5.011
639     NV = 0                                      # $] < 5.011
640     STASH = $ADDR\s+"IO::File"
641     IFP = $ADDR
642     OFP = $ADDR
643     DIRP = 0x0
644     LINES = 0
645     PAGE = 0
646     PAGE_LEN = 60
647     LINES_LEFT = 0
648     TOP_GV = 0x0
649     FMT_GV = 0x0
650     BOTTOM_GV = 0x0
651     SUBPROCESS = 0                              # $] < 5.009
652     TYPE = \'>\'
653     FLAGS = 0x4');
654
655 do_test('FORMAT',
656         *PIE{FORMAT},
657 'SV = $RV\\($ADDR\\) at $ADDR
658   REFCNT = 1
659   FLAGS = \\(ROK\\)
660   RV = $ADDR
661   SV = PVFM\\($ADDR\\) at $ADDR
662     REFCNT = 2
663     FLAGS = \\(\\)
664     IV = 0                                      # $] < 5.009
665     NV = 0                                      # $] < 5.009
666 (?:    PV = 0
667 )?    COMP_STASH = 0x0
668     START = $ADDR ===> \\d+
669     ROOT = $ADDR
670     XSUB = 0x0                                  # $] < 5.009
671     XSUBANY = 0                                 # $] < 5.009
672     GVGV::GV = $ADDR\\t"main" :: "PIE"
673     FILE = ".*\\b(?i:peek\\.t)"
674 (?:    DEPTH = 0
675     MUTEXP = $ADDR
676     OWNER = $ADDR
677 )?    FLAGS = 0x0
678     OUTSIDE_SEQ = \\d+
679     LINES = 0
680     PADLIST = $ADDR
681     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
682     OUTSIDE = $ADDR \\(MAIN\\)');
683
684 do_test('blessing to a class with embedded NUL characters',
685         (bless {}, "\0::foo::\n::baz::\t::\0"),
686 'SV = $RV\\($ADDR\\) at $ADDR
687   REFCNT = 1
688   FLAGS = \\(ROK\\)
689   RV = $ADDR
690   SV = PVHV\\($ADDR\\) at $ADDR
691     REFCNT = 1
692     FLAGS = \\(OBJECT,SHAREKEYS\\)
693     IV = 0                                      # $] < 5.009
694     NV = 0                                      # $] < 5.009
695     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
696     ARRAY = $ADDR
697     KEYS = 0
698     FILL = 0
699     MAX = 7
700     RITER = -1
701     EITER = 0x0', '',
702         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
703         : "Something causes the HV's array to become allocated");
704
705 do_test('ENAME on a stash',
706         \%RWOM::,
707 'SV = $RV\\($ADDR\\) at $ADDR
708   REFCNT = 1
709   FLAGS = \\(ROK\\)
710   RV = $ADDR
711   SV = PVHV\\($ADDR\\) at $ADDR
712     REFCNT = 2
713     FLAGS = \\(OOK,SHAREKEYS\\)
714     IV = 1                                      # $] < 5.009
715     NV = $FLOAT                                 # $] < 5.009
716     ARRAY = $ADDR
717     KEYS = 0
718     FILL = 0
719     MAX = 7
720     RITER = -1
721     EITER = 0x0
722     NAME = "RWOM"
723     ENAME = "RWOM"                              # $] > 5.012
724 ');
725
726 *KLANK:: = \%RWOM::;
727
728 do_test('ENAMEs on a stash',
729         \%RWOM::,
730 'SV = $RV\\($ADDR\\) at $ADDR
731   REFCNT = 1
732   FLAGS = \\(ROK\\)
733   RV = $ADDR
734   SV = PVHV\\($ADDR\\) at $ADDR
735     REFCNT = 3
736     FLAGS = \\(OOK,SHAREKEYS\\)
737     IV = 1                                      # $] < 5.009
738     NV = $FLOAT                                 # $] < 5.009
739     ARRAY = $ADDR
740     KEYS = 0
741     FILL = 0
742     MAX = 7
743     RITER = -1
744     EITER = 0x0
745     NAME = "RWOM"
746     NAMECOUNT = 2                               # $] > 5.012
747     ENAME = "RWOM", "KLANK"                     # $] > 5.012
748 ');
749
750 undef %RWOM::;
751
752 do_test('ENAMEs on a stash with no NAME',
753         \%RWOM::,
754 'SV = $RV\\($ADDR\\) at $ADDR
755   REFCNT = 1
756   FLAGS = \\(ROK\\)
757   RV = $ADDR
758   SV = PVHV\\($ADDR\\) at $ADDR
759     REFCNT = 3
760     FLAGS = \\(OOK,SHAREKEYS\\)
761     IV = 1                                      # $] < 5.009
762     NV = $FLOAT                                 # $] < 5.009
763     ARRAY = $ADDR
764     KEYS = 0
765     FILL = 0
766     MAX = 7
767     RITER = -1
768     EITER = 0x0
769     NAMECOUNT = -3                              # $] > 5.012
770     ENAME = "RWOM", "KLANK"                     # $] > 5.012
771 ');
772
773 SKIP: {
774     skip "Not built with usemymalloc", 1
775       unless $Config{usemymalloc} eq 'y';
776     my $x = __PACKAGE__;
777     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
778      or diag $@;
779 }
780
781 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
782 # prowess, but short of duplicating all the gubbins of this file, I can't see
783 # a way to make a better place for it:
784
785 use constant {
786     perl => 'rules',
787     beer => 'foamy',
788 };
789
790 unless ($Config{useithreads}) {
791     # These end up as copies in pads under ithreads, which rather defeats the
792     # the point of what we're trying to test here.
793
794     do_test('regular string constant', perl,
795 'SV = PV\\($ADDR\\) at $ADDR
796   REFCNT = 5
797   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
798   PV = $ADDR "rules"\\\0
799   CUR = 5
800   LEN = \d+
801 ');
802
803     eval 'index "", perl';
804
805     # FIXME - really this shouldn't say EVALED. It's a false posistive on
806     # 0x40000000 being used for several things, not a flag for "I'm in a string
807     # eval"
808
809     do_test('string constant now an FBM', perl,
810 'SV = PVMG\\($ADDR\\) at $ADDR
811   REFCNT = 5
812   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
813   PV = $ADDR "rules"\\\0
814   CUR = 5
815   LEN = \d+
816   MAGIC = $ADDR
817     MG_VIRTUAL = &PL_vtbl_regexp
818     MG_TYPE = PERL_MAGIC_bm\\(B\\)
819     MG_LEN = 256
820     MG_PTR = $ADDR "(?:\\\\\d){256}"
821   RARE = \d+
822   PREVIOUS = 1
823   USEFUL = 100
824 ');
825
826     is(study perl, '', "Not allowed to study an FBM");
827
828     do_test('string constant still an FBM', perl,
829 'SV = PVMG\\($ADDR\\) at $ADDR
830   REFCNT = 5
831   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
832   PV = $ADDR "rules"\\\0
833   CUR = 5
834   LEN = \d+
835   MAGIC = $ADDR
836     MG_VIRTUAL = &PL_vtbl_regexp
837     MG_TYPE = PERL_MAGIC_bm\\(B\\)
838     MG_LEN = 256
839     MG_PTR = $ADDR "(?:\\\\\d){256}"
840   RARE = \d+
841   PREVIOUS = 1
842   USEFUL = 100
843 ');
844
845     do_test('regular string constant', beer,
846 'SV = PV\\($ADDR\\) at $ADDR
847   REFCNT = 5
848   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
849   PV = $ADDR "foamy"\\\0
850   CUR = 5
851   LEN = \d+
852 ');
853
854     is(study beer, 1, "Our studies were successful");
855
856     do_test('string constant now studied', beer,
857 'SV = PVMG\\($ADDR\\) at $ADDR
858   REFCNT = 6
859   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
860   IV = 0
861   NV = 0
862   PV = $ADDR "foamy"\\\0
863   CUR = 5
864   LEN = \d+
865   MAGIC = $ADDR
866     MG_VIRTUAL = &PL_vtbl_mglob
867     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
868 ');
869
870     is (eval 'index "not too foamy", beer', 8, 'correct index');
871
872     do_test('string constant still studied', beer,
873 'SV = PVMG\\($ADDR\\) at $ADDR
874   REFCNT = 6
875   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
876   IV = 0
877   NV = 0
878   PV = $ADDR "foamy"\\\0
879   CUR = 5
880   LEN = \d+
881   MAGIC = $ADDR
882     MG_VIRTUAL = &PL_vtbl_mglob
883     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
884 ');
885 }
886
887 done_testing();