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