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 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     ARRAY = $ADDR
 171     FILL = 1
 172     MAX = 1
 173     ARYLEN = 0x0
 174     FLAGS = \\(REAL\\)
 175     Elt No. 0
 176     SV = IV\\($ADDR\\) at $ADDR
 177       REFCNT = 1
 178       FLAGS = \\(IOK,pIOK\\)
 179       IV = 123
 180     Elt No. 1' . $c_pattern);
 181
 182 do_test(12,
 183        {$b=>$c},
 184 'SV = RV\\($ADDR\\) at $ADDR
 185   REFCNT = 1
 186   FLAGS = \\(ROK\\)
 187   RV = $ADDR
 188   SV = PVHV\\($ADDR\\) at $ADDR
 189     REFCNT = 2
 190     FLAGS = \\(SHAREKEYS\\)
 191     ARRAY = $ADDR  \\(0:7, 1:1\\)
 192     hash quality = 100.0%
 193     KEYS = 1
 194     FILL = 1
 195     MAX = 7
 196     RITER = -1
 197     EITER = 0x0
 198     Elt "123" HASH = $ADDR' . $c_pattern);
 199
 200 do_test(13,
 201         sub(){@_},
 202 'SV = RV\\($ADDR\\) at $ADDR
 203   REFCNT = 1
 204   FLAGS = \\(ROK\\)
 205   RV = $ADDR
 206   SV = PVCV\\($ADDR\\) at $ADDR
 207     REFCNT = 2
 208     FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
 209     IV = 0
 210     NV = 0
 211     PROTOTYPE = ""
 212     COMP_STASH = $ADDR\\t"main"
 213     START = $ADDR ===> \\d+
 214     ROOT = $ADDR
 215     XSUB = 0x0
 216     XSUBANY = 0
 217     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
 218     FILE = ".*\\b(?i:peek\\.t)"
 219     DEPTH = 0
 220 (?:    MUTEXP = $ADDR
 221     OWNER = $ADDR
 222 )?    FLAGS = 0x404
 223     OUTSIDE_SEQ = \\d+
 224     PADLIST = $ADDR
 225     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 226     OUTSIDE = $ADDR \\(MAIN\\)');
 227
 228 do_test(14,
 229         \&do_test,
 230 'SV = RV\\($ADDR\\) at $ADDR
 231   REFCNT = 1
 232   FLAGS = \\(ROK\\)
 233   RV = $ADDR
 234   SV = PVCV\\($ADDR\\) at $ADDR
 235     REFCNT = (3|4)
 236     FLAGS = \\(\\)
 237     IV = 0
 238     NV = 0
 239     COMP_STASH = $ADDR\\t"main"
 240     START = $ADDR ===> \\d+
 241     ROOT = $ADDR
 242     XSUB = 0x0
 243     XSUBANY = 0
 244     GVGV::GV = $ADDR\\t"main" :: "do_test"
 245     FILE = ".*\\b(?i:peek\\.t)"
 246     DEPTH = 1
 247 (?:    MUTEXP = $ADDR
 248     OWNER = $ADDR
 249 )?    FLAGS = 0x0
 250     OUTSIDE_SEQ = \\d+
 251     PADLIST = $ADDR
 252     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 253        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
 254       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
 255       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
 256     OUTSIDE = $ADDR \\(MAIN\\)');
 257
 258 do_test(15,
 259         qr(tic),
 260 'SV = RV\\($ADDR\\) at $ADDR
 261   REFCNT = 1
 262   FLAGS = \\(ROK\\)
 263   RV = $ADDR
 264   SV = PVMG\\($ADDR\\) at $ADDR
 265     REFCNT = 1
 266     FLAGS = \\(OBJECT,SMG\\)
 267     IV = 0
 268     NV = 0
 269     PV = 0
 270     MAGIC = $ADDR
 271       MG_VIRTUAL = $ADDR
 272       MG_TYPE = PERL_MAGIC_qr\(r\)
 273       MG_OBJ = $ADDR
 274     STASH = $ADDR\\t"Regexp"');
 275
 276 do_test(16,
 277         (bless {}, "Tac"),
 278 'SV = RV\\($ADDR\\) at $ADDR
 279   REFCNT = 1
 280   FLAGS = \\(ROK\\)
 281   RV = $ADDR
 282   SV = PVHV\\($ADDR\\) at $ADDR
 283     REFCNT = 2
 284     FLAGS = \\(OBJECT,SHAREKEYS\\)
 285     STASH = $ADDR\\t"Tac"
 286     ARRAY = 0x0
 287     KEYS = 0
 288     FILL = 0
 289     MAX = 7
 290     RITER = -1
 291     EITER = 0x0');
 292
 293 do_test(17,
 294         *a,
 295 'SV = PVGV\\($ADDR\\) at $ADDR
 296   REFCNT = 5
 297   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
 298   IV = 0
 299   NV = 0
 300   MAGIC = $ADDR
 301     MG_VIRTUAL = &PL_vtbl_glob
 302     MG_TYPE = PERL_MAGIC_glob\(\*\)
 303     MG_OBJ = $ADDR
 304   NAME = "a"
 305   NAMELEN = 1
 306   GvSTASH = $ADDR\\t"main"
 307   GP = $ADDR
 308     SV = $ADDR
 309     REFCNT = 1
 310     IO = 0x0
 311     FORM = 0x0
 312     AV = 0x0
 313     HV = 0x0
 314     CV = 0x0
 315     CVGEN = 0x0
 316     LINE = \\d+
 317     FILE = ".*\\b(?i:peek\\.t)"
 318     FLAGS = $ADDR
 319     EGV = $ADDR\\t"a"');
 320
 321 if (ord('A') == 193) {
 322 do_test(18,
 323         chr(256).chr(0).chr(512),
 324 'SV = PV\\($ADDR\\) at $ADDR
 325   REFCNT = 1
 326   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 327   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 328   CUR = 5
 329   LEN = \\d+');
 330 } else {
 331 do_test(18,
 332         chr(256).chr(0).chr(512),
 333 'SV = PV\\($ADDR\\) at $ADDR
 334   REFCNT = 1
 335   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 336   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 337   CUR = 5
 338   LEN = \\d+');
 339 }
 340
 341 if (ord('A') == 193) {
 342 do_test(19,
 343         {chr(256)=>chr(512)},
 344 'SV = RV\\($ADDR\\) at $ADDR
 345   REFCNT = 1
 346   FLAGS = \\(ROK\\)
 347   RV = $ADDR
 348   SV = PVHV\\($ADDR\\) at $ADDR
 349     REFCNT = 2
 350     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 351     ARRAY = $ADDR  \\(0:7, 1:1\\)
 352     hash quality = 100.0%
 353     KEYS = 1
 354     FILL = 1
 355     MAX = 7
 356     RITER = -1
 357     EITER = $ADDR
 358     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 359     SV = PV\\($ADDR\\) at $ADDR
 360       REFCNT = 1
 361       FLAGS = \\(POK,pPOK,UTF8\\)
 362       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 363       CUR = 2
 364       LEN = \\d+');
 365 } else {
 366 do_test(19,
 367         {chr(256)=>chr(512)},
 368 'SV = RV\\($ADDR\\) at $ADDR
 369   REFCNT = 1
 370   FLAGS = \\(ROK\\)
 371   RV = $ADDR
 372   SV = PVHV\\($ADDR\\) at $ADDR
 373     REFCNT = 2
 374     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 375     ARRAY = $ADDR  \\(0:7, 1:1\\)
 376     hash quality = 100.0%
 377     KEYS = 1
 378     FILL = 1
 379     MAX = 7
 380     RITER = -1
 381     EITER = $ADDR
 382     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 383     SV = PV\\($ADDR\\) at $ADDR
 384       REFCNT = 1
 385       FLAGS = \\(POK,pPOK,UTF8\\)
 386       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 387       CUR = 2
 388       LEN = \\d+');
 389 }
 390
 391 my $x="";
 392 $x=~/.??/g;
 393 do_test(20,
 394         $x,
 395 'SV = PVMG\\($ADDR\\) at $ADDR
 396   REFCNT = 1
 397   FLAGS = \\(PADMY,SMG,POK,pPOK\\)
 398   IV = 0
 399   NV = 0
 400   PV = $ADDR ""\\\0
 401   CUR = 0
 402   LEN = \d+
 403   MAGIC = $ADDR
 404     MG_VIRTUAL = &PL_vtbl_mglob
 405     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 406     MG_FLAGS = 0x01
 407       MINMATCH');
 408
 409 #
 410 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 411 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 412 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
 413 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 414 # ENV hashes is also not always null terminated.
 415 #
 416 do_test(21,
 417         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 418 'SV = PVMG\\($ADDR\\) at $ADDR
 419   REFCNT = 1
 420   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
 421   IV = 0
 422   NV = 0
 423   PV = $ADDR "0"\\\0
 424   CUR = 1
 425   LEN = \d+
 426   MAGIC = $ADDR
 427     MG_VIRTUAL = &PL_vtbl_envelem
 428     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 429 (?:    MG_FLAGS = 0x01
 430       TAINTEDDIR
 431 )?    MG_LEN = -?\d+
 432     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
 433     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
 434       REFCNT = \d+
 435       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)pPOK\\)
 436 (?:      IV = 0
 437 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
 438       CUR = \d+
 439       LEN = \d+)
 440   MAGIC = $ADDR
 441     MG_VIRTUAL = &PL_vtbl_taint
 442     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 443
 444 END {
 445   1 while unlink("peek$$");
 446 }
 447
 448 # blessed refs
 449 do_test(22,
 450         bless(\\undef, 'Foobar'),
 451 'SV = RV\\($ADDR\\) at $ADDR
 452   REFCNT = 1
 453   FLAGS = \\(ROK\\)
 454   RV = $ADDR
 455   SV = PVMG\\($ADDR\\) at $ADDR
 456     REFCNT = 2
 457     FLAGS = \\(OBJECT,ROK\\)
 458     IV = -?\d+
 459     NV = $FLOAT
 460     RV = $ADDR
 461     SV = NULL\\(0x0\\) at $ADDR
 462       REFCNT = \d+
 463       FLAGS = \\(READONLY\\)
 464     PV = $ADDR ""
 465     CUR = 0
 466     LEN = 0
 467     STASH = $ADDR\s+"Foobar"');
 468
 469 # Constant subroutines
 470
 471 sub const () {
 472     "Perl rules";
 473 }
 474
 475 do_test(23,
 476         \&const,
 477 'SV = RV\\($ADDR\\) at $ADDR
 478   REFCNT = 1
 479   FLAGS = \\(ROK\\)
 480   RV = $ADDR
 481   SV = PVCV\\($ADDR\\) at $ADDR
 482     REFCNT = (2)
 483     FLAGS = \\(POK,pPOK,CONST\\)
 484     IV = 0
 485     NV = 0
 486     PROTOTYPE = ""
 487     COMP_STASH = 0x0
 488     ROOT = 0x0
 489     XSUB = $ADDR
 490     XSUBANY = $ADDR \\(CONST SV\\)
 491     SV = PV\\($ADDR\\) at $ADDR
 492       REFCNT = 1
 493       FLAGS = \\(.*POK,READONLY,pPOK\\)
 494       PV = $ADDR "Perl rules"\\\0
 495       CUR = 10
 496       LEN = \\d+
 497     GVGV::GV = $ADDR\\t"main" :: "const"
 498     FILE = ".*\\b(?i:peek\\.t)"
 499     DEPTH = 0
 500 (?:    MUTEXP = $ADDR
 501     OWNER = $ADDR
 502 )?    FLAGS = 0x200
 503     OUTSIDE_SEQ = 0
 504     PADLIST = 0x0
 505     OUTSIDE = 0x0 \\(null\\)');