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