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