ext/Devel/Peek/t/Peek.t

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