This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Slightly better failure output.
[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             print $pattern, "\n" if $DEBUG;
32             my $dump = <IN>;
33             print $dump, "\n"    if $DEBUG;
34             print "got:\n[\n$dump\n]\nexpected:\n[\n$pattern\n]\nnot "
35                 unless $dump =~ /\A$pattern\Z/ms;
36             print "ok $_[0]\n";
37             close(IN);
38             return $1;
39         } else {
40             die "$0: failed to open peek$$: !\n";
41         }
42     } else {
43         die "$0: failed to create peek$$: $!\n";
44     }
45 }
46
47 our   $a;
48 our   $b;
49 my    $c;
50 local $d = 0;
51
52 do_test( 1,
53         $a = "foo",
54 'SV = PV\\($ADDR\\) at $ADDR
55   REFCNT = 1
56   FLAGS = \\(POK,pPOK\\)
57   PV = $ADDR "foo"\\\0
58   CUR = 3
59   LEN = \\d+'
60        );
61
62 do_test( 2,
63         "bar",
64 'SV = PV\\($ADDR\\) at $ADDR
65   REFCNT = 1
66   FLAGS = \\(.*POK,READONLY,pPOK\\)
67   PV = $ADDR "bar"\\\0
68   CUR = 3
69   LEN = \\d+');
70
71 do_test( 3,
72         $b = 123,
73 'SV = IV\\($ADDR\\) at $ADDR
74   REFCNT = 1
75   FLAGS = \\(IOK,pIOK\\)
76   IV = 123');
77
78 do_test( 4,
79         456,
80 'SV = IV\\($ADDR\\) at $ADDR
81   REFCNT = 1
82   FLAGS = \\(.*IOK,READONLY,pIOK\\)
83   IV = 456');
84
85 do_test( 5,
86         $c = 456,
87 'SV = IV\\($ADDR\\) at $ADDR
88   REFCNT = 1
89   FLAGS = \\(PADMY,IOK,pIOK\\)
90   IV = 456');
91
92 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
93 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
94 # maths is done in floating point always, and this scalar will be an NV.
95 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
96 # building subsequent regexps.
97 my $type = do_test( 6,
98         $c + $d,
99 'SV = ([NI])V\\($ADDR\\) at $ADDR
100   REFCNT = 1
101   FLAGS = \\(PADTMP,\1OK,p\1OK\\)
102   \1V = 456');
103
104 ($d = "789") += 0.1;
105
106 do_test( 7,
107        $d,
108 'SV = PVNV\\($ADDR\\) at $ADDR
109   REFCNT = 1
110   FLAGS = \\(NOK,pNOK\\)
111   IV = 0
112   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
113   PV = $ADDR "789"\\\0
114   CUR = 3
115   LEN = \\d+');
116
117 do_test( 8,
118         0xabcd,
119 'SV = IV\\($ADDR\\) at $ADDR
120   REFCNT = 1
121   FLAGS = \\(.*IOK,READONLY,pIOK\\)
122   IV = 43981');
123
124 do_test( 9,
125         undef,
126 'SV = NULL\\(0x0\\) at $ADDR
127   REFCNT = 1
128   FLAGS = \\(\\)');
129
130 do_test(10,
131         \$a,
132 'SV = RV\\($ADDR\\) at $ADDR
133   REFCNT = 1
134   FLAGS = \\(ROK\\)
135   RV = $ADDR
136   SV = PV\\($ADDR\\) at $ADDR
137     REFCNT = 2
138     FLAGS = \\(POK,pPOK\\)
139     PV = $ADDR "foo"\\\0
140     CUR = 3
141     LEN = \\d+');
142
143 my $c_pattern;
144 if ($type eq 'N') {
145   $c_pattern = '
146     SV = PVNV\\($ADDR\\) at $ADDR
147       REFCNT = 1
148       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
149       IV = 456
150       NV = 456
151       PV = 0';
152 } else {
153   $c_pattern = '
154     SV = IV\\($ADDR\\) at $ADDR
155       REFCNT = 1
156       FLAGS = \\(IOK,pIOK\\)
157       IV = 456';
158 }
159 do_test(11,
160        [$b,$c],
161 'SV = RV\\($ADDR\\) at $ADDR
162   REFCNT = 1
163   FLAGS = \\(ROK\\)
164   RV = $ADDR
165   SV = PVAV\\($ADDR\\) at $ADDR
166     REFCNT = 2
167     FLAGS = \\(\\)
168     IV = 0
169     NV = 0
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     IV = 1
192     NV = $FLOAT
193     ARRAY = $ADDR  \\(0:7, 1:1\\)
194     hash quality = 100.0%
195     KEYS = 1
196     FILL = 1
197     MAX = 7
198     RITER = -1
199     EITER = 0x0
200     Elt "123" HASH = $ADDR' . $c_pattern);
201
202 do_test(13,
203         sub(){@_},
204 'SV = RV\\($ADDR\\) at $ADDR
205   REFCNT = 1
206   FLAGS = \\(ROK\\)
207   RV = $ADDR
208   SV = PVCV\\($ADDR\\) at $ADDR
209     REFCNT = 2
210     FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
211     IV = 0
212     NV = 0
213     PROTOTYPE = ""
214     COMP_STASH = $ADDR\\t"main"
215     START = $ADDR ===> \\d+
216     ROOT = $ADDR
217     XSUB = 0x0
218     XSUBANY = 0
219     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
220     FILE = ".*\\b(?i:peek\\.t)"
221     DEPTH = 0
222 (?:    MUTEXP = $ADDR
223     OWNER = $ADDR
224 )?    FLAGS = 0x404
225     OUTSIDE_SEQ = \\d+
226     PADLIST = $ADDR
227     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
228     OUTSIDE = $ADDR \\(MAIN\\)');
229
230 do_test(14,
231         \&do_test,
232 'SV = RV\\($ADDR\\) at $ADDR
233   REFCNT = 1
234   FLAGS = \\(ROK\\)
235   RV = $ADDR
236   SV = PVCV\\($ADDR\\) at $ADDR
237     REFCNT = (3|4)
238     FLAGS = \\(\\)
239     IV = 0
240     NV = 0
241     COMP_STASH = $ADDR\\t"main"
242     START = $ADDR ===> \\d+
243     ROOT = $ADDR
244     XSUB = 0x0
245     XSUBANY = 0
246     GVGV::GV = $ADDR\\t"main" :: "do_test"
247     FILE = ".*\\b(?i:peek\\.t)"
248     DEPTH = 1
249 (?:    MUTEXP = $ADDR
250     OWNER = $ADDR
251 )?    FLAGS = 0x0
252     OUTSIDE_SEQ = \\d+
253     PADLIST = $ADDR
254     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
255        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
256       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
257       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
258     OUTSIDE = $ADDR \\(MAIN\\)');
259
260 do_test(15,
261         qr(tic),
262 'SV = RV\\($ADDR\\) at $ADDR
263   REFCNT = 1
264   FLAGS = \\(ROK\\)
265   RV = $ADDR
266   SV = PVMG\\($ADDR\\) at $ADDR
267     REFCNT = 1
268     FLAGS = \\(OBJECT,SMG\\)
269     IV = 0
270     NV = 0
271     PV = 0
272     MAGIC = $ADDR
273       MG_VIRTUAL = $ADDR
274       MG_TYPE = PERL_MAGIC_qr\(r\)
275       MG_OBJ = $ADDR
276     STASH = $ADDR\\t"Regexp"');
277
278 do_test(16,
279         (bless {}, "Tac"),
280 'SV = RV\\($ADDR\\) at $ADDR
281   REFCNT = 1
282   FLAGS = \\(ROK\\)
283   RV = $ADDR
284   SV = PVHV\\($ADDR\\) at $ADDR
285     REFCNT = 2
286     FLAGS = \\(OBJECT,SHAREKEYS\\)
287     IV = 0
288     NV = 0
289     STASH = $ADDR\\t"Tac"
290     ARRAY = 0x0
291     KEYS = 0
292     FILL = 0
293     MAX = 7
294     RITER = -1
295     EITER = 0x0');
296
297 do_test(17,
298         *a,
299 'SV = PVGV\\($ADDR\\) at $ADDR
300   REFCNT = 5
301   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
302   IV = 0
303   NV = 0
304   MAGIC = $ADDR
305     MG_VIRTUAL = &PL_vtbl_glob
306     MG_TYPE = PERL_MAGIC_glob\(\*\)
307     MG_OBJ = $ADDR
308   NAME = "a"
309   NAMELEN = 1
310   GvSTASH = $ADDR\\t"main"
311   GP = $ADDR
312     SV = $ADDR
313     REFCNT = 1
314     IO = 0x0
315     FORM = 0x0  
316     AV = 0x0
317     HV = 0x0
318     CV = 0x0
319     CVGEN = 0x0
320     GPFLAGS = 0x0
321     LINE = \\d+
322     FILE = ".*\\b(?i:peek\\.t)"
323     FLAGS = $ADDR
324     EGV = $ADDR\\t"a"');
325
326 if (ord('A') == 193) {
327 do_test(18,
328         chr(256).chr(0).chr(512),
329 'SV = PV\\($ADDR\\) at $ADDR
330   REFCNT = 1
331   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
332   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
333   CUR = 5
334   LEN = \\d+');
335 } else {
336 do_test(18,
337         chr(256).chr(0).chr(512),
338 'SV = PV\\($ADDR\\) at $ADDR
339   REFCNT = 1
340   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
341   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
342   CUR = 5
343   LEN = \\d+');
344 }
345
346 if (ord('A') == 193) {
347 do_test(19,
348         {chr(256)=>chr(512)},
349 'SV = RV\\($ADDR\\) at $ADDR
350   REFCNT = 1
351   FLAGS = \\(ROK\\)
352   RV = $ADDR
353   SV = PVHV\\($ADDR\\) at $ADDR
354     REFCNT = 2
355     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
356     UV = 1
357     NV = $FLOAT
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     UV = 1
383     NV = 0
384     ARRAY = $ADDR  \\(0:7, 1:1\\)
385     hash quality = 100.0%
386     KEYS = 1
387     FILL = 1
388     MAX = 7
389     RITER = -1
390     EITER = $ADDR
391     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
392     SV = PV\\($ADDR\\) at $ADDR
393       REFCNT = 1
394       FLAGS = \\(POK,pPOK,UTF8\\)
395       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
396       CUR = 2
397       LEN = \\d+');
398 }
399
400 my $x="";
401 $x=~/.??/g;
402 do_test(20,
403         $x,
404 'SV = PVMG\\($ADDR\\) at $ADDR
405   REFCNT = 1
406   FLAGS = \\(PADMY,SMG,POK,pPOK\\)
407   IV = 0
408   NV = 0
409   PV = $ADDR ""\\\0
410   CUR = 0
411   LEN = 1
412   MAGIC = $ADDR
413     MG_VIRTUAL = &PL_vtbl_mglob
414     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
415     MG_FLAGS = 0x01
416       MINMATCH');
417
418 #
419 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
420 # environment variables may be invisibly case-forced, hence the (?i:PATH)
421 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
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,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"');