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