UTF-EBCDIC.
[p5sagit/p5-mst-13.2.git] / ext / Devel / Peek / Peek.t
1 #!./perl
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..19\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             print $pattern, "\n" if $DEBUG;
31             my $dump = <IN>;
32             print $dump, "\n"    if $DEBUG;
33             print "[$dump] vs [$pattern]\nnot " unless $dump =~ /$pattern/ms;
34             print "ok $_[0]\n";
35             close(IN);
36             return $1;
37         } else {
38             die "$0: failed to open peek$$: !\n";
39         }
40     } else {
41         die "$0: failed to create peek$$: $!\n";
42     }
43 }
44
45 our   $a;
46 our   $b;
47 my    $c;
48 local $d = 0;
49
50 do_test( 1,
51         $a = "foo",
52 'SV = PV\\($ADDR\\) at $ADDR
53   REFCNT = 1
54   FLAGS = \\(POK,pPOK\\)
55   PV = $ADDR "foo"\\\0
56   CUR = 3
57   LEN = 4'
58        );
59
60 do_test( 2,
61         "bar",
62 'SV = PV\\($ADDR\\) at $ADDR
63   REFCNT = 1
64   FLAGS = \\(.*POK,READONLY,pPOK\\)
65   PV = $ADDR "bar"\\\0
66   CUR = 3
67   LEN = 4');
68
69 do_test( 3,
70         $b = 123,
71 'SV = IV\\($ADDR\\) at $ADDR
72   REFCNT = 1
73   FLAGS = \\(IOK,pIOK\\)
74   IV = 123');
75
76 do_test( 4,
77         456,
78 'SV = IV\\($ADDR\\) at $ADDR
79   REFCNT = 1
80   FLAGS = \\(.*IOK,READONLY,pIOK\\)
81   IV = 456');
82
83 do_test( 5,
84         $c = 456,
85 'SV = IV\\($ADDR\\) at $ADDR
86   REFCNT = 1
87   FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\)
88   IV = 456');
89
90 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
91 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
92 # maths is done in floating point always, and this scalar will be an NV.
93 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
94 # building subsequent regexps.
95 my $type = do_test( 6,
96         $c + $d,
97 'SV = ([NI])V\\($ADDR\\) at $ADDR
98   REFCNT = 1
99   FLAGS = \\(PADTMP,\1OK,p\1OK\\)
100   \1V = 456');
101
102 ($d = "789") += 0.1;
103
104 do_test( 7,
105        $d,
106 'SV = PVNV\\($ADDR\\) at $ADDR
107   REFCNT = 1
108   FLAGS = \\(NOK,pNOK\\)
109   IV = 0
110   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
111   PV = $ADDR "789"\\\0
112   CUR = 3
113   LEN = 4');
114
115 do_test( 8,
116         0xabcd,
117 'SV = IV\\($ADDR\\) at $ADDR
118   REFCNT = 1
119   FLAGS = \\(.*IOK,READONLY,pIOK\\)
120   IV = 43981');
121
122 do_test( 9,
123         undef,
124 'SV = NULL\\(0x0\\) at $ADDR
125   REFCNT = 1
126   FLAGS = \\(\\)');
127
128 do_test(10,
129         \$a,
130 'SV = RV\\($ADDR\\) at $ADDR
131   REFCNT = 1
132   FLAGS = \\(ROK\\)
133   RV = $ADDR
134   SV = PV\\($ADDR\\) at $ADDR
135     REFCNT = 2
136     FLAGS = \\(POK,pPOK\\)
137     PV = $ADDR "foo"\\\0
138     CUR = 3
139     LEN = 4');
140
141 my $c_pattern;
142 if ($type eq 'N') {
143   $c_pattern = '
144     SV = PVNV\\($ADDR\\) at $ADDR
145       REFCNT = 1
146       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
147       IV = 456
148       NV = 456
149       PV = 0';
150 } else {
151   $c_pattern = '
152     SV = IV\\($ADDR\\) at $ADDR
153       REFCNT = 1
154       FLAGS = \\(IOK,pIOK\\)
155       IV = 456';
156 }
157 do_test(11,
158        [$b,$c],
159 'SV = RV\\($ADDR\\) at $ADDR
160   REFCNT = 1
161   FLAGS = \\(ROK\\)
162   RV = $ADDR
163   SV = PVAV\\($ADDR\\) at $ADDR
164     REFCNT = 2
165     FLAGS = \\(\\)
166     IV = 0
167     NV = 0
168     ARRAY = $ADDR
169     FILL = 1
170     MAX = 1
171     ARYLEN = 0x0
172     FLAGS = \\(REAL\\)
173     Elt No. 0
174     SV = IV\\($ADDR\\) at $ADDR
175       REFCNT = 1
176       FLAGS = \\(IOK,pIOK\\)
177       IV = 123
178     Elt No. 1' . $c_pattern);
179
180 do_test(12,
181        {$b=>$c},
182 'SV = RV\\($ADDR\\) at $ADDR
183   REFCNT = 1
184   FLAGS = \\(ROK\\)
185   RV = $ADDR
186   SV = PVHV\\($ADDR\\) at $ADDR
187     REFCNT = 2
188     FLAGS = \\(SHAREKEYS\\)
189     IV = 1
190     NV = 0
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 = \\(PADBUSY,PADMY,POK,pPOK,ANON\\)
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 = 0x4
223     PADLIST = $ADDR
224     OUTSIDE = $ADDR \\(MAIN\\)');
225
226 do_test(14,
227         \&do_test,
228 'SV = RV\\($ADDR\\) at $ADDR
229   REFCNT = 1
230   FLAGS = \\(ROK\\)
231   RV = $ADDR
232   SV = PVCV\\($ADDR\\) at $ADDR
233     REFCNT = (3|4)
234     FLAGS = \\(\\)
235     IV = 0
236     NV = 0
237     COMP_STASH = $ADDR\\t"main"
238     START = $ADDR ===> \\d+
239     ROOT = $ADDR
240     XSUB = 0x0
241     XSUBANY = 0
242     GVGV::GV = $ADDR\\t"main" :: "do_test"
243     FILE = ".*\\b(?i:peek\\.t)"
244     DEPTH = 1
245 (?:    MUTEXP = $ADDR
246     OWNER = $ADDR
247 )?    FLAGS = 0x0
248     PADLIST = $ADDR
249       \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
250      \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
251      \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
252     OUTSIDE = $ADDR \\(MAIN\\)');
253
254 do_test(15,
255         qr(tic),
256 'SV = RV\\($ADDR\\) at $ADDR
257   REFCNT = 1
258   FLAGS = \\(ROK\\)
259   RV = $ADDR
260   SV = PVMG\\($ADDR\\) at $ADDR
261     REFCNT = 1
262     FLAGS = \\(OBJECT,RMG\\)
263     IV = 0
264     NV = 0
265     PV = 0
266     MAGIC = $ADDR
267       MG_VIRTUAL = $ADDR
268       MG_TYPE = PERL_MAGIC_qr\(r\)
269       MG_OBJ = $ADDR
270     STASH = $ADDR\\t"Regexp"');
271
272 do_test(16,
273         (bless {}, "Tac"),
274 'SV = RV\\($ADDR\\) at $ADDR
275   REFCNT = 1
276   FLAGS = \\(ROK\\)
277   RV = $ADDR
278   SV = PVHV\\($ADDR\\) at $ADDR
279     REFCNT = 2
280     FLAGS = \\(OBJECT,SHAREKEYS\\)
281     IV = 0
282     NV = 0
283     STASH = $ADDR\\t"Tac"
284     ARRAY = 0x0
285     KEYS = 0
286     FILL = 0
287     MAX = 7
288     RITER = -1
289     EITER = 0x0');
290
291 do_test(17,
292         *a,
293 'SV = PVGV\\($ADDR\\) at $ADDR
294   REFCNT = 5
295   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
296   IV = 0
297   NV = 0
298   MAGIC = $ADDR
299     MG_VIRTUAL = &PL_vtbl_glob
300     MG_TYPE = PERL_MAGIC_glob\(\*\)
301     MG_OBJ = $ADDR
302   NAME = "a"
303   NAMELEN = 1
304   GvSTASH = $ADDR\\t"main"
305   GP = $ADDR
306     SV = $ADDR
307     REFCNT = 1
308     IO = 0x0
309     FORM = 0x0  
310     AV = 0x0
311     HV = 0x0
312     CV = 0x0
313     CVGEN = 0x0
314     GPFLAGS = 0x0
315     LINE = \\d+
316     FILE = ".*\\b(?i:peek\\.t)"
317     FLAGS = $ADDR
318     EGV = $ADDR\\t"a"');
319
320 if (ord('A') == 193) {
321 do_test(18,
322         chr(256).chr(0).chr(512),
323 'SV = PV\\($ADDR\\) at $ADDR
324   REFCNT = 1
325   FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
326   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
327   CUR = 5
328   LEN = 6');
329 } else {
330 do_test(18,
331         chr(256).chr(0).chr(512),
332 'SV = PV\\($ADDR\\) at $ADDR
333   REFCNT = 1
334   FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
335   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
336   CUR = 5
337   LEN = 6');
338 }
339
340 if (ord('A') == 193) {
341 do_test(19,
342         {chr(256)=>chr(512)},
343 'SV = RV\\($ADDR\\) at $ADDR
344   REFCNT = 1
345   FLAGS = \\(ROK\\)
346   RV = $ADDR
347   SV = PVHV\\($ADDR\\) at $ADDR
348     REFCNT = 2
349     FLAGS = \\(SHAREKEYS\\)
350     IV = 1
351     NV = 0
352     ARRAY = $ADDR  \\(0:7, 1:1\\)
353     hash quality = 100.0%
354     KEYS = 1
355     FILL = 1
356     MAX = 7
357     RITER = -1
358     EITER = $ADDR
359     Elt "\\\241\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
360     SV = PV\\($ADDR\\) at $ADDR
361       REFCNT = 1
362       FLAGS = \\(POK,pPOK,UTF8\\)
363       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
364       CUR = 2
365       LEN = 3');
366 } else {
367 do_test(19,
368         {chr(256)=>chr(512)},
369 'SV = RV\\($ADDR\\) at $ADDR
370   REFCNT = 1
371   FLAGS = \\(ROK\\)
372   RV = $ADDR
373   SV = PVHV\\($ADDR\\) at $ADDR
374     REFCNT = 2
375     FLAGS = \\(SHAREKEYS\\)
376     IV = 1
377     NV = 0
378     ARRAY = $ADDR  \\(0:7, 1:1\\)
379     hash quality = 100.0%
380     KEYS = 1
381     FILL = 1
382     MAX = 7
383     RITER = -1
384     EITER = $ADDR
385     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
386     SV = PV\\($ADDR\\) at $ADDR
387       REFCNT = 1
388       FLAGS = \\(POK,pPOK,UTF8\\)
389       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
390       CUR = 2
391       LEN = 3');
392 }
393
394 END {
395   1 while unlink("peek$$");
396 }