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