This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op.c:ck_eval: remove redundant null check
[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\\)               # $] < 5.019003
157   FLAGS = \\(\1OK,p\1OK\\)                      # $] >=5.019003
158   \1V = 456');
159
160 ($d = "789") += 0.1;
161
162 do_test('floating point value',
163        $d,
164 'SV = PVNV\\($ADDR\\) at $ADDR
165   REFCNT = 1
166   FLAGS = \\(NOK,pNOK\\)
167   IV = \d+
168   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
169   PV = $ADDR "789"\\\0
170   CUR = 3
171   LEN = \\d+');
172
173 do_test('integer constant',
174         0xabcd,
175 'SV = IV\\($ADDR\\) at $ADDR
176   REFCNT = 1
177   FLAGS = \\(.*IOK,READONLY,pIOK\\)
178   IV = 43981');
179
180 do_test('undef',
181         undef,
182 'SV = NULL\\(0x0\\) at $ADDR
183   REFCNT = 1
184   FLAGS = \\(\\)');
185
186 do_test('reference to scalar',
187         \$a,
188 'SV = $RV\\($ADDR\\) at $ADDR
189   REFCNT = 1
190   FLAGS = \\(ROK\\)
191   RV = $ADDR
192   SV = PV\\($ADDR\\) at $ADDR
193     REFCNT = 2
194     FLAGS = \\(POK,pPOK\\)
195     PV = $ADDR "foo"\\\0
196     CUR = 3
197     LEN = \\d+');
198
199 my $c_pattern;
200 if ($type eq 'N') {
201   $c_pattern = '
202     SV = PVNV\\($ADDR\\) at $ADDR
203       REFCNT = 1
204       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
205       IV = 456
206       NV = 456
207       PV = 0';
208 } else {
209   $c_pattern = '
210     SV = IV\\($ADDR\\) at $ADDR
211       REFCNT = 1
212       FLAGS = \\(IOK,pIOK\\)
213       IV = 456';
214 }
215 do_test('reference to array',
216        [$b,$c],
217 'SV = $RV\\($ADDR\\) at $ADDR
218   REFCNT = 1
219   FLAGS = \\(ROK\\)
220   RV = $ADDR
221   SV = PVAV\\($ADDR\\) at $ADDR
222     REFCNT = 1
223     FLAGS = \\(\\)
224     IV = 0                                      # $] < 5.009
225     NV = 0                                      # $] < 5.009
226     ARRAY = $ADDR
227     FILL = 1
228     MAX = 1
229     ARYLEN = 0x0
230     FLAGS = \\(REAL\\)
231     Elt No. 0
232     SV = IV\\($ADDR\\) at $ADDR
233       REFCNT = 1
234       FLAGS = \\(IOK,pIOK\\)
235       IV = 123
236     Elt No. 1' . $c_pattern);
237
238 do_test('reference to hash',
239        {$b=>$c},
240 'SV = $RV\\($ADDR\\) at $ADDR
241   REFCNT = 1
242   FLAGS = \\(ROK\\)
243   RV = $ADDR
244   SV = PVHV\\($ADDR\\) at $ADDR
245     REFCNT = [12]
246     FLAGS = \\(SHAREKEYS\\)
247     IV = 1                                      # $] < 5.009
248     NV = $FLOAT                                 # $] < 5.009
249     ARRAY = $ADDR  \\(0:7, 1:1\\)
250     hash quality = 100.0%
251     KEYS = 1
252     FILL = 1
253     MAX = 7
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\\) # $] < 5.015 || !thr
268     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
269     IV = 0                                      # $] < 5.009
270     NV = 0                                      # $] < 5.009
271     PROTOTYPE = ""
272     COMP_STASH = $ADDR\\t"main"
273     START = $ADDR ===> \\d+
274     ROOT = $ADDR
275     XSUB = 0x0                                  # $] < 5.009
276     XSUBANY = 0                                 # $] < 5.009
277     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
278     FILE = ".*\\b(?i:peek\\.t)"
279     DEPTH = 0(?:
280     MUTEXP = $ADDR
281     OWNER = $ADDR)?
282     FLAGS = 0x404                               # $] < 5.009
283     FLAGS = 0x490               # $] >= 5.009 && ($] < 5.015 || !thr)
284     FLAGS = 0x1490                              # $] >= 5.015 && thr
285     OUTSIDE_SEQ = \\d+
286     PADLIST = $ADDR
287     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
288     OUTSIDE = $ADDR \\(MAIN\\)');
289
290 do_test('reference to named subroutine without prototype',
291         \&do_test,
292 'SV = $RV\\($ADDR\\) at $ADDR
293   REFCNT = 1
294   FLAGS = \\(ROK\\)
295   RV = $ADDR
296   SV = PVCV\\($ADDR\\) at $ADDR
297     REFCNT = (3|4)
298     FLAGS = \\((?:HASEVAL)?\\)                  # $] < 5.015 || !thr
299     FLAGS = \\(DYNFILE(?:,HASEVAL)?\\)          # $] >= 5.015 && thr
300     IV = 0                                      # $] < 5.009
301     NV = 0                                      # $] < 5.009
302     COMP_STASH = $ADDR\\t"main"
303     START = $ADDR ===> \\d+
304     ROOT = $ADDR
305     XSUB = 0x0                                  # $] < 5.009
306     XSUBANY = 0                                 # $] < 5.009
307     GVGV::GV = $ADDR\\t"main" :: "do_test"
308     FILE = ".*\\b(?i:peek\\.t)"
309     DEPTH = 1(?:
310     MUTEXP = $ADDR
311     OWNER = $ADDR)?
312     FLAGS = 0x(?:400)?0                         # $] < 5.015 || !thr
313     FLAGS = 0x[145]000                          # $] >= 5.015 && thr
314     OUTSIDE_SEQ = \\d+
315     PADLIST = $ADDR
316     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
317        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
318        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
319        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
320       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
321       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
322       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
323       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
324     OUTSIDE = $ADDR \\(MAIN\\)');
325
326 if ($] >= 5.011) {
327 do_test('reference to regexp',
328         qr(tic),
329 'SV = $RV\\($ADDR\\) at $ADDR
330   REFCNT = 1
331   FLAGS = \\(ROK\\)
332   RV = $ADDR
333   SV = REGEXP\\($ADDR\\) at $ADDR
334     REFCNT = 1
335     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)          # $] < 5.017006
336     FLAGS = \\(OBJECT,FAKE\\)                   # $] >= 5.017006
337     PV = $ADDR "\\(\\?\\^:tic\\)"
338     CUR = 8
339     LEN = 0                                     # $] < 5.017006
340     STASH = $ADDR\\t"Regexp"'
341 . ($] < 5.013 ? '' :
342 '
343     COMPFLAGS = 0x0 \(\)
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         $] > 5.009
405         ? $] >= 5.015
406              ? 0
407              : 'The hash iterator used in dump.c sets the OOK flag'
408         : "Something causes the HV's array to become allocated");
409
410 do_test('typeglob',
411         *a,
412 'SV = PVGV\\($ADDR\\) at $ADDR
413   REFCNT = 5
414   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
415   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
416   IV = 0                                        # $] < 5.009
417   NV = 0                                        # $] < 5.009
418   PV = 0                                        # $] < 5.009
419   MAGIC = $ADDR                                 # $] < 5.009
420     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
421     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
422     MG_OBJ = $ADDR                              # $] < 5.009
423   NAME = "a"
424   NAMELEN = 1
425   GvSTASH = $ADDR\\t"main"
426   GP = $ADDR
427     SV = $ADDR
428     REFCNT = 1
429     IO = 0x0
430     FORM = 0x0  
431     AV = 0x0
432     HV = 0x0
433     CV = 0x0
434     CVGEN = 0x0
435     GPFLAGS = 0x0                               # $] < 5.009
436     LINE = \\d+
437     FILE = ".*\\b(?i:peek\\.t)"
438     FLAGS = $ADDR
439     EGV = $ADDR\\t"a"');
440
441 if (ord('A') == 193) {
442 do_test('string with Unicode',
443         chr(256).chr(0).chr(512),
444 'SV = PV\\($ADDR\\) at $ADDR
445   REFCNT = 1
446   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
447   FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\)              # $] >=5.019003
448   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
449   CUR = 5
450   LEN = \\d+');
451 } else {
452 do_test('string with Unicode',
453         chr(256).chr(0).chr(512),
454 'SV = PV\\($ADDR\\) at $ADDR
455   REFCNT = 1
456   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
457   FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\)              # $] >=5.019003
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     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
481     SV = PV\\($ADDR\\) at $ADDR
482       REFCNT = 1
483       FLAGS = \\(POK,pPOK,UTF8\\)
484       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
485       CUR = 2
486       LEN = \\d+',
487         $] > 5.009
488         ? $] >= 5.015
489             ?  0
490             : 'The hash iterator used in dump.c sets the OOK flag'
491         : 'sv_length has been called on the element, and cached the result in MAGIC');
492 } else {
493 do_test('reference to hash containing Unicode',
494         {chr(256)=>chr(512)},
495 'SV = $RV\\($ADDR\\) at $ADDR
496   REFCNT = 1
497   FLAGS = \\(ROK\\)
498   RV = $ADDR
499   SV = PVHV\\($ADDR\\) at $ADDR
500     REFCNT = [12]
501     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
502     UV = 1                                      # $] < 5.009
503     NV = 0                                      # $] < 5.009
504     ARRAY = $ADDR  \\(0:7, 1:1\\)
505     hash quality = 100.0%
506     KEYS = 1
507     FILL = 1
508     MAX = 7
509     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
510     SV = PV\\($ADDR\\) at $ADDR
511       REFCNT = 1
512       FLAGS = \\(POK,pPOK,UTF8\\)
513       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
514       CUR = 2
515       LEN = \\d+', '',
516         $] > 5.009
517         ? $] >= 5.015
518             ?  0
519             : 'The hash iterator used in dump.c sets the OOK flag'
520         : 'sv_length has been called on the element, and cached the result in MAGIC');
521 }
522
523 my $x="";
524 $x=~/.??/g;
525 do_test('scalar with pos magic',
526         $x,
527 'SV = PVMG\\($ADDR\\) at $ADDR
528   REFCNT = 1
529   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
530   IV = \d+
531   NV = 0
532   PV = $ADDR ""\\\0
533   CUR = 0
534   LEN = \d+(?:
535   COW_REFCNT = 1)?
536   MAGIC = $ADDR
537     MG_VIRTUAL = &PL_vtbl_mglob
538     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
539     MG_FLAGS = 0x01
540       MINMATCH');
541
542 #
543 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
544 # environment variables may be invisibly case-forced, hence the (?i:PATH)
545 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
546 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
547 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
548 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
549 # ENV hashes is also not always null terminated.
550 #
551 if (${^TAINT}) {
552   do_test('tainted value in %ENV',
553           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
554 'SV = PVMG\\($ADDR\\) at $ADDR
555   REFCNT = 1
556   FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
557   IV = 0
558   NV = 0
559   PV = $ADDR "0"\\\0
560   CUR = 1
561   LEN = \d+
562   MAGIC = $ADDR
563     MG_VIRTUAL = &PL_vtbl_envelem
564     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
565 (?:    MG_FLAGS = 0x01
566       TAINTEDDIR
567 )?    MG_LEN = -?\d+
568     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
569     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
570       REFCNT = \d+
571       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
572 (?:      IV = 0
573 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
574       CUR = \d+
575       LEN = \d+)
576   MAGIC = $ADDR
577     MG_VIRTUAL = &PL_vtbl_taint
578     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
579 }
580
581 do_test('blessed reference',
582         bless(\\undef, 'Foobar'),
583 'SV = $RV\\($ADDR\\) at $ADDR
584   REFCNT = 1
585   FLAGS = \\(ROK\\)
586   RV = $ADDR
587   SV = PVMG\\($ADDR\\) at $ADDR
588     REFCNT = 2
589     FLAGS = \\(OBJECT,ROK\\)
590     IV = -?\d+
591     NV = $FLOAT
592     RV = $ADDR
593     SV = NULL\\(0x0\\) at $ADDR
594       REFCNT = \d+
595       FLAGS = \\(READONLY\\)
596     PV = $ADDR ""
597     CUR = 0
598     LEN = 0
599     STASH = $ADDR\s+"Foobar"');
600
601 sub const () {
602     "Perl rules";
603 }
604
605 do_test('constant subroutine',
606         \&const,
607 'SV = $RV\\($ADDR\\) at $ADDR
608   REFCNT = 1
609   FLAGS = \\(ROK\\)
610   RV = $ADDR
611   SV = PVCV\\($ADDR\\) at $ADDR
612     REFCNT = (2)
613     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)         # $] < 5.015
614     FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
615     IV = 0                                      # $] < 5.009
616     NV = 0                                      # $] < 5.009
617     PROTOTYPE = ""
618     COMP_STASH = 0x0
619     ROOT = 0x0                                  # $] < 5.009
620     XSUB = $ADDR
621     XSUBANY = $ADDR \\(CONST SV\\)
622     SV = PV\\($ADDR\\) at $ADDR
623       REFCNT = 1
624       FLAGS = \\(.*POK,READONLY,pPOK\\)
625       PV = $ADDR "Perl rules"\\\0
626       CUR = 10
627       LEN = \\d+
628     GVGV::GV = $ADDR\\t"main" :: "const"
629     FILE = ".*\\b(?i:peek\\.t)"
630     DEPTH = 0(?:
631     MUTEXP = $ADDR
632     OWNER = $ADDR)?
633     FLAGS = 0x200                               # $] < 5.009
634     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
635     FLAGS = 0xc                                 # $] >= 5.013 && $] < 5.015
636     FLAGS = 0x100c                              # $] >= 5.015
637     OUTSIDE_SEQ = 0
638     PADLIST = 0x0
639     OUTSIDE = 0x0 \\(null\\)'); 
640
641 do_test('isUV should show on PVMG',
642         do { my $v = $1; $v = ~0; $v },
643 'SV = PVMG\\($ADDR\\) at $ADDR
644   REFCNT = 1
645   FLAGS = \\(IOK,pIOK,IsUV\\)
646   UV = \d+
647   NV = 0
648   PV = 0');
649
650 do_test('IO',
651         *STDOUT{IO},
652 'SV = $RV\\($ADDR\\) at $ADDR
653   REFCNT = 1
654   FLAGS = \\(ROK\\)
655   RV = $ADDR
656   SV = PVIO\\($ADDR\\) at $ADDR
657     REFCNT = 3
658     FLAGS = \\(OBJECT\\)
659     IV = 0                                      # $] < 5.011
660     NV = 0                                      # $] < 5.011
661     STASH = $ADDR\s+"IO::File"
662     IFP = $ADDR
663     OFP = $ADDR
664     DIRP = 0x0
665     LINES = 0
666     PAGE = 0
667     PAGE_LEN = 60
668     LINES_LEFT = 0
669     TOP_GV = 0x0
670     FMT_GV = 0x0
671     BOTTOM_GV = 0x0
672     SUBPROCESS = 0                              # $] < 5.009
673     TYPE = \'>\'
674     FLAGS = 0x4');
675
676 do_test('FORMAT',
677         *PIE{FORMAT},
678 'SV = $RV\\($ADDR\\) at $ADDR
679   REFCNT = 1
680   FLAGS = \\(ROK\\)
681   RV = $ADDR
682   SV = PVFM\\($ADDR\\) at $ADDR
683     REFCNT = 2
684     FLAGS = \\(\\)                              # $] < 5.015 || !thr
685     FLAGS = \\(DYNFILE\\)                       # $] >= 5.015 && thr
686     IV = 0                                      # $] < 5.009
687     NV = 0                                      # $] < 5.009
688 (?:    PV = 0
689 )?    COMP_STASH = 0x0
690     START = $ADDR ===> \\d+
691     ROOT = $ADDR
692     XSUB = 0x0                                  # $] < 5.009
693     XSUBANY = 0                                 # $] < 5.009
694     GVGV::GV = $ADDR\\t"main" :: "PIE"
695     FILE = ".*\\b(?i:peek\\.t)"(?:
696     DEPTH = 0)?(?:
697     MUTEXP = $ADDR
698     OWNER = $ADDR)?
699     FLAGS = 0x0                                 # $] < 5.015 || !thr
700     FLAGS = 0x1000                              # $] >= 5.015 && thr
701     OUTSIDE_SEQ = \\d+
702     LINES = 0                                   # $] < 5.017_003
703     PADLIST = $ADDR
704     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
705     OUTSIDE = $ADDR \\(MAIN\\)');
706
707 do_test('blessing to a class with embedded NUL characters',
708         (bless {}, "\0::foo::\n::baz::\t::\0"),
709 'SV = $RV\\($ADDR\\) at $ADDR
710   REFCNT = 1
711   FLAGS = \\(ROK\\)
712   RV = $ADDR
713   SV = PVHV\\($ADDR\\) at $ADDR
714     REFCNT = [12]
715     FLAGS = \\(OBJECT,SHAREKEYS\\)
716     IV = 0                                      # $] < 5.009
717     NV = 0                                      # $] < 5.009
718     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
719     ARRAY = $ADDR
720     KEYS = 0
721     FILL = 0
722     MAX = 7', '',
723         $] > 5.009
724         ? $] >= 5.015
725             ?  0
726             : 'The hash iterator used in dump.c sets the OOK flag'
727         : "Something causes the HV's array to become allocated");
728
729 do_test('ENAME on a stash',
730         \%RWOM::,
731 'SV = $RV\\($ADDR\\) at $ADDR
732   REFCNT = 1
733   FLAGS = \\(ROK\\)
734   RV = $ADDR
735   SV = PVHV\\($ADDR\\) at $ADDR
736     REFCNT = 2
737     FLAGS = \\(OOK,SHAREKEYS\\)
738     IV = 1                                      # $] < 5.009
739     NV = $FLOAT                                 # $] < 5.009
740     ARRAY = $ADDR
741     KEYS = 0
742     FILL = 0 \(cached = 0\)
743     MAX = 7
744     RITER = -1
745     EITER = 0x0
746     RAND = $ADDR
747     NAME = "RWOM"
748     ENAME = "RWOM"                              # $] > 5.012
749 ');
750
751 *KLANK:: = \%RWOM::;
752
753 do_test('ENAMEs on a stash',
754         \%RWOM::,
755 'SV = $RV\\($ADDR\\) at $ADDR
756   REFCNT = 1
757   FLAGS = \\(ROK\\)
758   RV = $ADDR
759   SV = PVHV\\($ADDR\\) at $ADDR
760     REFCNT = 3
761     FLAGS = \\(OOK,SHAREKEYS\\)
762     IV = 1                                      # $] < 5.009
763     NV = $FLOAT                                 # $] < 5.009
764     ARRAY = $ADDR
765     KEYS = 0
766     FILL = 0 \(cached = 0\)
767     MAX = 7
768     RITER = -1
769     EITER = 0x0
770     RAND = $ADDR
771     NAME = "RWOM"
772     NAMECOUNT = 2                               # $] > 5.012
773     ENAME = "RWOM", "KLANK"                     # $] > 5.012
774 ');
775
776 undef %RWOM::;
777
778 do_test('ENAMEs on a stash with no NAME',
779         \%RWOM::,
780 'SV = $RV\\($ADDR\\) at $ADDR
781   REFCNT = 1
782   FLAGS = \\(ROK\\)
783   RV = $ADDR
784   SV = PVHV\\($ADDR\\) at $ADDR
785     REFCNT = 3
786     FLAGS = \\(OOK,SHAREKEYS\\)                 # $] < 5.017
787     FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\)        # $] >=5.017
788     IV = 1                                      # $] < 5.009
789     NV = $FLOAT                                 # $] < 5.009
790     ARRAY = $ADDR
791     KEYS = 0
792     FILL = 0 \(cached = 0\)
793     MAX = 7
794     RITER = -1
795     EITER = 0x0
796     RAND = $ADDR
797     NAMECOUNT = -3                              # $] > 5.012
798     ENAME = "RWOM", "KLANK"                     # $] > 5.012
799 ');
800
801 my %small = ("Perl", "Rules", "Beer", "Foamy");
802 my $b = %small;
803 do_test('small hash',
804         \%small,
805 'SV = $RV\\($ADDR\\) at $ADDR
806   REFCNT = 1
807   FLAGS = \\(ROK\\)
808   RV = $ADDR
809   SV = PVHV\\($ADDR\\) at $ADDR
810     REFCNT = 2
811     FLAGS = \\(PADMY,SHAREKEYS\\)
812     IV = 1                                      # $] < 5.009
813     NV = $FLOAT                                 # $] < 5.009
814     ARRAY = $ADDR  \\(0:[67],.*\\)
815     hash quality = [0-9.]+%
816     KEYS = 2
817     FILL = [12]
818     MAX = 7
819 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
820     SV = PV\\($ADDR\\) at $ADDR
821       REFCNT = 1
822       FLAGS = \\(POK,pPOK\\)
823       PV = $ADDR "(?:Rules|Foamy)"\\\0
824       CUR = \d+
825       LEN = \d+
826 ){2}');
827
828 $b = keys %small;
829
830 do_test('small hash after keys',
831         \%small,
832 'SV = $RV\\($ADDR\\) at $ADDR
833   REFCNT = 1
834   FLAGS = \\(ROK\\)
835   RV = $ADDR
836   SV = PVHV\\($ADDR\\) at $ADDR
837     REFCNT = 2
838     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
839     IV = 1                                      # $] < 5.009
840     NV = $FLOAT                                 # $] < 5.009
841     ARRAY = $ADDR  \\(0:[67],.*\\)
842     hash quality = [0-9.]+%
843     KEYS = 2
844     FILL = [12] \\(cached = 0\\)
845     MAX = 7
846     RITER = -1
847     EITER = 0x0
848     RAND = $ADDR
849 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
850     SV = PV\\($ADDR\\) at $ADDR
851       REFCNT = 1
852       FLAGS = \\(POK,pPOK\\)
853       PV = $ADDR "(?:Rules|Foamy)"\\\0
854       CUR = \d+
855       LEN = \d+
856 ){2}');
857
858 $b = %small;
859
860 do_test('small hash after keys and scalar',
861         \%small,
862 'SV = $RV\\($ADDR\\) at $ADDR
863   REFCNT = 1
864   FLAGS = \\(ROK\\)
865   RV = $ADDR
866   SV = PVHV\\($ADDR\\) at $ADDR
867     REFCNT = 2
868     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
869     IV = 1                                      # $] < 5.009
870     NV = $FLOAT                                 # $] < 5.009
871     ARRAY = $ADDR  \\(0:[67],.*\\)
872     hash quality = [0-9.]+%
873     KEYS = 2
874     FILL = ([12]) \\(cached = \1\\)
875     MAX = 7
876     RITER = -1
877     EITER = 0x0
878     RAND = $ADDR
879 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
880     SV = PV\\($ADDR\\) at $ADDR
881       REFCNT = 1
882       FLAGS = \\(POK,pPOK\\)
883       PV = $ADDR "(?:Rules|Foamy)"\\\0
884       CUR = \d+
885       LEN = \d+
886 ){2}');
887
888 # This should immediately start with the FILL cached correctly.
889 my %large = (0..1999);
890 $b = %large;
891 do_test('large hash',
892         \%large,
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:\d+,.*\\)
903     hash quality = \d+\\.\d+%
904     KEYS = 1000
905     FILL = (\d+) \\(cached = \1\\)
906     MAX = 1023
907     RITER = -1
908     EITER = 0x0
909     RAND = $ADDR
910     Elt .*
911 ');
912
913 SKIP: {
914     skip "Not built with usemymalloc", 1
915       unless $Config{usemymalloc} eq 'y';
916     my $x = __PACKAGE__;
917     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
918      or diag $@;
919 }
920
921 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
922 # prowess, but short of duplicating all the gubbins of this file, I can't see
923 # a way to make a better place for it:
924
925 use constant {
926     perl => 'rules',
927     beer => 'foamy',
928 };
929
930 unless ($Config{useithreads}) {
931     # These end up as copies in pads under ithreads, which rather defeats the
932     # the point of what we're trying to test here.
933
934     do_test('regular string constant', perl,
935 'SV = PV\\($ADDR\\) at $ADDR
936   REFCNT = 5
937   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
938   PV = $ADDR "rules"\\\0
939   CUR = 5
940   LEN = \d+
941 ');
942
943     eval 'index "", perl';
944
945     # FIXME - really this shouldn't say EVALED. It's a false posistive on
946     # 0x40000000 being used for several things, not a flag for "I'm in a string
947     # eval"
948
949     do_test('string constant now an FBM', perl,
950 'SV = PVMG\\($ADDR\\) at $ADDR
951   REFCNT = 5
952   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
953   PV = $ADDR "rules"\\\0
954   CUR = 5
955   LEN = \d+
956   MAGIC = $ADDR
957     MG_VIRTUAL = &PL_vtbl_regexp
958     MG_TYPE = PERL_MAGIC_bm\\(B\\)
959     MG_LEN = 256
960     MG_PTR = $ADDR "(?:\\\\\d){256}"
961   RARE = \d+                                    # $] < 5.019002
962   PREVIOUS = 1                                  # $] < 5.019002
963   USEFUL = 100
964 ');
965
966     is(study perl, '', "Not allowed to study an FBM");
967
968     do_test('string constant still an FBM', perl,
969 'SV = PVMG\\($ADDR\\) at $ADDR
970   REFCNT = 5
971   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
972   PV = $ADDR "rules"\\\0
973   CUR = 5
974   LEN = \d+
975   MAGIC = $ADDR
976     MG_VIRTUAL = &PL_vtbl_regexp
977     MG_TYPE = PERL_MAGIC_bm\\(B\\)
978     MG_LEN = 256
979     MG_PTR = $ADDR "(?:\\\\\d){256}"
980   RARE = \d+                                    # $] < 5.019002
981   PREVIOUS = 1                                  # $] < 5.019002
982   USEFUL = 100
983 ');
984
985     do_test('regular string constant', beer,
986 'SV = PV\\($ADDR\\) at $ADDR
987   REFCNT = 6
988   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
989   PV = $ADDR "foamy"\\\0
990   CUR = 5
991   LEN = \d+
992 ');
993
994     is(study beer, 1, "Our studies were successful");
995
996     do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
997   REFCNT = 6
998   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
999   PV = $ADDR "foamy"\\\0
1000   CUR = 5
1001   LEN = \d+
1002 ');
1003
1004     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1005   REFCNT = 6
1006   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
1007   PV = $ADDR "foamy"\\\0
1008   CUR = 5
1009   LEN = \d+
1010   MAGIC = $ADDR
1011     MG_VIRTUAL = &PL_vtbl_regexp
1012     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1013     MG_LEN = 256
1014     MG_PTR = $ADDR "(?:\\\\\d){256}"
1015   RARE = \d+                                    # $] < 5.019002
1016   PREVIOUS = \d+                                # $] < 5.019002
1017   USEFUL = 100
1018 ';
1019
1020     is (eval 'index "not too foamy", beer', 8, 'correct index');
1021
1022     do_test('string constant now FBMed', beer, $want);
1023
1024     my $pie = 'good';
1025
1026     is(study $pie, 1, "Our studies were successful");
1027
1028     do_test('string constant still FBMed', beer, $want);
1029
1030     do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1031   REFCNT = 1
1032   FLAGS = \\(PADMY,POK,pPOK\\)
1033   PV = $ADDR "good"\\\0
1034   CUR = 4
1035   LEN = \d+
1036 ');
1037 }
1038
1039 # (One block of study tests removed when study was made a no-op.)
1040
1041 {
1042     open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1043     open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1044     DeadCode();
1045     open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1046     pass "no crash with DeadCode";
1047     close OUT;
1048 }
1049
1050 do_test('UTF-8 in a regular expression',
1051         qr/\x{100}/,
1052 'SV = IV\($ADDR\) at $ADDR
1053   REFCNT = 1
1054   FLAGS = \(ROK\)
1055   RV = $ADDR
1056   SV = REGEXP\($ADDR\) at $ADDR
1057     REFCNT = 1
1058     FLAGS = \(OBJECT,FAKE,UTF8\)
1059     PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1060     CUR = 13
1061     STASH = $ADDR       "Regexp"
1062     COMPFLAGS = 0x0 \(\)
1063     EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1064     INTFLAGS = 0x0
1065     NPARENS = 0
1066     LASTPAREN = 0
1067     LASTCLOSEPAREN = 0
1068     MINLEN = 1
1069     MINLENRET = 1
1070     GOFS = 0
1071     PRE_PREFIX = 5
1072     SUBLEN = 0
1073     SUBOFFSET = 0
1074     SUBCOFFSET = 0
1075     SUBBEG = 0x0
1076     ENGINE = $ADDR
1077     MOTHER_RE = $ADDR
1078     PAREN_NAMES = 0x0
1079     SUBSTRS = $ADDR
1080     PPRIVATE = $ADDR
1081     OFFS = $ADDR
1082     QR_ANONCV = 0x0(?:
1083     SAVED_COPY = 0x0)?
1084 ');
1085
1086 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1087   my %hash;
1088   my $base_count = Devel::Peek::SvREFCNT(%hash);
1089   my $ref = \%hash;
1090   is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1091 }
1092
1093 done_testing();