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..21\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 = \\(PADBUSY,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 = \\(PADBUSY,PADMY,POK,pPOK,ANON\\)
 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 = 0x4
 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     PADLIST = $ADDR
 251     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 252        \\d+\\. $ADDR<\\d+>      \\(\\d+,\\d+\\) "\\$pattern"
 253       \\d+\\. $ADDR<\\d+> FAKE \\(\\d+,\\d+\\) "\\$DEBUG"
 254       \\d+\\. $ADDR<\\d+>      \\(\\d+,\\d+\\) "\\$dump"
 255     OUTSIDE = $ADDR \\(MAIN\\)');
 256
 257 do_test(15,
 258         qr(tic),
 259 'SV = RV\\($ADDR\\) at $ADDR
 260   REFCNT = 1
 261   FLAGS = \\(ROK\\)
 262   RV = $ADDR
 263   SV = PVMG\\($ADDR\\) at $ADDR
 264     REFCNT = 1
 265     FLAGS = \\(OBJECT,RMG\\)
 266     IV = 0
 267     NV = 0
 268     PV = 0
 269     MAGIC = $ADDR
 270       MG_VIRTUAL = $ADDR
 271       MG_TYPE = PERL_MAGIC_qr\(r\)
 272       MG_OBJ = $ADDR
 273     STASH = $ADDR\\t"Regexp"');
 274
 275 do_test(16,
 276         (bless {}, "Tac"),
 277 'SV = RV\\($ADDR\\) at $ADDR
 278   REFCNT = 1
 279   FLAGS = \\(ROK\\)
 280   RV = $ADDR
 281   SV = PVHV\\($ADDR\\) at $ADDR
 282     REFCNT = 2
 283     FLAGS = \\(OBJECT,SHAREKEYS\\)
 284     IV = 0
 285     NV = 0
 286     STASH = $ADDR\\t"Tac"
 287     ARRAY = 0x0
 288     KEYS = 0
 289     FILL = 0
 290     MAX = 7
 291     RITER = -1
 292     EITER = 0x0');
 293
 294 do_test(17,
 295         *a,
 296 'SV = PVGV\\($ADDR\\) at $ADDR
 297   REFCNT = 5
 298   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
 299   IV = 0
 300   NV = 0
 301   MAGIC = $ADDR
 302     MG_VIRTUAL = &PL_vtbl_glob
 303     MG_TYPE = PERL_MAGIC_glob\(\*\)
 304     MG_OBJ = $ADDR
 305   NAME = "a"
 306   NAMELEN = 1
 307   GvSTASH = $ADDR\\t"main"
 308   GP = $ADDR
 309     SV = $ADDR
 310     REFCNT = 1
 311     IO = 0x0
 312     FORM = 0x0
 313     AV = 0x0
 314     HV = 0x0
 315     CV = 0x0
 316     CVGEN = 0x0
 317     GPFLAGS = 0x0
 318     LINE = \\d+
 319     FILE = ".*\\b(?i:peek\\.t)"
 320     FLAGS = $ADDR
 321     EGV = $ADDR\\t"a"');
 322
 323 if (ord('A') == 193) {
 324 do_test(18,
 325         chr(256).chr(0).chr(512),
 326 'SV = PV\\($ADDR\\) at $ADDR
 327   REFCNT = 1
 328   FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 329   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 330   CUR = 5
 331   LEN = \\d+');
 332 } else {
 333 do_test(18,
 334         chr(256).chr(0).chr(512),
 335 'SV = PV\\($ADDR\\) at $ADDR
 336   REFCNT = 1
 337   FLAGS = \\((?:PADBUSY,PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 338   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 339   CUR = 5
 340   LEN = \\d+');
 341 }
 342
 343 if (ord('A') == 193) {
 344 do_test(19,
 345         {chr(256)=>chr(512)},
 346 'SV = RV\\($ADDR\\) at $ADDR
 347   REFCNT = 1
 348   FLAGS = \\(ROK\\)
 349   RV = $ADDR
 350   SV = PVHV\\($ADDR\\) at $ADDR
 351     REFCNT = 2
 352     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 353     UV = 1
 354     NV = $FLOAT
 355     ARRAY = $ADDR  \\(0:7, 1:1\\)
 356     hash quality = 100.0%
 357     KEYS = 1
 358     FILL = 1
 359     MAX = 7
 360     RITER = -1
 361     EITER = $ADDR
 362     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 363     SV = PV\\($ADDR\\) at $ADDR
 364       REFCNT = 1
 365       FLAGS = \\(POK,pPOK,UTF8\\)
 366       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 367       CUR = 2
 368       LEN = \\d+');
 369 } else {
 370 do_test(19,
 371         {chr(256)=>chr(512)},
 372 'SV = RV\\($ADDR\\) at $ADDR
 373   REFCNT = 1
 374   FLAGS = \\(ROK\\)
 375   RV = $ADDR
 376   SV = PVHV\\($ADDR\\) at $ADDR
 377     REFCNT = 2
 378     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 379     UV = 1
 380     NV = 0
 381     ARRAY = $ADDR  \\(0:7, 1:1\\)
 382     hash quality = 100.0%
 383     KEYS = 1
 384     FILL = 1
 385     MAX = 7
 386     RITER = -1
 387     EITER = $ADDR
 388     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 389     SV = PV\\($ADDR\\) at $ADDR
 390       REFCNT = 1
 391       FLAGS = \\(POK,pPOK,UTF8\\)
 392       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 393       CUR = 2
 394       LEN = \\d+');
 395 }
 396
 397 my $x="";
 398 $x=~/.??/g;
 399 do_test(20,
 400         $x,
 401 'SV = PVMG\\($ADDR\\) at $ADDR
 402   REFCNT = 1
 403   FLAGS = \\(PADBUSY,PADMY,SMG,POK,pPOK\\)
 404   IV = 0
 405   NV = 0
 406   PV = $ADDR ""\\\0
 407   CUR = 0
 408   LEN = 1
 409   MAGIC = $ADDR
 410     MG_VIRTUAL = &PL_vtbl_mglob
 411     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 412     MG_FLAGS = 0x01
 413       MINMATCH');
 414
 415 do_test(21,
 416         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 417 'SV = PVMG\\($ADDR\\) at $ADDR
 418   REFCNT = 1
 419   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
 420   IV = 0
 421   NV = 0
 422   PV = $ADDR "0"\\\0
 423   CUR = 1
 424   LEN = \d+
 425   MAGIC = $ADDR
 426     MG_VIRTUAL = &PL_vtbl_envelem
 427     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 428 (?:    MG_FLAGS = 0x01
 429       TAINTEDDIR
 430 )?    MG_LEN = 4
 431     MG_PTR = $ADDR "PATH"
 432   MAGIC = $ADDR
 433     MG_VIRTUAL = &PL_vtbl_taint
 434     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 435
 436 END {
 437   1 while unlink("peek$$");
 438 }