Peek.t revision 1.4
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 require($core ? '../../t/test.pl' : './t/test.pl'); 13 } 14} 15 16use Test::More; 17 18use Devel::Peek; 19 20our $DEBUG = 0; 21open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; 22 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 33use constant thr => $Config{useithreads}; 34 35sub do_test { 36 my $todo = $_[3]; 37 my $repeat_todo = $_[4]; 38 my $pattern = $_[2]; 39 my $do_eval = $_[5]; 40 if (open(OUT,'>', "peek$$")) { 41 open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; 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 } 57 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; 58 close(OUT); 59 if (open(IN, '<', "peek$$")) { 60 local $/; 61 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; 62 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g; 63 # handle DEBUG_LEAKING_SCALARS prefix 64 $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg; 65 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 71 # whitespace on the line. So it seems better to mark lines that 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 80 s/\s*# (\$\].*)$// 81 ? (eval $1 ? $_ : '') 82 : $_ # Didn't match, so this line is in 83 } split /^/, $pattern; 84 85 $pattern =~ s/\$PADMY,/ 86 $] < 5.012005 ? 'PADMY,' : ''; 87 /mge; 88 $pattern =~ s/\$RV/ 89 ($] < 5.011) ? 'RV' : 'IV'; 90 /mge; 91 $pattern =~ s/^\h+COW_REFCNT = .*\n//mg 92 if $Config{ccflags} =~ 93 /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/ 94 || $] < 5.019003; 95 print $pattern, "\n" if $DEBUG; 96 my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>; 97 print $dump, "\n" if $DEBUG; 98 like( $dump, qr/\A$pattern\Z/ms, $_[0]) 99 or note("line " . (caller)[2]); 100 101 local $TODO = $repeat_todo; 102 is($dump2, $dump, "$_[0] (unchanged by dump)") 103 or note("line " . (caller)[2]); 104 105 close(IN); 106 107 return $1; 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; 119local $d = 0; 120 121END { 122 1 while unlink("peek$$"); 123} 124 125do_test('assignment of immediate constant (string)', 126 $a = "foo", 127'SV = PV\\($ADDR\\) at $ADDR 128 REFCNT = 1 129 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\) 130 PV = $ADDR "foo"\\\0 131 CUR = 3 132 LEN = \\d+ 133 COW_REFCNT = 1 134'); 135 136do_test('immediate constant (string)', 137 "bar", 138'SV = PV\\($ADDR\\) at $ADDR 139 REFCNT = 1 140 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 141 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005 142 PV = $ADDR "bar"\\\0 143 CUR = 3 144 LEN = \\d+ 145 COW_REFCNT = 0 146'); 147 148do_test('assignment of immediate constant (integer)', 149 $b = 123, 150'SV = IV\\($ADDR\\) at $ADDR 151 REFCNT = 1 152 FLAGS = \\(IOK,pIOK\\) 153 IV = 123'); 154 155do_test('immediate constant (integer)', 156 456, 157'SV = IV\\($ADDR\\) at $ADDR 158 REFCNT = 1 159 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005 160 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005 161 IV = 456'); 162 163do_test('assignment of immediate constant (integer)', 164 $c = 456, 165'SV = IV\\($ADDR\\) at $ADDR 166 REFCNT = 1 167 FLAGS = \\($PADMY,IOK,pIOK\\) 168 IV = 456'); 169 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. 175my $type = do_test('result of addition', 176 $c + $d, 177'SV = ([NI])V\\($ADDR\\) at $ADDR 178 REFCNT = 1 179 FLAGS = \\(PADTMP,\1OK,p\1OK\\) # $] < 5.019003 180 FLAGS = \\(\1OK,p\1OK\\) # $] >=5.019003 181 \1V = 456'); 182 183($d = "789") += 0.1; 184 185do_test('floating point value', 186 $d, 187 $] < 5.019003 188 || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/ 189 ? 190'SV = PVNV\\($ADDR\\) at $ADDR 191 REFCNT = 1 192 FLAGS = \\(NOK,pNOK\\) 193 IV = \d+ 194 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) 195 PV = $ADDR "789"\\\0 196 CUR = 3 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'); 205 206do_test('integer constant', 207 0xabcd, 208'SV = IV\\($ADDR\\) at $ADDR 209 REFCNT = 1 210 FLAGS = \\(.*IOK,READONLY,pIOK\\) # $] < 5.021005 211 FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\) # $] >=5.021005 212 IV = 43981'); 213 214do_test('undef', 215 undef, 216'SV = NULL\\(0x0\\) at $ADDR 217 REFCNT = \d+ 218 FLAGS = \\(READONLY\\) # $] < 5.021005 219 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005 220'); 221 222do_test('reference to scalar', 223 \$a, 224'SV = $RV\\($ADDR\\) at $ADDR 225 REFCNT = 1 226 FLAGS = \\(ROK\\) 227 RV = $ADDR 228 SV = PV\\($ADDR\\) at $ADDR 229 REFCNT = 2 230 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\) 231 PV = $ADDR "foo"\\\0 232 CUR = 3 233 LEN = \\d+ 234 COW_REFCNT = 1 235'); 236 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} 253do_test('reference to array', 254 [$b,$c], 255'SV = $RV\\($ADDR\\) at $ADDR 256 REFCNT = 1 257 FLAGS = \\(ROK\\) 258 RV = $ADDR 259 SV = PVAV\\($ADDR\\) at $ADDR 260 REFCNT = 1 261 FLAGS = \\(\\) 262 ARRAY = $ADDR 263 FILL = 1 264 MAX = 1 265 FLAGS = \\(REAL\\) 266 Elt No. 0 267 SV = IV\\($ADDR\\) at $ADDR 268 REFCNT = 1 269 FLAGS = \\(IOK,pIOK\\) 270 IV = 123 271 Elt No. 1' . $c_pattern); 272 273do_test('reference to hash', 274 {$b=>$c}, 275'SV = $RV\\($ADDR\\) at $ADDR 276 REFCNT = 1 277 FLAGS = \\(ROK\\) 278 RV = $ADDR 279 SV = PVHV\\($ADDR\\) at $ADDR 280 REFCNT = [12] 281 FLAGS = \\(SHAREKEYS\\) 282 ARRAY = $ADDR \\(0:7, 1:1\\) 283 hash quality = 100.0% 284 KEYS = 1 285 FILL = 1 286 MAX = 7 287 Elt "123" HASH = $ADDR' . $c_pattern, 288 '', 289 ($] < 5.015) ? 'The hash iterator used in dump.c sets the OOK flag' : undef); 290 291do_test('reference to anon sub with empty prototype', 292 sub(){@_}, 293'SV = $RV\\($ADDR\\) at $ADDR 294 REFCNT = 1 295 FLAGS = \\(ROK\\) 296 RV = $ADDR 297 SV = PVCV\\($ADDR\\) at $ADDR 298 REFCNT = 2 299 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr 300 FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr 301 PROTOTYPE = "" 302 COMP_STASH = $ADDR\\t"main" 303 START = $ADDR ===> \\d+ 304 ROOT = $ADDR 305 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" 306 FILE = ".*\\b(?i:peek\\.t)" 307 DEPTH = 0(?: 308 MUTEXP = $ADDR 309 OWNER = $ADDR)? 310 FLAGS = 0x490 # $] < 5.015 || !thr 311 FLAGS = 0x1490 # $] >= 5.015 && thr 312 OUTSIDE_SEQ = \\d+ 313 PADLIST = $ADDR 314 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) 315 OUTSIDE = $ADDR \\(MAIN\\)'); 316 317do_test('reference to named subroutine without prototype', 318 \&do_test, 319'SV = $RV\\($ADDR\\) at $ADDR 320 REFCNT = 1 321 FLAGS = \\(ROK\\) 322 RV = $ADDR 323 SV = PVCV\\($ADDR\\) at $ADDR 324 REFCNT = (3|4) 325 FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\) # $] < 5.015 || !thr 326 FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr 327 COMP_STASH = $ADDR\\t"main" 328 START = $ADDR ===> \\d+ 329 ROOT = $ADDR 330 NAME = "do_test" # $] >=5.021004 331 GVGV::GV = $ADDR\\t"main" :: "do_test" # $] < 5.021004 332 FILE = ".*\\b(?i:peek\\.t)" 333 DEPTH = 1(?: 334 MUTEXP = $ADDR 335 OWNER = $ADDR)? 336 FLAGS = 0x(?:[c4]00)?0 # $] < 5.015 || !thr 337 FLAGS = 0x[cd145]000 # $] >= 5.015 && thr 338 OUTSIDE_SEQ = \\d+ 339 PADLIST = $ADDR 340 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) 341 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo" 342 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo" 343 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" 344 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval" 345 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub" 346 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0 347 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump" 348 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2" 349 OUTSIDE = $ADDR \\(MAIN\\)'); 350 351if ($] >= 5.011) { 352# note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9 353do_test('reference to regexp', 354 qr(tic), 355'SV = $RV\\($ADDR\\) at $ADDR 356 REFCNT = 1 357 FLAGS = \\(ROK\\) 358 RV = $ADDR 359 SV = REGEXP\\($ADDR\\) at $ADDR 360 REFCNT = 1 361 FLAGS = \\(OBJECT,POK,FAKE,pPOK\\) 362 PV = $ADDR "\\(\\?\\^:tic\\)" 363 CUR = 8 364 LEN = 0 365 STASH = $ADDR\\t"Regexp"' 366. ($] < 5.013 ? '' : 367' 368 COMPFLAGS = 0x0 \(\) 369 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) 370(?: ENGINE = $ADDR \(STANDARD\) 371)? INTFLAGS = 0x0(?: \(\))? 372 NPARENS = 0 373 LASTPAREN = 0 374 LASTCLOSEPAREN = 0 375 MINLEN = 3 376 MINLENRET = 3 377 GOFS = 0 378 PRE_PREFIX = 4 379 SUBLEN = 0 380 SUBOFFSET = 0 381 SUBCOFFSET = 0 382 SUBBEG = 0x0 383(?: ENGINE = $ADDR 384)? MOTHER_RE = $ADDR' 385. ($] < 5.019003 ? '' : ' 386 SV = REGEXP\($ADDR\) at $ADDR 387 REFCNT = 2 388 FLAGS = \(POK,pPOK\) 389 PV = $ADDR "\(\?\^:tic\)" 390 CUR = 8 391 LEN = \d+ 392 COMPFLAGS = 0x0 \(\) 393 EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) 394(?: ENGINE = $ADDR \(STANDARD\) 395)? INTFLAGS = 0x0(?: \(\))? 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 407(?: ENGINE = $ADDR 408)? MOTHER_RE = 0x0 409 PAREN_NAMES = 0x0 410 SUBSTRS = $ADDR 411 PPRIVATE = $ADDR 412 OFFS = $ADDR 413 QR_ANONCV = 0x0(?: 414 SAVED_COPY = 0x0)?') . ' 415 PAREN_NAMES = 0x0 416 SUBSTRS = $ADDR 417 PPRIVATE = $ADDR 418 OFFS = $ADDR 419 QR_ANONCV = 0x0(?: 420 SAVED_COPY = 0x0)?' 421)); 422} else { 423do_test('reference to regexp', 424 qr(tic), 425'SV = $RV\\($ADDR\\) at $ADDR 426 REFCNT = 1 427 FLAGS = \\(ROK\\) 428 RV = $ADDR 429 SV = PVMG\\($ADDR\\) at $ADDR 430 REFCNT = 1 431 FLAGS = \\(OBJECT,SMG\\) 432 IV = 0 433 NV = 0 434 PV = 0 435 MAGIC = $ADDR 436 MG_VIRTUAL = $ADDR 437 MG_TYPE = PERL_MAGIC_qr\(r\) 438 MG_OBJ = $ADDR 439 PAT = "\(\?^:tic\)" 440 REFCNT = 2 441 STASH = $ADDR\\t"Regexp"'); 442} 443 444do_test('reference to blessed hash', 445 (bless {}, "Tac"), 446'SV = $RV\\($ADDR\\) at $ADDR 447 REFCNT = 1 448 FLAGS = \\(ROK\\) 449 RV = $ADDR 450 SV = PVHV\\($ADDR\\) at $ADDR 451 REFCNT = [12] 452 FLAGS = \\(OBJECT,SHAREKEYS\\) 453 STASH = $ADDR\\t"Tac" 454 ARRAY = 0x0 455 KEYS = 0 456 FILL = 0 457 MAX = 7', '', 458 $] >= 5.015 459 ? undef 460 : 'The hash iterator used in dump.c sets the OOK flag'); 461 462do_test('typeglob', 463 *a, 464'SV = PVGV\\($ADDR\\) at $ADDR 465 REFCNT = 5 466 FLAGS = \\(MULTI(?:,IN_PAD)?\\) 467 NAME = "a" 468 NAMELEN = 1 469 GvSTASH = $ADDR\\t"main" 470 FLAGS = $ADDR # $] >=5.021004 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 480 GPFLAGS = 0x0 \(\) # $] >= 5.021004 481 LINE = \\d+ 482 FILE = ".*\\b(?i:peek\\.t)" 483 FLAGS = $ADDR # $] < 5.021004 484 EGV = $ADDR\\t"a"'); 485 486if (ord('A') == 193) { 487do_test('string with Unicode', 488 chr(256).chr(0).chr(512), 489'SV = PV\\($ADDR\\) at $ADDR 490 REFCNT = 1 491 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 492 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 493 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] 494 CUR = 5 495 LEN = \\d+ 496 COW_REFCNT = 1 # $] < 5.019007 497'); 498} else { 499do_test('string with Unicode', 500 chr(256).chr(0).chr(512), 501'SV = PV\\($ADDR\\) at $ADDR 502 REFCNT = 1 503 FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\) # $] < 5.019003 504 FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\) # $] >=5.019003 505 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] 506 CUR = 5 507 LEN = \\d+ 508 COW_REFCNT = 1 # $] < 5.019007 509'); 510} 511 512if (ord('A') == 193) { 513do_test('reference to hash containing Unicode', 514 {chr(256)=>chr(512)}, 515'SV = $RV\\($ADDR\\) at $ADDR 516 REFCNT = 1 517 FLAGS = \\(ROK\\) 518 RV = $ADDR 519 SV = PVHV\\($ADDR\\) at $ADDR 520 REFCNT = [12] 521 FLAGS = \\(SHAREKEYS,HASKFLAGS\\) 522 ARRAY = $ADDR \\(0:7, 1:1\\) 523 hash quality = 100.0% 524 KEYS = 1 525 FILL = 1 526 MAX = 7 527 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR 528 SV = PV\\($ADDR\\) at $ADDR 529 REFCNT = 1 530 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\) 531 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\] 532 CUR = 2 533 LEN = \\d+ 534 COW_REFCNT = 1 # $] < 5.019007 535', '', 536 $] >= 5.015 537 ? undef 538 : 'The hash iterator used in dump.c sets the OOK flag'); 539} else { 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 "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR 555 SV = PV\\($ADDR\\) at $ADDR 556 REFCNT = 1 557 FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\) 558 PV = $ADDR "\\\310\\\200"\\\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} 567 568my $x=""; 569$x=~/.??/g; 570do_test('scalar with pos magic', 571 $x, 572'SV = PVMG\\($ADDR\\) at $ADDR 573 REFCNT = 1 574 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\) 575 IV = \d+ 576 NV = 0 577 PV = $ADDR ""\\\0 578 CUR = 0 579 LEN = \d+ 580 COW_REFCNT = [12] 581 MAGIC = $ADDR 582 MG_VIRTUAL = &PL_vtbl_mglob 583 MG_TYPE = PERL_MAGIC_regex_global\\(g\\) 584 MG_FLAGS = 0x01 # $] < 5.019003 585 MG_FLAGS = 0x41 # $] >=5.019003 586 MINMATCH 587 BYTES # $] >=5.019003 588'); 589 590# 591# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS 592# environment variables may be invisibly case-forced, hence the (?i:PATH) 593# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)? 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)? 596# VMS is setting FAKE and READONLY flags. What VMS uses for storing 597# ENV hashes is also not always null terminated. 598# 599if (${^TAINT}) { 600 # Save and restore PATH, since fresh_perl ends up using that in Windows. 601 my $path = $ENV{PATH}; 602 do_test('tainted value in %ENV', 603 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value 604'SV = PVMG\\($ADDR\\) at $ADDR 605 REFCNT = 1 606 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\) 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\\) 615(?: MG_FLAGS = 0x01 616 TAINTEDDIR 617)? MG_LEN = -?\d+ 618 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY 619 SV = PV(?:IV)?\\($ADDR\\) at $ADDR 620 REFCNT = \d+ 621 FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\) 622(?: IV = 0 623)? PV = $ADDR "(?i:PATH)"(?:\\\0)? 624 CUR = \d+ 625 LEN = \d+) 626 MAGIC = $ADDR 627 MG_VIRTUAL = &PL_vtbl_taint 628 MG_TYPE = PERL_MAGIC_taint\\(t\\)'); 629 $ENV{PATH} = $path; 630} 631 632do_test('blessed reference', 633 bless(\\undef, 'Foobar'), 634'SV = $RV\\($ADDR\\) at $ADDR 635 REFCNT = 1 636 FLAGS = \\(ROK\\) 637 RV = $ADDR 638 SV = PVMG\\($ADDR\\) at $ADDR 639 REFCNT = 2 640 FLAGS = \\(OBJECT,ROK\\) 641 IV = -?\d+ 642 NV = $FLOAT 643 RV = $ADDR 644 SV = NULL\\(0x0\\) at $ADDR 645 REFCNT = \d+ 646 FLAGS = \\(READONLY\\) # $] < 5.021005 647 FLAGS = \\(READONLY,PROTECT\\) # $] >=5.021005 648 PV = $ADDR "" 649 CUR = 0 650 LEN = 0 651 STASH = $ADDR\s+"Foobar"'); 652 653sub const () { 654 "Perl rules"; 655} 656 657do_test('constant subroutine', 658 \&const, 659'SV = $RV\\($ADDR\\) at $ADDR 660 REFCNT = 1 661 FLAGS = \\(ROK\\) 662 RV = $ADDR 663 SV = PVCV\\($ADDR\\) at $ADDR 664 REFCNT = (2) 665 FLAGS = \\(POK,pPOK,CONST,ISXSUB\\) # $] < 5.015 666 FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015 667 PROTOTYPE = "" 668 COMP_STASH = 0x0 # $] < 5.021004 669 COMP_STASH = $ADDR "main" # $] >=5.021004 670 XSUB = $ADDR 671 XSUBANY = $ADDR \\(CONST SV\\) 672 SV = PV\\($ADDR\\) at $ADDR 673 REFCNT = 1 674 FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 675 FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005 676 PV = $ADDR "Perl rules"\\\0 677 CUR = 10 678 LEN = \\d+ 679 COW_REFCNT = 0 680 GVGV::GV = $ADDR\\t"main" :: "const" 681 FILE = ".*\\b(?i:peek\\.t)" 682 DEPTH = 0(?: 683 MUTEXP = $ADDR 684 OWNER = $ADDR)? 685 FLAGS = 0xc00 # $] < 5.013 686 FLAGS = 0xc # $] >= 5.013 && $] < 5.015 687 FLAGS = 0x100c # $] >= 5.015 688 OUTSIDE_SEQ = 0 689 PADLIST = 0x0 # $] < 5.021006 690 HSCXT = $ADDR # $] >= 5.021006 691 OUTSIDE = 0x0 \\(null\\)'); 692 693do_test('isUV should show on PVMG', 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'); 701 702do_test('IO', 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\\) 711 IV = 0 # $] < 5.011 712 NV = 0 # $] < 5.011 713 STASH = $ADDR\s+"IO::File" 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 = \'>\' 725 FLAGS = 0x4'); 726 727do_test('FORMAT', 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 735 FLAGS = \\(\\) # $] < 5.015 || !thr 736 FLAGS = \\(DYNFILE\\) # $] >= 5.015 && thr 737(?: PV = 0 738)? COMP_STASH = 0x0 739 START = $ADDR ===> \\d+ 740 ROOT = $ADDR 741 GVGV::GV = $ADDR\\t"main" :: "PIE" 742 FILE = ".*\\b(?i:peek\\.t)"(?: 743 DEPTH = 0)?(?: 744 MUTEXP = $ADDR 745 OWNER = $ADDR)? 746 FLAGS = 0x0 # $] < 5.015 || !thr 747 FLAGS = 0x1000 # $] >= 5.015 && thr 748 OUTSIDE_SEQ = \\d+ 749 LINES = 0 # $] < 5.017_003 750 PADLIST = $ADDR 751 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) 752 OUTSIDE = $ADDR \\(MAIN\\)'); 753 754do_test('blessing to a class with embedded NUL characters', 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 761 REFCNT = [12] 762 FLAGS = \\(OBJECT,SHAREKEYS\\) 763 STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0" 764 ARRAY = $ADDR 765 KEYS = 0 766 FILL = 0 767 MAX = 7', '', 768 $] >= 5.015 769 ? undef 770 : 'The hash iterator used in dump.c sets the OOK flag'); 771 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\\) 781 AUX_FLAGS = 0 # $] > 5.019008 782 ARRAY = $ADDR 783 KEYS = 0 784 FILL = 0 785 MAX = 7 786 RITER = -1 787 EITER = 0x0 788 RAND = $ADDR 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\\) 804 AUX_FLAGS = 0 # $] > 5.019008 805 ARRAY = $ADDR 806 KEYS = 0 807 FILL = 0 808 MAX = 7 809 RITER = -1 810 EITER = 0x0 811 RAND = $ADDR 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 827 FLAGS = \\(OOK,SHAREKEYS\\) # $] < 5.017 828 FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\) # $] >=5.017 && $]<5.021005 829 FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\) # $] >=5.021005 830 AUX_FLAGS = 0 # $] > 5.019008 831 ARRAY = $ADDR 832 KEYS = 0 833 FILL = 0 834 MAX = 7 835 RITER = -1 836 EITER = 0x0 837 RAND = $ADDR 838 NAMECOUNT = -3 # $] > 5.012 839 ENAME = "RWOM", "KLANK" # $] > 5.012 840'); 841 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 852 FLAGS = \\($PADMY,SHAREKEYS\\) 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 861 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\) 862 PV = $ADDR "(?:Rules|Foamy)"\\\0 863 CUR = \d+ 864 LEN = \d+ 865 COW_REFCNT = 1 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 878 FLAGS = \\($PADMY,OOK,SHAREKEYS\\) 879 AUX_FLAGS = 0 # $] > 5.019008 880 ARRAY = $ADDR \\(0:[67],.*\\) 881 hash quality = [0-9.]+% 882 KEYS = 2 883 FILL = [12] 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 891 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\) 892 PV = $ADDR "(?:Rules|Foamy)"\\\0 893 CUR = \d+ 894 LEN = \d+ 895 COW_REFCNT = 1 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 908 FLAGS = \\($PADMY,OOK,SHAREKEYS\\) 909 AUX_FLAGS = 0 # $] > 5.019008 910 ARRAY = $ADDR \\(0:[67],.*\\) 911 hash quality = [0-9.]+% 912 KEYS = 2 913 FILL = ([12]) 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 921 FLAGS = \\(POK,(?:IsCOW,)?pPOK\\) 922 PV = $ADDR "(?:Rules|Foamy)"\\\0 923 CUR = \d+ 924 LEN = \d+ 925 COW_REFCNT = 1 926){2}'); 927 928# Dump with arrays, hashes, and operator return values 929@array = 1..3; 930do_test('Dump @array', '@array', <<'ARRAY', '', undef, 1); 931SV = PVAV\($ADDR\) at $ADDR 932 REFCNT = 1 933 FLAGS = \(\) 934 ARRAY = $ADDR 935 FILL = 2 936 MAX = 3 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 954 955do_test('Dump @array,1', '@array,1', <<'ARRAY', '', undef, 1); 956SV = PVAV\($ADDR\) at $ADDR 957 REFCNT = 1 958 FLAGS = \(\) 959 ARRAY = $ADDR 960 FILL = 2 961 MAX = 3 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 970%hash = 1..2; 971do_test('Dump %hash', '%hash', <<'HASH', '', undef, 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 986 987$_ = "hello"; 988do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', undef, 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 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 1003SKIP: { 1004 skip "Not built with usemymalloc", 2 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 $@; 1009 my $y; 1010 ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar'; 1011} 1012 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 1017use constant { 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', 1028}; 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 1036 REFCNT = 5 1037 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 1038 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 1039 PV = $ADDR "rule"\\\0 1040 CUR = 4 1041 LEN = \d+ 1042 COW_REFCNT = 0 1043'); 1044 1045 eval 'index "", perl'; 1046 1047 do_test('string constant now an FBM', perl, 1048'SV = PVMG\\($ADDR\\) at $ADDR 1049 REFCNT = 5 1050 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) 1051 PV = $ADDR "rule"\\\0 1052 CUR = 4 1053 LEN = \d+ 1054 COW_REFCNT = 0 1055 MAGIC = $ADDR 1056 MG_VIRTUAL = &PL_vtbl_regexp 1057 MG_TYPE = PERL_MAGIC_bm\\(B\\) 1058 MG_LEN = 256 1059 MG_PTR = $ADDR "(?:\\\\\d){256}" 1060 RARE = \d+ # $] < 5.019002 1061 PREVIOUS = 1 # $] < 5.019002 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, 1068'SV = PVMG\\($ADDR\\) at $ADDR 1069 REFCNT = 5 1070 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) 1071 PV = $ADDR "rule"\\\0 1072 CUR = 4 1073 LEN = \d+ 1074 COW_REFCNT = 0 1075 MAGIC = $ADDR 1076 MG_VIRTUAL = &PL_vtbl_regexp 1077 MG_TYPE = PERL_MAGIC_bm\\(B\\) 1078 MG_LEN = 256 1079 MG_PTR = $ADDR "(?:\\\\\d){256}" 1080 RARE = \d+ # $] < 5.019002 1081 PREVIOUS = 1 # $] < 5.019002 1082 USEFUL = 100 1083'); 1084 1085 do_test('regular string constant', beer, 1086'SV = PV\\($ADDR\\) at $ADDR 1087 REFCNT = 6 1088 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 1089 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 1090 PV = $ADDR "foam"\\\0 1091 CUR = 4 1092 LEN = \d+ 1093 COW_REFCNT = 0 1094'); 1095 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 1100 FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\) # $] < 5.021005 1101 FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\) # $] >=5.021005 1102 PV = $ADDR "foam"\\\0 1103 CUR = 4 1104 LEN = \d+ 1105 COW_REFCNT = 0 1106'); 1107 1108 my $want = 'SV = PVMG\\($ADDR\\) at $ADDR 1109 REFCNT = 6 1110 FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\) 1111 PV = $ADDR "foam"\\\0 1112 CUR = 4 1113 LEN = \d+ 1114 COW_REFCNT = 0 1115 MAGIC = $ADDR 1116 MG_VIRTUAL = &PL_vtbl_regexp 1117 MG_TYPE = PERL_MAGIC_bm\\(B\\) 1118 MG_LEN = 256 1119 MG_PTR = $ADDR "(?:\\\\\d){256}" 1120 RARE = \d+ # $] < 5.019002 1121 PREVIOUS = \d+ # $] < 5.019002 1122 USEFUL = 100 1123'; 1124 1125 is (eval 'index "not too foamy", beer', 8, 'correct index'); 1126 1127 do_test('string constant now FBMed', beer, $want); 1128 1129 my $pie = 'good'; 1130 1131 is(study $pie, 1, "Our studies were successful"); 1132 1133 do_test('string constant still FBMed', beer, $want); 1134 1135 do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR 1136 REFCNT = 1 1137 FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\) 1138 PV = $ADDR "good"\\\0 1139 CUR = 4 1140 LEN = \d+ 1141 COW_REFCNT = 1 1142'); 1143} 1144 1145# (One block of study tests removed when study was made a no-op.) 1146 1147{ 1148 open(OUT, '>', "peek$$") or die "Failed to open peek $$: $!"; 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"; 1153 close OUT; 1154} 1155# note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9 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 1164 FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\) 1165 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] 1166 CUR = 13 1167 LEN = 0 1168 STASH = $ADDR "Regexp" 1169 COMPFLAGS = 0x0 \(\) 1170 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) 1171(?: ENGINE = $ADDR \(STANDARD\) 1172)? INTFLAGS = 0x0(?: \(\))? 1173 NPARENS = 0 1174 LASTPAREN = 0 1175 LASTCLOSEPAREN = 0 1176 MINLEN = 1 1177 MINLENRET = 1 1178 GOFS = 0 1179 PRE_PREFIX = 5 1180 SUBLEN = 0 1181 SUBOFFSET = 0 1182 SUBCOFFSET = 0 1183 SUBBEG = 0x0 1184(?: ENGINE = $ADDR 1185)? MOTHER_RE = $ADDR' 1186. ($] < 5.019003 ? '' : ' 1187 SV = REGEXP\($ADDR\) at $ADDR 1188 REFCNT = 2 1189 FLAGS = \(POK,pPOK,UTF8\) 1190 PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\] 1191 CUR = 13 1192 LEN = \d+ 1193 COMPFLAGS = 0x0 \(\) 1194 EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\) 1195(?: ENGINE = $ADDR \(STANDARD\) 1196)? INTFLAGS = 0x0(?: \(\))? 1197 NPARENS = 0 1198 LASTPAREN = 0 1199 LASTCLOSEPAREN = 0 1200 MINLEN = 1 1201 MINLENRET = 1 1202 GOFS = 0 1203 PRE_PREFIX = 5 1204 SUBLEN = 0 1205 SUBOFFSET = 0 1206 SUBCOFFSET = 0 1207 SUBBEG = 0x0 1208(?: ENGINE = $ADDR 1209)? MOTHER_RE = 0x0 1210 PAREN_NAMES = 0x0 1211 SUBSTRS = $ADDR 1212 PPRIVATE = $ADDR 1213 OFFS = $ADDR 1214 QR_ANONCV = 0x0(?: 1215 SAVED_COPY = 0x0)?') . ' 1216 PAREN_NAMES = 0x0 1217 SUBSTRS = $ADDR 1218 PPRIVATE = $ADDR 1219 OFFS = $ADDR 1220 QR_ANONCV = 0x0(?: 1221 SAVED_COPY = 0x0)? 1222'); 1223 1224{ # perl #117793: Extend SvREFCNT* to work on any perl variable type 1225 my %hash; 1226 my $base_count = Devel::Peek::SvREFCNT(%hash); 1227 my $ref = \%hash; 1228 is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar"); 1229 ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype"); 1230} 1231{ 1232# utf8 tests 1233use utf8; 1234 1235sub _dump { 1236 open(OUT, '>', "peek$$") or die $!; 1237 open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; 1238 Dump($_[0]); 1239 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; 1240 close(OUT); 1241 open(IN, '<', "peek$$") or die $!; 1242 my $dump = do { local $/; <IN> }; 1243 close(IN); 1244 1 while unlink "peek$$"; 1245 return $dump; 1246} 1247 1248sub _get_coderef { 1249 my $x = $_[0]; 1250 utf8::upgrade($x); 1251 eval "sub $x {}; 1" or die $@; 1252 return *{$x}{CODE}; 1253} 1254 1255like( 1256 _dump(_get_coderef("\x{df}::\xdf")), 1257 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/, 1258 "GVGV's are correctly escaped for latin1 :: latin1", 1259); 1260 1261like( 1262 _dump(_get_coderef("\x{30cd}::\x{30cd}")), 1263 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/, 1264 "GVGV's are correctly escaped for UTF8 :: UTF8", 1265); 1266 1267like( 1268 _dump(_get_coderef("\x{df}::\x{30cd}")), 1269 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/, 1270 "GVGV's are correctly escaped for latin1 :: UTF8", 1271); 1272 1273like( 1274 _dump(_get_coderef("\x{30cd}::\x{df}")), 1275 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/, 1276 "GVGV's are correctly escaped for UTF8 :: latin1", 1277); 1278 1279like( 1280 _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")), 1281 qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/, 1282 "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8", 1283); 1284 1285my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"}); 1286 1287like( 1288 $dump, 1289 qr/NAME = \Q"\x{30dc}"/, 1290 "NAME is correctly escaped for UTF8 globs", 1291); 1292 1293like( 1294 $dump, 1295 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/, 1296 "GvSTASH is correctly escaped for UTF8 globs" 1297); 1298 1299like( 1300 $dump, 1301 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/, 1302 "EGV is correctly escaped for UTF8 globs" 1303); 1304 1305$dump = _dump(*{"\x{df}::\x{30cc}"}); 1306 1307like( 1308 $dump, 1309 qr/NAME = \Q"\x{30cc}"/, 1310 "NAME is correctly escaped for UTF8 globs with latin1 stashes", 1311); 1312 1313like( 1314 $dump, 1315 qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/, 1316 "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes" 1317); 1318 1319like( 1320 $dump, 1321 qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/, 1322 "EGV is correctly escaped for UTF8 globs with latin1 stashes" 1323); 1324 1325like( 1326 _dump(bless {}, "\0::\1::\x{30cd}"), 1327 qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/, 1328 "STASH for blessed hashrefs is correct" 1329); 1330 1331BEGIN { $::{doof} = "\0\1\x{30cd}" } 1332like( 1333 _dump(\&doof), 1334 qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/, 1335 "PROTOTYPE is escaped correctly" 1336); 1337 1338{ 1339 my $coderef = eval <<"EOP"; 1340 use feature 'lexical_subs'; 1341 no warnings 'experimental::lexical_subs'; 1342 my sub bar (\$\x{30cd}) {1}; \\&bar 1343EOP 1344 like( 1345 _dump($coderef), 1346 qr/PROTOTYPE = "\$\Q\x{30cd}"/, 1347 "PROTOTYPE works on lexical subs" 1348 ) 1349} 1350 1351sub get_outside { 1352 eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()"; 1353} 1354sub basic { my $x; return eval q{sub { eval q{$x} }} } 1355like( 1356 _dump(basic()), 1357 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/, 1358 'OUTSIDE works' 1359); 1360 1361like( 1362 _dump(get_outside("\x{30ce}")), 1363 qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/, 1364 'OUTSIDE + UTF8 works' 1365); 1366 1367# TODO AUTOLOAD = stashname, which requires using a XS autoload 1368# and calling Dump() on the cv 1369 1370 1371 1372sub test_utf8_stashes { 1373 my ($stash_name, $test) = @_; 1374 1375 $dump = _dump(\%{"${stash_name}::"}); 1376 1377 my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x'; 1378 $escaped_stash_name = join "", map { 1379 $_ eq ':' ? $_ : sprintf $format, ord $_ 1380 } split //, $stash_name; 1381 1382 like( 1383 $dump, 1384 qr/\QNAME = "$escaped_stash_name"/, 1385 "NAME is correct escaped for $test" 1386 ); 1387 1388 like( 1389 $dump, 1390 qr/\QENAME = "$escaped_stash_name"/, 1391 "ENAME is correct escaped for $test" 1392 ); 1393} 1394 1395for my $test ( 1396 [ "\x{30cd}", "UTF8 stashes" ], 1397 [ "\x{df}", "latin 1 stashes" ], 1398 [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ], 1399 [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ], 1400) { 1401 test_utf8_stashes(@$test); 1402} 1403 1404} 1405 1406my $runperl_args = { switches => ['-Ilib'] }; 1407sub test_DumpProg { 1408 my ($prog, $expected, $name, $test) = @_; 1409 $test ||= 'like'; 1410 1411 my $u = 'use Devel::Peek "DumpProg"; DumpProg();'; 1412 1413 # Interface between Test::Builder & test.pl 1414 my $builder = Test::More->builder(); 1415 t::curr_test($builder->current_test() + 1); 1416 1417 utf8::encode($prog); 1418 1419 if ( $test eq 'is' ) { 1420 t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name) 1421 } 1422 else { 1423 t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name) 1424 } 1425 1426 $builder->current_test(t::curr_test() - 1); 1427} 1428 1429my $threads = $Config{'useithreads'}; 1430 1431for my $test ( 1432[ 1433 "package test;", 1434 qr/PACKAGE = "test"/, 1435 "DumpProg() + package declaration" 1436], 1437[ 1438 "use utf8; package \x{30cd};", 1439 qr/PACKAGE = "\\x\Q{30cd}"/, 1440 "DumpProg() + UTF8 package declaration" 1441], 1442[ 1443 "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};", 1444 ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/) 1445], 1446[ 1447 "use utf8; \x{30cc}: { last \x{30cc} }", 1448 qr/LABEL = \Q"\x{30cc}"/ 1449], 1450) 1451{ 1452 test_DumpProg(@$test); 1453} 1454 1455{ 1456 local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS'; 1457 my $e = <<'EODUMP'; 1458dumpindent is 4 at -e line 1. 1459 14601 leave LISTOP(0xNNN) ===> [0x0] 1461 PARENT ===> [0x0] 1462 TARG = 1 1463 FLAGS = (VOID,KIDS,PARENS,SLABBED) 1464 PRIVATE = (REFC) 1465 REFCNT = 1 1466 | 14672 +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN] 1468 | FLAGS = (UNKNOWN,SLABBED,MORESIB) 1469 | 14703 +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN] 1471 | FLAGS = (VOID,SLABBED,MORESIB) 1472 | LINE = 1 1473 | PACKAGE = "t" 1474 | | 14755 +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN] 1476 TARG = 1 1477 FLAGS = (VOID,KIDS,STACKED,SLABBED) 1478 PRIVATE = (TARG) 1479 | 14806 +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN] 1481 FLAGS = (UNKNOWN,KIDS,SLABBED) 1482 | 14834 +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN] 1484 | FLAGS = (SCALAR,SLABBED,MORESIB) 1485 | 14868 +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN] 1487 FLAGS = (SCALAR,KIDS,SLABBED) 1488 PRIVATE = (0x1) 1489 | 14907 +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN] 1491 FLAGS = (SCALAR,SLABBED) 1492 GV_OR_PADIX 1493EODUMP 1494 1495 $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e; 1496 $e =~ s/SVOP/PADOP/g if $threads; 1497 my $out = t::runperl 1498 switches => ['-Ilib'], 1499 prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();', 1500 stderr=>1; 1501 $out =~ s/ *SEQ = .*\n//; 1502 $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g; 1503 $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g; 1504 is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning"; 1505} 1506done_testing(); 1507