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