This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
give REGEXP SVs the POK flag again
[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];
1ae6ead9 40 if (open(OUT,'>', "peek$$")) {
277ddfaf 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);
1ae6ead9 59 if (open(IN, '<', "peek$$")) {
9248c45a
JH
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
92e8e650 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
df6b4bd5 362 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
fb85c044
KW
363 PV = $ADDR "\\(\\?\\^:tic\\)"
364 CUR = 8
8d919b0a 365 LEN = 0 # $] < 5.017006
d63e6659
DM
366 STASH = $ADDR\\t"Regexp"'
367. ($] < 5.013 ? '' :
368'
dbc200c5 369 COMPFLAGS = 0x0 \(\)
d63e6659 370 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
371(?: ENGINE = $ADDR \(STANDARD\)
372)? INTFLAGS = 0x0(?: \(\))?
d63e6659
DM
373 NPARENS = 0
374 LASTPAREN = 0
375 LASTCLOSEPAREN = 0
376 MINLEN = 3
377 MINLENRET = 3
378 GOFS = 0
379 PRE_PREFIX = 4
d63e6659 380 SUBLEN = 0
6502e081
DM
381 SUBOFFSET = 0
382 SUBCOFFSET = 0
d63e6659 383 SUBBEG = 0x0
e3e400ec
YO
384(?: ENGINE = $ADDR
385)? MOTHER_RE = $ADDR'
01ffd0f1
FC
386. ($] < 5.019003 ? '' : '
387 SV = REGEXP\($ADDR\) at $ADDR
388 REFCNT = 2
df6b4bd5 389 FLAGS = \(POK,pPOK\)
01ffd0f1
FC
390 PV = $ADDR "\(\?\^:tic\)"
391 CUR = 8
392 COMPFLAGS = 0x0 \(\)
393 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
394(?: ENGINE = $ADDR \(STANDARD\)
395)? INTFLAGS = 0x0(?: \(\))?
01ffd0f1
FC
396 NPARENS = 0
397 LASTPAREN = 0
398 LASTCLOSEPAREN = 0
399 MINLEN = 3
400 MINLENRET = 3
401 GOFS = 0
402 PRE_PREFIX = 4
403 SUBLEN = 0
404 SUBOFFSET = 0
405 SUBCOFFSET = 0
406 SUBBEG = 0x0
e3e400ec
YO
407(?: ENGINE = $ADDR
408)? MOTHER_RE = 0x0
01ffd0f1
FC
409 PAREN_NAMES = 0x0
410 SUBSTRS = $ADDR
411 PPRIVATE = $ADDR
412 OFFS = $ADDR
413 QR_ANONCV = 0x0(?:
414 SAVED_COPY = 0x0)?') . '
d63e6659
DM
415 PAREN_NAMES = 0x0
416 SUBSTRS = $ADDR
417 PPRIVATE = $ADDR
d63c20f2 418 OFFS = $ADDR
c9669de2
FC
419 QR_ANONCV = 0x0(?:
420 SAVED_COPY = 0x0)?'
d63e6659 421));
3ce3ed55 422} else {
06a5cade 423do_test('reference to regexp',
9248c45a 424 qr(tic),
4df7f6af 425'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
426 REFCNT = 1
427 FLAGS = \\(ROK\\)
428 RV = $ADDR
429 SV = PVMG\\($ADDR\\) at $ADDR
430 REFCNT = 1
faf82a0b 431 FLAGS = \\(OBJECT,SMG\\)
9248c45a
JH
432 IV = 0
433 NV = 0
434 PV = 0
435 MAGIC = $ADDR
436 MG_VIRTUAL = $ADDR
14befaf4 437 MG_TYPE = PERL_MAGIC_qr\(r\)
9248c45a 438 MG_OBJ = $ADDR
9d27f129
FC
439 PAT = "\(\?^:tic\)"
440 REFCNT = 2
9248c45a 441 STASH = $ADDR\\t"Regexp"');
3ce3ed55 442}
9248c45a 443
06a5cade 444do_test('reference to blessed hash',
9248c45a 445 (bless {}, "Tac"),
4df7f6af 446'SV = $RV\\($ADDR\\) at $ADDR
9248c45a
JH
447 REFCNT = 1
448 FLAGS = \\(ROK\\)
449 RV = $ADDR
450 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 451 REFCNT = [12]
9248c45a 452 FLAGS = \\(OBJECT,SHAREKEYS\\)
9248c45a
JH
453 STASH = $ADDR\\t"Tac"
454 ARRAY = 0x0
455 KEYS = 0
456 FILL = 0
e1a7ec8d 457 MAX = 7', '',
9d27f129 458 $] >= 5.015
f3ce8053 459 ? 0
9d27f129 460 : 'The hash iterator used in dump.c sets the OOK flag');
9248c45a 461
06a5cade 462do_test('typeglob',
9248c45a
JH
463 *a,
464'SV = PVGV\\($ADDR\\) at $ADDR
465 REFCNT = 5
9d27f129 466 FLAGS = \\(MULTI(?:,IN_PAD)?\\)
9248c45a
JH
467 NAME = "a"
468 NAMELEN = 1
469 GvSTASH = $ADDR\\t"main"
a6de8fc7 470 FLAGS = $ADDR # $] >=5.021004
9248c45a
JH
471 GP = $ADDR
472 SV = $ADDR
473 REFCNT = 1
474 IO = 0x0
475 FORM = 0x0
476 AV = 0x0
477 HV = 0x0
478 CV = 0x0
479 CVGEN = 0x0
008009b0 480 GPFLAGS = 0x0 \(\) # $] >= 5.021004
9ec58fb7 481 LINE = \\d+
084d946d 482 FILE = ".*\\b(?i:peek\\.t)"
a6de8fc7 483 FLAGS = $ADDR # $] < 5.021004
9248c45a
JH
484 EGV = $ADDR\\t"a"');
485
cdb2dd7b 486if (ord('A') == 193) {
06a5cade 487do_test('string with Unicode',
cdb2dd7b
JH
488 chr(256).chr(0).chr(512),
489'SV = PV\\($ADDR\\) at $ADDR
490 REFCNT = 1
9d27f129
FC
491 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
492 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
cdb2dd7b
JH
493 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
494 CUR = 5
7fa949d0 495 LEN = \\d+
393e2657 496 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 497');
cdb2dd7b 498} else {
06a5cade 499do_test('string with Unicode',
e6abe6d8
JH
500 chr(256).chr(0).chr(512),
501'SV = PV\\($ADDR\\) at $ADDR
502 REFCNT = 1
9d27f129
FC
503 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003
504 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003
98c991d1 505 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
e6abe6d8 506 CUR = 5
7fa949d0 507 LEN = \\d+
393e2657 508 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 509');
cdb2dd7b 510}
e6abe6d8 511
cdb2dd7b 512if (ord('A') == 193) {
06a5cade 513do_test('reference to hash containing Unicode',
cdb2dd7b 514 {chr(256)=>chr(512)},
4df7f6af 515'SV = $RV\\($ADDR\\) at $ADDR
cdb2dd7b
JH
516 REFCNT = 1
517 FLAGS = \\(ROK\\)
518 RV = $ADDR
519 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 520 REFCNT = [12]
b2caaddd 521 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
cdb2dd7b
JH
522 ARRAY = $ADDR \\(0:7, 1:1\\)
523 hash quality = 100.0%
524 KEYS = 1
525 FILL = 1
526 MAX = 7
6cbfa5b4 527 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
cdb2dd7b
JH
528 SV = PV\\($ADDR\\) at $ADDR
529 REFCNT = 1
7fa949d0 530 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
cdb2dd7b
JH
531 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
532 CUR = 2
7fa949d0 533 LEN = \\d+
393e2657 534 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 535', '',
9d27f129 536 $] >= 5.015
f3ce8053 537 ? 0
9d27f129 538 : 'The hash iterator used in dump.c sets the OOK flag');
cdb2dd7b 539} else {
06a5cade 540do_test('reference to hash containing Unicode',
98c991d1 541 {chr(256)=>chr(512)},
4df7f6af 542'SV = $RV\\($ADDR\\) at $ADDR
98c991d1
JH
543 REFCNT = 1
544 FLAGS = \\(ROK\\)
545 RV = $ADDR
546 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 547 REFCNT = [12]
19692e8d 548 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
98c991d1
JH
549 ARRAY = $ADDR \\(0:7, 1:1\\)
550 hash quality = 100.0%
551 KEYS = 1
552 FILL = 1
553 MAX = 7
98c991d1
JH
554 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
555 SV = PV\\($ADDR\\) at $ADDR
556 REFCNT = 1
7fa949d0 557 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
98c991d1
JH
558 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
559 CUR = 2
7fa949d0 560 LEN = \\d+
393e2657 561 COW_REFCNT = 1 # $] < 5.019007
7fa949d0 562', '',
9d27f129 563 $] >= 5.015
f3ce8053 564 ? 0
9d27f129 565 : 'The hash iterator used in dump.c sets the OOK flag');
cdb2dd7b 566}
98c991d1 567
99331854
YST
568my $x="";
569$x=~/.??/g;
06a5cade 570do_test('scalar with pos magic',
99331854
YST
571 $x,
572'SV = PVMG\\($ADDR\\) at $ADDR
573 REFCNT = 1
c9669de2 574 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
eed1f77c 575 IV = \d+
99331854
YST
576 NV = 0
577 PV = $ADDR ""\\\0
578 CUR = 0
e811af66 579 LEN = \d+
7fa949d0 580 COW_REFCNT = [12]
99331854
YST
581 MAGIC = $ADDR
582 MG_VIRTUAL = &PL_vtbl_mglob
583 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
25fdce4a
FC
584 MG_FLAGS = 0x01 # $] < 5.019003
585 MG_FLAGS = 0x41 # $] >=5.019003
586 MINMATCH
587 BYTES # $] >=5.019003
588');
99331854 589
f24fdb76
HS
590#
591# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
592# environment variables may be invisibly case-forced, hence the (?i:PATH)
5e836f43 593# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
12033064
CS
594# Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
595# Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
d9baf692
JM
596# VMS is setting FAKE and READONLY flags. What VMS uses for storing
597# ENV hashes is also not always null terminated.
f24fdb76 598#
284167a5 599if (${^TAINT}) {
bea5cecf
BF
600 # Save and restore PATH, since fresh_perl ends up using that in Windows.
601 my $path = $ENV{PATH};
284167a5
SM
602 do_test('tainted value in %ENV',
603 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
99331854
YST
604'SV = PVMG\\($ADDR\\) at $ADDR
605 REFCNT = 1
12033064 606 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
99331854
YST
607 IV = 0
608 NV = 0
609 PV = $ADDR "0"\\\0
610 CUR = 1
611 LEN = \d+
612 MAGIC = $ADDR
613 MG_VIRTUAL = &PL_vtbl_envelem
614 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
d25a523c 615(?: MG_FLAGS = 0x01
99331854 616 TAINTEDDIR
143a3e5e
CB
617)? MG_LEN = -?\d+
618 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
5e836f43 619 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
143a3e5e 620 REFCNT = \d+
02091bd7 621 FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
f0fabfd7 622(?: IV = 0
d9baf692 623)? PV = $ADDR "(?i:PATH)"(?:\\\0)?
143a3e5e
CB
624 CUR = \d+
625 LEN = \d+)
99331854
YST
626 MAGIC = $ADDR
627 MG_VIRTUAL = &PL_vtbl_taint
628 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
bea5cecf 629 $ENV{PATH} = $path;
284167a5 630}
99331854 631
06a5cade 632do_test('blessed reference',
6bf47b08 633 bless(\\undef, 'Foobar'),
4df7f6af 634'SV = $RV\\($ADDR\\) at $ADDR
6bf47b08
SR
635 REFCNT = 1
636 FLAGS = \\(ROK\\)
637 RV = $ADDR
638 SV = PVMG\\($ADDR\\) at $ADDR
639 REFCNT = 2
640 FLAGS = \\(OBJECT,ROK\\)
7957ad98
MB
641 IV = -?\d+
642 NV = $FLOAT
6bf47b08
SR
643 RV = $ADDR
644 SV = NULL\\(0x0\\) at $ADDR
645 REFCNT = \d+
8c7751f4
FC
646 FLAGS = \\(READONLY\\) # $] < 5.021005
647 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005
6bf47b08
SR
648 PV = $ADDR ""
649 CUR = 0
650 LEN = 0
651 STASH = $ADDR\s+"Foobar"');
b1886099 652
b1886099
NC
653sub const () {
654 "Perl rules";
655}
656
06a5cade 657do_test('constant subroutine',
b1886099 658 \&const,
4df7f6af 659'SV = $RV\\($ADDR\\) at $ADDR
b1886099
NC
660 REFCNT = 1
661 FLAGS = \\(ROK\\)
662 RV = $ADDR
663 SV = PVCV\\($ADDR\\) at $ADDR
664 REFCNT = (2)
bad4ae38
FC
665 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
666 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
b1886099 667 PROTOTYPE = ""
02bd0dfc
FC
668 COMP_STASH = 0x0 # $] < 5.021004
669 COMP_STASH = $ADDR "main" # $] >=5.021004
b1886099
NC
670 XSUB = $ADDR
671 XSUBANY = $ADDR \\(CONST SV\\)
672 SV = PV\\($ADDR\\) at $ADDR
673 REFCNT = 1
8c7751f4
FC
674 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
675 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
b1886099
NC
676 PV = $ADDR "Perl rules"\\\0
677 CUR = 10
678 LEN = \\d+
32ce4ca8 679 COW_REFCNT = 0
b1886099
NC
680 GVGV::GV = $ADDR\\t"main" :: "const"
681 FILE = ".*\\b(?i:peek\\.t)"
000fd473
NC
682 DEPTH = 0(?:
683 MUTEXP = $ADDR
684 OWNER = $ADDR)?
9d27f129 685 FLAGS = 0xc00 # $] < 5.013
bad4ae38
FC
686 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
687 FLAGS = 0x100c # $] >= 5.015
b1886099 688 OUTSIDE_SEQ = 0
eacbb379 689 PADLIST = 0x0 # $] < 5.021006
db6e00bd 690 HSCXT = $ADDR # $] >= 5.021006
b1886099 691 OUTSIDE = 0x0 \\(null\\)');
2e94196c 692
06a5cade 693do_test('isUV should show on PVMG',
2e94196c
NC
694 do { my $v = $1; $v = ~0; $v },
695'SV = PVMG\\($ADDR\\) at $ADDR
696 REFCNT = 1
697 FLAGS = \\(IOK,pIOK,IsUV\\)
698 UV = \d+
699 NV = 0
700 PV = 0');
c0a413d1 701
06a5cade 702do_test('IO',
c0a413d1
NC
703 *STDOUT{IO},
704'SV = $RV\\($ADDR\\) at $ADDR
705 REFCNT = 1
706 FLAGS = \\(ROK\\)
707 RV = $ADDR
708 SV = PVIO\\($ADDR\\) at $ADDR
709 REFCNT = 3
710 FLAGS = \\(OBJECT\\)
3cf51070 711 IV = 0 # $] < 5.011
1bcecb77 712 NV = 0 # $] < 5.011
d963bf01 713 STASH = $ADDR\s+"IO::File"
c0a413d1
NC
714 IFP = $ADDR
715 OFP = $ADDR
716 DIRP = 0x0
717 LINES = 0
718 PAGE = 0
719 PAGE_LEN = 60
720 LINES_LEFT = 0
721 TOP_GV = 0x0
722 FMT_GV = 0x0
723 BOTTOM_GV = 0x0
724 TYPE = \'>\'
50a9fad1 725 FLAGS = 0x4');
bfe27a58 726
06a5cade 727do_test('FORMAT',
bfe27a58
NC
728 *PIE{FORMAT},
729'SV = $RV\\($ADDR\\) at $ADDR
730 REFCNT = 1
731 FLAGS = \\(ROK\\)
732 RV = $ADDR
733 SV = PVFM\\($ADDR\\) at $ADDR
734 REFCNT = 2
bad4ae38
FC
735 FLAGS = \\(\\) # $] < 5.015 || !thr
736 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
251a4af1
DM
737(?: PV = 0
738)? COMP_STASH = 0x0
bfe27a58
NC
739 START = $ADDR ===> \\d+
740 ROOT = $ADDR
bfe27a58 741 GVGV::GV = $ADDR\\t"main" :: "PIE"
bad4ae38 742 FILE = ".*\\b(?i:peek\\.t)"(?:
d3810ef8 743 DEPTH = 0)?(?:
c12100a4 744 MUTEXP = $ADDR
bad4ae38
FC
745 OWNER = $ADDR)?
746 FLAGS = 0x0 # $] < 5.015 || !thr
747 FLAGS = 0x1000 # $] >= 5.015 && thr
bfe27a58 748 OUTSIDE_SEQ = \\d+
d3810ef8 749 LINES = 0 # $] < 5.017_003
bfe27a58
NC
750 PADLIST = $ADDR
751 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
752 OUTSIDE = $ADDR \\(MAIN\\)');
d7d51f4b 753
b7b1e41b 754do_test('blessing to a class with embedded NUL characters',
d7d51f4b
YO
755 (bless {}, "\0::foo::\n::baz::\t::\0"),
756'SV = $RV\\($ADDR\\) at $ADDR
757 REFCNT = 1
758 FLAGS = \\(ROK\\)
759 RV = $ADDR
760 SV = PVHV\\($ADDR\\) at $ADDR
3ed356df 761 REFCNT = [12]
d7d51f4b 762 FLAGS = \\(OBJECT,SHAREKEYS\\)
d7d51f4b
YO
763 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
764 ARRAY = $ADDR
765 KEYS = 0
766 FILL = 0
e1a7ec8d 767 MAX = 7', '',
9d27f129 768 $] >= 5.015
f3ce8053 769 ? 0
9d27f129 770 : 'The hash iterator used in dump.c sets the OOK flag');
d7d51f4b 771
bed53064
NC
772do_test('ENAME on a stash',
773 \%RWOM::,
774'SV = $RV\\($ADDR\\) at $ADDR
775 REFCNT = 1
776 FLAGS = \\(ROK\\)
777 RV = $ADDR
778 SV = PVHV\\($ADDR\\) at $ADDR
779 REFCNT = 2
780 FLAGS = \\(OOK,SHAREKEYS\\)
0c22a733 781 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
782 ARRAY = $ADDR
783 KEYS = 0
8bf4c401 784 FILL = 0
bed53064
NC
785 MAX = 7
786 RITER = -1
787 EITER = 0x0
e1a7ec8d 788 RAND = $ADDR
bed53064
NC
789 NAME = "RWOM"
790 ENAME = "RWOM" # $] > 5.012
791');
792
793*KLANK:: = \%RWOM::;
794
795do_test('ENAMEs on a stash',
796 \%RWOM::,
797'SV = $RV\\($ADDR\\) at $ADDR
798 REFCNT = 1
799 FLAGS = \\(ROK\\)
800 RV = $ADDR
801 SV = PVHV\\($ADDR\\) at $ADDR
802 REFCNT = 3
803 FLAGS = \\(OOK,SHAREKEYS\\)
0c22a733 804 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
805 ARRAY = $ADDR
806 KEYS = 0
8bf4c401 807 FILL = 0
bed53064
NC
808 MAX = 7
809 RITER = -1
810 EITER = 0x0
e1a7ec8d 811 RAND = $ADDR
bed53064
NC
812 NAME = "RWOM"
813 NAMECOUNT = 2 # $] > 5.012
814 ENAME = "RWOM", "KLANK" # $] > 5.012
815');
816
817undef %RWOM::;
818
819do_test('ENAMEs on a stash with no NAME',
820 \%RWOM::,
821'SV = $RV\\($ADDR\\) at $ADDR
822 REFCNT = 1
823 FLAGS = \\(ROK\\)
824 RV = $ADDR
825 SV = PVHV\\($ADDR\\) at $ADDR
826 REFCNT = 3
6acb8aa1 827 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
8c7751f4
FC
828 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005
829 FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005
0c22a733 830 AUX_FLAGS = 0 # $] > 5.019008
bed53064
NC
831 ARRAY = $ADDR
832 KEYS = 0
8bf4c401 833 FILL = 0
bed53064
NC
834 MAX = 7
835 RITER = -1
836 EITER = 0x0
e1a7ec8d 837 RAND = $ADDR
bed53064
NC
838 NAMECOUNT = -3 # $] > 5.012
839 ENAME = "RWOM", "KLANK" # $] > 5.012
840');
841
9faf471a
NC
842my %small = ("Perl", "Rules", "Beer", "Foamy");
843my $b = %small;
844do_test('small hash',
845 \%small,
846'SV = $RV\\($ADDR\\) at $ADDR
847 REFCNT = 1
848 FLAGS = \\(ROK\\)
849 RV = $ADDR
850 SV = PVHV\\($ADDR\\) at $ADDR
851 REFCNT = 2
a9f1090b 852 FLAGS = \\($PADMY,SHAREKEYS\\)
9faf471a
NC
853 ARRAY = $ADDR \\(0:[67],.*\\)
854 hash quality = [0-9.]+%
855 KEYS = 2
856 FILL = [12]
857 MAX = 7
858(?: Elt "(?:Perl|Beer)" HASH = $ADDR
859 SV = PV\\($ADDR\\) at $ADDR
860 REFCNT = 1
7fa949d0 861 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
862 PV = $ADDR "(?:Rules|Foamy)"\\\0
863 CUR = \d+
864 LEN = \d+
32ce4ca8 865 COW_REFCNT = 1
9faf471a
NC
866){2}');
867
868$b = keys %small;
869
870do_test('small hash after keys',
871 \%small,
872'SV = $RV\\($ADDR\\) at $ADDR
873 REFCNT = 1
874 FLAGS = \\(ROK\\)
875 RV = $ADDR
876 SV = PVHV\\($ADDR\\) at $ADDR
877 REFCNT = 2
a9f1090b 878 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
0c22a733 879 AUX_FLAGS = 0 # $] > 5.019008
9faf471a
NC
880 ARRAY = $ADDR \\(0:[67],.*\\)
881 hash quality = [0-9.]+%
882 KEYS = 2
8bf4c401 883 FILL = [12]
9faf471a
NC
884 MAX = 7
885 RITER = -1
886 EITER = 0x0
887 RAND = $ADDR
888(?: Elt "(?:Perl|Beer)" HASH = $ADDR
889 SV = PV\\($ADDR\\) at $ADDR
890 REFCNT = 1
7fa949d0 891 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
892 PV = $ADDR "(?:Rules|Foamy)"\\\0
893 CUR = \d+
894 LEN = \d+
32ce4ca8 895 COW_REFCNT = 1
9faf471a
NC
896){2}');
897
898$b = %small;
899
900do_test('small hash after keys and scalar',
901 \%small,
902'SV = $RV\\($ADDR\\) at $ADDR
903 REFCNT = 1
904 FLAGS = \\(ROK\\)
905 RV = $ADDR
906 SV = PVHV\\($ADDR\\) at $ADDR
907 REFCNT = 2
a9f1090b 908 FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
0c22a733 909 AUX_FLAGS = 0 # $] > 5.019008
9faf471a
NC
910 ARRAY = $ADDR \\(0:[67],.*\\)
911 hash quality = [0-9.]+%
912 KEYS = 2
8bf4c401 913 FILL = ([12])
9faf471a
NC
914 MAX = 7
915 RITER = -1
916 EITER = 0x0
917 RAND = $ADDR
918(?: Elt "(?:Perl|Beer)" HASH = $ADDR
919 SV = PV\\($ADDR\\) at $ADDR
920 REFCNT = 1
7fa949d0 921 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
9faf471a
NC
922 PV = $ADDR "(?:Rules|Foamy)"\\\0
923 CUR = \d+
924 LEN = \d+
32ce4ca8 925 COW_REFCNT = 1
9faf471a
NC
926){2}');
927
34b94bc4
FC
928# Dump with arrays, hashes, and operator return values
929@array = 1..3;
930do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
931SV = PVAV\($ADDR\) at $ADDR
932 REFCNT = 1
933 FLAGS = \(\)
934 ARRAY = $ADDR
935 FILL = 2
936 MAX = 3
34b94bc4
FC
937 FLAGS = \(REAL\)
938 Elt No. 0
939 SV = IV\($ADDR\) at $ADDR
940 REFCNT = 1
941 FLAGS = \(IOK,pIOK\)
942 IV = 1
943 Elt No. 1
944 SV = IV\($ADDR\) at $ADDR
945 REFCNT = 1
946 FLAGS = \(IOK,pIOK\)
947 IV = 2
948 Elt No. 2
949 SV = IV\($ADDR\) at $ADDR
950 REFCNT = 1
951 FLAGS = \(IOK,pIOK\)
952 IV = 3
953ARRAY
e864b323
DM
954
955do_test('Dump @array,1', '@array,1', <<'ARRAY', '', '', 1);
956SV = PVAV\($ADDR\) at $ADDR
957 REFCNT = 1
958 FLAGS = \(\)
959 ARRAY = $ADDR
960 FILL = 2
961 MAX = 3
e864b323
DM
962 FLAGS = \(REAL\)
963 Elt No. 0
964 SV = IV\($ADDR\) at $ADDR
965 REFCNT = 1
966 FLAGS = \(IOK,pIOK\)
967 IV = 1
968ARRAY
969
34b94bc4
FC
970%hash = 1..2;
971do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
972SV = PVHV\($ADDR\) at $ADDR
973 REFCNT = 1
974 FLAGS = \(SHAREKEYS\)
975 ARRAY = $ADDR \(0:7, 1:1\)
976 hash quality = 100.0%
977 KEYS = 1
978 FILL = 1
979 MAX = 7
980 Elt "1" HASH = $ADDR
981 SV = IV\($ADDR\) at $ADDR
982 REFCNT = 1
983 FLAGS = \(IOK,pIOK\)
984 IV = 2
985HASH
e864b323 986
34b94bc4
FC
987$_ = "hello";
988do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
989SV = PV\($ADDR\) at $ADDR
990 REFCNT = 1
991 FLAGS = \(PADTMP,POK,pPOK\)
992 PV = $ADDR "el"\\0
993 CUR = 2
994 LEN = \d+
995SUBSTR
996
313efa90
FC
997# Dump with no arguments
998eval 'Dump';
999like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1000eval 'Dump()';
1001like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1002
4ab5bd5f 1003SKIP: {
b59747ac 1004 skip "Not built with usemymalloc", 2
4ab5bd5f
FC
1005 unless $Config{usemymalloc} eq 'y';
1006 my $x = __PACKAGE__;
1007 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1008 or diag $@;
b59747ac
FC
1009 my $y;
1010 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
4ab5bd5f
FC
1011}
1012
bc9a5256
NC
1013# This is more a test of fbm_compile/pp_study (non) interaction than dumping
1014# prowess, but short of duplicating all the gubbins of this file, I can't see
1015# a way to make a better place for it:
1016
ccbcbb3d 1017use constant {
94563b2d
KW
1018
1019 # The length of the rhs string must be such that if chr() is applied to it
1020 # doesn't yield a character with a backslash mnemonic. For example, if it
1021 # were 'rules' instead of 'rule', it would have 5 characters, and on
1022 # EBCDIC, chr(5) is \t. The dumping code would translate all the 5's in
1023 # MG_PTR into "\t", and this test code would be expecting \5's, so the
1024 # tests would fail. No platform that Perl works on translates chr(4) into
1025 # a mnemonic.
1026 perl => 'rule',
1027 beer => 'foam',
ccbcbb3d 1028};
0a0c4b76
NC
1029
1030unless ($Config{useithreads}) {
1031 # These end up as copies in pads under ithreads, which rather defeats the
1032 # the point of what we're trying to test here.
1033
1034 do_test('regular string constant', perl,
1035'SV = PV\\($ADDR\\) at $ADDR
bc9a5256 1036 REFCNT = 5
0881bdf0 1037 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1038 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1039 PV = $ADDR "rule"\\\0
1040 CUR = 4
0a0c4b76 1041 LEN = \d+
32ce4ca8 1042 COW_REFCNT = 0
0a0c4b76
NC
1043');
1044
1045 eval 'index "", perl';
1046
0a0c4b76 1047 do_test('string constant now an FBM', perl,
c13a5c80 1048'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256 1049 REFCNT = 5
a5c7cb08 1050 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1051 PV = $ADDR "rule"\\\0
1052 CUR = 4
bc9a5256 1053 LEN = \d+
32ce4ca8 1054 COW_REFCNT = 0
bc9a5256 1055 MAGIC = $ADDR
b76b0bf9 1056 MG_VIRTUAL = &PL_vtbl_regexp
bc9a5256 1057 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
1058 MG_LEN = 256
1059 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1060 RARE = \d+ # $] < 5.019002
1061 PREVIOUS = 1 # $] < 5.019002
bc9a5256
NC
1062 USEFUL = 100
1063');
1064
1065 is(study perl, '', "Not allowed to study an FBM");
1066
1067 do_test('string constant still an FBM', perl,
c13a5c80 1068'SV = PVMG\\($ADDR\\) at $ADDR
bc9a5256 1069 REFCNT = 5
a5c7cb08 1070 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1071 PV = $ADDR "rule"\\\0
1072 CUR = 4
0a0c4b76 1073 LEN = \d+
32ce4ca8 1074 COW_REFCNT = 0
0a0c4b76 1075 MAGIC = $ADDR
b76b0bf9 1076 MG_VIRTUAL = &PL_vtbl_regexp
0a0c4b76 1077 MG_TYPE = PERL_MAGIC_bm\\(B\\)
2bda37ba
NC
1078 MG_LEN = 256
1079 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1080 RARE = \d+ # $] < 5.019002
1081 PREVIOUS = 1 # $] < 5.019002
0a0c4b76
NC
1082 USEFUL = 100
1083');
ccbcbb3d
NC
1084
1085 do_test('regular string constant', beer,
1086'SV = PV\\($ADDR\\) at $ADDR
4185c919 1087 REFCNT = 6
0881bdf0 1088 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1089 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1090 PV = $ADDR "foam"\\\0
1091 CUR = 4
ccbcbb3d 1092 LEN = \d+
32ce4ca8 1093 COW_REFCNT = 0
ccbcbb3d
NC
1094');
1095
a58a85fa
AMS
1096 is(study beer, 1, "Our studies were successful");
1097
1098 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1099 REFCNT = 6
0881bdf0 1100 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005
a9f1090b 1101 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005
94563b2d
KW
1102 PV = $ADDR "foam"\\\0
1103 CUR = 4
a58a85fa 1104 LEN = \d+
32ce4ca8 1105 COW_REFCNT = 0
a58a85fa
AMS
1106');
1107
4185c919 1108 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
4265b45d 1109 REFCNT = 6
a5c7cb08 1110 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
94563b2d
KW
1111 PV = $ADDR "foam"\\\0
1112 CUR = 4
4265b45d 1113 LEN = \d+
32ce4ca8 1114 COW_REFCNT = 0
4265b45d 1115 MAGIC = $ADDR
0177730e 1116 MG_VIRTUAL = &PL_vtbl_regexp
a58a85fa
AMS
1117 MG_TYPE = PERL_MAGIC_bm\\(B\\)
1118 MG_LEN = 256
1119 MG_PTR = $ADDR "(?:\\\\\d){256}"
8922e438
FC
1120 RARE = \d+ # $] < 5.019002
1121 PREVIOUS = \d+ # $] < 5.019002
a58a85fa 1122 USEFUL = 100
4185c919
NC
1123';
1124
4265b45d
NC
1125 is (eval 'index "not too foamy", beer', 8, 'correct index');
1126
a58a85fa 1127 do_test('string constant now FBMed', beer, $want);
4185c919
NC
1128
1129 my $pie = 'good';
1130
1131 is(study $pie, 1, "Our studies were successful");
1132
a58a85fa 1133 do_test('string constant still FBMed', beer, $want);
4185c919 1134
a58a85fa 1135 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
4185c919 1136 REFCNT = 1
a9f1090b 1137 FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\)
4185c919
NC
1138 PV = $ADDR "good"\\\0
1139 CUR = 4
fb1c5e87
NC
1140 LEN = \d+
1141 COW_REFCNT = 1
ccbcbb3d 1142');
0a0c4b76
NC
1143}
1144
a58a85fa 1145# (One block of study tests removed when study was made a no-op.)
72de20cd 1146
486ffce2 1147{
1ae6ead9 1148 open(OUT, '>', "peek$$") or die "Failed to open peek $$: $!";
486ffce2
FC
1149 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1150 DeadCode();
1151 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1152 pass "no crash with DeadCode";
7bf23f34 1153 close OUT;
486ffce2 1154}
e3e400ec 1155# note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
8cdde9f8
NC
1156do_test('UTF-8 in a regular expression',
1157 qr/\x{100}/,
1158'SV = IV\($ADDR\) at $ADDR
1159 REFCNT = 1
1160 FLAGS = \(ROK\)
1161 RV = $ADDR
1162 SV = REGEXP\($ADDR\) at $ADDR
1163 REFCNT = 1
df6b4bd5 1164 FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\)
8cdde9f8
NC
1165 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1166 CUR = 13
1167 STASH = $ADDR "Regexp"
dbc200c5 1168 COMPFLAGS = 0x0 \(\)
fde14af1 1169 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
1170(?: ENGINE = $ADDR \(STANDARD\)
1171)? INTFLAGS = 0x0(?: \(\))?
8cdde9f8
NC
1172 NPARENS = 0
1173 LASTPAREN = 0
1174 LASTCLOSEPAREN = 0
1175 MINLEN = 1
1176 MINLENRET = 1
1177 GOFS = 0
1178 PRE_PREFIX = 5
1179 SUBLEN = 0
1180 SUBOFFSET = 0
1181 SUBCOFFSET = 0
1182 SUBBEG = 0x0
e3e400ec
YO
1183(?: ENGINE = $ADDR
1184)? MOTHER_RE = $ADDR'
01ffd0f1
FC
1185. ($] < 5.019003 ? '' : '
1186 SV = REGEXP\($ADDR\) at $ADDR
1187 REFCNT = 2
df6b4bd5 1188 FLAGS = \(POK,pPOK,UTF8\)
01ffd0f1
FC
1189 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1190 CUR = 13
1191 COMPFLAGS = 0x0 \(\)
fde14af1 1192 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
e3e400ec
YO
1193(?: ENGINE = $ADDR \(STANDARD\)
1194)? INTFLAGS = 0x0(?: \(\))?
01ffd0f1
FC
1195 NPARENS = 0
1196 LASTPAREN = 0
1197 LASTCLOSEPAREN = 0
1198 MINLEN = 1
1199 MINLENRET = 1
1200 GOFS = 0
1201 PRE_PREFIX = 5
1202 SUBLEN = 0
1203 SUBOFFSET = 0
1204 SUBCOFFSET = 0
1205 SUBBEG = 0x0
e3e400ec
YO
1206(?: ENGINE = $ADDR
1207)? MOTHER_RE = 0x0
01ffd0f1
FC
1208 PAREN_NAMES = 0x0
1209 SUBSTRS = $ADDR
1210 PPRIVATE = $ADDR
1211 OFFS = $ADDR
1212 QR_ANONCV = 0x0(?:
1213 SAVED_COPY = 0x0)?') . '
8cdde9f8
NC
1214 PAREN_NAMES = 0x0
1215 SUBSTRS = $ADDR
1216 PPRIVATE = $ADDR
1217 OFFS = $ADDR
09af2132
DM
1218 QR_ANONCV = 0x0(?:
1219 SAVED_COPY = 0x0)?
8cdde9f8
NC
1220');
1221
da1929e7
TC
1222{ # perl #117793: Extend SvREFCNT* to work on any perl variable type
1223 my %hash;
1224 my $base_count = Devel::Peek::SvREFCNT(%hash);
1225 my $ref = \%hash;
1226 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
e4c0574e 1227 ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
da1929e7 1228}
0eb335df
BF
1229{
1230# utf8 tests
1231use utf8;
1232
1233sub _dump {
1ae6ead9 1234 open(OUT, '>', "peek$$") or die $!;
0eb335df 1235 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
559d64fb 1236 Dump($_[0]);
0eb335df
BF
1237 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1238 close(OUT);
1ae6ead9 1239 open(IN, '<', "peek$$") or die $!;
0eb335df
BF
1240 my $dump = do { local $/; <IN> };
1241 close(IN);
559d64fb 1242 1 while unlink "peek$$";
0eb335df
BF
1243 return $dump;
1244}
1245
1246sub _get_coderef {
1247 my $x = $_[0];
1248 utf8::upgrade($x);
1249 eval "sub $x {}; 1" or die $@;
1250 return *{$x}{CODE};
1251}
1252
1253like(
1254 _dump(_get_coderef("\x{df}::\xdf")),
1255 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1256 "GVGV's are correctly escaped for latin1 :: latin1",
1257);
1258
1259like(
1260 _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1261 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1262 "GVGV's are correctly escaped for UTF8 :: UTF8",
1263);
1264
1265like(
1266 _dump(_get_coderef("\x{df}::\x{30cd}")),
1267 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1268 "GVGV's are correctly escaped for latin1 :: UTF8",
1269);
1270
1271like(
1272 _dump(_get_coderef("\x{30cd}::\x{df}")),
1273 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1274 "GVGV's are correctly escaped for UTF8 :: latin1",
1275);
1276
1277like(
1278 _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1279 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1280 "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1281);
1282
1283my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1284
1285like(
1286 $dump,
1287 qr/NAME = \Q"\x{30dc}"/,
1288 "NAME is correctly escaped for UTF8 globs",
1289);
1290
1291like(
1292 $dump,
1293 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1294 "GvSTASH is correctly escaped for UTF8 globs"
1295);
1296
1297like(
1298 $dump,
1299 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1300 "EGV is correctly escaped for UTF8 globs"
1301);
1302
1303$dump = _dump(*{"\x{df}::\x{30cc}"});
1304
1305like(
1306 $dump,
1307 qr/NAME = \Q"\x{30cc}"/,
1308 "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1309);
1310
1311like(
1312 $dump,
1313 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1314 "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1315);
1316
1317like(
1318 $dump,
1319 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1320 "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1321);
1322
1323like(
1324 _dump(bless {}, "\0::\1::\x{30cd}"),
1325 qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1326 "STASH for blessed hashrefs is correct"
1327);
1328
1329BEGIN { $::{doof} = "\0\1\x{30cd}" }
1330like(
1331 _dump(\&doof),
1332 qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1333 "PROTOTYPE is escaped correctly"
1334);
1335
1336{
1337 my $coderef = eval <<"EOP";
1338 use feature 'lexical_subs';
1339 no warnings 'experimental::lexical_subs';
1340 my sub bar (\$\x{30cd}) {1}; \\&bar
1341EOP
1342 like(
1343 _dump($coderef),
1344 qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1345 "PROTOTYPE works on lexical subs"
1346 )
1347}
1348
0eb335df 1349sub get_outside {
01d7523a 1350 eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
0eb335df 1351}
559d64fb 1352sub basic { my $x; return eval q{sub { eval q{$x} }} }
0eb335df 1353like(
559d64fb 1354 _dump(basic()),
0eb335df
BF
1355 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1356 'OUTSIDE works'
1357);
1358
1359like(
1360 _dump(get_outside("\x{30ce}")),
1361 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1362 'OUTSIDE + UTF8 works'
1363);
0eb335df
BF
1364
1365# TODO AUTOLOAD = stashname, which requires using a XS autoload
1366# and calling Dump() on the cv
1367
1368
1369
1370sub test_utf8_stashes {
1371 my ($stash_name, $test) = @_;
1372
1373 $dump = _dump(\%{"${stash_name}::"});
1374
1375 my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1376 $escaped_stash_name = join "", map {
1377 $_ eq ':' ? $_ : sprintf $format, ord $_
1378 } split //, $stash_name;
1379
1380 like(
1381 $dump,
1382 qr/\QNAME = "$escaped_stash_name"/,
1383 "NAME is correct escaped for $test"
1384 );
1385
1386 like(
1387 $dump,
1388 qr/\QENAME = "$escaped_stash_name"/,
1389 "ENAME is correct escaped for $test"
1390 );
1391}
1392
1393for my $test (
1394 [ "\x{30cd}", "UTF8 stashes" ],
1395 [ "\x{df}", "latin 1 stashes" ],
1396 [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1397 [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1398) {
1399 test_utf8_stashes(@$test);
1400}
1401
1402}
1403
c695838a 1404my $runperl_args = { switches => ['-Ilib'] };
0eb335df
BF
1405sub test_DumpProg {
1406 my ($prog, $expected, $name, $test) = @_;
1407 $test ||= 'like';
1408
1409 my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1410
1411 # Interface between Test::Builder & test.pl
1412 my $builder = Test::More->builder();
1413 t::curr_test($builder->current_test() + 1);
1414
1415 utf8::encode($prog);
1416
1417 if ( $test eq 'is' ) {
c695838a 1418 t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
0eb335df
BF
1419 }
1420 else {
c695838a 1421 t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
0eb335df
BF
1422 }
1423
1424 $builder->current_test(t::curr_test() - 1);
1425}
1426
1427my $threads = $Config{'useithreads'};
1428
1429for my $test (
1430[
1431 "package test;",
1432 qr/PACKAGE = "test"/,
1433 "DumpProg() + package declaration"
1434],
1435[
1436 "use utf8; package \x{30cd};",
1437 qr/PACKAGE = "\\x\Q{30cd}"/,
1438 "DumpProg() + UTF8 package declaration"
1439],
1440[
1441 "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1442 ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1443],
1444[
1445 "use utf8; \x{30cc}: { last \x{30cc} }",
1446 qr/LABEL = \Q"\x{30cc}"/
1447],
1448)
1449{
1450 test_DumpProg(@$test);
1451}
1452
e6ad046a
CB
1453{
1454 local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
1455 my $e = <<'EODUMP';
c5c79a53 1456dumpindent is 4 at -e line 1.
cd6e4874
DM
1457
14581 leave LISTOP(0xNNN) ===> [0x0]
1459 TARG = 1
1460 FLAGS = (VOID,KIDS,PARENS,SLABBED)
1461 PRIVATE = (REFC)
1462 REFCNT = 1
1463 |
14642 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN]
1465 | FLAGS = (UNKNOWN,SLABBED,MORESIB)
1466 |
14673 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN]
1468 | FLAGS = (VOID,SLABBED,MORESIB)
1469 | LINE = 1
1470 | PACKAGE = "t"
1471 | |
14725 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN]
1473 TARG = 1
1474 FLAGS = (VOID,KIDS,STACKED,SLABBED)
1475 PRIVATE = (TARG)
1476 |
14776 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN]
1478 FLAGS = (UNKNOWN,KIDS,SLABBED)
1479 |
14804 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN]
1481 | FLAGS = (SCALAR,SLABBED,MORESIB)
1482 |
14838 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN]
1484 FLAGS = (SCALAR,KIDS,SLABBED)
1485 PRIVATE = (0x1)
1486 |
14877 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN]
1488 FLAGS = (SCALAR,SLABBED)
1489 GV_OR_PADIX
0eb335df
BF
1490EODUMP
1491
e18c4116 1492 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
cd6e4874 1493 $e =~ s/SVOP/PADOP/g if $threads;
e6ad046a
CB
1494 my $out = t::runperl
1495 switches => ['-Ilib'],
1496 prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
1497 stderr=>1;
1498 $out =~ s/ *SEQ = .*\n//;
cd6e4874 1499 $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g;
e18c4116 1500 $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g;
e6ad046a
CB
1501 is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
1502}
06a5cade 1503done_testing();