ext/Devel/Peek/Peek.t

   1 #!./perl
   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..19\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 =~ /$pattern/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     OUTSIDE = $ADDR \\(MAIN\\)');
 226
 227 do_test(14,
 228         \&do_test,
 229 'SV = RV\\($ADDR\\) at $ADDR
 230   REFCNT = 1
 231   FLAGS = \\(ROK\\)
 232   RV = $ADDR
 233   SV = PVCV\\($ADDR\\) at $ADDR
 234     REFCNT = (3|4)
 235     FLAGS = \\(\\)
 236     IV = 0
 237     NV = 0
 238     COMP_STASH = $ADDR\\t"main"
 239     START = $ADDR ===> \\d+
 240     ROOT = $ADDR
 241     XSUB = 0x0
 242     XSUBANY = 0
 243     GVGV::GV = $ADDR\\t"main" :: "do_test"
 244     FILE = ".*\\b(?i:peek\\.t)"
 245     DEPTH = 1
 246 (?:    MUTEXP = $ADDR
 247     OWNER = $ADDR
 248 )?    FLAGS = 0x0
 249     PADLIST = $ADDR
 250       \\d+\\. $ADDR \\("\\$pattern" \\d+-\\d+\\)
 251      \\d+\\. $ADDR \\(FAKE "\\$DEBUG" 0-\\d+\\)
 252      \\d+\\. $ADDR \\("\\$dump" \\d+-\\d+\\)
 253     OUTSIDE = $ADDR \\(MAIN\\)');
 254
 255 do_test(15,
 256         qr(tic),
 257 'SV = RV\\($ADDR\\) at $ADDR
 258   REFCNT = 1
 259   FLAGS = \\(ROK\\)
 260   RV = $ADDR
 261   SV = PVMG\\($ADDR\\) at $ADDR
 262     REFCNT = 1
 263     FLAGS = \\(OBJECT,RMG\\)
 264     IV = 0
 265     NV = 0
 266     PV = 0
 267     MAGIC = $ADDR
 268       MG_VIRTUAL = $ADDR
 269       MG_TYPE = PERL_MAGIC_qr\(r\)
 270       MG_OBJ = $ADDR
 271     STASH = $ADDR\\t"Regexp"');
 272
 273 do_test(16,
 274         (bless {}, "Tac"),
 275 'SV = RV\\($ADDR\\) at $ADDR
 276   REFCNT = 1
 277   FLAGS = \\(ROK\\)
 278   RV = $ADDR
 279   SV = PVHV\\($ADDR\\) at $ADDR
 280     REFCNT = 2
 281     FLAGS = \\(OBJECT,SHAREKEYS\\)
 282     IV = 0
 283     NV = 0
 284     STASH = $ADDR\\t"Tac"
 285     ARRAY = 0x0
 286     KEYS = 0
 287     FILL = 0
 288     MAX = 7
 289     RITER = -1
 290     EITER = 0x0');
 291
 292 do_test(17,
 293         *a,
 294 'SV = PVGV\\($ADDR\\) at $ADDR
 295   REFCNT = 5
 296   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
 297   IV = 0
 298   NV = 0
 299   MAGIC = $ADDR
 300     MG_VIRTUAL = &PL_vtbl_glob
 301     MG_TYPE = PERL_MAGIC_glob\(\*\)
 302     MG_OBJ = $ADDR
 303   NAME = "a"
 304   NAMELEN = 1
 305   GvSTASH = $ADDR\\t"main"
 306   GP = $ADDR
 307     SV = $ADDR
 308     REFCNT = 1
 309     IO = 0x0
 310     FORM = 0x0
 311     AV = 0x0
 312     HV = 0x0
 313     CV = 0x0
 314     CVGEN = 0x0
 315     GPFLAGS = 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 = \\((?:PADBUSY,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 = \\((?:PADBUSY,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,UTF8\\)
 351     UV = 1
 352     NV = $FLOAT
 353     ARRAY = $ADDR  \\(0:7, 1:1\\)
 354     hash quality = 100.0%
 355     KEYS = 1
 356     FILL = 1
 357     MAX = 7
 358     RITER = -1
 359     EITER = $ADDR
 360     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 361     SV = PV\\($ADDR\\) at $ADDR
 362       REFCNT = 1
 363       FLAGS = \\(POK,pPOK,UTF8\\)
 364       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 365       CUR = 2
 366       LEN = \\d+');
 367 } else {
 368 do_test(19,
 369         {chr(256)=>chr(512)},
 370 'SV = RV\\($ADDR\\) at $ADDR
 371   REFCNT = 1
 372   FLAGS = \\(ROK\\)
 373   RV = $ADDR
 374   SV = PVHV\\($ADDR\\) at $ADDR
 375     REFCNT = 2
 376     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 377     UV = 1
 378     NV = 0
 379     ARRAY = $ADDR  \\(0:7, 1:1\\)
 380     hash quality = 100.0%
 381     KEYS = 1
 382     FILL = 1
 383     MAX = 7
 384     RITER = -1
 385     EITER = $ADDR
 386     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 387     SV = PV\\($ADDR\\) at $ADDR
 388       REFCNT = 1
 389       FLAGS = \\(POK,pPOK,UTF8\\)
 390       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 391       CUR = 2
 392       LEN = \\d+');
 393 }
 394
 395 END {
 396   1 while unlink("peek$$");
 397 }