This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame_incremental
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (non-incremental) | history | HEAD
Magic flags harmonization.
[perl5.git] / ext / Devel-Peek / t / Peek.t
... / ...
CommitLineData
1#!./perl -T
2
3BEGIN {
4 require Config; import Config;
5 if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
6 print "1..0 # Skip: Devel::Peek was not built\n";
7 exit 0;
8 }
9}
10
11use Test::More;
12
13use Devel::Peek;
14
15our $DEBUG = 0;
16open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
17
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
28use constant thr => $Config{useithreads};
29
30sub do_test {
31 my $todo = $_[3];
32 my $repeat_todo = $_[4];
33 my $pattern = $_[2];
34 if (open(OUT,">peek$$")) {
35 open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
36 Dump($_[1]);
37 print STDERR "*****\n";
38 Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
39 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
40 close(OUT);
41 if (open(IN, "peek$$")) {
42 local $/;
43 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
44 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
45 # handle DEBUG_LEAKING_SCALARS prefix
46 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
47
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
53 # whitespace on the line. So it seems better to mark lines that
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
62 s/\s*# (\$].*)$//
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;
73 $pattern =~ s/\$RV/
74 ($] < 5.011) ? 'RV' : 'IV';
75 /mge;
76
77 print $pattern, "\n" if $DEBUG;
78 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
79 print $dump, "\n" if $DEBUG;
80 like( $dump, qr/\A$pattern\Z/ms, $_[0])
81 or note("line " . (caller)[2]);
82
83 local $TODO = $repeat_todo;
84 is($dump2, $dump, "$_[0] (unchanged by dump)")
85 or note("line " . (caller)[2]);
86
87 close(IN);
88
89 return $1;
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;
101local $d = 0;
102
103END {
104 1 while unlink("peek$$");
105}
106
107do_test('assignment of immediate constant (string)',
108 $a = "foo",
109'SV = PV\\($ADDR\\) at $ADDR
110 REFCNT = 1
111 FLAGS = \\(POK,pPOK\\)
112 PV = $ADDR "foo"\\\0
113 CUR = 3
114 LEN = \\d+'
115 );
116
117do_test('immediate constant (string)',
118 "bar",
119'SV = PV\\($ADDR\\) at $ADDR
120 REFCNT = 1
121 FLAGS = \\(.*POK,READONLY,pPOK\\)
122 PV = $ADDR "bar"\\\0
123 CUR = 3
124 LEN = \\d+');
125
126do_test('assignment of immediate constant (integer)',
127 $b = 123,
128'SV = IV\\($ADDR\\) at $ADDR
129 REFCNT = 1
130 FLAGS = \\(IOK,pIOK\\)
131 IV = 123');
132
133do_test('immediate constant (integer)',
134 456,
135'SV = IV\\($ADDR\\) at $ADDR
136 REFCNT = 1
137 FLAGS = \\(.*IOK,READONLY,pIOK\\)
138 IV = 456');
139
140do_test('assignment of immediate constant (integer)',
141 $c = 456,
142'SV = IV\\($ADDR\\) at $ADDR
143 REFCNT = 1
144 FLAGS = \\($PADMY,IOK,pIOK\\)
145 IV = 456');
146
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.
152my $type = do_test('result of addition',
153 $c + $d,
154'SV = ([NI])V\\($ADDR\\) at $ADDR
155 REFCNT = 1
156 FLAGS = \\(PADTMP,\1OK,p\1OK\\)
157 \1V = 456');
158
159($d = "789") += 0.1;
160
161do_test('floating point value',
162 $d,
163'SV = PVNV\\($ADDR\\) at $ADDR
164 REFCNT = 1
165 FLAGS = \\(NOK,pNOK\\)
166 IV = \d+
167 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
168 PV = $ADDR "789"\\\0
169 CUR = 3
170 LEN = \\d+');
171
172do_test('integer constant',
173 0xabcd,
174'SV = IV\\($ADDR\\) at $ADDR
175 REFCNT = 1
176 FLAGS = \\(.*IOK,READONLY,pIOK\\)
177 IV = 43981');
178
179do_test('undef',
180 undef,
181'SV = NULL\\(0x0\\) at $ADDR
182 REFCNT = 1
183 FLAGS = \\(\\)');
184
185do_test('reference to scalar',
186 \$a,
187'SV = $RV\\($ADDR\\) at $ADDR
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
196 LEN = \\d+');
197
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}
214do_test('reference to array',
215 [$b,$c],
216'SV = $RV\\($ADDR\\) at $ADDR
217 REFCNT = 1
218 FLAGS = \\(ROK\\)
219 RV = $ADDR
220 SV = PVAV\\($ADDR\\) at $ADDR
221 REFCNT = 1
222 FLAGS = \\(\\)
223 IV = 0 # $] < 5.009
224 NV = 0 # $] < 5.009
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
235 Elt No. 1' . $c_pattern);
236
237do_test('reference to hash',
238 {$b=>$c},
239'SV = $RV\\($ADDR\\) at $ADDR
240 REFCNT = 1
241 FLAGS = \\(ROK\\)
242 RV = $ADDR
243 SV = PVHV\\($ADDR\\) at $ADDR
244 REFCNT = 1
245 FLAGS = \\(SHAREKEYS\\)
246 IV = 1 # $] < 5.009
247 NV = $FLOAT # $] < 5.009
248 ARRAY = $ADDR \\(0:7, 1:1\\)
249 hash quality = 100.0%
250 KEYS = 1
251 FILL = 1
252 MAX = 7
253 RITER = -1
254 EITER = 0x0
255 Elt "123" HASH = $ADDR' . $c_pattern,
256 '',
257 $] > 5.009 && $] < 5.015
258 && 'The hash iterator used in dump.c sets the OOK flag');
259
260do_test('reference to anon sub with empty prototype',
261 sub(){@_},
262'SV = $RV\\($ADDR\\) at $ADDR
263 REFCNT = 1
264 FLAGS = \\(ROK\\)
265 RV = $ADDR
266 SV = PVCV\\($ADDR\\) at $ADDR
267 REFCNT = 2
268 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
269 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
270 IV = 0 # $] < 5.009
271 NV = 0 # $] < 5.009
272 PROTOTYPE = ""
273 COMP_STASH = $ADDR\\t"main"
274 START = $ADDR ===> \\d+
275 ROOT = $ADDR
276 XSUB = 0x0 # $] < 5.009
277 XSUBANY = 0 # $] < 5.009
278 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
279 FILE = ".*\\b(?i:peek\\.t)"
280 DEPTH = 0(?:
281 MUTEXP = $ADDR
282 OWNER = $ADDR)?
283 FLAGS = 0x404 # $] < 5.009
284 FLAGS = 0x490 # $] >= 5.009 && ($] < 5.015 || !thr)
285 FLAGS = 0x1490 # $] >= 5.015 && thr
286 OUTSIDE_SEQ = \\d+
287 PADLIST = $ADDR
288 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
289 OUTSIDE = $ADDR \\(MAIN\\)');
290
291do_test('reference to named subroutine without prototype',
292 \&do_test,
293'SV = $RV\\($ADDR\\) at $ADDR
294 REFCNT = 1
295 FLAGS = \\(ROK\\)
296 RV = $ADDR
297 SV = PVCV\\($ADDR\\) at $ADDR
298 REFCNT = (3|4)
299 FLAGS = \\(\\) # $] < 5.015 || !thr
300 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
301 IV = 0 # $] < 5.009
302 NV = 0 # $] < 5.009
303 COMP_STASH = $ADDR\\t"main"
304 START = $ADDR ===> \\d+
305 ROOT = $ADDR
306 XSUB = 0x0 # $] < 5.009
307 XSUBANY = 0 # $] < 5.009
308 GVGV::GV = $ADDR\\t"main" :: "do_test"
309 FILE = ".*\\b(?i:peek\\.t)"
310 DEPTH = 1(?:
311 MUTEXP = $ADDR
312 OWNER = $ADDR)?
313 FLAGS = 0x0 # $] < 5.015 || !thr
314 FLAGS = 0x1000 # $] >= 5.015 && thr
315 OUTSIDE_SEQ = \\d+
316 PADLIST = $ADDR
317 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
318 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
319 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
320 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
321 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" # $] < 5.009
322 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 # $] >= 5.009
323 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
324 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
325 OUTSIDE = $ADDR \\(MAIN\\)');
326
327if ($] >= 5.011) {
328do_test('reference to regexp',
329 qr(tic),
330'SV = $RV\\($ADDR\\) at $ADDR
331 REFCNT = 1
332 FLAGS = \\(ROK\\)
333 RV = $ADDR
334 SV = REGEXP\\($ADDR\\) at $ADDR
335 REFCNT = 1
336 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
337 PV = $ADDR "\\(\\?\\^:tic\\)"
338 CUR = 8
339 LEN = 0
340 STASH = $ADDR\\t"Regexp"'
341. ($] < 5.013 ? '' :
342'
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
352 SUBLEN = 0
353 SUBBEG = 0x0
354 ENGINE = $ADDR
355 MOTHER_RE = $ADDR
356 PAREN_NAMES = 0x0
357 SUBSTRS = $ADDR
358 PPRIVATE = $ADDR
359 OFFS = $ADDR
360 QR_ANONCV = 0x0'
361));
362} else {
363do_test('reference to regexp',
364 qr(tic),
365'SV = $RV\\($ADDR\\) at $ADDR
366 REFCNT = 1
367 FLAGS = \\(ROK\\)
368 RV = $ADDR
369 SV = PVMG\\($ADDR\\) at $ADDR
370 REFCNT = 1
371 FLAGS = \\(OBJECT,SMG\\)
372 IV = 0
373 NV = 0
374 PV = 0
375 MAGIC = $ADDR
376 MG_VIRTUAL = $ADDR
377 MG_TYPE = PERL_MAGIC_qr\(r\)
378 MG_OBJ = $ADDR
379 PAT = "\(\?^:tic\)" # $] >= 5.009
380 REFCNT = 2 # $] >= 5.009
381 STASH = $ADDR\\t"Regexp"');
382}
383
384do_test('reference to blessed hash',
385 (bless {}, "Tac"),
386'SV = $RV\\($ADDR\\) at $ADDR
387 REFCNT = 1
388 FLAGS = \\(ROK\\)
389 RV = $ADDR
390 SV = PVHV\\($ADDR\\) at $ADDR
391 REFCNT = 1
392 FLAGS = \\(OBJECT,SHAREKEYS\\)
393 IV = 0 # $] < 5.009
394 NV = 0 # $] < 5.009
395 STASH = $ADDR\\t"Tac"
396 ARRAY = 0x0
397 KEYS = 0
398 FILL = 0
399 MAX = 7
400 RITER = -1
401 EITER = 0x0', '',
402 $] > 5.009
403 ? $] >= 5.015
404 ? 0
405 : 'The hash iterator used in dump.c sets the OOK flag'
406 : "Something causes the HV's array to become allocated");
407
408do_test('typeglob',
409 *a,
410'SV = PVGV\\($ADDR\\) at $ADDR
411 REFCNT = 5
412 FLAGS = \\(MULTI(?:,IN_PAD)?\\) # $] >= 5.009
413 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) # $] < 5.009
414 IV = 0 # $] < 5.009
415 NV = 0 # $] < 5.009
416 PV = 0 # $] < 5.009
417 MAGIC = $ADDR # $] < 5.009
418 MG_VIRTUAL = &PL_vtbl_glob # $] < 5.009
419 MG_TYPE = PERL_MAGIC_glob\(\*\) # $] < 5.009
420 MG_OBJ = $ADDR # $] < 5.009
421 NAME = "a"
422 NAMELEN = 1
423 GvSTASH = $ADDR\\t"main"
424 GP = $ADDR
425 SV = $ADDR
426 REFCNT = 1
427 IO = 0x0
428 FORM = 0x0
429 AV = 0x0
430 HV = 0x0
431 CV = 0x0
432 CVGEN = 0x0
433 GPFLAGS = 0x0 # $] < 5.009
434 LINE = \\d+
435 FILE = ".*\\b(?i:peek\\.t)"
436 FLAGS = $ADDR
437 EGV = $ADDR\\t"a"');
438
439if (ord('A') == 193) {
440do_test('string with Unicode',
441 chr(256).chr(0).chr(512),
442'SV = PV\\($ADDR\\) at $ADDR
443 REFCNT = 1
444 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
445 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
446 CUR = 5
447 LEN = \\d+');
448} else {
449do_test('string with Unicode',
450 chr(256).chr(0).chr(512),
451'SV = PV\\($ADDR\\) at $ADDR
452 REFCNT = 1
453 FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
454 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
455 CUR = 5
456 LEN = \\d+');
457}
458
459if (ord('A') == 193) {
460do_test('reference to hash containing Unicode',
461 {chr(256)=>chr(512)},
462'SV = $RV\\($ADDR\\) at $ADDR
463 REFCNT = 1
464 FLAGS = \\(ROK\\)
465 RV = $ADDR
466 SV = PVHV\\($ADDR\\) at $ADDR
467 REFCNT = 1
468 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
469 UV = 1 # $] < 5.009
470 NV = $FLOAT # $] < 5.009
471 ARRAY = $ADDR \\(0:7, 1:1\\)
472 hash quality = 100.0%
473 KEYS = 1
474 FILL = 1
475 MAX = 7
476 RITER = -1
477 EITER = $ADDR
478 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
479 SV = PV\\($ADDR\\) at $ADDR
480 REFCNT = 1
481 FLAGS = \\(POK,pPOK,UTF8\\)
482 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
483 CUR = 2
484 LEN = \\d+',
485 $] > 5.009
486 ? $] >= 5.015
487 ? 0
488 : 'The hash iterator used in dump.c sets the OOK flag'
489 : 'sv_length has been called on the element, and cached the result in MAGIC');
490} else {
491do_test('reference to hash containing Unicode',
492 {chr(256)=>chr(512)},
493'SV = $RV\\($ADDR\\) at $ADDR
494 REFCNT = 1
495 FLAGS = \\(ROK\\)
496 RV = $ADDR
497 SV = PVHV\\($ADDR\\) at $ADDR
498 REFCNT = 1
499 FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
500 UV = 1 # $] < 5.009
501 NV = 0 # $] < 5.009
502 ARRAY = $ADDR \\(0:7, 1:1\\)
503 hash quality = 100.0%
504 KEYS = 1
505 FILL = 1
506 MAX = 7
507 RITER = -1
508 EITER = $ADDR
509 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
510 SV = PV\\($ADDR\\) at $ADDR
511 REFCNT = 1
512 FLAGS = \\(POK,pPOK,UTF8\\)
513 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
514 CUR = 2
515 LEN = \\d+', '',
516 $] > 5.009
517 ? $] >= 5.015
518 ? 0
519 : 'The hash iterator used in dump.c sets the OOK flag'
520 : 'sv_length has been called on the element, and cached the result in MAGIC');
521}
522
523my $x="";
524$x=~/.??/g;
525do_test('scalar with pos magic',
526 $x,
527'SV = PVMG\\($ADDR\\) at $ADDR
528 REFCNT = 1
529 FLAGS = \\($PADMY,SMG,POK,pPOK\\)
530 IV = 0
531 NV = 0
532 PV = $ADDR ""\\\0
533 CUR = 0
534 LEN = \d+
535 MAGIC = $ADDR
536 MG_VIRTUAL = &PL_vtbl_mglob
537 MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
538 MG_FLAGS = 0x01
539 MINMATCH');
540
541#
542# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
543# environment variables may be invisibly case-forced, hence the (?i:PATH)
544# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
545# VMS is setting FAKE and READONLY flags. What VMS uses for storing
546# ENV hashes is also not always null terminated.
547#
548do_test('tainted value in %ENV',
549 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
550'SV = PVMG\\($ADDR\\) at $ADDR
551 REFCNT = 1
552 FLAGS = \\(GMG,SMG,RMG,IOK,POK,pIOK,pPOK\\)
553 IV = 0
554 NV = 0
555 PV = $ADDR "0"\\\0
556 CUR = 1
557 LEN = \d+
558 MAGIC = $ADDR
559 MG_VIRTUAL = &PL_vtbl_envelem
560 MG_TYPE = PERL_MAGIC_envelem\\(e\\)
561(?: MG_FLAGS = 0x01
562 TAINTEDDIR
563)? MG_LEN = -?\d+
564 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
565 SV = PV(?:IV)?\\($ADDR\\) at $ADDR
566 REFCNT = \d+
567 FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
568(?: IV = 0
569)? PV = $ADDR "(?i:PATH)"(?:\\\0)?
570 CUR = \d+
571 LEN = \d+)
572 MAGIC = $ADDR
573 MG_VIRTUAL = &PL_vtbl_taint
574 MG_TYPE = PERL_MAGIC_taint\\(t\\)');
575
576do_test('blessed reference',
577 bless(\\undef, 'Foobar'),
578'SV = $RV\\($ADDR\\) at $ADDR
579 REFCNT = 1
580 FLAGS = \\(ROK\\)
581 RV = $ADDR
582 SV = PVMG\\($ADDR\\) at $ADDR
583 REFCNT = 2
584 FLAGS = \\(OBJECT,ROK\\)
585 IV = -?\d+
586 NV = $FLOAT
587 RV = $ADDR
588 SV = NULL\\(0x0\\) at $ADDR
589 REFCNT = \d+
590 FLAGS = \\(READONLY\\)
591 PV = $ADDR ""
592 CUR = 0
593 LEN = 0
594 STASH = $ADDR\s+"Foobar"');
595
596sub const () {
597 "Perl rules";
598}
599
600do_test('constant subroutine',
601 \&const,
602'SV = $RV\\($ADDR\\) at $ADDR
603 REFCNT = 1
604 FLAGS = \\(ROK\\)
605 RV = $ADDR
606 SV = PVCV\\($ADDR\\) at $ADDR
607 REFCNT = (2)
608 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015
609 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
610 IV = 0 # $] < 5.009
611 NV = 0 # $] < 5.009
612 PROTOTYPE = ""
613 COMP_STASH = 0x0
614 ROOT = 0x0 # $] < 5.009
615 XSUB = $ADDR
616 XSUBANY = $ADDR \\(CONST SV\\)
617 SV = PV\\($ADDR\\) at $ADDR
618 REFCNT = 1
619 FLAGS = \\(.*POK,READONLY,pPOK\\)
620 PV = $ADDR "Perl rules"\\\0
621 CUR = 10
622 LEN = \\d+
623 GVGV::GV = $ADDR\\t"main" :: "const"
624 FILE = ".*\\b(?i:peek\\.t)"
625 DEPTH = 0(?:
626 MUTEXP = $ADDR
627 OWNER = $ADDR)?
628 FLAGS = 0x200 # $] < 5.009
629 FLAGS = 0xc00 # $] >= 5.009 && $] < 5.013
630 FLAGS = 0xc # $] >= 5.013 && $] < 5.015
631 FLAGS = 0x100c # $] >= 5.015
632 OUTSIDE_SEQ = 0
633 PADLIST = 0x0
634 OUTSIDE = 0x0 \\(null\\)');
635
636do_test('isUV should show on PVMG',
637 do { my $v = $1; $v = ~0; $v },
638'SV = PVMG\\($ADDR\\) at $ADDR
639 REFCNT = 1
640 FLAGS = \\(IOK,pIOK,IsUV\\)
641 UV = \d+
642 NV = 0
643 PV = 0');
644
645do_test('IO',
646 *STDOUT{IO},
647'SV = $RV\\($ADDR\\) at $ADDR
648 REFCNT = 1
649 FLAGS = \\(ROK\\)
650 RV = $ADDR
651 SV = PVIO\\($ADDR\\) at $ADDR
652 REFCNT = 3
653 FLAGS = \\(OBJECT\\)
654 IV = 0 # $] < 5.011
655 NV = 0 # $] < 5.011
656 STASH = $ADDR\s+"IO::File"
657 IFP = $ADDR
658 OFP = $ADDR
659 DIRP = 0x0
660 LINES = 0
661 PAGE = 0
662 PAGE_LEN = 60
663 LINES_LEFT = 0
664 TOP_GV = 0x0
665 FMT_GV = 0x0
666 BOTTOM_GV = 0x0
667 SUBPROCESS = 0 # $] < 5.009
668 TYPE = \'>\'
669 FLAGS = 0x4');
670
671do_test('FORMAT',
672 *PIE{FORMAT},
673'SV = $RV\\($ADDR\\) at $ADDR
674 REFCNT = 1
675 FLAGS = \\(ROK\\)
676 RV = $ADDR
677 SV = PVFM\\($ADDR\\) at $ADDR
678 REFCNT = 2
679 FLAGS = \\(\\) # $] < 5.015 || !thr
680 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr
681 IV = 0 # $] < 5.009
682 NV = 0 # $] < 5.009
683(?: PV = 0
684)? COMP_STASH = 0x0
685 START = $ADDR ===> \\d+
686 ROOT = $ADDR
687 XSUB = 0x0 # $] < 5.009
688 XSUBANY = 0 # $] < 5.009
689 GVGV::GV = $ADDR\\t"main" :: "PIE"
690 FILE = ".*\\b(?i:peek\\.t)"(?:
691 DEPTH = 0
692 MUTEXP = $ADDR
693 OWNER = $ADDR)?
694 FLAGS = 0x0 # $] < 5.015 || !thr
695 FLAGS = 0x1000 # $] >= 5.015 && thr
696 OUTSIDE_SEQ = \\d+
697 LINES = 0
698 PADLIST = $ADDR
699 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
700 OUTSIDE = $ADDR \\(MAIN\\)');
701
702do_test('blessing to a class with embedded NUL characters',
703 (bless {}, "\0::foo::\n::baz::\t::\0"),
704'SV = $RV\\($ADDR\\) at $ADDR
705 REFCNT = 1
706 FLAGS = \\(ROK\\)
707 RV = $ADDR
708 SV = PVHV\\($ADDR\\) at $ADDR
709 REFCNT = 1
710 FLAGS = \\(OBJECT,SHAREKEYS\\)
711 IV = 0 # $] < 5.009
712 NV = 0 # $] < 5.009
713 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
714 ARRAY = $ADDR
715 KEYS = 0
716 FILL = 0
717 MAX = 7
718 RITER = -1
719 EITER = 0x0', '',
720 $] > 5.009
721 ? $] >= 5.015
722 ? 0
723 : 'The hash iterator used in dump.c sets the OOK flag'
724 : "Something causes the HV's array to become allocated");
725
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
743 NAME = "RWOM"
744 ENAME = "RWOM" # $] > 5.012
745');
746
747*KLANK:: = \%RWOM::;
748
749do_test('ENAMEs on a stash',
750 \%RWOM::,
751'SV = $RV\\($ADDR\\) at $ADDR
752 REFCNT = 1
753 FLAGS = \\(ROK\\)
754 RV = $ADDR
755 SV = PVHV\\($ADDR\\) at $ADDR
756 REFCNT = 3
757 FLAGS = \\(OOK,SHAREKEYS\\)
758 IV = 1 # $] < 5.009
759 NV = $FLOAT # $] < 5.009
760 ARRAY = $ADDR
761 KEYS = 0
762 FILL = 0
763 MAX = 7
764 RITER = -1
765 EITER = 0x0
766 NAME = "RWOM"
767 NAMECOUNT = 2 # $] > 5.012
768 ENAME = "RWOM", "KLANK" # $] > 5.012
769');
770
771undef %RWOM::;
772
773do_test('ENAMEs on a stash with no NAME',
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 = 3
781 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017
782 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017
783 IV = 1 # $] < 5.009
784 NV = $FLOAT # $] < 5.009
785 ARRAY = $ADDR
786 KEYS = 0
787 FILL = 0
788 MAX = 7
789 RITER = -1
790 EITER = 0x0
791 NAMECOUNT = -3 # $] > 5.012
792 ENAME = "RWOM", "KLANK" # $] > 5.012
793');
794
795SKIP: {
796 skip "Not built with usemymalloc", 1
797 unless $Config{usemymalloc} eq 'y';
798 my $x = __PACKAGE__;
799 ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
800 or diag $@;
801}
802
803# This is more a test of fbm_compile/pp_study (non) interaction than dumping
804# prowess, but short of duplicating all the gubbins of this file, I can't see
805# a way to make a better place for it:
806
807use constant {
808 perl => 'rules',
809 beer => 'foamy',
810};
811
812unless ($Config{useithreads}) {
813 # These end up as copies in pads under ithreads, which rather defeats the
814 # the point of what we're trying to test here.
815
816 do_test('regular string constant', perl,
817'SV = PV\\($ADDR\\) at $ADDR
818 REFCNT = 5
819 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
820 PV = $ADDR "rules"\\\0
821 CUR = 5
822 LEN = \d+
823');
824
825 eval 'index "", perl';
826
827 # FIXME - really this shouldn't say EVALED. It's a false posistive on
828 # 0x40000000 being used for several things, not a flag for "I'm in a string
829 # eval"
830
831 do_test('string constant now an FBM', perl,
832'SV = PVMG\\($ADDR\\) at $ADDR
833 REFCNT = 5
834 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
835 PV = $ADDR "rules"\\\0
836 CUR = 5
837 LEN = \d+
838 MAGIC = $ADDR
839 MG_VIRTUAL = &PL_vtbl_regexp
840 MG_TYPE = PERL_MAGIC_bm\\(B\\)
841 MG_LEN = 256
842 MG_PTR = $ADDR "(?:\\\\\d){256}"
843 RARE = \d+
844 PREVIOUS = 1
845 USEFUL = 100
846');
847
848 is(study perl, '', "Not allowed to study an FBM");
849
850 do_test('string constant still an FBM', perl,
851'SV = PVMG\\($ADDR\\) at $ADDR
852 REFCNT = 5
853 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
854 PV = $ADDR "rules"\\\0
855 CUR = 5
856 LEN = \d+
857 MAGIC = $ADDR
858 MG_VIRTUAL = &PL_vtbl_regexp
859 MG_TYPE = PERL_MAGIC_bm\\(B\\)
860 MG_LEN = 256
861 MG_PTR = $ADDR "(?:\\\\\d){256}"
862 RARE = \d+
863 PREVIOUS = 1
864 USEFUL = 100
865');
866
867 do_test('regular string constant', beer,
868'SV = PV\\($ADDR\\) at $ADDR
869 REFCNT = 6
870 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
871 PV = $ADDR "foamy"\\\0
872 CUR = 5
873 LEN = \d+
874');
875
876 is(study beer, 1, "Our studies were successful");
877
878 do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
879 REFCNT = 6
880 FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
881 PV = $ADDR "foamy"\\\0
882 CUR = 5
883 LEN = \d+
884');
885
886 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
887 REFCNT = 6
888 FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
889 PV = $ADDR "foamy"\\\0
890 CUR = 5
891 LEN = \d+
892 MAGIC = $ADDR
893 MG_VIRTUAL = &PL_vtbl_regexp
894 MG_TYPE = PERL_MAGIC_bm\\(B\\)
895 MG_LEN = 256
896 MG_PTR = $ADDR "(?:\\\\\d){256}"
897 RARE = \d+
898 PREVIOUS = \d+
899 USEFUL = 100
900';
901
902 is (eval 'index "not too foamy", beer', 8, 'correct index');
903
904 do_test('string constant now FBMed', beer, $want);
905
906 my $pie = 'good';
907
908 is(study $pie, 1, "Our studies were successful");
909
910 do_test('string constant still FBMed', beer, $want);
911
912 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
913 REFCNT = 1
914 FLAGS = \\(PADMY,POK,pPOK\\)
915 PV = $ADDR "good"\\\0
916 CUR = 4
917 LEN = \d+
918');
919}
920
921# (One block of study tests removed when study was made a no-op.)
922
923done_testing();
Unnamed repository; edit this file 'description' to name the repository.