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