This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eliminate SVpbm_VALID flag
[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 }
0eb335df
BF
9 {
10 package t;
11 my $core = !!$ENV{PERL_CORE};
12 require($core ? '../../t/test.pl' : './t/test.pl');
13 }
9ec58fb7
JH
14}
15
06a5cade 16use Test::More;
e7ecf62c 17
9248c45a
JH
18use Devel::Peek;
19
9248c45a 20our $DEBUG = 0;
277ddfaf 21open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
9248c45a 22
bfe27a58
NC
23# If I reference any lexicals in this, I get the entire outer subroutine (or
24# MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
25# maintain that.
26format PIE =
27Pie @<<<<<
28$::type
29Good @>>>>>
30$::mmmm
31.
32
bad4ae38
FC
33use constant thr => $Config{useithreads};
34
9248c45a 35sub do_test {
000fd473
NC
36 my $todo = $_[3];
37 my $repeat_todo = $_[4];
38 my $pattern = $_[2];
34b94bc4 39 my $do_eval = $_[5];
277ddfaf
GS
40 if (open(OUT,">peek$$")) {
41 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
34b94bc4
FC
42 if ($do_eval) {
43 my $sub = eval "sub { Dump $_[1] }";
44 $sub->();
45 print STDERR "*****\n";
46 # second dump to compare with the first to make sure nothing
47 # changed.
48 $sub->();
49 }
50 else {
51 Dump($_[1]);
52 print STDERR "*****\n";
53 # second dump to compare with the first to make sure nothing
54 # changed.
55 Dump($_[1]);
56 }
277ddfaf
GS
57 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
58 close(OUT);
9248c45a
JH
59 if (open(IN, "peek$$")) {
60 local $/;
61 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
8aacddc1 62 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
fd0854ff 63 # handle DEBUG_LEAKING_SCALARS prefix
d94a5950 64 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
bf53b3a5 65
000fd473
NC
66 # Need some clear generic mechanism to eliminate (or add) lines
67 # of dump output dependant on perl version. The (previous) use of
68 # things like $IVNV gave the illusion that the string passed in was
69 # a regexp into which variables were interpolated, but this wasn't
70 # actually true as those 'variables' actually also ate the
b7b1e41b 71 # whitespace on the line. So it seems better to mark lines that
000fd473
NC
72 # need to be eliminated. I considered (?# ... ) and (?{ ... }),
73 # but whilst embedded code or comment syntax would keep it as a
74 # legitimate regexp, it still isn't true. Seems easier and clearer
75 # things that look like comments.
76
77 # Could do this is in a s///mge but seems clearer like this:
78 $pattern = join '', map {
79 # If we identify the version condition, take *it* out whatever
bad4ae38 80 s/\s*# (\$].*)$//
000fd473
NC
81 ? (eval $1 ? $_ : '')
82 : $_ # Didn't match, so this line is in
83 } split /^/, $pattern;
84
a9f1090b
FC
85 $pattern =~ s/\$PADMY,/
86 $] < 5.012005 ? 'PADMY,' : '';
000fd473 87 /mge;
2b631c93
NC
88 $pattern =~ s/\$RV/
89 ($] < 5.011) ? 'RV' : 'IV';
90 /mge;
11d7de88 91 $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
e811af66 92 if $Config{ccflags} =~
0d93ddf1 93 /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
32ce4ca8 94 || $] < 5.019003;
9248c45a 95 print $pattern, "\n" if $DEBUG;
e9569a7a 96 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
9248c45a 97 print $dump, "\n" if $DEBUG;
06a5cade
NC
98 like( $dump, qr/\A$pattern\Z/ms, $_[0])
99 or note("line " . (caller)[2]);
e9569a7a 100
000fd473 101 local $TODO = $repeat_todo;
06a5cade
NC
102 is($dump2, $dump, "$_[0] (unchanged by dump)")
103 or note("line " . (caller)[2]);
e9569a7a 104
9248c45a 105 close(IN);
e9569a7a 106
59d8ce62 107 return $1;
9248c45a
JH
108 } else {
109 die "$0: failed to open peek$$: !\n";
110 }
111 } else {
112 die "$0: failed to create peek$$: $!\n";
113 }
114}
115
116our $a;
117our $b;
118my $c;
208edb77 119local $d = 0;
9248c45a 120
e7ecf62c
RGS
121END {
122 1 while unlink("peek$$");
123}
bf53b3a5 124
06a5cade 125do_test('assignment of immediate constant (string)',
9248c45a
JH
126 $a = "foo",
127'SV = PV\\($ADDR\\) at $ADDR
128 REFCNT = 1
7fa949d0 129 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9248c45a
JH
130 PV = $ADDR "foo"\\\0
131 CUR = 3
7fa949d0 132 LEN = \\d+
32ce4ca8 133 COW_REFCNT = 1
7fa949d0 134');
9248c45a 135
06a5cade 136do_test('immediate constant (string)',
9248c45a
JH
137 "bar",
138'SV = PV\\($ADDR\\) at $ADDR
139 REFCNT = 1
8c7751f4
FC
140 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
141 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
9248c45a
JH
142 PV = $ADDR "bar"\\\0
143 CUR = 3
7fa949d0 144 LEN = \\d+
32ce4ca8 145 COW_REFCNT = 0
7fa949d0 146');
9248c45a 147
b7b1e41b 148do_test('assignment of immediate constant (integer)',
9248c45a
JH
149 $b = 123,
150'SV = IV\\($ADDR\\) at $ADDR
151 REFCNT = 1
152 FLAGS = \\(IOK,pIOK\\)
153 IV = 123');
154
06a5cade 155do_test('immediate constant (integer)',
9248c45a
JH
156 456,
157'SV = IV\\($ADDR\\) at $ADDR
158 REFCNT = 1
8c7751f4
FC
159 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005
160 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005
9248c45a
JH
161 IV = 456');
162
06a5cade 163do_test('assignment of immediate constant (integer)',
9248c45a
JH
164 $c = 456,
165'SV = IV\\($ADDR\\) at $ADDR
166 REFCNT = 1
000fd473 167 FLAGS = \\($PADMY,IOK,pIOK\\)
9248c45a
JH
168 IV = 456');
169
59d8ce62
NC
170# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
171# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
172# maths is done in floating point always, and this scalar will be an NV.
173# ([NI]) captures the type, referred to by \1 in this regexp and $type for
174# building subsequent regexps.
06a5cade 175my $type = do_test('result of addition',
9248c45a 176 $c + $d,
59d8ce62 177'SV = ([NI])V\\($ADDR\\) at $ADDR
9248c45a 178 REFCNT = 1
f5b4a412
FC
179 FLAGS = \\(PADTMP,\1OK,p\1OK\\) # $] < 5.019003
180 FLAGS = \\(\1OK,p\1OK\\) # $] >=5.019003
59d8ce62 181 \1V = 456');
9248c45a
JH
182
183($d = "789") += 0.1;
184
06a5cade 185do_test('floating point value',
9248c45a 186 $d,
7fa949d0 187 $] < 5.019003
0d93ddf1 188 || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/
7fa949d0 189 ?
9248c45a
JH
190'SV = PVNV\\($ADDR\\) at $ADDR
191 REFCNT = 1
192 FLAGS = \\(NOK,pNOK\\)
78d00c47 193 IV = \d+
ac634a9a 194 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
9248c45a
JH
195 PV = $ADDR "789"\\\0
196 CUR = 3
7fa949d0
FC
197 LEN = \\d+'
198 :
199'SV = PVNV\\($ADDR\\) at $ADDR
200 REFCNT = 1
201 FLAGS = \\(NOK,pNOK\\)
202 IV = \d+
203 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
204 PV = 0');
9248c45a 205
06a5cade 206do_test('integer constant',
9248c45a
JH
207 0xabcd,
208'SV = IV\\($ADDR\\) at $ADDR
209 REFCNT = 1
8c7751f4
FC
210 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005
211 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005
28e5dec8 212 IV = 43981');
9248c45a 213
06a5cade 214do_test('undef',
9248c45a
JH
215 undef,
216'SV = NULL\\(0x0\\) at $ADDR
34b94bc4 217 REFCNT = \d+
8c7751f4
FC
218 FLAGS = \\(READONLY\\) # $] < 5.021005
219 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
f7634e86 220');
9248c45a 221
06a5cade 222do_test('reference to scalar',
9248c45a 223 \$a,
4df7f6af 224'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
225 REFCNT = 1
226 FLAGS = \\(ROK\\)
227 RV = $ADDR
228 SV = PV\\($ADDR\\) at $ADDR
229 REFCNT = 2
7fa949d0 230 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9248c45a
JH
231 PV = $ADDR "foo"\\\0
232 CUR = 3
7fa949d0 233 LEN = \\d+
32ce4ca8 234 COW_REFCNT = 1
7fa949d0 235');
9248c45a 236
59d8ce62
NC
237my $c_pattern;
238if ($type eq 'N') {
239 $c_pattern = '
240 SV = PVNV\\($ADDR\\) at $ADDR
241 REFCNT = 1
242 FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
243 IV = 456
244 NV = 456
245 PV = 0';
246} else {
247 $c_pattern = '
248 SV = IV\\($ADDR\\) at $ADDR
249 REFCNT = 1
250 FLAGS = \\(IOK,pIOK\\)
251 IV = 456';
252}
06a5cade 253do_test('reference to array',
9248c45a 254 [$b,$c],
4df7f6af 255'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
256 REFCNT = 1
257 FLAGS = \\(ROK\\)
258 RV = $ADDR
259 SV = PVAV\\($ADDR\\) at $ADDR
78c72037 260 REFCNT = 1
9248c45a 261 FLAGS = \\(\\)
9248c45a
JH
262 ARRAY = $ADDR
263 FILL = 1
264 MAX = 1
9248c45a
JH
265 FLAGS = \\(REAL\\)
266 Elt No. 0
267 SV = IV\\($ADDR\\) at $ADDR
268 REFCNT = 1
269 FLAGS = \\(IOK,pIOK\\)
270 IV = 123
59d8ce62 271 Elt No. 1' . $c_pattern);
9248c45a 272
06a5cade 273do_test('reference to hash',
9248c45a 274 {$b=>$c},
4df7f6af 275'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
276 REFCNT = 1
277 FLAGS = \\(ROK\\)
278 RV = $ADDR
279 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 280 REFCNT = [12]
9248c45a 281 FLAGS = \\(SHAREKEYS\\)
9248c45a 282 ARRAY = $ADDR \\(0:7, 1:1\\)
b8fa94d8 283 hash quality = 100.0%
9248c45a
JH
284 KEYS = 1
285 FILL = 1
286 MAX = 7
000fd473
NC
287 Elt "123" HASH = $ADDR' . $c_pattern,
288 '',
9d27f129 289 $] < 5.015
f3ce8053 290 && 'The hash iterator used in dump.c sets the OOK flag');
9248c45a 291
06a5cade 292do_test('reference to anon sub with empty prototype',
9248c45a 293 sub(){@_},
4df7f6af 294'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
295 REFCNT = 1
296 FLAGS = \\(ROK\\)
297 RV = $ADDR
298 SV = PVCV\\($ADDR\\) at $ADDR
299 REFCNT = 2
bad4ae38
FC
300 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
301 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
9248c45a
JH
302 PROTOTYPE = ""
303 COMP_STASH = $ADDR\\t"main"
304 START = $ADDR ===> \\d+
305 ROOT = $ADDR
208edb77 306 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
084d946d 307 FILE = ".*\\b(?i:peek\\.t)"
000fd473
NC
308 DEPTH = 0(?:
309 MUTEXP = $ADDR
310 OWNER = $ADDR)?
9d27f129 311 FLAGS = 0x490 # $] < 5.015 || !thr
bad4ae38 312 FLAGS = 0x1490 # $] >= 5.015 && thr
a3985cdc 313 OUTSIDE_SEQ = \\d+
9248c45a 314 PADLIST = $ADDR
dd2155a4 315 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
9248c45a
JH
316 OUTSIDE = $ADDR \\(MAIN\\)');
317
06a5cade 318do_test('reference to named subroutine without prototype',
9248c45a 319 \&do_test,
4df7f6af 320'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
321 REFCNT = 1
322 FLAGS = \\(ROK\\)
323 RV = $ADDR
324 SV = PVCV\\($ADDR\\) at $ADDR
9856a127 325 REFCNT = (3|4)
13290311
FC
326 FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr
327 FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
9248c45a
JH
328 COMP_STASH = $ADDR\\t"main"
329 START = $ADDR ===> \\d+
330 ROOT = $ADDR
13290311
FC
331 NAME = "do_test" # $] >=5.021004
332 GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004
084d946d 333 FILE = ".*\\b(?i:peek\\.t)"
bad4ae38
FC
334 DEPTH = 1(?:
335 MUTEXP = $ADDR
336 OWNER = $ADDR)?
13290311
FC
337 FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr
338 FLAGS = 0x[cd145]000 # $] >= 5.015 && thr
a3985cdc 339 OUTSIDE_SEQ = \\d+
9248c45a 340 PADLIST = $ADDR
dd2155a4 341 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
000fd473
NC
342 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
343 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
ee6cee0c 344 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
34b94bc4
FC
345 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
346 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
9d27f129 347 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
ee6cee0c 348 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
e9569a7a 349 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
9248c45a
JH
350 OUTSIDE = $ADDR \\(MAIN\\)');
351
3ce3ed55 352if ($] >= 5.011) {
e3e400ec 353# note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
06a5cade 354do_test('reference to regexp',
3ce3ed55
NC
355 qr(tic),
356'SV = $RV\\($ADDR\\) at $ADDR
357 REFCNT = 1
358 FLAGS = \\(ROK\\)
359 RV = $ADDR
5c35adbb 360 SV = REGEXP\\($ADDR\\) at $ADDR
c2123ae3 361 REFCNT = 1
8d919b0a
FC
362 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) # $] < 5.017006
363 FLAGS = \\(OBJECT,FAKE\\) # $] >= 5.017006
fb85c044
KW
364 PV = $ADDR "\\(\\?\\^:tic\\)"
365 CUR = 8
8d919b0a 366 LEN = 0 # $] < 5.017006
d63e6659
DM
367 STASH = $ADDR\\t"Regexp"'
368. ($] < 5.013 ? '' :
369'
dbc200c5 370 COMPFLAGS = 0x0 \(\)
d63e6659 371 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
372(?: ENGINE = $ADDR \(STANDARD\)
373)? INTFLAGS = 0x0(?: \(\))?
d63e6659
DM
374 NPARENS = 0
375 LASTPAREN = 0
376 LASTCLOSEPAREN = 0
377 MINLEN = 3
378 MINLENRET = 3
379 GOFS = 0
380 PRE_PREFIX = 4
d63e6659 381 SUBLEN = 0
6502e081
DM
382 SUBOFFSET = 0
383 SUBCOFFSET = 0
d63e6659 384 SUBBEG = 0x0
e3e400ec
YO
385(?: ENGINE = $ADDR
386)? MOTHER_RE = $ADDR'
01ffd0f1
FC
387. ($] < 5.019003 ? '' : '
388 SV = REGEXP\($ADDR\) at $ADDR
389 REFCNT = 2
390 FLAGS = \(\)
391 PV = $ADDR "\(\?\^:tic\)"
392 CUR = 8
393 COMPFLAGS = 0x0 \(\)
394 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
395(?: ENGINE = $ADDR \(STANDARD\)
396)? INTFLAGS = 0x0(?: \(\))?
01ffd0f1
FC
397 NPARENS = 0
398 LASTPAREN = 0
399 LASTCLOSEPAREN = 0
400 MINLEN = 3
401 MINLENRET = 3
402 GOFS = 0
403 PRE_PREFIX = 4
404 SUBLEN = 0
405 SUBOFFSET = 0
406 SUBCOFFSET = 0
407 SUBBEG = 0x0
e3e400ec
YO
408(?: ENGINE = $ADDR
409)? MOTHER_RE = 0x0
01ffd0f1
FC
410 PAREN_NAMES = 0x0
411 SUBSTRS = $ADDR
412 PPRIVATE = $ADDR
413 OFFS = $ADDR
414 QR_ANONCV = 0x0(?:
415 SAVED_COPY = 0x0)?') . '
d63e6659
DM
416 PAREN_NAMES = 0x0
417 SUBSTRS = $ADDR
418 PPRIVATE = $ADDR
d63c20f2 419 OFFS = $ADDR
c9669de2
FC
420 QR_ANONCV = 0x0(?:
421 SAVED_COPY = 0x0)?'
d63e6659 422));
3ce3ed55 423} else {
06a5cade 424do_test('reference to regexp',
9248c45a 425 qr(tic),
4df7f6af 426'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
427 REFCNT = 1
428 FLAGS = \\(ROK\\)
429 RV = $ADDR
430 SV = PVMG\\($ADDR\\) at $ADDR
431 REFCNT = 1
faf82a0b 432 FLAGS = \\(OBJECT,SMG\\)
9248c45a
JH
433 IV = 0
434 NV = 0
435 PV = 0
436 MAGIC = $ADDR
437 MG_VIRTUAL = $ADDR
14befaf4 438 MG_TYPE = PERL_MAGIC_qr\(r\)
9248c45a 439 MG_OBJ = $ADDR
9d27f129
FC
440 PAT = "\(\?^:tic\)"
441 REFCNT = 2
9248c45a 442 STASH = $ADDR\\t"Regexp"');
3ce3ed55 443}
9248c45a 444
06a5cade 445do_test('reference to blessed hash',
9248c45a 446 (bless {}, "Tac"),
4df7f6af 447'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
448 REFCNT = 1
449 FLAGS = \\(ROK\\)
450 RV = $ADDR
451 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 452 REFCNT = [12]
9248c45a 453 FLAGS = \\(OBJECT,SHAREKEYS\\)
9248c45a
JH
454 STASH = $ADDR\\t"Tac"
455 ARRAY = 0x0
456 KEYS = 0
457 FILL = 0
e1a7ec8d 458 MAX = 7', '',
9d27f129 459 $] >= 5.015
f3ce8053 460 ? 0
9d27f129 461 : 'The hash iterator used in dump.c sets the OOK flag');
9248c45a 462
06a5cade 463do_test('typeglob',
9248c45a
JH
464 *a,
465'SV = PVGV\\($ADDR\\) at $ADDR
466 REFCNT = 5
9d27f129 467 FLAGS = \\(MULTI(?:,IN_PAD)?\\)
9248c45a
JH
468 NAME = "a"
469 NAMELEN = 1
470 GvSTASH = $ADDR\\t"main"
a6de8fc7 471 FLAGS = $ADDR # $] >=5.021004
9248c45a
JH
472 GP = $ADDR
473 SV = $ADDR
474 REFCNT = 1
475 IO = 0x0
476 FORM = 0x0
477 AV = 0x0
478 HV = 0x0
479 CV = 0x0
480 CVGEN = 0x0
008009b0 481 GPFLAGS = 0x0 \(\) # $] >= 5.021004
9ec58fb7 482 LINE = \\d+
084d946d 483 FILE = ".*\\b(?i:peek\\.t)"
a6de8fc7 484 FLAGS = $ADDR # $] < 5.021004
9248c45a
JH
485 EGV = $ADDR\\t"a"');
486
cdb2dd7b 487if (ord('A') == 193) {
06a5cade 488do_test('string with Unicode',
cdb2dd7b
JH
489 chr(256).chr(0).chr(512),
490'SV = PV\\($ADDR\\) at $ADDR
491 REFCNT = 1
9d27f129
FC
492 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
493 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
cdb2dd7b
JH
494 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
495 CUR = 5
7fa949d0 496 LEN = \\d+
393e2657 497 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 498');
cdb2dd7b 499} else {
06a5cade 500do_test('string with Unicode',
e6abe6d8
JH
501 chr(256).chr(0).chr(512),
502'SV = PV\\($ADDR\\) at $ADDR
503 REFCNT = 1
9d27f129
FC
504 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
505 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
98c991d1 506 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
e6abe6d8 507 CUR = 5
7fa949d0 508 LEN = \\d+
393e2657 509 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 510');
cdb2dd7b 511}
e6abe6d8 512
cdb2dd7b 513if (ord('A') == 193) {
06a5cade 514do_test('reference to hash containing Unicode',
cdb2dd7b 515 {chr(256)=>chr(512)},
4df7f6af 516'SV = $RV\\($ADDR\\) at $ADDR
cdb2dd7b
JH
517 REFCNT = 1
518 FLAGS = \\(ROK\\)
519 RV = $ADDR
520 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 521 REFCNT = [12]
b2caaddd 522 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
cdb2dd7b
JH
523 ARRAY = $ADDR \\(0:7, 1:1\\)
524 hash quality = 100.0%
525 KEYS = 1
526 FILL = 1
527 MAX = 7
6cbfa5b4 528 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
cdb2dd7b
JH
529 SV = PV\\($ADDR\\) at $ADDR
530 REFCNT = 1
7fa949d0 531 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
cdb2dd7b
JH
532 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
533 CUR = 2
7fa949d0 534 LEN = \\d+
393e2657 535 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 536', '',
9d27f129 537 $] >= 5.015
f3ce8053 538 ? 0
9d27f129 539 : 'The hash iterator used in dump.c sets the OOK flag');
cdb2dd7b 540} else {
06a5cade 541do_test('reference to hash containing Unicode',
98c991d1 542 {chr(256)=>chr(512)},
4df7f6af 543'SV = $RV\\($ADDR\\) at $ADDR
98c991d1
JH
544 REFCNT = 1
545 FLAGS = \\(ROK\\)
546 RV = $ADDR
547 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 548 REFCNT = [12]
19692e8d 549 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
98c991d1
JH
550 ARRAY = $ADDR \\(0:7, 1:1\\)
551 hash quality = 100.0%
552 KEYS = 1
553 FILL = 1
554 MAX = 7
98c991d1
JH
555 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
556 SV = PV\\($ADDR\\) at $ADDR
557 REFCNT = 1
7fa949d0 558 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
98c991d1
JH
559 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
560 CUR = 2
7fa949d0 561 LEN = \\d+
393e2657 562 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 563', '',
9d27f129 564 $] >= 5.015
f3ce8053 565 ? 0
9d27f129 566 : 'The hash iterator used in dump.c sets the OOK flag');
cdb2dd7b 567}
98c991d1 568
99331854
YST
569my $x="";
570$x=~/.??/g;
06a5cade 571do_test('scalar with pos magic',
99331854
YST
572 $x,
573'SV = PVMG\\($ADDR\\) at $ADDR
574 REFCNT = 1
c9669de2 575 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
eed1f77c 576 IV = \d+
99331854
YST
577 NV = 0
578 PV = $ADDR ""\\\0
579 CUR = 0
e811af66 580 LEN = \d+
7fa949d0 581 COW_REFCNT = [12]
99331854
YST
582 MAGIC = $ADDR
583 MG_VIRTUAL = &PL_vtbl_mglob
584 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
25fdce4a
FC
585 MG_FLAGS = 0x01 # $] < 5.019003
586 MG_FLAGS = 0x41 # $] >=5.019003
587 MINMATCH
588 BYTES # $] >=5.019003
589');
99331854 590
f24fdb76
HS
591#
592# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
593# environment variables may be invisibly case-forced, hence the (?i:PATH)
5e836f43 594# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
12033064
CS
595# Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
596# Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
d9baf692
JM
597# VMS is setting FAKE and READONLY flags. What VMS uses for storing
598# ENV hashes is also not always null terminated.
f24fdb76 599#
284167a5 600if (${^TAINT}) {
bea5cecf
BF
601 # Save and restore PATH, since fresh_perl ends up using that in Windows.
602 my $path = $ENV{PATH};
284167a5
SM
603 do_test('tainted value in %ENV',
604 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
99331854
YST
605'SV = PVMG\\($ADDR\\) at $ADDR
606 REFCNT = 1
12033064 607 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
99331854
YST
608 IV = 0
609 NV = 0
610 PV = $ADDR "0"\\\0
611 CUR = 1
612 LEN = \d+
613 MAGIC = $ADDR
614 MG_VIRTUAL = &PL_vtbl_envelem
615 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
d25a523c 616(?: MG_FLAGS = 0x01
99331854 617 TAINTEDDIR
143a3e5e
CB
618)? MG_LEN = -?\d+
619 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
5e836f43 620 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
143a3e5e 621 REFCNT = \d+
02091bd7 622 FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
f0fabfd7 623(?: IV = 0
d9baf692 624)? PV = $ADDR "(?i:PATH)"(?:\\\0)?
143a3e5e
CB
625 CUR = \d+
626 LEN = \d+)
99331854
YST
627 MAGIC = $ADDR
628 MG_VIRTUAL = &PL_vtbl_taint
629 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
bea5cecf 630 $ENV{PATH} = $path;
284167a5 631}
99331854 632
06a5cade 633do_test('blessed reference',
6bf47b08 634 bless(\\undef, 'Foobar'),
4df7f6af 635'SV = $RV\\($ADDR\\) at $ADDR
6bf47b08
SR
636 REFCNT = 1
637 FLAGS = \\(ROK\\)
638 RV = $ADDR
639 SV = PVMG\\($ADDR\\) at $ADDR
640 REFCNT = 2
641 FLAGS = \\(OBJECT,ROK\\)
7957ad98
MB
642 IV = -?\d+
643 NV = $FLOAT
6bf47b08
SR
644 RV = $ADDR
645 SV = NULL\\(0x0\\) at $ADDR
646 REFCNT = \d+
8c7751f4
FC
647 FLAGS = \\(READONLY\\) # $] < 5.021005
648 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
6bf47b08
SR
649 PV = $ADDR ""
650 CUR = 0
651 LEN = 0
652 STASH = $ADDR\s+"Foobar"');
b1886099 653
b1886099
NC
654sub const () {
655 "Perl rules";
656}
657
06a5cade 658do_test('constant subroutine',
b1886099 659 \&const,
4df7f6af 660'SV = $RV\\($ADDR\\) at $ADDR
b1886099
NC
661 REFCNT = 1
662 FLAGS = \\(ROK\\)
663 RV = $ADDR
664 SV = PVCV\\($ADDR\\) at $ADDR
665 REFCNT = (2)
bad4ae38
FC
666 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
667 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
b1886099 668 PROTOTYPE = ""
02bd0dfc
FC
669 COMP_STASH = 0x0 # $] < 5.021004
670 COMP_STASH = $ADDR "main" # $] >=5.021004
b1886099
NC
671 XSUB = $ADDR
672 XSUBANY = $ADDR \\(CONST SV\\)
673 SV = PV\\($ADDR\\) at $ADDR
674 REFCNT = 1
8c7751f4
FC
675 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
676 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
b1886099
NC
677 PV = $ADDR "Perl rules"\\\0
678 CUR = 10
679 LEN = \\d+
32ce4ca8 680 COW_REFCNT = 0
b1886099
NC
681 GVGV::GV = $ADDR\\t"main" :: "const"
682 FILE = ".*\\b(?i:peek\\.t)"
000fd473
NC
683 DEPTH = 0(?:
684 MUTEXP = $ADDR
685 OWNER = $ADDR)?
9d27f129 686 FLAGS = 0xc00 # $] < 5.013
bad4ae38
FC
687 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
688 FLAGS = 0x100c # $] >= 5.015
b1886099 689 OUTSIDE_SEQ = 0
eacbb379 690 PADLIST = 0x0 # $] < 5.021006
db6e00bd 691 HSCXT = $ADDR # $] >= 5.021006
b1886099 692 OUTSIDE = 0x0 \\(null\\)');
2e94196c 693
06a5cade 694do_test('isUV should show on PVMG',
2e94196c
NC
695 do { my $v = $1; $v = ~0; $v },
696'SV = PVMG\\($ADDR\\) at $ADDR
697 REFCNT = 1
698 FLAGS = \\(IOK,pIOK,IsUV\\)
699 UV = \d+
700 NV = 0
701 PV = 0');
c0a413d1 702
06a5cade 703do_test('IO',
c0a413d1
NC
704 *STDOUT{IO},
705'SV = $RV\\($ADDR\\) at $ADDR
706 REFCNT = 1
707 FLAGS = \\(ROK\\)
708 RV = $ADDR
709 SV = PVIO\\($ADDR\\) at $ADDR
710 REFCNT = 3
711 FLAGS = \\(OBJECT\\)
3cf51070 712 IV = 0 # $] < 5.011
1bcecb77 713 NV = 0 # $] < 5.011
d963bf01 714 STASH = $ADDR\s+"IO::File"
c0a413d1
NC
715 IFP = $ADDR
716 OFP = $ADDR
717 DIRP = 0x0
718 LINES = 0
719 PAGE = 0
720 PAGE_LEN = 60
721 LINES_LEFT = 0
722 TOP_GV = 0x0
723 FMT_GV = 0x0
724 BOTTOM_GV = 0x0
725 TYPE = \'>\'
50a9fad1 726 FLAGS = 0x4');
bfe27a58 727
06a5cade 728do_test('FORMAT',
bfe27a58
NC
729 *PIE{FORMAT},
730'SV = $RV\\($ADDR\\) at $ADDR
731 REFCNT = 1
732 FLAGS = \\(ROK\\)
733 RV = $ADDR
734 SV = PVFM\\($ADDR\\) at $ADDR
735 REFCNT = 2
bad4ae38
FC
736 FLAGS = \\(\\) # $] < 5.015 || !thr
737 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
251a4af1
DM
738(?: PV = 0
739)? COMP_STASH = 0x0
bfe27a58
NC
740 START = $ADDR ===> \\d+
741 ROOT = $ADDR
bfe27a58 742 GVGV::GV = $ADDR\\t"main" :: "PIE"
bad4ae38 743 FILE = ".*\\b(?i:peek\\.t)"(?:
d3810ef8 744 DEPTH = 0)?(?:
c12100a4 745 MUTEXP = $ADDR
bad4ae38
FC
746 OWNER = $ADDR)?
747 FLAGS = 0x0 # $] < 5.015 || !thr
748 FLAGS = 0x1000 # $] >= 5.015 && thr
bfe27a58 749 OUTSIDE_SEQ = \\d+
d3810ef8 750 LINES = 0 # $] < 5.017_003
bfe27a58
NC
751 PADLIST = $ADDR
752 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
753 OUTSIDE = $ADDR \\(MAIN\\)');
d7d51f4b 754
b7b1e41b 755do_test('blessing to a class with embedded NUL characters',
d7d51f4b
YO
756 (bless {}, "\0::foo::\n::baz::\t::\0"),
757'SV = $RV\\($ADDR\\) at $ADDR
758 REFCNT = 1
759 FLAGS = \\(ROK\\)
760 RV = $ADDR
761 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 762 REFCNT = [12]
d7d51f4b 763 FLAGS = \\(OBJECT,SHAREKEYS\\)
d7d51f4b
YO
764 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
765 ARRAY = $ADDR
766 KEYS = 0
767 FILL = 0
e1a7ec8d 768 MAX = 7', '',
9d27f129 769 $] >= 5.015
f3ce8053 770 ? 0
9d27f129 771 : 'The hash iterator used in dump.c sets the OOK flag');
d7d51f4b 772
bed53064
NC
773do_test('ENAME on a stash',
774 \%RWOM::,
775'SV = $RV\\($ADDR\\) at $ADDR
776 REFCNT = 1
777 FLAGS = \\(ROK\\)
778 RV = $ADDR
779 SV = PVHV\\($ADDR\\) at $ADDR
780 REFCNT = 2
781 FLAGS = \\(OOK,SHAREKEYS\\)
0c22a733 782 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
783 ARRAY = $ADDR
784 KEYS = 0
8bf4c401 785 FILL = 0
bed53064
NC
786 MAX = 7
787 RITER = -1
788 EITER = 0x0
e1a7ec8d 789 RAND = $ADDR
bed53064
NC
790 NAME = "RWOM"
791 ENAME = "RWOM" # $] > 5.012
792');
793
794*KLANK:: = \%RWOM::;
795
796do_test('ENAMEs on a stash',
797 \%RWOM::,
798'SV = $RV\\($ADDR\\) at $ADDR
799 REFCNT = 1
800 FLAGS = \\(ROK\\)
801 RV = $ADDR
802 SV = PVHV\\($ADDR\\) at $ADDR
803 REFCNT = 3
804 FLAGS = \\(OOK,SHAREKEYS\\)
0c22a733 805 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
806 ARRAY = $ADDR
807 KEYS = 0
8bf4c401 808 FILL = 0
bed53064
NC
809 MAX = 7
810 RITER = -1
811 EITER = 0x0
e1a7ec8d 812 RAND = $ADDR
bed53064
NC
813 NAME = "RWOM"
814 NAMECOUNT = 2 # $] > 5.012
815 ENAME = "RWOM", "KLANK" # $] > 5.012
816');
817
818undef %RWOM::;
819
820do_test('ENAMEs on a stash with no NAME',
821 \%RWOM::,
822'SV = $RV\\($ADDR\\) at $ADDR
823 REFCNT = 1
824 FLAGS = \\(ROK\\)
825 RV = $ADDR
826 SV = PVHV\\($ADDR\\) at $ADDR
827 REFCNT = 3
6acb8aa1 828 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
8c7751f4
FC
829 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005
830 FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005
0c22a733 831 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
832 ARRAY = $ADDR
833 KEYS = 0
8bf4c401 834 FILL = 0
bed53064
NC
835 MAX = 7
836 RITER = -1
837 EITER = 0x0
e1a7ec8d 838 RAND = $ADDR
bed53064
NC
839 NAMECOUNT = -3 # $] > 5.012
840 ENAME = "RWOM", "KLANK" # $] > 5.012
841');
842
9faf471a
NC
843my %small = ("Perl", "Rules", "Beer", "Foamy");
844my $b = %small;
845do_test('small hash',
846 \%small,
847'SV = $RV\\($ADDR\\) at $ADDR
848 REFCNT = 1
849 FLAGS = \\(ROK\\)
850 RV = $ADDR
851 SV = PVHV\\($ADDR\\) at $ADDR
852 REFCNT = 2
a9f1090b 853 FLAGS = \\($PADMY,SHAREKEYS\\)
9faf471a
NC
854 ARRAY = $ADDR \\(0:[67],.*\\)
855 hash quality = [0-9.]+%
856 KEYS = 2
857 FILL = [12]
858 MAX = 7
859(?: Elt "(?:Perl|Beer)" HASH = $ADDR
860 SV = PV\\($ADDR\\) at $ADDR
861 REFCNT = 1
7fa949d0 862 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
863 PV = $ADDR "(?:Rules|Foamy)"\\\0
864 CUR = \d+
865 LEN = \d+
32ce4ca8 866 COW_REFCNT = 1
9faf471a
NC
867){2}');
868
869$b = keys %small;
870
871do_test('small hash after keys',
872 \%small,
873'SV = $RV\\($ADDR\\) at $ADDR
874 REFCNT = 1
875 FLAGS = \\(ROK\\)
876 RV = $ADDR
877 SV = PVHV\\($ADDR\\) at $ADDR
878 REFCNT = 2
a9f1090b 879 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
0c22a733 880 AUX_FLAGS = 0 # $] > 5.019008
9faf471a
NC
881 ARRAY = $ADDR \\(0:[67],.*\\)
882 hash quality = [0-9.]+%
883 KEYS = 2
8bf4c401 884 FILL = [12]
9faf471a
NC
885 MAX = 7
886 RITER = -1
887 EITER = 0x0
888 RAND = $ADDR
889(?: Elt "(?:Perl|Beer)" HASH = $ADDR
890 SV = PV\\($ADDR\\) at $ADDR
891 REFCNT = 1
7fa949d0 892 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
893 PV = $ADDR "(?:Rules|Foamy)"\\\0
894 CUR = \d+
895 LEN = \d+
32ce4ca8 896 COW_REFCNT = 1
9faf471a
NC
897){2}');
898
899$b = %small;
900
901do_test('small hash after keys and scalar',
902 \%small,
903'SV = $RV\\($ADDR\\) at $ADDR
904 REFCNT = 1
905 FLAGS = \\(ROK\\)
906 RV = $ADDR
907 SV = PVHV\\($ADDR\\) at $ADDR
908 REFCNT = 2
a9f1090b 909 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
0c22a733 910 AUX_FLAGS = 0 # $] > 5.019008
9faf471a
NC
911 ARRAY = $ADDR \\(0:[67],.*\\)
912 hash quality = [0-9.]+%
913 KEYS = 2
8bf4c401 914 FILL = ([12])
9faf471a
NC
915 MAX = 7
916 RITER = -1
917 EITER = 0x0
918 RAND = $ADDR
919(?: Elt "(?:Perl|Beer)" HASH = $ADDR
920 SV = PV\\($ADDR\\) at $ADDR
921 REFCNT = 1
7fa949d0 922 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
923 PV = $ADDR "(?:Rules|Foamy)"\\\0
924 CUR = \d+
925 LEN = \d+
32ce4ca8 926 COW_REFCNT = 1
9faf471a
NC
927){2}');
928
34b94bc4
FC
929# Dump with arrays, hashes, and operator return values
930@array = 1..3;
931do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
932SV = PVAV\($ADDR\) at $ADDR
933 REFCNT = 1
934 FLAGS = \(\)
935 ARRAY = $ADDR
936 FILL = 2
937 MAX = 3
34b94bc4
FC
938 FLAGS = \(REAL\)
939 Elt No. 0
940 SV = IV\($ADDR\) at $ADDR
941 REFCNT = 1
942 FLAGS = \(IOK,pIOK\)
943 IV = 1
944 Elt No. 1
945 SV = IV\($ADDR\) at $ADDR
946 REFCNT = 1
947 FLAGS = \(IOK,pIOK\)
948 IV = 2
949 Elt No. 2
950 SV = IV\($ADDR\) at $ADDR
951 REFCNT = 1
952 FLAGS = \(IOK,pIOK\)
953 IV = 3
954ARRAY
e864b323
DM
955
956do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1);
957SV = PVAV\($ADDR\) at $ADDR
958 REFCNT = 1
959 FLAGS = \(\)
960 ARRAY = $ADDR
961 FILL = 2
962 MAX = 3
e864b323
DM
963 FLAGS = \(REAL\)
964 Elt No. 0
965 SV = IV\($ADDR\) at $ADDR
966 REFCNT = 1
967 FLAGS = \(IOK,pIOK\)
968 IV = 1
969ARRAY
970
34b94bc4
FC
971%hash = 1..2;
972do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
973SV = PVHV\($ADDR\) at $ADDR
974 REFCNT = 1
975 FLAGS = \(SHAREKEYS\)
976 ARRAY = $ADDR \(0:7, 1:1\)
977 hash quality = 100.0%
978 KEYS = 1
979 FILL = 1
980 MAX = 7
981 Elt "1" HASH = $ADDR
982 SV = IV\($ADDR\) at $ADDR
983 REFCNT = 1
984 FLAGS = \(IOK,pIOK\)
985 IV = 2
986HASH
e864b323 987
34b94bc4
FC
988$_ = "hello";
989do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
990SV = PV\($ADDR\) at $ADDR
991 REFCNT = 1
992 FLAGS = \(PADTMP,POK,pPOK\)
993 PV = $ADDR "el"\\0
994 CUR = 2
995 LEN = \d+
996SUBSTR
997
313efa90
FC
998# Dump with no arguments
999eval 'Dump';
1000like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1001eval 'Dump()';
1002like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1003
4ab5bd5f 1004SKIP: {
b59747ac 1005 skip "Not built with usemymalloc", 2
4ab5bd5f
FC
1006 unless $Config{usemymalloc} eq 'y';
1007 my $x = __PACKAGE__;
1008 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1009 or diag $@;
b59747ac
FC
1010 my $y;
1011 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
4ab5bd5f
FC
1012}
1013
bc9a5256
NC
1014# This is more a test of fbm_compile/pp_study (non) interaction than dumping
1015# prowess, but short of duplicating all the gubbins of this file, I can't see
1016# a way to make a better place for it:
1017
ccbcbb3d 1018use constant {
94563b2d
KW
1019
1020 # The length of the rhs string must be such that if chr() is applied to it
1021 # doesn't yield a character with a backslash mnemonic. For example, if it
1022 # were 'rules' instead of 'rule', it would have 5 characters, and on
1023 # EBCDIC, chr(5) is \t. The dumping code would translate all the 5's in
1024 # MG_PTR into "\t", and this test code would be expecting \5's, so the
1025 # tests would fail. No platform that Perl works on translates chr(4) into
1026 # a mnemonic.
1027 perl => 'rule',
1028 beer => 'foam',
ccbcbb3d 1029};
0a0c4b76
NC
1030
1031unless ($Config{useithreads}) {
1032 # These end up as copies in pads under ithreads, which rather defeats the
1033 # the point of what we're trying to test here.
1034
1035 do_test('regular string constant', perl,
1036'SV = PV\\($ADDR\\) at $ADDR
bc9a5256 1037 REFCNT = 5
0881bdf0 1038 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1039 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1040 PV = $ADDR "rule"\\\0
1041 CUR = 4
0a0c4b76 1042 LEN = \d+
32ce4ca8 1043 COW_REFCNT = 0
0a0c4b76
NC
1044');
1045
1046 eval 'index "", perl';
1047
0a0c4b76 1048 do_test('string constant now an FBM', perl,
c13a5c80 1049'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256 1050 REFCNT = 5
a5c7cb08 1051 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1052 PV = $ADDR "rule"\\\0
1053 CUR = 4
bc9a5256 1054 LEN = \d+
32ce4ca8 1055 COW_REFCNT = 0
bc9a5256 1056 MAGIC = $ADDR
b76b0bf9 1057 MG_VIRTUAL = &PL_vtbl_regexp
bc9a5256 1058 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
1059 MG_LEN = 256
1060 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1061 RARE = \d+ # $] < 5.019002
1062 PREVIOUS = 1 # $] < 5.019002
bc9a5256
NC
1063 USEFUL = 100
1064');
1065
1066 is(study perl, '', "Not allowed to study an FBM");
1067
1068 do_test('string constant still an FBM', perl,
c13a5c80 1069'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256 1070 REFCNT = 5
a5c7cb08 1071 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1072 PV = $ADDR "rule"\\\0
1073 CUR = 4
0a0c4b76 1074 LEN = \d+
32ce4ca8 1075 COW_REFCNT = 0
0a0c4b76 1076 MAGIC = $ADDR
b76b0bf9 1077 MG_VIRTUAL = &PL_vtbl_regexp
0a0c4b76 1078 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
1079 MG_LEN = 256
1080 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1081 RARE = \d+ # $] < 5.019002
1082 PREVIOUS = 1 # $] < 5.019002
0a0c4b76
NC
1083 USEFUL = 100
1084');
ccbcbb3d
NC
1085
1086 do_test('regular string constant', beer,
1087'SV = PV\\($ADDR\\) at $ADDR
4185c919 1088 REFCNT = 6
0881bdf0 1089 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1090 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1091 PV = $ADDR "foam"\\\0
1092 CUR = 4
ccbcbb3d 1093 LEN = \d+
32ce4ca8 1094 COW_REFCNT = 0
ccbcbb3d
NC
1095');
1096
a58a85fa
AMS
1097 is(study beer, 1, "Our studies were successful");
1098
1099 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1100 REFCNT = 6
0881bdf0 1101 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1102 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1103 PV = $ADDR "foam"\\\0
1104 CUR = 4
a58a85fa 1105 LEN = \d+
32ce4ca8 1106 COW_REFCNT = 0
a58a85fa
AMS
1107');
1108
4185c919 1109 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
4265b45d 1110 REFCNT = 6
a5c7cb08 1111 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1112 PV = $ADDR "foam"\\\0
1113 CUR = 4
4265b45d 1114 LEN = \d+
32ce4ca8 1115 COW_REFCNT = 0
4265b45d 1116 MAGIC = $ADDR
0177730e 1117 MG_VIRTUAL = &PL_vtbl_regexp
a58a85fa
AMS
1118 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1119 MG_LEN = 256
1120 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1121 RARE = \d+ # $] < 5.019002
1122 PREVIOUS = \d+ # $] < 5.019002
a58a85fa 1123 USEFUL = 100
4185c919
NC
1124';
1125
4265b45d
NC
1126 is (eval 'index "not too foamy", beer', 8, 'correct index');
1127
a58a85fa 1128 do_test('string constant now FBMed', beer, $want);
4185c919
NC
1129
1130 my $pie = 'good';
1131
1132 is(study $pie, 1, "Our studies were successful");
1133
a58a85fa 1134 do_test('string constant still FBMed', beer, $want);
4185c919 1135
a58a85fa 1136 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
4185c919 1137 REFCNT = 1
a9f1090b 1138 FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\)
4185c919
NC
1139 PV = $ADDR "good"\\\0
1140 CUR = 4
fb1c5e87
NC
1141 LEN = \d+
1142 COW_REFCNT = 1
ccbcbb3d 1143');
0a0c4b76
NC
1144}
1145
a58a85fa 1146# (One block of study tests removed when study was made a no-op.)
72de20cd 1147
486ffce2
FC
1148{
1149 open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1150 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1151 DeadCode();
1152 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1153 pass "no crash with DeadCode";
7bf23f34 1154 close OUT;
486ffce2 1155}
e3e400ec 1156# note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
8cdde9f8
NC
1157do_test('UTF-8 in a regular expression',
1158 qr/\x{100}/,
1159'SV = IV\($ADDR\) at $ADDR
1160 REFCNT = 1
1161 FLAGS = \(ROK\)
1162 RV = $ADDR
1163 SV = REGEXP\($ADDR\) at $ADDR
1164 REFCNT = 1
1165 FLAGS = \(OBJECT,FAKE,UTF8\)
1166 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1167 CUR = 13
1168 STASH = $ADDR "Regexp"
dbc200c5 1169 COMPFLAGS = 0x0 \(\)
fde14af1 1170 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
1171(?: ENGINE = $ADDR \(STANDARD\)
1172)? INTFLAGS = 0x0(?: \(\))?
8cdde9f8
NC
1173 NPARENS = 0
1174 LASTPAREN = 0
1175 LASTCLOSEPAREN = 0
1176 MINLEN = 1
1177 MINLENRET = 1
1178 GOFS = 0
1179 PRE_PREFIX = 5
1180 SUBLEN = 0
1181 SUBOFFSET = 0
1182 SUBCOFFSET = 0
1183 SUBBEG = 0x0
e3e400ec
YO
1184(?: ENGINE = $ADDR
1185)? MOTHER_RE = $ADDR'
01ffd0f1
FC
1186. ($] < 5.019003 ? '' : '
1187 SV = REGEXP\($ADDR\) at $ADDR
1188 REFCNT = 2
1189 FLAGS = \(UTF8\)
1190 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1191 CUR = 13
1192 COMPFLAGS = 0x0 \(\)
fde14af1 1193 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
1194(?: ENGINE = $ADDR \(STANDARD\)
1195)? INTFLAGS = 0x0(?: \(\))?
01ffd0f1
FC
1196 NPARENS = 0
1197 LASTPAREN = 0
1198 LASTCLOSEPAREN = 0
1199 MINLEN = 1
1200 MINLENRET = 1
1201 GOFS = 0
1202 PRE_PREFIX = 5
1203 SUBLEN = 0
1204 SUBOFFSET = 0
1205 SUBCOFFSET = 0
1206 SUBBEG = 0x0
e3e400ec
YO
1207(?: ENGINE = $ADDR
1208)? MOTHER_RE = 0x0
01ffd0f1
FC
1209 PAREN_NAMES = 0x0
1210 SUBSTRS = $ADDR
1211 PPRIVATE = $ADDR
1212 OFFS = $ADDR
1213 QR_ANONCV = 0x0(?:
1214 SAVED_COPY = 0x0)?') . '
8cdde9f8
NC
1215 PAREN_NAMES = 0x0
1216 SUBSTRS = $ADDR
1217 PPRIVATE = $ADDR
1218 OFFS = $ADDR
09af2132
DM
1219 QR_ANONCV = 0x0(?:
1220 SAVED_COPY = 0x0)?
8cdde9f8
NC
1221');
1222
da1929e7
TC
1223{ # perl #117793: Extend SvREFCNT* to work on any perl variable type
1224 my %hash;
1225 my $base_count = Devel::Peek::SvREFCNT(%hash);
1226 my $ref = \%hash;
1227 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
e4c0574e 1228 ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
da1929e7 1229}
0eb335df
BF
1230{
1231# utf8 tests
1232use utf8;
1233
1234sub _dump {
1235 open(OUT,">peek$$") or die $!;
1236 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
559d64fb 1237 Dump($_[0]);
0eb335df
BF
1238 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1239 close(OUT);
1240 open(IN, "peek$$") or die $!;
1241 my $dump = do { local $/; <IN> };
1242 close(IN);
559d64fb 1243 1 while unlink "peek$$";
0eb335df
BF
1244 return $dump;
1245}
1246
1247sub _get_coderef {
1248 my $x = $_[0];
1249 utf8::upgrade($x);
1250 eval "sub $x {}; 1" or die $@;
1251 return *{$x}{CODE};
1252}
1253
1254like(
1255 _dump(_get_coderef("\x{df}::\xdf")),
1256 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1257 "GVGV's are correctly escaped for latin1 :: latin1",
1258);
1259
1260like(
1261 _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1262 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1263 "GVGV's are correctly escaped for UTF8 :: UTF8",
1264);
1265
1266like(
1267 _dump(_get_coderef("\x{df}::\x{30cd}")),
1268 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1269 "GVGV's are correctly escaped for latin1 :: UTF8",
1270);
1271
1272like(
1273 _dump(_get_coderef("\x{30cd}::\x{df}")),
1274 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1275 "GVGV's are correctly escaped for UTF8 :: latin1",
1276);
1277
1278like(
1279 _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1280 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1281 "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1282);
1283
1284my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1285
1286like(
1287 $dump,
1288 qr/NAME = \Q"\x{30dc}"/,
1289 "NAME is correctly escaped for UTF8 globs",
1290);
1291
1292like(
1293 $dump,
1294 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1295 "GvSTASH is correctly escaped for UTF8 globs"
1296);
1297
1298like(
1299 $dump,
1300 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1301 "EGV is correctly escaped for UTF8 globs"
1302);
1303
1304$dump = _dump(*{"\x{df}::\x{30cc}"});
1305
1306like(
1307 $dump,
1308 qr/NAME = \Q"\x{30cc}"/,
1309 "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1310);
1311
1312like(
1313 $dump,
1314 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1315 "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1316);
1317
1318like(
1319 $dump,
1320 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1321 "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1322);
1323
1324like(
1325 _dump(bless {}, "\0::\1::\x{30cd}"),
1326 qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1327 "STASH for blessed hashrefs is correct"
1328);
1329
1330BEGIN { $::{doof} = "\0\1\x{30cd}" }
1331like(
1332 _dump(\&doof),
1333 qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1334 "PROTOTYPE is escaped correctly"
1335);
1336
1337{
1338 my $coderef = eval <<"EOP";
1339 use feature 'lexical_subs';
1340 no warnings 'experimental::lexical_subs';
1341 my sub bar (\$\x{30cd}) {1}; \\&bar
1342EOP
1343 like(
1344 _dump($coderef),
1345 qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1346 "PROTOTYPE works on lexical subs"
1347 )
1348}
1349
0eb335df 1350sub get_outside {
01d7523a 1351 eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
0eb335df 1352}
559d64fb 1353sub basic { my $x; return eval q{sub { eval q{$x} }} }
0eb335df 1354like(
559d64fb 1355 _dump(basic()),
0eb335df
BF
1356 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1357 'OUTSIDE works'
1358);
1359
1360like(
1361 _dump(get_outside("\x{30ce}")),
1362 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1363 'OUTSIDE + UTF8 works'
1364);
0eb335df
BF
1365
1366# TODO AUTOLOAD = stashname, which requires using a XS autoload
1367# and calling Dump() on the cv
1368
1369
1370
1371sub test_utf8_stashes {
1372 my ($stash_name, $test) = @_;
1373
1374 $dump = _dump(\%{"${stash_name}::"});
1375
1376 my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1377 $escaped_stash_name = join "", map {
1378 $_ eq ':' ? $_ : sprintf $format, ord $_
1379 } split //, $stash_name;
1380
1381 like(
1382 $dump,
1383 qr/\QNAME = "$escaped_stash_name"/,
1384 "NAME is correct escaped for $test"
1385 );
1386
1387 like(
1388 $dump,
1389 qr/\QENAME = "$escaped_stash_name"/,
1390 "ENAME is correct escaped for $test"
1391 );
1392}
1393
1394for my $test (
1395 [ "\x{30cd}", "UTF8 stashes" ],
1396 [ "\x{df}", "latin 1 stashes" ],
1397 [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1398 [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1399) {
1400 test_utf8_stashes(@$test);
1401}
1402
1403}
1404
c695838a 1405my $runperl_args = { switches => ['-Ilib'] };
0eb335df
BF
1406sub test_DumpProg {
1407 my ($prog, $expected, $name, $test) = @_;
1408 $test ||= 'like';
1409
1410 my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1411
1412 # Interface between Test::Builder & test.pl
1413 my $builder = Test::More->builder();
1414 t::curr_test($builder->current_test() + 1);
1415
1416 utf8::encode($prog);
1417
1418 if ( $test eq 'is' ) {
c695838a 1419 t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
0eb335df
BF
1420 }
1421 else {
c695838a 1422 t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
0eb335df
BF
1423 }
1424
1425 $builder->current_test(t::curr_test() - 1);
1426}
1427
1428my $threads = $Config{'useithreads'};
1429
1430for my $test (
1431[
1432 "package test;",
1433 qr/PACKAGE = "test"/,
1434 "DumpProg() + package declaration"
1435],
1436[
1437 "use utf8; package \x{30cd};",
1438 qr/PACKAGE = "\\x\Q{30cd}"/,
1439 "DumpProg() + UTF8 package declaration"
1440],
1441[
1442 "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1443 ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1444],
1445[
1446 "use utf8; \x{30cc}: { last \x{30cc} }",
1447 qr/LABEL = \Q"\x{30cc}"/
1448],
1449)
1450{
1451 test_DumpProg(@$test);
1452}
1453
e6ad046a
CB
1454{
1455 local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
1456 my $e = <<'EODUMP';
c5c79a53 1457dumpindent is 4 at -e line 1.
0eb335df
BF
1458{
14591 TYPE = leave ===> NULL
1460 TARG = 1
87b5a8b9 1461 FLAGS = (VOID,KIDS,PARENS,SLABBED)
f3574cc6 1462 PRIVATE = (REFC)
0eb335df
BF
1463 REFCNT = 1
1464 {
14652 TYPE = enter ===> 3
87b5a8b9 1466 FLAGS = (UNKNOWN,SLABBED,MORESIB)
0eb335df
BF
1467 }
1468 {
14693 TYPE = nextstate ===> 4
87b5a8b9 1470 FLAGS = (VOID,SLABBED,MORESIB)
0eb335df
BF
1471 LINE = 1
1472 PACKAGE = "t"
1473 }
1474 {
14755 TYPE = entersub ===> 1
075ddd1f 1476 TARG = 1
87b5a8b9 1477 FLAGS = (VOID,KIDS,STACKED,SLABBED)
f3574cc6 1478 PRIVATE = (TARG)
0eb335df
BF
1479 {
14806 TYPE = null ===> (5)
1481 (was list)
87b5a8b9 1482 FLAGS = (UNKNOWN,KIDS,SLABBED)
0eb335df
BF
1483 {
14844 TYPE = pushmark ===> 7
87b5a8b9 1485 FLAGS = (SCALAR,SLABBED,MORESIB)
0eb335df
BF
1486 }
1487 {
14888 TYPE = null ===> (6)
1489 (was rv2cv)
87b5a8b9 1490 FLAGS = (SCALAR,KIDS,SLABBED)
ef0f35a3 1491 PRIVATE = (0x1)
0eb335df
BF
1492 {
14937 TYPE = gv ===> 5
87b5a8b9 1494 FLAGS = (SCALAR,SLABBED)
0eb335df
BF
1495 GV_OR_PADIX
1496 }
1497 }
1498 }
1499 }
1500}
1501EODUMP
1502
e6ad046a
CB
1503 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
1504 $e =~ s/.*PRIVATE = \(0x1\).*\n// if $] < 5.021004;
1505 my $out = t::runperl
1506 switches => ['-Ilib'],
1507 prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
1508 stderr=>1;
1509 $out =~ s/ *SEQ = .*\n//;
1510 is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
1511}
06a5cade 1512done_testing();