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