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