This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make FAKE,READONLY optional on VMS in test 21
[perl5.git] / ext / Devel / Peek / t / Peek.t
CommitLineData
99331854 1#!./perl -T
9ec58fb7
JH
2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
9ec58fb7
JH
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
9248c45a
JH
13use Devel::Peek;
14
b1886099 15print "1..23\n";
9248c45a
JH
16
17our $DEBUG = 0;
277ddfaf 18open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
9248c45a
JH
19
20sub do_test {
21 my $pattern = pop;
277ddfaf
GS
22 if (open(OUT,">peek$$")) {
23 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
9248c45a 24 Dump($_[1]);
277ddfaf
GS
25 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
26 close(OUT);
9248c45a
JH
27 if (open(IN, "peek$$")) {
28 local $/;
29 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
8aacddc1 30 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
fd0854ff 31 # handle DEBUG_LEAKING_SCALARS prefix
d94a5950 32 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
9248c45a
JH
33 print $pattern, "\n" if $DEBUG;
34 my $dump = <IN>;
35 print $dump, "\n" if $DEBUG;
dc3aa7ec
JH
36 print "got:\n[\n$dump\n]\nexpected:\n[\n$pattern\n]\nnot "
37 unless $dump =~ /\A$pattern\Z/ms;
9248c45a
JH
38 print "ok $_[0]\n";
39 close(IN);
59d8ce62 40 return $1;
9248c45a
JH
41 } else {
42 die "$0: failed to open peek$$: !\n";
43 }
44 } else {
45 die "$0: failed to create peek$$: $!\n";
46 }
47}
48
49our $a;
50our $b;
51my $c;
208edb77 52local $d = 0;
9248c45a
JH
53
54do_test( 1,
55 $a = "foo",
56'SV = PV\\($ADDR\\) at $ADDR
57 REFCNT = 1
58 FLAGS = \\(POK,pPOK\\)
59 PV = $ADDR "foo"\\\0
60 CUR = 3
1badabf5 61 LEN = \\d+'
9248c45a
JH
62 );
63
64do_test( 2,
65 "bar",
66'SV = PV\\($ADDR\\) at $ADDR
67 REFCNT = 1
7766e686 68 FLAGS = \\(.*POK,READONLY,pPOK\\)
9248c45a
JH
69 PV = $ADDR "bar"\\\0
70 CUR = 3
1badabf5 71 LEN = \\d+');
9248c45a
JH
72
73do_test( 3,
74 $b = 123,
75'SV = IV\\($ADDR\\) at $ADDR
76 REFCNT = 1
77 FLAGS = \\(IOK,pIOK\\)
78 IV = 123');
79
80do_test( 4,
81 456,
82'SV = IV\\($ADDR\\) at $ADDR
83 REFCNT = 1
7766e686 84 FLAGS = \\(.*IOK,READONLY,pIOK\\)
9248c45a
JH
85 IV = 456');
86
87do_test( 5,
88 $c = 456,
89'SV = IV\\($ADDR\\) at $ADDR
90 REFCNT = 1
235cc2e3 91 FLAGS = \\(PADMY,IOK,pIOK\\)
9248c45a
JH
92 IV = 456');
93
59d8ce62
NC
94# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
95# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
96# maths is done in floating point always, and this scalar will be an NV.
97# ([NI]) captures the type, referred to by \1 in this regexp and $type for
98# building subsequent regexps.
99my $type = do_test( 6,
9248c45a 100 $c + $d,
59d8ce62 101'SV = ([NI])V\\($ADDR\\) at $ADDR
9248c45a 102 REFCNT = 1
59d8ce62
NC
103 FLAGS = \\(PADTMP,\1OK,p\1OK\\)
104 \1V = 456');
9248c45a
JH
105
106($d = "789") += 0.1;
107
108do_test( 7,
109 $d,
110'SV = PVNV\\($ADDR\\) at $ADDR
111 REFCNT = 1
112 FLAGS = \\(NOK,pNOK\\)
113 IV = 0
ac634a9a 114 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
9248c45a
JH
115 PV = $ADDR "789"\\\0
116 CUR = 3
1badabf5 117 LEN = \\d+');
9248c45a
JH
118
119do_test( 8,
120 0xabcd,
121'SV = IV\\($ADDR\\) at $ADDR
122 REFCNT = 1
28e5dec8
JH
123 FLAGS = \\(.*IOK,READONLY,pIOK\\)
124 IV = 43981');
9248c45a
JH
125
126do_test( 9,
127 undef,
128'SV = NULL\\(0x0\\) at $ADDR
129 REFCNT = 1
130 FLAGS = \\(\\)');
131
132do_test(10,
133 \$a,
134'SV = RV\\($ADDR\\) at $ADDR
135 REFCNT = 1
136 FLAGS = \\(ROK\\)
137 RV = $ADDR
138 SV = PV\\($ADDR\\) at $ADDR
139 REFCNT = 2
140 FLAGS = \\(POK,pPOK\\)
141 PV = $ADDR "foo"\\\0
142 CUR = 3
1badabf5 143 LEN = \\d+');
9248c45a 144
59d8ce62
NC
145my $c_pattern;
146if ($type eq 'N') {
147 $c_pattern = '
148 SV = PVNV\\($ADDR\\) at $ADDR
149 REFCNT = 1
150 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
151 IV = 456
152 NV = 456
153 PV = 0';
154} else {
155 $c_pattern = '
156 SV = IV\\($ADDR\\) at $ADDR
157 REFCNT = 1
158 FLAGS = \\(IOK,pIOK\\)
159 IV = 456';
160}
9248c45a
JH
161do_test(11,
162 [$b,$c],
163'SV = RV\\($ADDR\\) at $ADDR
164 REFCNT = 1
165 FLAGS = \\(ROK\\)
166 RV = $ADDR
167 SV = PVAV\\($ADDR\\) at $ADDR
168 REFCNT = 2
169 FLAGS = \\(\\)
9248c45a
JH
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
59d8ce62 180 Elt No. 1' . $c_pattern);
9248c45a
JH
181
182do_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\\)
9248c45a 191 ARRAY = $ADDR \\(0:7, 1:1\\)
b8fa94d8 192 hash quality = 100.0%
9248c45a
JH
193 KEYS = 1
194 FILL = 1
195 MAX = 7
196 RITER = -1
197 EITER = 0x0
59d8ce62 198 Elt "123" HASH = $ADDR' . $c_pattern);
9248c45a
JH
199
200do_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
235cc2e3 208 FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
9248c45a
JH
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
208edb77 217 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
084d946d 218 FILE = ".*\\b(?i:peek\\.t)"
9248c45a 219 DEPTH = 0
9856a127 220(?: MUTEXP = $ADDR
208edb77 221 OWNER = $ADDR
7dafbf52 222)? FLAGS = 0x404
a3985cdc 223 OUTSIDE_SEQ = \\d+
9248c45a 224 PADLIST = $ADDR
dd2155a4 225 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
9248c45a
JH
226 OUTSIDE = $ADDR \\(MAIN\\)');
227
228do_test(14,
229 \&do_test,
230'SV = RV\\($ADDR\\) at $ADDR
231 REFCNT = 1
232 FLAGS = \\(ROK\\)
233 RV = $ADDR
234 SV = PVCV\\($ADDR\\) at $ADDR
9856a127 235 REFCNT = (3|4)
9248c45a
JH
236 FLAGS = \\(\\)
237 IV = 0
238 NV = 0
239 COMP_STASH = $ADDR\\t"main"
240 START = $ADDR ===> \\d+
241 ROOT = $ADDR
242 XSUB = 0x0
243 XSUBANY = 0
244 GVGV::GV = $ADDR\\t"main" :: "do_test"
084d946d 245 FILE = ".*\\b(?i:peek\\.t)"
9248c45a 246 DEPTH = 1
9856a127 247(?: MUTEXP = $ADDR
208edb77
MG
248 OWNER = $ADDR
249)? FLAGS = 0x0
a3985cdc 250 OUTSIDE_SEQ = \\d+
9248c45a 251 PADLIST = $ADDR
dd2155a4 252 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
ee6cee0c 253 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
b5c19bd7 254 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
ee6cee0c 255 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
9248c45a
JH
256 OUTSIDE = $ADDR \\(MAIN\\)');
257
258do_test(15,
259 qr(tic),
260'SV = RV\\($ADDR\\) at $ADDR
261 REFCNT = 1
262 FLAGS = \\(ROK\\)
263 RV = $ADDR
264 SV = PVMG\\($ADDR\\) at $ADDR
265 REFCNT = 1
faf82a0b 266 FLAGS = \\(OBJECT,SMG\\)
9248c45a
JH
267 IV = 0
268 NV = 0
269 PV = 0
270 MAGIC = $ADDR
271 MG_VIRTUAL = $ADDR
14befaf4 272 MG_TYPE = PERL_MAGIC_qr\(r\)
9248c45a
JH
273 MG_OBJ = $ADDR
274 STASH = $ADDR\\t"Regexp"');
275
276do_test(16,
277 (bless {}, "Tac"),
278'SV = RV\\($ADDR\\) at $ADDR
279 REFCNT = 1
280 FLAGS = \\(ROK\\)
281 RV = $ADDR
282 SV = PVHV\\($ADDR\\) at $ADDR
283 REFCNT = 2
284 FLAGS = \\(OBJECT,SHAREKEYS\\)
9248c45a
JH
285 STASH = $ADDR\\t"Tac"
286 ARRAY = 0x0
287 KEYS = 0
288 FILL = 0
289 MAX = 7
290 RITER = -1
291 EITER = 0x0');
292
293do_test(17,
294 *a,
295'SV = PVGV\\($ADDR\\) at $ADDR
296 REFCNT = 5
b07ccbd7 297 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
9248c45a
JH
298 IV = 0
299 NV = 0
300 MAGIC = $ADDR
301 MG_VIRTUAL = &PL_vtbl_glob
14befaf4 302 MG_TYPE = PERL_MAGIC_glob\(\*\)
9248c45a 303 MG_OBJ = $ADDR
9248c45a
JH
304 NAME = "a"
305 NAMELEN = 1
306 GvSTASH = $ADDR\\t"main"
307 GP = $ADDR
308 SV = $ADDR
309 REFCNT = 1
310 IO = 0x0
311 FORM = 0x0
312 AV = 0x0
313 HV = 0x0
314 CV = 0x0
315 CVGEN = 0x0
9ec58fb7 316 LINE = \\d+
084d946d 317 FILE = ".*\\b(?i:peek\\.t)"
e39917cc 318 FLAGS = $ADDR
9248c45a
JH
319 EGV = $ADDR\\t"a"');
320
cdb2dd7b
JH
321if (ord('A') == 193) {
322do_test(18,
323 chr(256).chr(0).chr(512),
324'SV = PV\\($ADDR\\) at $ADDR
325 REFCNT = 1
235cc2e3 326 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
cdb2dd7b
JH
327 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
328 CUR = 5
1badabf5 329 LEN = \\d+');
cdb2dd7b 330} else {
e6abe6d8
JH
331do_test(18,
332 chr(256).chr(0).chr(512),
333'SV = PV\\($ADDR\\) at $ADDR
334 REFCNT = 1
235cc2e3 335 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
98c991d1 336 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
e6abe6d8 337 CUR = 5
1badabf5 338 LEN = \\d+');
cdb2dd7b 339}
e6abe6d8 340
cdb2dd7b
JH
341if (ord('A') == 193) {
342do_test(19,
343 {chr(256)=>chr(512)},
344'SV = RV\\($ADDR\\) at $ADDR
345 REFCNT = 1
346 FLAGS = \\(ROK\\)
347 RV = $ADDR
348 SV = PVHV\\($ADDR\\) at $ADDR
349 REFCNT = 2
b2caaddd 350 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
cdb2dd7b
JH
351 ARRAY = $ADDR \\(0:7, 1:1\\)
352 hash quality = 100.0%
353 KEYS = 1
354 FILL = 1
355 MAX = 7
356 RITER = -1
357 EITER = $ADDR
6cbfa5b4 358 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
cdb2dd7b
JH
359 SV = PV\\($ADDR\\) at $ADDR
360 REFCNT = 1
361 FLAGS = \\(POK,pPOK,UTF8\\)
362 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
363 CUR = 2
1badabf5 364 LEN = \\d+');
cdb2dd7b 365} else {
98c991d1
JH
366do_test(19,
367 {chr(256)=>chr(512)},
368'SV = RV\\($ADDR\\) at $ADDR
369 REFCNT = 1
370 FLAGS = \\(ROK\\)
371 RV = $ADDR
372 SV = PVHV\\($ADDR\\) at $ADDR
373 REFCNT = 2
19692e8d 374 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
98c991d1
JH
375 ARRAY = $ADDR \\(0:7, 1:1\\)
376 hash quality = 100.0%
377 KEYS = 1
378 FILL = 1
379 MAX = 7
380 RITER = -1
381 EITER = $ADDR
382 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
383 SV = PV\\($ADDR\\) at $ADDR
384 REFCNT = 1
385 FLAGS = \\(POK,pPOK,UTF8\\)
386 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
387 CUR = 2
1badabf5 388 LEN = \\d+');
cdb2dd7b 389}
98c991d1 390
99331854
YST
391my $x="";
392$x=~/.??/g;
393do_test(20,
394 $x,
395'SV = PVMG\\($ADDR\\) at $ADDR
396 REFCNT = 1
235cc2e3 397 FLAGS = \\(PADMY,SMG,POK,pPOK\\)
99331854
YST
398 IV = 0
399 NV = 0
400 PV = $ADDR ""\\\0
401 CUR = 0
1936d2a7 402 LEN = \d+
99331854
YST
403 MAGIC = $ADDR
404 MG_VIRTUAL = &PL_vtbl_mglob
405 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
406 MG_FLAGS = 0x01
407 MINMATCH');
408
f24fdb76
HS
409#
410# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
411# environment variables may be invisibly case-forced, hence the (?i:PATH)
5e836f43 412# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
d9baf692
JM
413# VMS is setting FAKE and READONLY flags. What VMS uses for storing
414# ENV hashes is also not always null terminated.
f24fdb76 415#
99331854
YST
416do_test(21,
417 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
418'SV = PVMG\\($ADDR\\) at $ADDR
419 REFCNT = 1
420 FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
421 IV = 0
422 NV = 0
423 PV = $ADDR "0"\\\0
424 CUR = 1
425 LEN = \d+
426 MAGIC = $ADDR
427 MG_VIRTUAL = &PL_vtbl_envelem
428 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
d25a523c 429(?: MG_FLAGS = 0x01
99331854 430 TAINTEDDIR
143a3e5e
CB
431)? MG_LEN = -?\d+
432 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
5e836f43 433 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
143a3e5e 434 REFCNT = \d+
11e2783c 435 FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
f0fabfd7 436(?: IV = 0
d9baf692 437)? PV = $ADDR "(?i:PATH)"(?:\\\0)?
143a3e5e
CB
438 CUR = \d+
439 LEN = \d+)
99331854
YST
440 MAGIC = $ADDR
441 MG_VIRTUAL = &PL_vtbl_taint
442 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
443
9248c45a 444END {
92e5451f 445 1 while unlink("peek$$");
9248c45a 446}
6bf47b08
SR
447
448# blessed refs
449do_test(22,
450 bless(\\undef, 'Foobar'),
451'SV = RV\\($ADDR\\) at $ADDR
452 REFCNT = 1
453 FLAGS = \\(ROK\\)
454 RV = $ADDR
455 SV = PVMG\\($ADDR\\) at $ADDR
456 REFCNT = 2
457 FLAGS = \\(OBJECT,ROK\\)
7957ad98
MB
458 IV = -?\d+
459 NV = $FLOAT
6bf47b08
SR
460 RV = $ADDR
461 SV = NULL\\(0x0\\) at $ADDR
462 REFCNT = \d+
463 FLAGS = \\(READONLY\\)
464 PV = $ADDR ""
465 CUR = 0
466 LEN = 0
467 STASH = $ADDR\s+"Foobar"');
b1886099
NC
468
469# Constant subroutines
470
471sub const () {
472 "Perl rules";
473}
474
475do_test(23,
476 \&const,
477'SV = RV\\($ADDR\\) at $ADDR
478 REFCNT = 1
479 FLAGS = \\(ROK\\)
480 RV = $ADDR
481 SV = PVCV\\($ADDR\\) at $ADDR
482 REFCNT = (2)
483 FLAGS = \\(POK,pPOK,CONST\\)
484 IV = 0
485 NV = 0
486 PROTOTYPE = ""
487 COMP_STASH = 0x0
488 ROOT = 0x0
489 XSUB = $ADDR
490 XSUBANY = $ADDR \\(CONST SV\\)
491 SV = PV\\($ADDR\\) at $ADDR
492 REFCNT = 1
493 FLAGS = \\(.*POK,READONLY,pPOK\\)
494 PV = $ADDR "Perl rules"\\\0
495 CUR = 10
496 LEN = \\d+
497 GVGV::GV = $ADDR\\t"main" :: "const"
498 FILE = ".*\\b(?i:peek\\.t)"
499 DEPTH = 0
500(?: MUTEXP = $ADDR
501 OWNER = $ADDR
502)? FLAGS = 0x200
503 OUTSIDE_SEQ = 0
504 PADLIST = 0x0
505 OUTSIDE = 0x0 \\(null\\)');