This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make FAKE,READONLY optional on VMS in test 21
[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 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     ARRAY = $ADDR
171     FILL = 1
172     MAX = 1
173     ARYLEN = 0x0
174     FLAGS = \\(REAL\\)
175     Elt No. 0
176     SV = IV\\($ADDR\\) at $ADDR
177       REFCNT = 1
178       FLAGS = \\(IOK,pIOK\\)
179       IV = 123
180     Elt No. 1' . $c_pattern);
181
182 do_test(12,
183        {$b=>$c},
184 'SV = RV\\($ADDR\\) at $ADDR
185   REFCNT = 1
186   FLAGS = \\(ROK\\)
187   RV = $ADDR
188   SV = PVHV\\($ADDR\\) at $ADDR
189     REFCNT = 2
190     FLAGS = \\(SHAREKEYS\\)
191     ARRAY = $ADDR  \\(0:7, 1:1\\)
192     hash quality = 100.0%
193     KEYS = 1
194     FILL = 1
195     MAX = 7
196     RITER = -1
197     EITER = 0x0
198     Elt "123" HASH = $ADDR' . $c_pattern);
199
200 do_test(13,
201         sub(){@_},
202 'SV = RV\\($ADDR\\) at $ADDR
203   REFCNT = 1
204   FLAGS = \\(ROK\\)
205   RV = $ADDR
206   SV = PVCV\\($ADDR\\) at $ADDR
207     REFCNT = 2
208     FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
209     IV = 0
210     NV = 0
211     PROTOTYPE = ""
212     COMP_STASH = $ADDR\\t"main"
213     START = $ADDR ===> \\d+
214     ROOT = $ADDR
215     XSUB = 0x0
216     XSUBANY = 0
217     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
218     FILE = ".*\\b(?i:peek\\.t)"
219     DEPTH = 0
220 (?:    MUTEXP = $ADDR
221     OWNER = $ADDR
222 )?    FLAGS = 0x404
223     OUTSIDE_SEQ = \\d+
224     PADLIST = $ADDR
225     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
226     OUTSIDE = $ADDR \\(MAIN\\)');
227
228 do_test(14,
229         \&do_test,
230 'SV = RV\\($ADDR\\) at $ADDR
231   REFCNT = 1
232   FLAGS = \\(ROK\\)
233   RV = $ADDR
234   SV = PVCV\\($ADDR\\) at $ADDR
235     REFCNT = (3|4)
236     FLAGS = \\(\\)
237     IV = 0
238     NV = 0
239     COMP_STASH = $ADDR\\t"main"
240     START = $ADDR ===> \\d+
241     ROOT = $ADDR
242     XSUB = 0x0
243     XSUBANY = 0
244     GVGV::GV = $ADDR\\t"main" :: "do_test"
245     FILE = ".*\\b(?i:peek\\.t)"
246     DEPTH = 1
247 (?:    MUTEXP = $ADDR
248     OWNER = $ADDR
249 )?    FLAGS = 0x0
250     OUTSIDE_SEQ = \\d+
251     PADLIST = $ADDR
252     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
253        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
254       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
255       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
256     OUTSIDE = $ADDR \\(MAIN\\)');
257
258 do_test(15,
259         qr(tic),
260 'SV = RV\\($ADDR\\) at $ADDR
261   REFCNT = 1
262   FLAGS = \\(ROK\\)
263   RV = $ADDR
264   SV = PVMG\\($ADDR\\) at $ADDR
265     REFCNT = 1
266     FLAGS = \\(OBJECT,SMG\\)
267     IV = 0
268     NV = 0
269     PV = 0
270     MAGIC = $ADDR
271       MG_VIRTUAL = $ADDR
272       MG_TYPE = PERL_MAGIC_qr\(r\)
273       MG_OBJ = $ADDR
274     STASH = $ADDR\\t"Regexp"');
275
276 do_test(16,
277         (bless {}, "Tac"),
278 'SV = RV\\($ADDR\\) at $ADDR
279   REFCNT = 1
280   FLAGS = \\(ROK\\)
281   RV = $ADDR
282   SV = PVHV\\($ADDR\\) at $ADDR
283     REFCNT = 2
284     FLAGS = \\(OBJECT,SHAREKEYS\\)
285     STASH = $ADDR\\t"Tac"
286     ARRAY = 0x0
287     KEYS = 0
288     FILL = 0
289     MAX = 7
290     RITER = -1
291     EITER = 0x0');
292
293 do_test(17,
294         *a,
295 'SV = PVGV\\($ADDR\\) at $ADDR
296   REFCNT = 5
297   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
298   IV = 0
299   NV = 0
300   MAGIC = $ADDR
301     MG_VIRTUAL = &PL_vtbl_glob
302     MG_TYPE = PERL_MAGIC_glob\(\*\)
303     MG_OBJ = $ADDR
304   NAME = "a"
305   NAMELEN = 1
306   GvSTASH = $ADDR\\t"main"
307   GP = $ADDR
308     SV = $ADDR
309     REFCNT = 1
310     IO = 0x0
311     FORM = 0x0  
312     AV = 0x0
313     HV = 0x0
314     CV = 0x0
315     CVGEN = 0x0
316     LINE = \\d+
317     FILE = ".*\\b(?i:peek\\.t)"
318     FLAGS = $ADDR
319     EGV = $ADDR\\t"a"');
320
321 if (ord('A') == 193) {
322 do_test(18,
323         chr(256).chr(0).chr(512),
324 'SV = PV\\($ADDR\\) at $ADDR
325   REFCNT = 1
326   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
327   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
328   CUR = 5
329   LEN = \\d+');
330 } else {
331 do_test(18,
332         chr(256).chr(0).chr(512),
333 'SV = PV\\($ADDR\\) at $ADDR
334   REFCNT = 1
335   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
336   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
337   CUR = 5
338   LEN = \\d+');
339 }
340
341 if (ord('A') == 193) {
342 do_test(19,
343         {chr(256)=>chr(512)},
344 'SV = RV\\($ADDR\\) at $ADDR
345   REFCNT = 1
346   FLAGS = \\(ROK\\)
347   RV = $ADDR
348   SV = PVHV\\($ADDR\\) at $ADDR
349     REFCNT = 2
350     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
351     ARRAY = $ADDR  \\(0:7, 1:1\\)
352     hash quality = 100.0%
353     KEYS = 1
354     FILL = 1
355     MAX = 7
356     RITER = -1
357     EITER = $ADDR
358     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
359     SV = PV\\($ADDR\\) at $ADDR
360       REFCNT = 1
361       FLAGS = \\(POK,pPOK,UTF8\\)
362       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
363       CUR = 2
364       LEN = \\d+');
365 } else {
366 do_test(19,
367         {chr(256)=>chr(512)},
368 'SV = RV\\($ADDR\\) at $ADDR
369   REFCNT = 1
370   FLAGS = \\(ROK\\)
371   RV = $ADDR
372   SV = PVHV\\($ADDR\\) at $ADDR
373     REFCNT = 2
374     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
375     ARRAY = $ADDR  \\(0:7, 1:1\\)
376     hash quality = 100.0%
377     KEYS = 1
378     FILL = 1
379     MAX = 7
380     RITER = -1
381     EITER = $ADDR
382     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
383     SV = PV\\($ADDR\\) at $ADDR
384       REFCNT = 1
385       FLAGS = \\(POK,pPOK,UTF8\\)
386       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
387       CUR = 2
388       LEN = \\d+');
389 }
390
391 my $x="";
392 $x=~/.??/g;
393 do_test(20,
394         $x,
395 'SV = PVMG\\($ADDR\\) at $ADDR
396   REFCNT = 1
397   FLAGS = \\(PADMY,SMG,POK,pPOK\\)
398   IV = 0
399   NV = 0
400   PV = $ADDR ""\\\0
401   CUR = 0
402   LEN = \d+
403   MAGIC = $ADDR
404     MG_VIRTUAL = &PL_vtbl_mglob
405     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
406     MG_FLAGS = 0x01
407       MINMATCH');
408
409 #
410 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
411 # environment variables may be invisibly case-forced, hence the (?i:PATH)
412 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
413 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
414 # ENV hashes is also not always null terminated.
415 #
416 do_test(21,
417         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
418 'SV = PVMG\\($ADDR\\) at $ADDR
419   REFCNT = 1
420   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
421   IV = 0
422   NV = 0
423   PV = $ADDR "0"\\\0
424   CUR = 1
425   LEN = \d+
426   MAGIC = $ADDR
427     MG_VIRTUAL = &PL_vtbl_envelem
428     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
429 (?:    MG_FLAGS = 0x01
430       TAINTEDDIR
431 )?    MG_LEN = -?\d+
432     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
433     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
434       REFCNT = \d+
435       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
436 (?:      IV = 0
437 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
438       CUR = \d+
439       LEN = \d+)
440   MAGIC = $ADDR
441     MG_VIRTUAL = &PL_vtbl_taint
442     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
443
444 END {
445   1 while unlink("peek$$");
446 }
447
448 # blessed refs
449 do_test(22,
450         bless(\\undef, 'Foobar'),
451 'SV = RV\\($ADDR\\) at $ADDR
452   REFCNT = 1
453   FLAGS = \\(ROK\\)
454   RV = $ADDR
455   SV = PVMG\\($ADDR\\) at $ADDR
456     REFCNT = 2
457     FLAGS = \\(OBJECT,ROK\\)
458     IV = -?\d+
459     NV = $FLOAT
460     RV = $ADDR
461     SV = NULL\\(0x0\\) at $ADDR
462       REFCNT = \d+
463       FLAGS = \\(READONLY\\)
464     PV = $ADDR ""
465     CUR = 0
466     LEN = 0
467     STASH = $ADDR\s+"Foobar"');
468
469 # Constant subroutines
470
471 sub const () {
472     "Perl rules";
473 }
474
475 do_test(23,
476         \&const,
477 'SV = RV\\($ADDR\\) at $ADDR
478   REFCNT = 1
479   FLAGS = \\(ROK\\)
480   RV = $ADDR
481   SV = PVCV\\($ADDR\\) at $ADDR
482     REFCNT = (2)
483     FLAGS = \\(POK,pPOK,CONST\\)
484     IV = 0
485     NV = 0
486     PROTOTYPE = ""
487     COMP_STASH = 0x0
488     ROOT = 0x0
489     XSUB = $ADDR
490     XSUBANY = $ADDR \\(CONST SV\\)
491     SV = PV\\($ADDR\\) at $ADDR
492       REFCNT = 1
493       FLAGS = \\(.*POK,READONLY,pPOK\\)
494       PV = $ADDR "Perl rules"\\\0
495       CUR = 10
496       LEN = \\d+
497     GVGV::GV = $ADDR\\t"main" :: "const"
498     FILE = ".*\\b(?i:peek\\.t)"
499     DEPTH = 0
500 (?:    MUTEXP = $ADDR
501     OWNER = $ADDR
502 )?    FLAGS = 0x200
503     OUTSIDE_SEQ = 0
504     PADLIST = 0x0
505     OUTSIDE = 0x0 \\(null\\)');