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