1#!./perl -T 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require Config; import Config; 7 if ($Config{'extensions'} !~ /\bPeek\b/) { 8 print "1..0 # Skip: Devel::Peek was not built\n"; 9 exit 0; 10 } 11} 12 13use Devel::Peek; 14 15print "1..22\n"; 16 17our $DEBUG = 0; 18open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!"; 19 20sub do_test { 21 my $pattern = pop; 22 if (open(OUT,">peek$$")) { 23 open(STDERR, ">&OUT") or die "Can't dup OUT: $!"; 24 Dump($_[1]); 25 open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!"; 26 close(OUT); 27 if (open(IN, "peek$$")) { 28 local $/; 29 $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g; 30 $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g; 31 print $pattern, "\n" if $DEBUG; 32 my $dump = <IN>; 33 print $dump, "\n" if $DEBUG; 34 print "got:\n[\n$dump\n]\nexpected:\n[\n$pattern\n]\nnot " 35 unless $dump =~ /\A$pattern\Z/ms; 36 print "ok $_[0]\n"; 37 close(IN); 38 return $1; 39 } else { 40 die "$0: failed to open peek$$: !\n"; 41 } 42 } else { 43 die "$0: failed to create peek$$: $!\n"; 44 } 45} 46 47our $a; 48our $b; 49my $c; 50local $d = 0; 51 52do_test( 1, 53 $a = "foo", 54'SV = PV\\($ADDR\\) at $ADDR 55 REFCNT = 1 56 FLAGS = \\(POK,pPOK\\) 57 PV = $ADDR "foo"\\\0 58 CUR = 3 59 LEN = \\d+' 60 ); 61 62do_test( 2, 63 "bar", 64'SV = PV\\($ADDR\\) at $ADDR 65 REFCNT = 1 66 FLAGS = \\(.*POK,READONLY,pPOK\\) 67 PV = $ADDR "bar"\\\0 68 CUR = 3 69 LEN = \\d+'); 70 71do_test( 3, 72 $b = 123, 73'SV = IV\\($ADDR\\) at $ADDR 74 REFCNT = 1 75 FLAGS = \\(IOK,pIOK\\) 76 IV = 123'); 77 78do_test( 4, 79 456, 80'SV = IV\\($ADDR\\) at $ADDR 81 REFCNT = 1 82 FLAGS = \\(.*IOK,READONLY,pIOK\\) 83 IV = 456'); 84 85do_test( 5, 86 $c = 456, 87'SV = IV\\($ADDR\\) at $ADDR 88 REFCNT = 1 89 FLAGS = \\(PADBUSY,PADMY,IOK,pIOK\\) 90 IV = 456'); 91 92# If perl is built with PERL_PRESERVE_IVUV then maths is done as integers 93# where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then 94# maths is done in floating point always, and this scalar will be an NV. 95# ([NI]) captures the type, referred to by \1 in this regexp and $type for 96# building subsequent regexps. 97my $type = do_test( 6, 98 $c + $d, 99'SV = ([NI])V\\($ADDR\\) at $ADDR 100 REFCNT = 1 101 FLAGS = \\(PADTMP,\1OK,p\1OK\\) 102 \1V = 456'); 103 104($d = "789") += 0.1; 105 106do_test( 7, 107 $d, 108'SV = PVNV\\($ADDR\\) at $ADDR 109 REFCNT = 1 110 FLAGS = \\(NOK,pNOK\\) 111 IV = 0 112 NV = 789\\.(?:1(?:000+\d+)?|0999+\d+) 113 PV = $ADDR "789"\\\0 114 CUR = 3 115 LEN = \\d+'); 116 117do_test( 8, 118 0xabcd, 119'SV = IV\\($ADDR\\) at $ADDR 120 REFCNT = 1 121 FLAGS = \\(.*IOK,READONLY,pIOK\\) 122 IV = 43981'); 123 124do_test( 9, 125 undef, 126'SV = NULL\\(0x0\\) at $ADDR 127 REFCNT = 1 128 FLAGS = \\(\\)'); 129 130do_test(10, 131 \$a, 132'SV = RV\\($ADDR\\) at $ADDR 133 REFCNT = 1 134 FLAGS = \\(ROK\\) 135 RV = $ADDR 136 SV = PV\\($ADDR\\) at $ADDR 137 REFCNT = 2 138 FLAGS = \\(POK,pPOK\\) 139 PV = $ADDR "foo"\\\0 140 CUR = 3 141 LEN = \\d+'); 142 143my $c_pattern; 144if ($type eq 'N') { 145 $c_pattern = ' 146 SV = PVNV\\($ADDR\\) at $ADDR 147 REFCNT = 1 148 FLAGS = \\(IOK,NOK,pIOK,pNOK\\) 149 IV = 456 150 NV = 456 151 PV = 0'; 152} else { 153 $c_pattern = ' 154 SV = IV\\($ADDR\\) at $ADDR 155 REFCNT = 1 156 FLAGS = \\(IOK,pIOK\\) 157 IV = 456'; 158} 159do_test(11, 160 [$b,$c], 161'SV = RV\\($ADDR\\) at $ADDR 162 REFCNT = 1 163 FLAGS = \\(ROK\\) 164 RV = $ADDR 165 SV = PVAV\\($ADDR\\) at $ADDR 166 REFCNT = 2 167 FLAGS = \\(\\) 168 IV = 0 169 NV = 0 170 ARRAY = $ADDR 171 FILL = 1 172 MAX = 1 173 ARYLEN = 0x0 174 FLAGS = \\(REAL\\) 175 Elt No. 0 176 SV = IV\\($ADDR\\) at $ADDR 177 REFCNT = 1 178 FLAGS = \\(IOK,pIOK\\) 179 IV = 123 180 Elt No. 1' . $c_pattern); 181 182do_test(12, 183 {$b=>$c}, 184'SV = RV\\($ADDR\\) at $ADDR 185 REFCNT = 1 186 FLAGS = \\(ROK\\) 187 RV = $ADDR 188 SV = PVHV\\($ADDR\\) at $ADDR 189 REFCNT = 2 190 FLAGS = \\(SHAREKEYS\\) 191 IV = 1 192 NV = $FLOAT 193 ARRAY = $ADDR \\(0:7, 1:1\\) 194 hash quality = 100.0% 195 KEYS = 1 196 FILL = 1 197 MAX = 7 198 RITER = -1 199 EITER = 0x0 200 Elt "123" HASH = $ADDR' . $c_pattern); 201 202do_test(13, 203 sub(){@_}, 204'SV = RV\\($ADDR\\) at $ADDR 205 REFCNT = 1 206 FLAGS = \\(ROK\\) 207 RV = $ADDR 208 SV = PVCV\\($ADDR\\) at $ADDR 209 REFCNT = 2 210 FLAGS = \\(PADBUSY,PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\) 211 IV = 0 212 NV = 0 213 PROTOTYPE = "" 214 COMP_STASH = $ADDR\\t"main" 215 START = $ADDR ===> \\d+ 216 ROOT = $ADDR 217 XSUB = 0x0 218 XSUBANY = 0 219 GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*" 220 FILE = ".*\\b(?i:peek\\.t)" 221 DEPTH = 0 222(?: MUTEXP = $ADDR 223 OWNER = $ADDR 224)? FLAGS = 0x404 225 OUTSIDE_SEQ = \\d+ 226 PADLIST = $ADDR 227 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) 228 OUTSIDE = $ADDR \\(MAIN\\)'); 229 230do_test(14, 231 \&do_test, 232'SV = RV\\($ADDR\\) at $ADDR 233 REFCNT = 1 234 FLAGS = \\(ROK\\) 235 RV = $ADDR 236 SV = PVCV\\($ADDR\\) at $ADDR 237 REFCNT = (3|4) 238 FLAGS = \\(\\) 239 IV = 0 240 NV = 0 241 COMP_STASH = $ADDR\\t"main" 242 START = $ADDR ===> \\d+ 243 ROOT = $ADDR 244 XSUB = 0x0 245 XSUBANY = 0 246 GVGV::GV = $ADDR\\t"main" :: "do_test" 247 FILE = ".*\\b(?i:peek\\.t)" 248 DEPTH = 1 249(?: MUTEXP = $ADDR 250 OWNER = $ADDR 251)? FLAGS = 0x0 252 OUTSIDE_SEQ = \\d+ 253 PADLIST = $ADDR 254 PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\) 255 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern" 256 \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" 257 \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump" 258 OUTSIDE = $ADDR \\(MAIN\\)'); 259 260do_test(15, 261 qr(tic), 262'SV = RV\\($ADDR\\) at $ADDR 263 REFCNT = 1 264 FLAGS = \\(ROK\\) 265 RV = $ADDR 266 SV = PVMG\\($ADDR\\) at $ADDR 267 REFCNT = 1 268 FLAGS = \\(OBJECT,SMG\\) 269 IV = 0 270 NV = 0 271 PV = 0 272 MAGIC = $ADDR 273 MG_VIRTUAL = $ADDR 274 MG_TYPE = PERL_MAGIC_qr\(r\) 275 MG_OBJ = $ADDR 276 STASH = $ADDR\\t"Regexp"'); 277 278do_test(16, 279 (bless {}, "Tac"), 280'SV = RV\\($ADDR\\) at $ADDR 281 REFCNT = 1 282 FLAGS = \\(ROK\\) 283 RV = $ADDR 284 SV = PVHV\\($ADDR\\) at $ADDR 285 REFCNT = 2 286 FLAGS = \\(OBJECT,SHAREKEYS\\) 287 IV = 0 288 NV = 0 289 STASH = $ADDR\\t"Tac" 290 ARRAY = 0x0 291 KEYS = 0 292 FILL = 0 293 MAX = 7 294 RITER = -1 295 EITER = 0x0'); 296 297do_test(17, 298 *a, 299'SV = PVGV\\($ADDR\\) at $ADDR 300 REFCNT = 5 301 FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\) 302 IV = 0 303 NV = 0 304 MAGIC = $ADDR 305 MG_VIRTUAL = &PL_vtbl_glob 306 MG_TYPE = PERL_MAGIC_glob\(\*\) 307 MG_OBJ = $ADDR 308 NAME = "a" 309 NAMELEN = 1 310 GvSTASH = $ADDR\\t"main" 311 GP = $ADDR 312 SV = $ADDR 313 REFCNT = 1 314 IO = 0x0 315 FORM = 0x0 316 AV = 0x0 317 HV = 0x0 318 CV = 0x0 319 CVGEN = 0x0 320 GPFLAGS = 0x0 321 LINE = \\d+ 322 FILE = ".*\\b(?i:peek\\.t)" 323 FLAGS = $ADDR 324 EGV = $ADDR\\t"a"'); 325 326if (ord('A') == 193) { 327do_test(18, 328 chr(256).chr(0).chr(512), 329'SV = PV\\($ADDR\\) at $ADDR 330 REFCNT = 1 331 FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\) 332 PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] 333 CUR = 5 334 LEN = \\d+'); 335} else { 336do_test(18, 337 chr(256).chr(0).chr(512), 338'SV = PV\\($ADDR\\) at $ADDR 339 REFCNT = 1 340 FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\) 341 PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\] 342 CUR = 5 343 LEN = \\d+'); 344} 345 346if (ord('A') == 193) { 347do_test(19, 348 {chr(256)=>chr(512)}, 349'SV = RV\\($ADDR\\) at $ADDR 350 REFCNT = 1 351 FLAGS = \\(ROK\\) 352 RV = $ADDR 353 SV = PVHV\\($ADDR\\) at $ADDR 354 REFCNT = 2 355 FLAGS = \\(SHAREKEYS,HASKFLAGS\\) 356 UV = 1 357 NV = $FLOAT 358 ARRAY = $ADDR \\(0:7, 1:1\\) 359 hash quality = 100.0% 360 KEYS = 1 361 FILL = 1 362 MAX = 7 363 RITER = -1 364 EITER = $ADDR 365 Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR 366 SV = PV\\($ADDR\\) at $ADDR 367 REFCNT = 1 368 FLAGS = \\(POK,pPOK,UTF8\\) 369 PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\] 370 CUR = 2 371 LEN = \\d+'); 372} else { 373do_test(19, 374 {chr(256)=>chr(512)}, 375'SV = RV\\($ADDR\\) at $ADDR 376 REFCNT = 1 377 FLAGS = \\(ROK\\) 378 RV = $ADDR 379 SV = PVHV\\($ADDR\\) at $ADDR 380 REFCNT = 2 381 FLAGS = \\(SHAREKEYS,HASKFLAGS\\) 382 UV = 1 383 NV = 0 384 ARRAY = $ADDR \\(0:7, 1:1\\) 385 hash quality = 100.0% 386 KEYS = 1 387 FILL = 1 388 MAX = 7 389 RITER = -1 390 EITER = $ADDR 391 Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR 392 SV = PV\\($ADDR\\) at $ADDR 393 REFCNT = 1 394 FLAGS = \\(POK,pPOK,UTF8\\) 395 PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\] 396 CUR = 2 397 LEN = \\d+'); 398} 399 400my $x=""; 401$x=~/.??/g; 402do_test(20, 403 $x, 404'SV = PVMG\\($ADDR\\) at $ADDR 405 REFCNT = 1 406 FLAGS = \\(PADBUSY,PADMY,SMG,POK,pPOK\\) 407 IV = 0 408 NV = 0 409 PV = $ADDR ""\\\0 410 CUR = 0 411 LEN = 1 412 MAGIC = $ADDR 413 MG_VIRTUAL = &PL_vtbl_mglob 414 MG_TYPE = PERL_MAGIC_regex_global\\(g\\) 415 MG_FLAGS = 0x01 416 MINMATCH'); 417 418# 419# TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS 420# environment variables may be invisibly case-forced, hence the (?i:PATH) 421# C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)? 422# 423do_test(21, 424 $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value 425'SV = PVMG\\($ADDR\\) at $ADDR 426 REFCNT = 1 427 FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\) 428 IV = 0 429 NV = 0 430 PV = $ADDR "0"\\\0 431 CUR = 1 432 LEN = \d+ 433 MAGIC = $ADDR 434 MG_VIRTUAL = &PL_vtbl_envelem 435 MG_TYPE = PERL_MAGIC_envelem\\(e\\) 436(?: MG_FLAGS = 0x01 437 TAINTEDDIR 438)? MG_LEN = -?\d+ 439 MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY 440 SV = PV(?:IV)?\\($ADDR\\) at $ADDR 441 REFCNT = \d+ 442 FLAGS = \\(TEMP,POK,pPOK\\) 443(?: IV = 0 444)? PV = $ADDR "(?i:PATH)"\\\0 445 CUR = \d+ 446 LEN = \d+) 447 MAGIC = $ADDR 448 MG_VIRTUAL = &PL_vtbl_taint 449 MG_TYPE = PERL_MAGIC_taint\\(t\\)'); 450 451END { 452 1 while unlink("peek$$"); 453} 454 455# blessed refs 456do_test(22, 457 bless(\\undef, 'Foobar'), 458'SV = RV\\($ADDR\\) at $ADDR 459 REFCNT = 1 460 FLAGS = \\(ROK\\) 461 RV = $ADDR 462 SV = PVMG\\($ADDR\\) at $ADDR 463 REFCNT = 2 464 FLAGS = \\(OBJECT,ROK\\) 465 IV = -?\d+ 466 NV = $FLOAT 467 RV = $ADDR 468 SV = NULL\\(0x0\\) at $ADDR 469 REFCNT = \d+ 470 FLAGS = \\(READONLY\\) 471 PV = $ADDR "" 472 CUR = 0 473 LEN = 0 474 STASH = $ADDR\s+"Foobar"'); 475