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