This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to threads 1.87
[perl5.git] / ext / Devel-Peek / t / Peek.t
CommitLineData
99331854 1#!./perl -T
9ec58fb7
JH
2
3BEGIN {
9ec58fb7 4 require Config; import Config;
e7ecf62c 5 if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
9ec58fb7
JH
6 print "1..0 # Skip: Devel::Peek was not built\n";
7 exit 0;
8 }
9}
10
06a5cade 11use Test::More;
e7ecf62c 12
9248c45a
JH
13use Devel::Peek;
14
9248c45a 15our $DEBUG = 0;
277ddfaf 16open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
9248c45a 17
bfe27a58
NC
18# If I reference any lexicals in this, I get the entire outer subroutine (or
19# MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
20# maintain that.
21format PIE =
22Pie @<<<<<
23$::type
24Good @>>>>>
25$::mmmm
26.
27
bad4ae38
FC
28use constant thr => $Config{useithreads};
29
9248c45a 30sub do_test {
000fd473
NC
31 my $todo = $_[3];
32 my $repeat_todo = $_[4];
33 my $pattern = $_[2];
277ddfaf
GS
34 if (open(OUT,">peek$$")) {
35 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
9248c45a 36 Dump($_[1]);
e9569a7a
GG
37 print STDERR "*****\n";
38 Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
277ddfaf
GS
39 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
40 close(OUT);
9248c45a
JH
41 if (open(IN, "peek$$")) {
42 local $/;
43 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
8aacddc1 44 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
fd0854ff 45 # handle DEBUG_LEAKING_SCALARS prefix
d94a5950 46 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
bf53b3a5 47
000fd473
NC
48 # Need some clear generic mechanism to eliminate (or add) lines
49 # of dump output dependant on perl version. The (previous) use of
50 # things like $IVNV gave the illusion that the string passed in was
51 # a regexp into which variables were interpolated, but this wasn't
52 # actually true as those 'variables' actually also ate the
b7b1e41b 53 # whitespace on the line. So it seems better to mark lines that
000fd473
NC
54 # need to be eliminated. I considered (?# ... ) and (?{ ... }),
55 # but whilst embedded code or comment syntax would keep it as a
56 # legitimate regexp, it still isn't true. Seems easier and clearer
57 # things that look like comments.
58
59 # Could do this is in a s///mge but seems clearer like this:
60 $pattern = join '', map {
61 # If we identify the version condition, take *it* out whatever
bad4ae38 62 s/\s*# (\$].*)$//
000fd473
NC
63 ? (eval $1 ? $_ : '')
64 : $_ # Didn't match, so this line is in
65 } split /^/, $pattern;
66
67 $pattern =~ s/\$PADMY/
68 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
69 /mge;
70 $pattern =~ s/\$PADTMP/
71 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
72 /mge;
2b631c93
NC
73 $pattern =~ s/\$RV/
74 ($] < 5.011) ? 'RV' : 'IV';
75 /mge;
d04ba589 76
9248c45a 77 print $pattern, "\n" if $DEBUG;
e9569a7a 78 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
9248c45a 79 print $dump, "\n" if $DEBUG;
06a5cade
NC
80 like( $dump, qr/\A$pattern\Z/ms, $_[0])
81 or note("line " . (caller)[2]);
e9569a7a 82
000fd473 83 local $TODO = $repeat_todo;
06a5cade
NC
84 is($dump2, $dump, "$_[0] (unchanged by dump)")
85 or note("line " . (caller)[2]);
e9569a7a 86
9248c45a 87 close(IN);
e9569a7a 88
59d8ce62 89 return $1;
9248c45a
JH
90 } else {
91 die "$0: failed to open peek$$: !\n";
92 }
93 } else {
94 die "$0: failed to create peek$$: $!\n";
95 }
96}
97
98our $a;
99our $b;
100my $c;
208edb77 101local $d = 0;
9248c45a 102
e7ecf62c
RGS
103END {
104 1 while unlink("peek$$");
105}
bf53b3a5 106
06a5cade 107do_test('assignment of immediate constant (string)',
9248c45a
JH
108 $a = "foo",
109'SV = PV\\($ADDR\\) at $ADDR
110 REFCNT = 1
111 FLAGS = \\(POK,pPOK\\)
112 PV = $ADDR "foo"\\\0
113 CUR = 3
1badabf5 114 LEN = \\d+'
9248c45a
JH
115 );
116
06a5cade 117do_test('immediate constant (string)',
9248c45a
JH
118 "bar",
119'SV = PV\\($ADDR\\) at $ADDR
120 REFCNT = 1
7766e686 121 FLAGS = \\(.*POK,READONLY,pPOK\\)
9248c45a
JH
122 PV = $ADDR "bar"\\\0
123 CUR = 3
1badabf5 124 LEN = \\d+');
9248c45a 125
b7b1e41b 126do_test('assignment of immediate constant (integer)',
9248c45a
JH
127 $b = 123,
128'SV = IV\\($ADDR\\) at $ADDR
129 REFCNT = 1
130 FLAGS = \\(IOK,pIOK\\)
131 IV = 123');
132
06a5cade 133do_test('immediate constant (integer)',
9248c45a
JH
134 456,
135'SV = IV\\($ADDR\\) at $ADDR
136 REFCNT = 1
7766e686 137 FLAGS = \\(.*IOK,READONLY,pIOK\\)
9248c45a
JH
138 IV = 456');
139
06a5cade 140do_test('assignment of immediate constant (integer)',
9248c45a
JH
141 $c = 456,
142'SV = IV\\($ADDR\\) at $ADDR
143 REFCNT = 1
000fd473 144 FLAGS = \\($PADMY,IOK,pIOK\\)
9248c45a
JH
145 IV = 456');
146
59d8ce62
NC
147# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
148# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
149# maths is done in floating point always, and this scalar will be an NV.
150# ([NI]) captures the type, referred to by \1 in this regexp and $type for
151# building subsequent regexps.
06a5cade 152my $type = do_test('result of addition',
9248c45a 153 $c + $d,
59d8ce62 154'SV = ([NI])V\\($ADDR\\) at $ADDR
9248c45a 155 REFCNT = 1
59d8ce62
NC
156 FLAGS = \\(PADTMP,\1OK,p\1OK\\)
157 \1V = 456');
9248c45a
JH
158
159($d = "789") += 0.1;
160
06a5cade 161do_test('floating point value',
9248c45a
JH
162 $d,
163'SV = PVNV\\($ADDR\\) at $ADDR
164 REFCNT = 1
165 FLAGS = \\(NOK,pNOK\\)
78d00c47 166 IV = \d+
ac634a9a 167 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
9248c45a
JH
168 PV = $ADDR "789"\\\0
169 CUR = 3
1badabf5 170 LEN = \\d+');
9248c45a 171
06a5cade 172do_test('integer constant',
9248c45a
JH
173 0xabcd,
174'SV = IV\\($ADDR\\) at $ADDR
175 REFCNT = 1
28e5dec8
JH
176 FLAGS = \\(.*IOK,READONLY,pIOK\\)
177 IV = 43981');
9248c45a 178
06a5cade 179do_test('undef',
9248c45a
JH
180 undef,
181'SV = NULL\\(0x0\\) at $ADDR
182 REFCNT = 1
183 FLAGS = \\(\\)');
184
06a5cade 185do_test('reference to scalar',
9248c45a 186 \$a,
4df7f6af 187'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
188 REFCNT = 1
189 FLAGS = \\(ROK\\)
190 RV = $ADDR
191 SV = PV\\($ADDR\\) at $ADDR
192 REFCNT = 2
193 FLAGS = \\(POK,pPOK\\)
194 PV = $ADDR "foo"\\\0
195 CUR = 3
1badabf5 196 LEN = \\d+');
9248c45a 197
59d8ce62
NC
198my $c_pattern;
199if ($type eq 'N') {
200 $c_pattern = '
201 SV = PVNV\\($ADDR\\) at $ADDR
202 REFCNT = 1
203 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
204 IV = 456
205 NV = 456
206 PV = 0';
207} else {
208 $c_pattern = '
209 SV = IV\\($ADDR\\) at $ADDR
210 REFCNT = 1
211 FLAGS = \\(IOK,pIOK\\)
212 IV = 456';
213}
06a5cade 214do_test('reference to array',
9248c45a 215 [$b,$c],
4df7f6af 216'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
217 REFCNT = 1
218 FLAGS = \\(ROK\\)
219 RV = $ADDR
220 SV = PVAV\\($ADDR\\) at $ADDR
78c72037 221 REFCNT = 1
9248c45a 222 FLAGS = \\(\\)
1bcecb77
NC
223 IV = 0 # $] < 5.009
224 NV = 0 # $] < 5.009
9248c45a
JH
225 ARRAY = $ADDR
226 FILL = 1
227 MAX = 1
228 ARYLEN = 0x0
229 FLAGS = \\(REAL\\)
230 Elt No. 0
231 SV = IV\\($ADDR\\) at $ADDR
232 REFCNT = 1
233 FLAGS = \\(IOK,pIOK\\)
234 IV = 123
59d8ce62 235 Elt No. 1' . $c_pattern);
9248c45a 236
06a5cade 237do_test('reference to hash',
9248c45a 238 {$b=>$c},
4df7f6af 239'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
240 REFCNT = 1
241 FLAGS = \\(ROK\\)
242 RV = $ADDR
243 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 244 REFCNT = [12]
9248c45a 245 FLAGS = \\(SHAREKEYS\\)
1bcecb77
NC
246 IV = 1 # $] < 5.009
247 NV = $FLOAT # $] < 5.009
9248c45a 248 ARRAY = $ADDR \\(0:7, 1:1\\)
b8fa94d8 249 hash quality = 100.0%
9248c45a
JH
250 KEYS = 1
251 FILL = 1
252 MAX = 7
000fd473
NC
253 Elt "123" HASH = $ADDR' . $c_pattern,
254 '',
f3ce8053
FC
255 $] > 5.009 && $] < 5.015
256 && 'The hash iterator used in dump.c sets the OOK flag');
9248c45a 257
06a5cade 258do_test('reference to anon sub with empty prototype',
9248c45a 259 sub(){@_},
4df7f6af 260'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
261 REFCNT = 1
262 FLAGS = \\(ROK\\)
263 RV = $ADDR
264 SV = PVCV\\($ADDR\\) at $ADDR
265 REFCNT = 2
bad4ae38
FC
266 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
267 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
1bcecb77
NC
268 IV = 0 # $] < 5.009
269 NV = 0 # $] < 5.009
9248c45a
JH
270 PROTOTYPE = ""
271 COMP_STASH = $ADDR\\t"main"
272 START = $ADDR ===> \\d+
273 ROOT = $ADDR
1bcecb77
NC
274 XSUB = 0x0 # $] < 5.009
275 XSUBANY = 0 # $] < 5.009
208edb77 276 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
084d946d 277 FILE = ".*\\b(?i:peek\\.t)"
000fd473
NC
278 DEPTH = 0(?:
279 MUTEXP = $ADDR
280 OWNER = $ADDR)?
1bcecb77 281 FLAGS = 0x404 # $] < 5.009
bad4ae38
FC
282 FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr)
283 FLAGS = 0x1490 # $] >= 5.015 && thr
a3985cdc 284 OUTSIDE_SEQ = \\d+
9248c45a 285 PADLIST = $ADDR
dd2155a4 286 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
9248c45a
JH
287 OUTSIDE = $ADDR \\(MAIN\\)');
288
06a5cade 289do_test('reference to named subroutine without prototype',
9248c45a 290 \&do_test,
4df7f6af 291'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
292 REFCNT = 1
293 FLAGS = \\(ROK\\)
294 RV = $ADDR
295 SV = PVCV\\($ADDR\\) at $ADDR
9856a127 296 REFCNT = (3|4)
2156df4b
FC
297 FLAGS = \\((?:HASEVAL)?\\) # $] < 5.015 || !thr
298 FLAGS = \\(DYNFILE(?:,HASEVAL)?\\) # $] >= 5.015 && thr
1bcecb77
NC
299 IV = 0 # $] < 5.009
300 NV = 0 # $] < 5.009
9248c45a
JH
301 COMP_STASH = $ADDR\\t"main"
302 START = $ADDR ===> \\d+
303 ROOT = $ADDR
1bcecb77
NC
304 XSUB = 0x0 # $] < 5.009
305 XSUBANY = 0 # $] < 5.009
9248c45a 306 GVGV::GV = $ADDR\\t"main" :: "do_test"
084d946d 307 FILE = ".*\\b(?i:peek\\.t)"
bad4ae38
FC
308 DEPTH = 1(?:
309 MUTEXP = $ADDR
310 OWNER = $ADDR)?
2156df4b
FC
311 FLAGS = 0x(?:400)?0 # $] < 5.015 || !thr
312 FLAGS = 0x[145]000 # $] >= 5.015 && thr
a3985cdc 313 OUTSIDE_SEQ = \\d+
9248c45a 314 PADLIST = $ADDR
dd2155a4 315 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
000fd473
NC
316 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
317 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
ee6cee0c 318 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
000fd473
NC
319 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009
320 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009
ee6cee0c 321 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
e9569a7a 322 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
9248c45a
JH
323 OUTSIDE = $ADDR \\(MAIN\\)');
324
3ce3ed55 325if ($] >= 5.011) {
06a5cade 326do_test('reference to regexp',
3ce3ed55
NC
327 qr(tic),
328'SV = $RV\\($ADDR\\) at $ADDR
329 REFCNT = 1
330 FLAGS = \\(ROK\\)
331 RV = $ADDR
5c35adbb 332 SV = REGEXP\\($ADDR\\) at $ADDR
c2123ae3 333 REFCNT = 1
8d919b0a
FC
334 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
335 FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
fb85c044
KW
336 PV = $ADDR "\\(\\?\\^:tic\\)"
337 CUR = 8
8d919b0a 338 LEN = 0 # $] < 5.017006
d63e6659
DM
339 STASH = $ADDR\\t"Regexp"'
340. ($] < 5.013 ? '' :
341'
dbc200c5 342 COMPFLAGS = 0x0 \(\)
d63e6659
DM
343 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
344 INTFLAGS = 0x0
345 NPARENS = 0
346 LASTPAREN = 0
347 LASTCLOSEPAREN = 0
348 MINLEN = 3
349 MINLENRET = 3
350 GOFS = 0
351 PRE_PREFIX = 4
d63e6659 352 SUBLEN = 0
6502e081
DM
353 SUBOFFSET = 0
354 SUBCOFFSET = 0
d63e6659
DM
355 SUBBEG = 0x0
356 ENGINE = $ADDR
357 MOTHER_RE = $ADDR
358 PAREN_NAMES = 0x0
359 SUBSTRS = $ADDR
360 PPRIVATE = $ADDR
d63c20f2 361 OFFS = $ADDR
c9669de2
FC
362 QR_ANONCV = 0x0(?:
363 SAVED_COPY = 0x0)?'
d63e6659 364));
3ce3ed55 365} else {
06a5cade 366do_test('reference to regexp',
9248c45a 367 qr(tic),
4df7f6af 368'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
369 REFCNT = 1
370 FLAGS = \\(ROK\\)
371 RV = $ADDR
372 SV = PVMG\\($ADDR\\) at $ADDR
373 REFCNT = 1
faf82a0b 374 FLAGS = \\(OBJECT,SMG\\)
9248c45a
JH
375 IV = 0
376 NV = 0
377 PV = 0
378 MAGIC = $ADDR
379 MG_VIRTUAL = $ADDR
14befaf4 380 MG_TYPE = PERL_MAGIC_qr\(r\)
9248c45a 381 MG_OBJ = $ADDR
fb85c044 382 PAT = "\(\?^:tic\)" # $] >= 5.009
1bcecb77 383 REFCNT = 2 # $] >= 5.009
9248c45a 384 STASH = $ADDR\\t"Regexp"');
3ce3ed55 385}
9248c45a 386
06a5cade 387do_test('reference to blessed hash',
9248c45a 388 (bless {}, "Tac"),
4df7f6af 389'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
390 REFCNT = 1
391 FLAGS = \\(ROK\\)
392 RV = $ADDR
393 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 394 REFCNT = [12]
9248c45a 395 FLAGS = \\(OBJECT,SHAREKEYS\\)
1bcecb77
NC
396 IV = 0 # $] < 5.009
397 NV = 0 # $] < 5.009
9248c45a
JH
398 STASH = $ADDR\\t"Tac"
399 ARRAY = 0x0
400 KEYS = 0
401 FILL = 0
e1a7ec8d 402 MAX = 7', '',
f3ce8053
FC
403 $] > 5.009
404 ? $] >= 5.015
405 ? 0
406 : 'The hash iterator used in dump.c sets the OOK flag'
000fd473 407 : "Something causes the HV's array to become allocated");
9248c45a 408
06a5cade 409do_test('typeglob',
9248c45a
JH
410 *a,
411'SV = PVGV\\($ADDR\\) at $ADDR
412 REFCNT = 5
000fd473
NC
413 FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009
414 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009
415 IV = 0 # $] < 5.009
416 NV = 0 # $] < 5.009
417 PV = 0 # $] < 5.009
418 MAGIC = $ADDR # $] < 5.009
419 MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009
420 MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009
421 MG_OBJ = $ADDR # $] < 5.009
9248c45a
JH
422 NAME = "a"
423 NAMELEN = 1
424 GvSTASH = $ADDR\\t"main"
425 GP = $ADDR
426 SV = $ADDR
427 REFCNT = 1
428 IO = 0x0
429 FORM = 0x0
430 AV = 0x0
431 HV = 0x0
432 CV = 0x0
433 CVGEN = 0x0
000fd473 434 GPFLAGS = 0x0 # $] < 5.009
9ec58fb7 435 LINE = \\d+
084d946d 436 FILE = ".*\\b(?i:peek\\.t)"
e39917cc 437 FLAGS = $ADDR
9248c45a
JH
438 EGV = $ADDR\\t"a"');
439
cdb2dd7b 440if (ord('A') == 193) {
06a5cade 441do_test('string with Unicode',
cdb2dd7b
JH
442 chr(256).chr(0).chr(512),
443'SV = PV\\($ADDR\\) at $ADDR
444 REFCNT = 1
000fd473 445 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
cdb2dd7b
JH
446 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
447 CUR = 5
1badabf5 448 LEN = \\d+');
cdb2dd7b 449} else {
06a5cade 450do_test('string with Unicode',
e6abe6d8
JH
451 chr(256).chr(0).chr(512),
452'SV = PV\\($ADDR\\) at $ADDR
453 REFCNT = 1
000fd473 454 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
98c991d1 455 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
e6abe6d8 456 CUR = 5
1badabf5 457 LEN = \\d+');
cdb2dd7b 458}
e6abe6d8 459
cdb2dd7b 460if (ord('A') == 193) {
06a5cade 461do_test('reference to hash containing Unicode',
cdb2dd7b 462 {chr(256)=>chr(512)},
4df7f6af 463'SV = $RV\\($ADDR\\) at $ADDR
cdb2dd7b
JH
464 REFCNT = 1
465 FLAGS = \\(ROK\\)
466 RV = $ADDR
467 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 468 REFCNT = [12]
b2caaddd 469 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
1bcecb77
NC
470 UV = 1 # $] < 5.009
471 NV = $FLOAT # $] < 5.009
cdb2dd7b
JH
472 ARRAY = $ADDR \\(0:7, 1:1\\)
473 hash quality = 100.0%
474 KEYS = 1
475 FILL = 1
476 MAX = 7
6cbfa5b4 477 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
cdb2dd7b
JH
478 SV = PV\\($ADDR\\) at $ADDR
479 REFCNT = 1
480 FLAGS = \\(POK,pPOK,UTF8\\)
481 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
482 CUR = 2
000fd473 483 LEN = \\d+',
f3ce8053
FC
484 $] > 5.009
485 ? $] >= 5.015
486 ? 0
487 : 'The hash iterator used in dump.c sets the OOK flag'
000fd473 488 : 'sv_length has been called on the element, and cached the result in MAGIC');
cdb2dd7b 489} else {
06a5cade 490do_test('reference to hash containing Unicode',
98c991d1 491 {chr(256)=>chr(512)},
4df7f6af 492'SV = $RV\\($ADDR\\) at $ADDR
98c991d1
JH
493 REFCNT = 1
494 FLAGS = \\(ROK\\)
495 RV = $ADDR
496 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 497 REFCNT = [12]
19692e8d 498 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
1bcecb77
NC
499 UV = 1 # $] < 5.009
500 NV = 0 # $] < 5.009
98c991d1
JH
501 ARRAY = $ADDR \\(0:7, 1:1\\)
502 hash quality = 100.0%
503 KEYS = 1
504 FILL = 1
505 MAX = 7
98c991d1
JH
506 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
507 SV = PV\\($ADDR\\) at $ADDR
508 REFCNT = 1
509 FLAGS = \\(POK,pPOK,UTF8\\)
510 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
511 CUR = 2
000fd473 512 LEN = \\d+', '',
f3ce8053
FC
513 $] > 5.009
514 ? $] >= 5.015
515 ? 0
516 : 'The hash iterator used in dump.c sets the OOK flag'
000fd473 517 : 'sv_length has been called on the element, and cached the result in MAGIC');
cdb2dd7b 518}
98c991d1 519
99331854
YST
520my $x="";
521$x=~/.??/g;
06a5cade 522do_test('scalar with pos magic',
99331854
YST
523 $x,
524'SV = PVMG\\($ADDR\\) at $ADDR
525 REFCNT = 1
c9669de2 526 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
eed1f77c 527 IV = \d+
99331854
YST
528 NV = 0
529 PV = $ADDR ""\\\0
530 CUR = 0
c9669de2
FC
531 LEN = \d+(?:
532 COW_REFCNT = 1)?
99331854
YST
533 MAGIC = $ADDR
534 MG_VIRTUAL = &PL_vtbl_mglob
535 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
536 MG_FLAGS = 0x01
537 MINMATCH');
538
f24fdb76
HS
539#
540# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
541# environment variables may be invisibly case-forced, hence the (?i:PATH)
5e836f43 542# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
12033064
CS
543# Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
544# Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
d9baf692
JM
545# VMS is setting FAKE and READONLY flags. What VMS uses for storing
546# ENV hashes is also not always null terminated.
f24fdb76 547#
284167a5
SM
548if (${^TAINT}) {
549 do_test('tainted value in %ENV',
550 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
99331854
YST
551'SV = PVMG\\($ADDR\\) at $ADDR
552 REFCNT = 1
12033064 553 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
99331854
YST
554 IV = 0
555 NV = 0
556 PV = $ADDR "0"\\\0
557 CUR = 1
558 LEN = \d+
559 MAGIC = $ADDR
560 MG_VIRTUAL = &PL_vtbl_envelem
561 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
d25a523c 562(?: MG_FLAGS = 0x01
99331854 563 TAINTEDDIR
143a3e5e
CB
564)? MG_LEN = -?\d+
565 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
5e836f43 566 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
143a3e5e 567 REFCNT = \d+
11e2783c 568 FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
f0fabfd7 569(?: IV = 0
d9baf692 570)? PV = $ADDR "(?i:PATH)"(?:\\\0)?
143a3e5e
CB
571 CUR = \d+
572 LEN = \d+)
99331854
YST
573 MAGIC = $ADDR
574 MG_VIRTUAL = &PL_vtbl_taint
575 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
284167a5 576}
99331854 577
06a5cade 578do_test('blessed reference',
6bf47b08 579 bless(\\undef, 'Foobar'),
4df7f6af 580'SV = $RV\\($ADDR\\) at $ADDR
6bf47b08
SR
581 REFCNT = 1
582 FLAGS = \\(ROK\\)
583 RV = $ADDR
584 SV = PVMG\\($ADDR\\) at $ADDR
585 REFCNT = 2
586 FLAGS = \\(OBJECT,ROK\\)
7957ad98
MB
587 IV = -?\d+
588 NV = $FLOAT
6bf47b08
SR
589 RV = $ADDR
590 SV = NULL\\(0x0\\) at $ADDR
591 REFCNT = \d+
592 FLAGS = \\(READONLY\\)
593 PV = $ADDR ""
594 CUR = 0
595 LEN = 0
596 STASH = $ADDR\s+"Foobar"');
b1886099 597
b1886099
NC
598sub const () {
599 "Perl rules";
600}
601
06a5cade 602do_test('constant subroutine',
b1886099 603 \&const,
4df7f6af 604'SV = $RV\\($ADDR\\) at $ADDR
b1886099
NC
605 REFCNT = 1
606 FLAGS = \\(ROK\\)
607 RV = $ADDR
608 SV = PVCV\\($ADDR\\) at $ADDR
609 REFCNT = (2)
bad4ae38
FC
610 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
611 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
1bcecb77
NC
612 IV = 0 # $] < 5.009
613 NV = 0 # $] < 5.009
b1886099
NC
614 PROTOTYPE = ""
615 COMP_STASH = 0x0
1bcecb77 616 ROOT = 0x0 # $] < 5.009
b1886099
NC
617 XSUB = $ADDR
618 XSUBANY = $ADDR \\(CONST SV\\)
619 SV = PV\\($ADDR\\) at $ADDR
620 REFCNT = 1
621 FLAGS = \\(.*POK,READONLY,pPOK\\)
622 PV = $ADDR "Perl rules"\\\0
623 CUR = 10
624 LEN = \\d+
625 GVGV::GV = $ADDR\\t"main" :: "const"
626 FILE = ".*\\b(?i:peek\\.t)"
000fd473
NC
627 DEPTH = 0(?:
628 MUTEXP = $ADDR
629 OWNER = $ADDR)?
1bcecb77 630 FLAGS = 0x200 # $] < 5.009
c2485e0c 631 FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013
bad4ae38
FC
632 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
633 FLAGS = 0x100c # $] >= 5.015
b1886099
NC
634 OUTSIDE_SEQ = 0
635 PADLIST = 0x0
636 OUTSIDE = 0x0 \\(null\\)');
2e94196c 637
06a5cade 638do_test('isUV should show on PVMG',
2e94196c
NC
639 do { my $v = $1; $v = ~0; $v },
640'SV = PVMG\\($ADDR\\) at $ADDR
641 REFCNT = 1
642 FLAGS = \\(IOK,pIOK,IsUV\\)
643 UV = \d+
644 NV = 0
645 PV = 0');
c0a413d1 646
06a5cade 647do_test('IO',
c0a413d1
NC
648 *STDOUT{IO},
649'SV = $RV\\($ADDR\\) at $ADDR
650 REFCNT = 1
651 FLAGS = \\(ROK\\)
652 RV = $ADDR
653 SV = PVIO\\($ADDR\\) at $ADDR
654 REFCNT = 3
655 FLAGS = \\(OBJECT\\)
3cf51070 656 IV = 0 # $] < 5.011
1bcecb77 657 NV = 0 # $] < 5.011
d963bf01 658 STASH = $ADDR\s+"IO::File"
c0a413d1
NC
659 IFP = $ADDR
660 OFP = $ADDR
661 DIRP = 0x0
662 LINES = 0
663 PAGE = 0
664 PAGE_LEN = 60
665 LINES_LEFT = 0
666 TOP_GV = 0x0
667 FMT_GV = 0x0
668 BOTTOM_GV = 0x0
1bcecb77 669 SUBPROCESS = 0 # $] < 5.009
c0a413d1 670 TYPE = \'>\'
50a9fad1 671 FLAGS = 0x4');
bfe27a58 672
06a5cade 673do_test('FORMAT',
bfe27a58
NC
674 *PIE{FORMAT},
675'SV = $RV\\($ADDR\\) at $ADDR
676 REFCNT = 1
677 FLAGS = \\(ROK\\)
678 RV = $ADDR
679 SV = PVFM\\($ADDR\\) at $ADDR
680 REFCNT = 2
bad4ae38
FC
681 FLAGS = \\(\\) # $] < 5.015 || !thr
682 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
30ec677d 683 IV = 0 # $] < 5.009
bfe27a58 684 NV = 0 # $] < 5.009
251a4af1
DM
685(?: PV = 0
686)? COMP_STASH = 0x0
bfe27a58
NC
687 START = $ADDR ===> \\d+
688 ROOT = $ADDR
689 XSUB = 0x0 # $] < 5.009
690 XSUBANY = 0 # $] < 5.009
691 GVGV::GV = $ADDR\\t"main" :: "PIE"
bad4ae38 692 FILE = ".*\\b(?i:peek\\.t)"(?:
d3810ef8 693 DEPTH = 0)?(?:
c12100a4 694 MUTEXP = $ADDR
bad4ae38
FC
695 OWNER = $ADDR)?
696 FLAGS = 0x0 # $] < 5.015 || !thr
697 FLAGS = 0x1000 # $] >= 5.015 && thr
bfe27a58 698 OUTSIDE_SEQ = \\d+
d3810ef8 699 LINES = 0 # $] < 5.017_003
bfe27a58
NC
700 PADLIST = $ADDR
701 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
702 OUTSIDE = $ADDR \\(MAIN\\)');
d7d51f4b 703
b7b1e41b 704do_test('blessing to a class with embedded NUL characters',
d7d51f4b
YO
705 (bless {}, "\0::foo::\n::baz::\t::\0"),
706'SV = $RV\\($ADDR\\) at $ADDR
707 REFCNT = 1
708 FLAGS = \\(ROK\\)
709 RV = $ADDR
710 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 711 REFCNT = [12]
d7d51f4b
YO
712 FLAGS = \\(OBJECT,SHAREKEYS\\)
713 IV = 0 # $] < 5.009
714 NV = 0 # $] < 5.009
715 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
716 ARRAY = $ADDR
717 KEYS = 0
718 FILL = 0
e1a7ec8d 719 MAX = 7', '',
f3ce8053
FC
720 $] > 5.009
721 ? $] >= 5.015
722 ? 0
723 : 'The hash iterator used in dump.c sets the OOK flag'
d7d51f4b
YO
724 : "Something causes the HV's array to become allocated");
725
bed53064
NC
726do_test('ENAME on a stash',
727 \%RWOM::,
728'SV = $RV\\($ADDR\\) at $ADDR
729 REFCNT = 1
730 FLAGS = \\(ROK\\)
731 RV = $ADDR
732 SV = PVHV\\($ADDR\\) at $ADDR
733 REFCNT = 2
734 FLAGS = \\(OOK,SHAREKEYS\\)
735 IV = 1 # $] < 5.009
736 NV = $FLOAT # $] < 5.009
737 ARRAY = $ADDR
738 KEYS = 0
739 FILL = 0
740 MAX = 7
741 RITER = -1
742 EITER = 0x0
e1a7ec8d 743 RAND = $ADDR
bed53064
NC
744 NAME = "RWOM"
745 ENAME = "RWOM" # $] > 5.012
746');
747
748*KLANK:: = \%RWOM::;
749
750do_test('ENAMEs on a stash',
751 \%RWOM::,
752'SV = $RV\\($ADDR\\) at $ADDR
753 REFCNT = 1
754 FLAGS = \\(ROK\\)
755 RV = $ADDR
756 SV = PVHV\\($ADDR\\) at $ADDR
757 REFCNT = 3
758 FLAGS = \\(OOK,SHAREKEYS\\)
759 IV = 1 # $] < 5.009
760 NV = $FLOAT # $] < 5.009
761 ARRAY = $ADDR
762 KEYS = 0
763 FILL = 0
764 MAX = 7
765 RITER = -1
766 EITER = 0x0
e1a7ec8d 767 RAND = $ADDR
bed53064
NC
768 NAME = "RWOM"
769 NAMECOUNT = 2 # $] > 5.012
770 ENAME = "RWOM", "KLANK" # $] > 5.012
771');
772
773undef %RWOM::;
774
775do_test('ENAMEs on a stash with no NAME',
776 \%RWOM::,
777'SV = $RV\\($ADDR\\) at $ADDR
778 REFCNT = 1
779 FLAGS = \\(ROK\\)
780 RV = $ADDR
781 SV = PVHV\\($ADDR\\) at $ADDR
782 REFCNT = 3
6acb8aa1
FC
783 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
784 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017
bed53064
NC
785 IV = 1 # $] < 5.009
786 NV = $FLOAT # $] < 5.009
787 ARRAY = $ADDR
788 KEYS = 0
789 FILL = 0
790 MAX = 7
791 RITER = -1
792 EITER = 0x0
e1a7ec8d 793 RAND = $ADDR
bed53064
NC
794 NAMECOUNT = -3 # $] > 5.012
795 ENAME = "RWOM", "KLANK" # $] > 5.012
796');
797
4ab5bd5f
FC
798SKIP: {
799 skip "Not built with usemymalloc", 1
800 unless $Config{usemymalloc} eq 'y';
801 my $x = __PACKAGE__;
802 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
803 or diag $@;
804}
805
bc9a5256
NC
806# This is more a test of fbm_compile/pp_study (non) interaction than dumping
807# prowess, but short of duplicating all the gubbins of this file, I can't see
808# a way to make a better place for it:
809
ccbcbb3d
NC
810use constant {
811 perl => 'rules',
812 beer => 'foamy',
813};
0a0c4b76
NC
814
815unless ($Config{useithreads}) {
816 # These end up as copies in pads under ithreads, which rather defeats the
817 # the point of what we're trying to test here.
818
819 do_test('regular string constant', perl,
820'SV = PV\\($ADDR\\) at $ADDR
bc9a5256 821 REFCNT = 5
0a0c4b76
NC
822 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
823 PV = $ADDR "rules"\\\0
824 CUR = 5
825 LEN = \d+
826');
827
828 eval 'index "", perl';
829
830 # FIXME - really this shouldn't say EVALED. It's a false posistive on
831 # 0x40000000 being used for several things, not a flag for "I'm in a string
832 # eval"
833
834 do_test('string constant now an FBM', perl,
c13a5c80 835'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256
NC
836 REFCNT = 5
837 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
838 PV = $ADDR "rules"\\\0
839 CUR = 5
840 LEN = \d+
841 MAGIC = $ADDR
b76b0bf9 842 MG_VIRTUAL = &PL_vtbl_regexp
bc9a5256 843 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
844 MG_LEN = 256
845 MG_PTR = $ADDR "(?:\\\\\d){256}"
bc9a5256
NC
846 RARE = \d+
847 PREVIOUS = 1
848 USEFUL = 100
849');
850
851 is(study perl, '', "Not allowed to study an FBM");
852
853 do_test('string constant still an FBM', perl,
c13a5c80 854'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256 855 REFCNT = 5
0a0c4b76
NC
856 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
857 PV = $ADDR "rules"\\\0
858 CUR = 5
859 LEN = \d+
860 MAGIC = $ADDR
b76b0bf9 861 MG_VIRTUAL = &PL_vtbl_regexp
0a0c4b76 862 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
863 MG_LEN = 256
864 MG_PTR = $ADDR "(?:\\\\\d){256}"
0a0c4b76
NC
865 RARE = \d+
866 PREVIOUS = 1
867 USEFUL = 100
868');
ccbcbb3d
NC
869
870 do_test('regular string constant', beer,
871'SV = PV\\($ADDR\\) at $ADDR
4185c919 872 REFCNT = 6
ccbcbb3d
NC
873 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
874 PV = $ADDR "foamy"\\\0
875 CUR = 5
876 LEN = \d+
877');
878
a58a85fa
AMS
879 is(study beer, 1, "Our studies were successful");
880
881 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
882 REFCNT = 6
883 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
884 PV = $ADDR "foamy"\\\0
885 CUR = 5
886 LEN = \d+
887');
888
4185c919 889 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
4265b45d 890 REFCNT = 6
a58a85fa 891 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
4265b45d
NC
892 PV = $ADDR "foamy"\\\0
893 CUR = 5
894 LEN = \d+
895 MAGIC = $ADDR
0177730e 896 MG_VIRTUAL = &PL_vtbl_regexp
a58a85fa
AMS
897 MG_TYPE = PERL_MAGIC_bm\\(B\\)
898 MG_LEN = 256
899 MG_PTR = $ADDR "(?:\\\\\d){256}"
900 RARE = \d+
901 PREVIOUS = \d+
902 USEFUL = 100
4185c919
NC
903';
904
4265b45d
NC
905 is (eval 'index "not too foamy", beer', 8, 'correct index');
906
a58a85fa 907 do_test('string constant now FBMed', beer, $want);
4185c919
NC
908
909 my $pie = 'good';
910
911 is(study $pie, 1, "Our studies were successful");
912
a58a85fa 913 do_test('string constant still FBMed', beer, $want);
4185c919 914
a58a85fa 915 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
4185c919 916 REFCNT = 1
a58a85fa 917 FLAGS = \\(PADMY,POK,pPOK\\)
4185c919
NC
918 PV = $ADDR "good"\\\0
919 CUR = 4
ccbcbb3d 920 LEN = \d+
ccbcbb3d 921');
0a0c4b76
NC
922}
923
a58a85fa 924# (One block of study tests removed when study was made a no-op.)
72de20cd 925
486ffce2
FC
926{
927 open(OUT,">peek$$") or die "Failed to open peek $$: $!";
928 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
929 DeadCode();
930 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
931 pass "no crash with DeadCode";
7bf23f34 932 close OUT;
486ffce2
FC
933}
934
8cdde9f8
NC
935do_test('UTF-8 in a regular expression',
936 qr/\x{100}/,
937'SV = IV\($ADDR\) at $ADDR
938 REFCNT = 1
939 FLAGS = \(ROK\)
940 RV = $ADDR
941 SV = REGEXP\($ADDR\) at $ADDR
942 REFCNT = 1
943 FLAGS = \(OBJECT,FAKE,UTF8\)
944 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
945 CUR = 13
946 STASH = $ADDR "Regexp"
dbc200c5 947 COMPFLAGS = 0x0 \(\)
8cdde9f8
NC
948 EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
949 INTFLAGS = 0x0
950 NPARENS = 0
951 LASTPAREN = 0
952 LASTCLOSEPAREN = 0
953 MINLEN = 1
954 MINLENRET = 1
955 GOFS = 0
956 PRE_PREFIX = 5
957 SUBLEN = 0
958 SUBOFFSET = 0
959 SUBCOFFSET = 0
960 SUBBEG = 0x0
961 ENGINE = $ADDR
962 MOTHER_RE = $ADDR
963 PAREN_NAMES = 0x0
964 SUBSTRS = $ADDR
965 PPRIVATE = $ADDR
966 OFFS = $ADDR
09af2132
DM
967 QR_ANONCV = 0x0(?:
968 SAVED_COPY = 0x0)?
8cdde9f8
NC
969');
970
06a5cade 971done_testing();