This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Need to substitute out the placeholder '$RV' for earlier perls too.
[perl5.git] / ext / Devel / Peek / t / Peek.t
1 #!./perl -T
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require Config; import Config;
7     if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
8         print "1..0 # Skip: Devel::Peek was not built\n";
9         exit 0;
10     }
11 }
12
13 BEGIN { require "./test.pl"; }
14
15 use Devel::Peek;
16
17 plan(50);
18
19 our $DEBUG = 0;
20 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
21
22 sub do_test {
23     my $pattern = pop;
24     if (open(OUT,">peek$$")) {
25         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
26         Dump($_[1]);
27         print STDERR "*****\n";
28         Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
29         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
30         close(OUT);
31         if (open(IN, "peek$$")) {
32             local $/;
33             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
34             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
35             # handle DEBUG_LEAKING_SCALARS prefix
36             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
37
38             $pattern =~ s/^ *\$XSUB *\n/
39                 ($] < 5.009) ? "    XSUB = 0\n    XSUBANY = 0\n" : '';
40             /mge;
41             $pattern =~ s/^ *\$ROOT *\n/
42                 ($] < 5.009) ? "    ROOT = 0x0\n" : '';
43             /mge;
44             $pattern =~ s/^ *\$IVNV *\n/
45                 ($] < 5.009) ? "    IV = 0\n    NV = 0\n" : '';
46             /mge;
47             $pattern =~ s/\$RV/
48                 ($] < 5.011) ? 'RV' : 'IV';
49             /mge;
50             $pattern =~ s/^ *\$NV *\n/
51                 ($] < 5.011) ? "    NV = 0\n" : '';
52             /mge;
53
54             print $pattern, "\n" if $DEBUG;
55             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
56             print $dump, "\n"    if $DEBUG;
57             like( $dump, qr/\A$pattern\Z/ms );
58
59             local $TODO = $dump2 =~ /OOK/ ? "The hash iterator used in dump.c sets the OOK flag" : undef;
60             is($dump2, $dump);
61
62             close(IN);
63
64             return $1;
65         } else {
66             die "$0: failed to open peek$$: !\n";
67         }
68     } else {
69         die "$0: failed to create peek$$: $!\n";
70     }
71 }
72
73 our   $a;
74 our   $b;
75 my    $c;
76 local $d = 0;
77
78 END {
79     1 while unlink("peek$$");
80 }
81
82 do_test( 1,
83         $a = "foo",
84 'SV = PV\\($ADDR\\) at $ADDR
85   REFCNT = 1
86   FLAGS = \\(POK,pPOK\\)
87   PV = $ADDR "foo"\\\0
88   CUR = 3
89   LEN = \\d+'
90        );
91
92 do_test( 2,
93         "bar",
94 'SV = PV\\($ADDR\\) at $ADDR
95   REFCNT = 1
96   FLAGS = \\(.*POK,READONLY,pPOK\\)
97   PV = $ADDR "bar"\\\0
98   CUR = 3
99   LEN = \\d+');
100
101 do_test( 3,
102         $b = 123,
103 'SV = IV\\($ADDR\\) at $ADDR
104   REFCNT = 1
105   FLAGS = \\(IOK,pIOK\\)
106   IV = 123');
107
108 do_test( 4,
109         456,
110 'SV = IV\\($ADDR\\) at $ADDR
111   REFCNT = 1
112   FLAGS = \\(.*IOK,READONLY,pIOK\\)
113   IV = 456');
114
115 do_test( 5,
116         $c = 456,
117 'SV = IV\\($ADDR\\) at $ADDR
118   REFCNT = 1
119   FLAGS = \\(PADMY,IOK,pIOK\\)
120   IV = 456');
121
122 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
123 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
124 # maths is done in floating point always, and this scalar will be an NV.
125 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
126 # building subsequent regexps.
127 my $type = do_test( 6,
128         $c + $d,
129 'SV = ([NI])V\\($ADDR\\) at $ADDR
130   REFCNT = 1
131   FLAGS = \\(PADTMP,\1OK,p\1OK\\)
132   \1V = 456');
133
134 ($d = "789") += 0.1;
135
136 do_test( 7,
137        $d,
138 'SV = PVNV\\($ADDR\\) at $ADDR
139   REFCNT = 1
140   FLAGS = \\(NOK,pNOK\\)
141   IV = \d+
142   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
143   PV = $ADDR "789"\\\0
144   CUR = 3
145   LEN = \\d+');
146
147 do_test( 8,
148         0xabcd,
149 'SV = IV\\($ADDR\\) at $ADDR
150   REFCNT = 1
151   FLAGS = \\(.*IOK,READONLY,pIOK\\)
152   IV = 43981');
153
154 do_test( 9,
155         undef,
156 'SV = NULL\\(0x0\\) at $ADDR
157   REFCNT = 1
158   FLAGS = \\(\\)');
159
160 do_test(10,
161         \$a,
162 'SV = $RV\\($ADDR\\) at $ADDR
163   REFCNT = 1
164   FLAGS = \\(ROK\\)
165   RV = $ADDR
166   SV = PV\\($ADDR\\) at $ADDR
167     REFCNT = 2
168     FLAGS = \\(POK,pPOK\\)
169     PV = $ADDR "foo"\\\0
170     CUR = 3
171     LEN = \\d+');
172
173 my $c_pattern;
174 if ($type eq 'N') {
175   $c_pattern = '
176     SV = PVNV\\($ADDR\\) at $ADDR
177       REFCNT = 1
178       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
179       IV = 456
180       NV = 456
181       PV = 0';
182 } else {
183   $c_pattern = '
184     SV = IV\\($ADDR\\) at $ADDR
185       REFCNT = 1
186       FLAGS = \\(IOK,pIOK\\)
187       IV = 456';
188 }
189 do_test(11,
190        [$b,$c],
191 'SV = $RV\\($ADDR\\) at $ADDR
192   REFCNT = 1
193   FLAGS = \\(ROK\\)
194   RV = $ADDR
195   SV = PVAV\\($ADDR\\) at $ADDR
196     REFCNT = 1
197     FLAGS = \\(\\)
198     ARRAY = $ADDR
199     FILL = 1
200     MAX = 1
201     ARYLEN = 0x0
202     FLAGS = \\(REAL\\)
203     Elt No. 0
204     SV = IV\\($ADDR\\) at $ADDR
205       REFCNT = 1
206       FLAGS = \\(IOK,pIOK\\)
207       IV = 123
208     Elt No. 1' . $c_pattern);
209
210 do_test(12,
211        {$b=>$c},
212 'SV = $RV\\($ADDR\\) at $ADDR
213   REFCNT = 1
214   FLAGS = \\(ROK\\)
215   RV = $ADDR
216   SV = PVHV\\($ADDR\\) at $ADDR
217     REFCNT = 1
218     FLAGS = \\(SHAREKEYS\\)
219     ARRAY = $ADDR  \\(0:7, 1:1\\)
220     hash quality = 100.0%
221     KEYS = 1
222     FILL = 1
223     MAX = 7
224     RITER = -1
225     EITER = 0x0
226     Elt "123" HASH = $ADDR' . $c_pattern);
227
228 do_test(13,
229         sub(){@_},
230 'SV = $RV\\($ADDR\\) at $ADDR
231   REFCNT = 1
232   FLAGS = \\(ROK\\)
233   RV = $ADDR
234   SV = PVCV\\($ADDR\\) at $ADDR
235     REFCNT = 2
236     FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
237     $IVNV
238     PROTOTYPE = ""
239     COMP_STASH = $ADDR\\t"main"
240     START = $ADDR ===> \\d+
241     ROOT = $ADDR
242     $XSUB
243     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
244     FILE = ".*\\b(?i:peek\\.t)"
245     DEPTH = 0
246 (?:    MUTEXP = $ADDR
247     OWNER = $ADDR
248 )?    FLAGS = 0x90
249     OUTSIDE_SEQ = \\d+
250     PADLIST = $ADDR
251     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
252     OUTSIDE = $ADDR \\(MAIN\\)');
253
254 do_test(14,
255         \&do_test,
256 'SV = $RV\\($ADDR\\) at $ADDR
257   REFCNT = 1
258   FLAGS = \\(ROK\\)
259   RV = $ADDR
260   SV = PVCV\\($ADDR\\) at $ADDR
261     REFCNT = (3|4)
262     FLAGS = \\(\\)
263     $IVNV
264     COMP_STASH = $ADDR\\t"main"
265     START = $ADDR ===> \\d+
266     ROOT = $ADDR
267     $XSUB
268     GVGV::GV = $ADDR\\t"main" :: "do_test"
269     FILE = ".*\\b(?i:peek\\.t)"
270     DEPTH = 1
271 (?:    MUTEXP = $ADDR
272     OWNER = $ADDR
273 )?    FLAGS = 0x0
274     OUTSIDE_SEQ = \\d+
275     PADLIST = $ADDR
276     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
277        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
278       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
279       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
280       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
281     OUTSIDE = $ADDR \\(MAIN\\)');
282
283 if ($] >= 5.011) {
284 do_test(15,
285         qr(tic),
286 'SV = $RV\\($ADDR\\) at $ADDR
287   REFCNT = 1
288   FLAGS = \\(ROK\\)
289   RV = $ADDR
290   SV = REGEXP\\($ADDR\\) at $ADDR
291     REFCNT = 2
292     FLAGS = \\(OBJECT,POK,pPOK\\)
293     IV = 0
294     PV = $ADDR "\\(\\?-xism:tic\\)"\\\0
295     CUR = 12
296     LEN = \\d+
297     STASH = $ADDR\\t"Regexp"');
298 } else {
299 do_test(15,
300         qr(tic),
301 'SV = $RV\\($ADDR\\) at $ADDR
302   REFCNT = 1
303   FLAGS = \\(ROK\\)
304   RV = $ADDR
305   SV = PVMG\\($ADDR\\) at $ADDR
306     REFCNT = 1
307     FLAGS = \\(OBJECT,SMG\\)
308     IV = 0
309     NV = 0
310     PV = 0
311     MAGIC = $ADDR
312       MG_VIRTUAL = $ADDR
313       MG_TYPE = PERL_MAGIC_qr\(r\)
314       MG_OBJ = $ADDR
315         PAT = "\(\?-xism:tic\)"
316         REFCNT = 2
317     STASH = $ADDR\\t"Regexp"');
318 }
319
320 do_test(16,
321         (bless {}, "Tac"),
322 'SV = $RV\\($ADDR\\) at $ADDR
323   REFCNT = 1
324   FLAGS = \\(ROK\\)
325   RV = $ADDR
326   SV = PVHV\\($ADDR\\) at $ADDR
327     REFCNT = 1
328     FLAGS = \\(OBJECT,SHAREKEYS\\)
329     STASH = $ADDR\\t"Tac"
330     ARRAY = 0x0
331     KEYS = 0
332     FILL = 0
333     MAX = 7
334     RITER = -1
335     EITER = 0x0');
336
337 do_test(17,
338         *a,
339 'SV = PVGV\\($ADDR\\) at $ADDR
340   REFCNT = 5
341   FLAGS = \\(MULTI(?:,IN_PAD)?\\)
342   NAME = "a"
343   NAMELEN = 1
344   GvSTASH = $ADDR\\t"main"
345   GP = $ADDR
346     SV = $ADDR
347     REFCNT = 1
348     IO = 0x0
349     FORM = 0x0  
350     AV = 0x0
351     HV = 0x0
352     CV = 0x0
353     CVGEN = 0x0
354     LINE = \\d+
355     FILE = ".*\\b(?i:peek\\.t)"
356     FLAGS = $ADDR
357     EGV = $ADDR\\t"a"');
358
359 if (ord('A') == 193) {
360 do_test(18,
361         chr(256).chr(0).chr(512),
362 'SV = PV\\($ADDR\\) at $ADDR
363   REFCNT = 1
364   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
365   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
366   CUR = 5
367   LEN = \\d+');
368 } else {
369 do_test(18,
370         chr(256).chr(0).chr(512),
371 'SV = PV\\($ADDR\\) at $ADDR
372   REFCNT = 1
373   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
374   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
375   CUR = 5
376   LEN = \\d+');
377 }
378
379 if (ord('A') == 193) {
380 do_test(19,
381         {chr(256)=>chr(512)},
382 'SV = $RV\\($ADDR\\) at $ADDR
383   REFCNT = 1
384   FLAGS = \\(ROK\\)
385   RV = $ADDR
386   SV = PVHV\\($ADDR\\) at $ADDR
387     REFCNT = 1
388     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
389     ARRAY = $ADDR  \\(0:7, 1:1\\)
390     hash quality = 100.0%
391     KEYS = 1
392     FILL = 1
393     MAX = 7
394     RITER = -1
395     EITER = $ADDR
396     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
397     SV = PV\\($ADDR\\) at $ADDR
398       REFCNT = 1
399       FLAGS = \\(POK,pPOK,UTF8\\)
400       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
401       CUR = 2
402       LEN = \\d+');
403 } else {
404 do_test(19,
405         {chr(256)=>chr(512)},
406 'SV = $RV\\($ADDR\\) at $ADDR
407   REFCNT = 1
408   FLAGS = \\(ROK\\)
409   RV = $ADDR
410   SV = PVHV\\($ADDR\\) at $ADDR
411     REFCNT = 1
412     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
413     ARRAY = $ADDR  \\(0:7, 1:1\\)
414     hash quality = 100.0%
415     KEYS = 1
416     FILL = 1
417     MAX = 7
418     RITER = -1
419     EITER = $ADDR
420     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
421     SV = PV\\($ADDR\\) at $ADDR
422       REFCNT = 1
423       FLAGS = \\(POK,pPOK,UTF8\\)
424       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
425       CUR = 2
426       LEN = \\d+');
427 }
428
429 my $x="";
430 $x=~/.??/g;
431 do_test(20,
432         $x,
433 'SV = PVMG\\($ADDR\\) at $ADDR
434   REFCNT = 1
435   FLAGS = \\(PADMY,SMG,POK,pPOK\\)
436   IV = 0
437   NV = 0
438   PV = $ADDR ""\\\0
439   CUR = 0
440   LEN = \d+
441   MAGIC = $ADDR
442     MG_VIRTUAL = &PL_vtbl_mglob
443     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
444     MG_FLAGS = 0x01
445       MINMATCH');
446
447 #
448 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
449 # environment variables may be invisibly case-forced, hence the (?i:PATH)
450 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
451 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
452 # ENV hashes is also not always null terminated.
453 #
454 do_test(21,
455         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
456 'SV = PVMG\\($ADDR\\) at $ADDR
457   REFCNT = 1
458   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
459   IV = 0
460   NV = 0
461   PV = $ADDR "0"\\\0
462   CUR = 1
463   LEN = \d+
464   MAGIC = $ADDR
465     MG_VIRTUAL = &PL_vtbl_envelem
466     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
467 (?:    MG_FLAGS = 0x01
468       TAINTEDDIR
469 )?    MG_LEN = -?\d+
470     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
471     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
472       REFCNT = \d+
473       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
474 (?:      IV = 0
475 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
476       CUR = \d+
477       LEN = \d+)
478   MAGIC = $ADDR
479     MG_VIRTUAL = &PL_vtbl_taint
480     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
481
482 # blessed refs
483 do_test(22,
484         bless(\\undef, 'Foobar'),
485 'SV = $RV\\($ADDR\\) at $ADDR
486   REFCNT = 1
487   FLAGS = \\(ROK\\)
488   RV = $ADDR
489   SV = PVMG\\($ADDR\\) at $ADDR
490     REFCNT = 2
491     FLAGS = \\(OBJECT,ROK\\)
492     IV = -?\d+
493     NV = $FLOAT
494     RV = $ADDR
495     SV = NULL\\(0x0\\) at $ADDR
496       REFCNT = \d+
497       FLAGS = \\(READONLY\\)
498     PV = $ADDR ""
499     CUR = 0
500     LEN = 0
501     STASH = $ADDR\s+"Foobar"');
502
503 # Constant subroutines
504
505 sub const () {
506     "Perl rules";
507 }
508
509 do_test(23,
510         \&const,
511 'SV = $RV\\($ADDR\\) at $ADDR
512   REFCNT = 1
513   FLAGS = \\(ROK\\)
514   RV = $ADDR
515   SV = PVCV\\($ADDR\\) at $ADDR
516     REFCNT = (2)
517     FLAGS = \\(POK,pPOK,CONST\\)
518     $IVNV
519     PROTOTYPE = ""
520     COMP_STASH = 0x0
521     $ROOT
522     XSUB = $ADDR
523     XSUBANY = $ADDR \\(CONST SV\\)
524     SV = PV\\($ADDR\\) at $ADDR
525       REFCNT = 1
526       FLAGS = \\(.*POK,READONLY,pPOK\\)
527       PV = $ADDR "Perl rules"\\\0
528       CUR = 10
529       LEN = \\d+
530     GVGV::GV = $ADDR\\t"main" :: "const"
531     FILE = ".*\\b(?i:peek\\.t)"
532     DEPTH = 0
533 (?:    MUTEXP = $ADDR
534     OWNER = $ADDR
535 )?    FLAGS = 0xc00
536     OUTSIDE_SEQ = 0
537     PADLIST = 0x0
538     OUTSIDE = 0x0 \\(null\\)'); 
539
540 # isUV should show on PVMG
541 do_test(24,
542         do { my $v = $1; $v = ~0; $v },
543 'SV = PVMG\\($ADDR\\) at $ADDR
544   REFCNT = 1
545   FLAGS = \\(IOK,pIOK,IsUV\\)
546   UV = \d+
547   NV = 0
548   PV = 0');
549
550 do_test(25,
551         *STDOUT{IO},
552 'SV = $RV\\($ADDR\\) at $ADDR
553   REFCNT = 1
554   FLAGS = \\(ROK\\)
555   RV = $ADDR
556   SV = PVIO\\($ADDR\\) at $ADDR
557     REFCNT = 3
558     FLAGS = \\(OBJECT\\)
559     IV = 0
560     $NV
561     STASH = $ADDR\s+"IO::Handle"
562     IFP = $ADDR
563     OFP = $ADDR
564     DIRP = 0x0
565     LINES = 0
566     PAGE = 0
567     PAGE_LEN = 60
568     LINES_LEFT = 0
569     TOP_GV = 0x0
570     FMT_GV = 0x0
571     BOTTOM_GV = 0x0
572     TYPE = \'>\'
573     FLAGS = 0x0');