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