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