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