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