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