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