ext/Devel-Peek/t/Peek.t

   1 #!./perl -T
   2
   3 BEGIN {
   4     require Config; import Config;
   5     if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
   6         print "1..0 # Skip: Devel::Peek was not built\n";
   7         exit 0;
   8     }
   9 }
  10
  11 use Test::More;
  12
  13 use Devel::Peek;
  14
  15 our $DEBUG = 0;
  16 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
  17
  18 # If I reference any lexicals in this, I get the entire outer subroutine (or
  19 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
  20 # maintain that.
  21 format PIE =
  22 Pie     @<<<<<
  23 $::type
  24 Good    @>>>>>
  25 $::mmmm
  26 .
  27
  28 sub do_test {
  29     my $todo = $_[3];
  30     my $repeat_todo = $_[4];
  31     my $pattern = $_[2];
  32     if (open(OUT,">peek$$")) {
  33         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
  34         Dump($_[1]);
  35         print STDERR "*****\n";
  36         Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
  37         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
  38         close(OUT);
  39         if (open(IN, "peek$$")) {
  40             local $/;
  41             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
  42             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
  43             # handle DEBUG_LEAKING_SCALARS prefix
  44             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
  45
  46             # Need some clear generic mechanism to eliminate (or add) lines
  47             # of dump output dependant on perl version. The (previous) use of
  48             # things like $IVNV gave the illusion that the string passed in was
  49             # a regexp into which variables were interpolated, but this wasn't
  50             # actually true as those 'variables' actually also ate the
  51             # whitespace on the line. So it seems better to mark lines that
  52             # need to be eliminated. I considered (?# ... ) and (?{ ... }),
  53             # but whilst embedded code or comment syntax would keep it as a
  54             # legitimate regexp, it still isn't true. Seems easier and clearer
  55             # things that look like comments.
  56
  57             my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/;
  58             # Could do this is in a s///mge but seems clearer like this:
  59             $pattern = join '', map {
  60                 # If we identify the version condition, take *it* out whatever
  61                 s/\s*# ($version_condition(?: && $version_condition)?)$//
  62                     ? (eval $1 ? $_ : '')
  63                     : $_ # Didn't match, so this line is in
  64             } split /^/, $pattern;
  65
  66             $pattern =~ s/\$PADMY/
  67                 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
  68             /mge;
  69             $pattern =~ s/\$PADTMP/
  70                 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
  71             /mge;
  72             $pattern =~ s/\$RV/
  73                 ($] < 5.011) ? 'RV' : 'IV';
  74             /mge;
  75
  76             print $pattern, "\n" if $DEBUG;
  77             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
  78             print $dump, "\n"    if $DEBUG;
  79             like( $dump, qr/\A$pattern\Z/ms, $_[0])
  80               or note("line " . (caller)[2]);
  81
  82             local $TODO = $repeat_todo;
  83             is($dump2, $dump, "$_[0] (unchanged by dump)")
  84               or note("line " . (caller)[2]);
  85
  86             close(IN);
  87
  88             return $1;
  89         } else {
  90             die "$0: failed to open peek$$: !\n";
  91         }
  92     } else {
  93         die "$0: failed to create peek$$: $!\n";
  94     }
  95 }
  96
  97 our   $a;
  98 our   $b;
  99 my    $c;
 100 local $d = 0;
 101
 102 END {
 103     1 while unlink("peek$$");
 104 }
 105
 106 do_test('assignment of immediate constant (string)',
 107         $a = "foo",
 108 'SV = PV\\($ADDR\\) at $ADDR
 109   REFCNT = 1
 110   FLAGS = \\(POK,pPOK\\)
 111   PV = $ADDR "foo"\\\0
 112   CUR = 3
 113   LEN = \\d+'
 114        );
 115
 116 do_test('immediate constant (string)',
 117         "bar",
 118 'SV = PV\\($ADDR\\) at $ADDR
 119   REFCNT = 1
 120   FLAGS = \\(.*POK,READONLY,pPOK\\)
 121   PV = $ADDR "bar"\\\0
 122   CUR = 3
 123   LEN = \\d+');
 124
 125 do_test('assignment of immediate constant (integer)',
 126         $b = 123,
 127 'SV = IV\\($ADDR\\) at $ADDR
 128   REFCNT = 1
 129   FLAGS = \\(IOK,pIOK\\)
 130   IV = 123');
 131
 132 do_test('immediate constant (integer)',
 133         456,
 134 'SV = IV\\($ADDR\\) at $ADDR
 135   REFCNT = 1
 136   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 137   IV = 456');
 138
 139 do_test('assignment of immediate constant (integer)',
 140         $c = 456,
 141 'SV = IV\\($ADDR\\) at $ADDR
 142   REFCNT = 1
 143   FLAGS = \\($PADMY,IOK,pIOK\\)
 144   IV = 456');
 145
 146 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
 147 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
 148 # maths is done in floating point always, and this scalar will be an NV.
 149 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
 150 # building subsequent regexps.
 151 my $type = do_test('result of addition',
 152         $c + $d,
 153 'SV = ([NI])V\\($ADDR\\) at $ADDR
 154   REFCNT = 1
 155   FLAGS = \\(PADTMP,\1OK,p\1OK\\)
 156   \1V = 456');
 157
 158 ($d = "789") += 0.1;
 159
 160 do_test('floating point value',
 161        $d,
 162 'SV = PVNV\\($ADDR\\) at $ADDR
 163   REFCNT = 1
 164   FLAGS = \\(NOK,pNOK\\)
 165   IV = \d+
 166   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
 167   PV = $ADDR "789"\\\0
 168   CUR = 3
 169   LEN = \\d+');
 170
 171 do_test('integer constant',
 172         0xabcd,
 173 'SV = IV\\($ADDR\\) at $ADDR
 174   REFCNT = 1
 175   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 176   IV = 43981');
 177
 178 do_test('undef',
 179         undef,
 180 'SV = NULL\\(0x0\\) at $ADDR
 181   REFCNT = 1
 182   FLAGS = \\(\\)');
 183
 184 do_test('reference to scalar',
 185         \$a,
 186 'SV = $RV\\($ADDR\\) at $ADDR
 187   REFCNT = 1
 188   FLAGS = \\(ROK\\)
 189   RV = $ADDR
 190   SV = PV\\($ADDR\\) at $ADDR
 191     REFCNT = 2
 192     FLAGS = \\(POK,pPOK\\)
 193     PV = $ADDR "foo"\\\0
 194     CUR = 3
 195     LEN = \\d+');
 196
 197 my $c_pattern;
 198 if ($type eq 'N') {
 199   $c_pattern = '
 200     SV = PVNV\\($ADDR\\) at $ADDR
 201       REFCNT = 1
 202       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
 203       IV = 456
 204       NV = 456
 205       PV = 0';
 206 } else {
 207   $c_pattern = '
 208     SV = IV\\($ADDR\\) at $ADDR
 209       REFCNT = 1
 210       FLAGS = \\(IOK,pIOK\\)
 211       IV = 456';
 212 }
 213 do_test('reference to array',
 214        [$b,$c],
 215 'SV = $RV\\($ADDR\\) at $ADDR
 216   REFCNT = 1
 217   FLAGS = \\(ROK\\)
 218   RV = $ADDR
 219   SV = PVAV\\($ADDR\\) at $ADDR
 220     REFCNT = 1
 221     FLAGS = \\(\\)
 222     IV = 0                                      # $] < 5.009
 223     NV = 0                                      # $] < 5.009
 224     ARRAY = $ADDR
 225     FILL = 1
 226     MAX = 1
 227     ARYLEN = 0x0
 228     FLAGS = \\(REAL\\)
 229     Elt No. 0
 230     SV = IV\\($ADDR\\) at $ADDR
 231       REFCNT = 1
 232       FLAGS = \\(IOK,pIOK\\)
 233       IV = 123
 234     Elt No. 1' . $c_pattern);
 235
 236 do_test('reference to hash',
 237        {$b=>$c},
 238 'SV = $RV\\($ADDR\\) at $ADDR
 239   REFCNT = 1
 240   FLAGS = \\(ROK\\)
 241   RV = $ADDR
 242   SV = PVHV\\($ADDR\\) at $ADDR
 243     REFCNT = 1
 244     FLAGS = \\(SHAREKEYS\\)
 245     IV = 1                                      # $] < 5.009
 246     NV = $FLOAT                                 # $] < 5.009
 247     ARRAY = $ADDR  \\(0:7, 1:1\\)
 248     hash quality = 100.0%
 249     KEYS = 1
 250     FILL = 1
 251     MAX = 7
 252     RITER = -1
 253     EITER = 0x0
 254     Elt "123" HASH = $ADDR' . $c_pattern,
 255         '',
 256         $] > 5.009 && $] < 5.015
 257          && 'The hash iterator used in dump.c sets the OOK flag');
 258
 259 do_test('reference to anon sub with empty prototype',
 260         sub(){@_},
 261 'SV = $RV\\($ADDR\\) at $ADDR
 262   REFCNT = 1
 263   FLAGS = \\(ROK\\)
 264   RV = $ADDR
 265   SV = PVCV\\($ADDR\\) at $ADDR
 266     REFCNT = 2
 267     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
 268     IV = 0                                      # $] < 5.009
 269     NV = 0                                      # $] < 5.009
 270     PROTOTYPE = ""
 271     COMP_STASH = $ADDR\\t"main"
 272     START = $ADDR ===> \\d+
 273     ROOT = $ADDR
 274     XSUB = 0x0                                  # $] < 5.009
 275     XSUBANY = 0                                 # $] < 5.009
 276     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
 277     FILE = ".*\\b(?i:peek\\.t)"
 278     DEPTH = 0(?:
 279     MUTEXP = $ADDR
 280     OWNER = $ADDR)?
 281     FLAGS = 0x404                               # $] < 5.009
 282     FLAGS = 0x490                               # $] >= 5.009
 283     OUTSIDE_SEQ = \\d+
 284     PADLIST = $ADDR
 285     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 286     OUTSIDE = $ADDR \\(MAIN\\)');
 287
 288 do_test('reference to named subroutine without prototype',
 289         \&do_test,
 290 'SV = $RV\\($ADDR\\) at $ADDR
 291   REFCNT = 1
 292   FLAGS = \\(ROK\\)
 293   RV = $ADDR
 294   SV = PVCV\\($ADDR\\) at $ADDR
 295     REFCNT = (3|4)
 296     FLAGS = \\(\\)
 297     IV = 0                                      # $] < 5.009
 298     NV = 0                                      # $] < 5.009
 299     COMP_STASH = $ADDR\\t"main"
 300     START = $ADDR ===> \\d+
 301     ROOT = $ADDR
 302     XSUB = 0x0                                  # $] < 5.009
 303     XSUBANY = 0                                 # $] < 5.009
 304     GVGV::GV = $ADDR\\t"main" :: "do_test"
 305     FILE = ".*\\b(?i:peek\\.t)"
 306     DEPTH = 1
 307 (?:    MUTEXP = $ADDR
 308     OWNER = $ADDR
 309 )?    FLAGS = 0x0
 310     OUTSIDE_SEQ = \\d+
 311     PADLIST = $ADDR
 312     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 313        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
 314        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
 315        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
 316       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
 317       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
 318       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
 319       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
 320       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
 321     OUTSIDE = $ADDR \\(MAIN\\)');
 322
 323 if ($] >= 5.011) {
 324 do_test('reference to regexp',
 325         qr(tic),
 326 'SV = $RV\\($ADDR\\) at $ADDR
 327   REFCNT = 1
 328   FLAGS = \\(ROK\\)
 329   RV = $ADDR
 330   SV = REGEXP\\($ADDR\\) at $ADDR
 331     REFCNT = 1
 332     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
 333     PV = $ADDR "\\(\\?\\^:tic\\)"
 334     CUR = 8
 335     LEN = 0
 336     STASH = $ADDR\\t"Regexp"'
 337 . ($] < 5.013 ? '' :
 338 '
 339     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
 340     INTFLAGS = 0x0
 341     NPARENS = 0
 342     LASTPAREN = 0
 343     LASTCLOSEPAREN = 0
 344     MINLEN = 3
 345     MINLENRET = 3
 346     GOFS = 0
 347     PRE_PREFIX = 4
 348     SEEN_EVALS = 0
 349     SUBLEN = 0
 350     SUBBEG = 0x0
 351     ENGINE = $ADDR
 352     MOTHER_RE = $ADDR
 353     PAREN_NAMES = 0x0
 354     SUBSTRS = $ADDR
 355     PPRIVATE = $ADDR
 356     OFFS = $ADDR'
 357 ));
 358 } else {
 359 do_test('reference to regexp',
 360         qr(tic),
 361 'SV = $RV\\($ADDR\\) at $ADDR
 362   REFCNT = 1
 363   FLAGS = \\(ROK\\)
 364   RV = $ADDR
 365   SV = PVMG\\($ADDR\\) at $ADDR
 366     REFCNT = 1
 367     FLAGS = \\(OBJECT,SMG\\)
 368     IV = 0
 369     NV = 0
 370     PV = 0
 371     MAGIC = $ADDR
 372       MG_VIRTUAL = $ADDR
 373       MG_TYPE = PERL_MAGIC_qr\(r\)
 374       MG_OBJ = $ADDR
 375         PAT = "\(\?^:tic\)"                     # $] >= 5.009
 376         REFCNT = 2                              # $] >= 5.009
 377     STASH = $ADDR\\t"Regexp"');
 378 }
 379
 380 do_test('reference to blessed hash',
 381         (bless {}, "Tac"),
 382 'SV = $RV\\($ADDR\\) at $ADDR
 383   REFCNT = 1
 384   FLAGS = \\(ROK\\)
 385   RV = $ADDR
 386   SV = PVHV\\($ADDR\\) at $ADDR
 387     REFCNT = 1
 388     FLAGS = \\(OBJECT,SHAREKEYS\\)
 389     IV = 0                                      # $] < 5.009
 390     NV = 0                                      # $] < 5.009
 391     STASH = $ADDR\\t"Tac"
 392     ARRAY = 0x0
 393     KEYS = 0
 394     FILL = 0
 395     MAX = 7
 396     RITER = -1
 397     EITER = 0x0', '',
 398         $] > 5.009
 399         ? $] >= 5.015
 400              ? 0
 401              : 'The hash iterator used in dump.c sets the OOK flag'
 402         : "Something causes the HV's array to become allocated");
 403
 404 do_test('typeglob',
 405         *a,
 406 'SV = PVGV\\($ADDR\\) at $ADDR
 407   REFCNT = 5
 408   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
 409   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
 410   IV = 0                                        # $] < 5.009
 411   NV = 0                                        # $] < 5.009
 412   PV = 0                                        # $] < 5.009
 413   MAGIC = $ADDR                                 # $] < 5.009
 414     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
 415     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
 416     MG_OBJ = $ADDR                              # $] < 5.009
 417   NAME = "a"
 418   NAMELEN = 1
 419   GvSTASH = $ADDR\\t"main"
 420   GP = $ADDR
 421     SV = $ADDR
 422     REFCNT = 1
 423     IO = 0x0
 424     FORM = 0x0
 425     AV = 0x0
 426     HV = 0x0
 427     CV = 0x0
 428     CVGEN = 0x0
 429     GPFLAGS = 0x0                               # $] < 5.009
 430     LINE = \\d+
 431     FILE = ".*\\b(?i:peek\\.t)"
 432     FLAGS = $ADDR
 433     EGV = $ADDR\\t"a"');
 434
 435 if (ord('A') == 193) {
 436 do_test('string with Unicode',
 437         chr(256).chr(0).chr(512),
 438 'SV = PV\\($ADDR\\) at $ADDR
 439   REFCNT = 1
 440   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 441   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 442   CUR = 5
 443   LEN = \\d+');
 444 } else {
 445 do_test('string with Unicode',
 446         chr(256).chr(0).chr(512),
 447 'SV = PV\\($ADDR\\) at $ADDR
 448   REFCNT = 1
 449   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 450   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 451   CUR = 5
 452   LEN = \\d+');
 453 }
 454
 455 if (ord('A') == 193) {
 456 do_test('reference to hash containing Unicode',
 457         {chr(256)=>chr(512)},
 458 'SV = $RV\\($ADDR\\) at $ADDR
 459   REFCNT = 1
 460   FLAGS = \\(ROK\\)
 461   RV = $ADDR
 462   SV = PVHV\\($ADDR\\) at $ADDR
 463     REFCNT = 1
 464     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 465     UV = 1                                      # $] < 5.009
 466     NV = $FLOAT                                 # $] < 5.009
 467     ARRAY = $ADDR  \\(0:7, 1:1\\)
 468     hash quality = 100.0%
 469     KEYS = 1
 470     FILL = 1
 471     MAX = 7
 472     RITER = -1
 473     EITER = $ADDR
 474     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 475     SV = PV\\($ADDR\\) at $ADDR
 476       REFCNT = 1
 477       FLAGS = \\(POK,pPOK,UTF8\\)
 478       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 479       CUR = 2
 480       LEN = \\d+',
 481         $] > 5.009
 482         ? $] >= 5.015
 483             ?  0
 484             : 'The hash iterator used in dump.c sets the OOK flag'
 485         : 'sv_length has been called on the element, and cached the result in MAGIC');
 486 } else {
 487 do_test('reference to hash containing Unicode',
 488         {chr(256)=>chr(512)},
 489 'SV = $RV\\($ADDR\\) at $ADDR
 490   REFCNT = 1
 491   FLAGS = \\(ROK\\)
 492   RV = $ADDR
 493   SV = PVHV\\($ADDR\\) at $ADDR
 494     REFCNT = 1
 495     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 496     UV = 1                                      # $] < 5.009
 497     NV = 0                                      # $] < 5.009
 498     ARRAY = $ADDR  \\(0:7, 1:1\\)
 499     hash quality = 100.0%
 500     KEYS = 1
 501     FILL = 1
 502     MAX = 7
 503     RITER = -1
 504     EITER = $ADDR
 505     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 506     SV = PV\\($ADDR\\) at $ADDR
 507       REFCNT = 1
 508       FLAGS = \\(POK,pPOK,UTF8\\)
 509       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 510       CUR = 2
 511       LEN = \\d+', '',
 512         $] > 5.009
 513         ? $] >= 5.015
 514             ?  0
 515             : 'The hash iterator used in dump.c sets the OOK flag'
 516         : 'sv_length has been called on the element, and cached the result in MAGIC');
 517 }
 518
 519 my $x="";
 520 $x=~/.??/g;
 521 do_test('scalar with pos magic',
 522         $x,
 523 'SV = PVMG\\($ADDR\\) at $ADDR
 524   REFCNT = 1
 525   FLAGS = \\($PADMY,SMG,POK,pPOK\\)
 526   IV = 0
 527   NV = 0
 528   PV = $ADDR ""\\\0
 529   CUR = 0
 530   LEN = \d+
 531   MAGIC = $ADDR
 532     MG_VIRTUAL = &PL_vtbl_mglob
 533     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 534     MG_FLAGS = 0x01
 535       MINMATCH');
 536
 537 #
 538 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 539 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 540 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
 541 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 542 # ENV hashes is also not always null terminated.
 543 #
 544 do_test('tainted value in %ENV',
 545         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 546 'SV = PVMG\\($ADDR\\) at $ADDR
 547   REFCNT = 1
 548   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
 549   IV = 0
 550   NV = 0
 551   PV = $ADDR "0"\\\0
 552   CUR = 1
 553   LEN = \d+
 554   MAGIC = $ADDR
 555     MG_VIRTUAL = &PL_vtbl_envelem
 556     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 557 (?:    MG_FLAGS = 0x01
 558       TAINTEDDIR
 559 )?    MG_LEN = -?\d+
 560     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
 561     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
 562       REFCNT = \d+
 563       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
 564 (?:      IV = 0
 565 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
 566       CUR = \d+
 567       LEN = \d+)
 568   MAGIC = $ADDR
 569     MG_VIRTUAL = &PL_vtbl_taint
 570     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 571
 572 do_test('blessed reference',
 573         bless(\\undef, 'Foobar'),
 574 'SV = $RV\\($ADDR\\) at $ADDR
 575   REFCNT = 1
 576   FLAGS = \\(ROK\\)
 577   RV = $ADDR
 578   SV = PVMG\\($ADDR\\) at $ADDR
 579     REFCNT = 2
 580     FLAGS = \\(OBJECT,ROK\\)
 581     IV = -?\d+
 582     NV = $FLOAT
 583     RV = $ADDR
 584     SV = NULL\\(0x0\\) at $ADDR
 585       REFCNT = \d+
 586       FLAGS = \\(READONLY\\)
 587     PV = $ADDR ""
 588     CUR = 0
 589     LEN = 0
 590     STASH = $ADDR\s+"Foobar"');
 591
 592 sub const () {
 593     "Perl rules";
 594 }
 595
 596 do_test('constant subroutine',
 597         \&const,
 598 'SV = $RV\\($ADDR\\) at $ADDR
 599   REFCNT = 1
 600   FLAGS = \\(ROK\\)
 601   RV = $ADDR
 602   SV = PVCV\\($ADDR\\) at $ADDR
 603     REFCNT = (2)
 604     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
 605     IV = 0                                      # $] < 5.009
 606     NV = 0                                      # $] < 5.009
 607     PROTOTYPE = ""
 608     COMP_STASH = 0x0
 609     ROOT = 0x0                                  # $] < 5.009
 610     XSUB = $ADDR
 611     XSUBANY = $ADDR \\(CONST SV\\)
 612     SV = PV\\($ADDR\\) at $ADDR
 613       REFCNT = 1
 614       FLAGS = \\(.*POK,READONLY,pPOK\\)
 615       PV = $ADDR "Perl rules"\\\0
 616       CUR = 10
 617       LEN = \\d+
 618     GVGV::GV = $ADDR\\t"main" :: "const"
 619     FILE = ".*\\b(?i:peek\\.t)"
 620     DEPTH = 0(?:
 621     MUTEXP = $ADDR
 622     OWNER = $ADDR)?
 623     FLAGS = 0x200                               # $] < 5.009
 624     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
 625     FLAGS = 0xc                                 # $] >= 5.013
 626     OUTSIDE_SEQ = 0
 627     PADLIST = 0x0
 628     OUTSIDE = 0x0 \\(null\\)');
 629
 630 do_test('isUV should show on PVMG',
 631         do { my $v = $1; $v = ~0; $v },
 632 'SV = PVMG\\($ADDR\\) at $ADDR
 633   REFCNT = 1
 634   FLAGS = \\(IOK,pIOK,IsUV\\)
 635   UV = \d+
 636   NV = 0
 637   PV = 0');
 638
 639 do_test('IO',
 640         *STDOUT{IO},
 641 'SV = $RV\\($ADDR\\) at $ADDR
 642   REFCNT = 1
 643   FLAGS = \\(ROK\\)
 644   RV = $ADDR
 645   SV = PVIO\\($ADDR\\) at $ADDR
 646     REFCNT = 3
 647     FLAGS = \\(OBJECT\\)
 648     IV = 0                                      # $] < 5.011
 649     NV = 0                                      # $] < 5.011
 650     STASH = $ADDR\s+"IO::File"
 651     IFP = $ADDR
 652     OFP = $ADDR
 653     DIRP = 0x0
 654     LINES = 0
 655     PAGE = 0
 656     PAGE_LEN = 60
 657     LINES_LEFT = 0
 658     TOP_GV = 0x0
 659     FMT_GV = 0x0
 660     BOTTOM_GV = 0x0
 661     SUBPROCESS = 0                              # $] < 5.009
 662     TYPE = \'>\'
 663     FLAGS = 0x4');
 664
 665 do_test('FORMAT',
 666         *PIE{FORMAT},
 667 'SV = $RV\\($ADDR\\) at $ADDR
 668   REFCNT = 1
 669   FLAGS = \\(ROK\\)
 670   RV = $ADDR
 671   SV = PVFM\\($ADDR\\) at $ADDR
 672     REFCNT = 2
 673     FLAGS = \\(\\)
 674     IV = 0                                      # $] < 5.009
 675     NV = 0                                      # $] < 5.009
 676 (?:    PV = 0
 677 )?    COMP_STASH = 0x0
 678     START = $ADDR ===> \\d+
 679     ROOT = $ADDR
 680     XSUB = 0x0                                  # $] < 5.009
 681     XSUBANY = 0                                 # $] < 5.009
 682     GVGV::GV = $ADDR\\t"main" :: "PIE"
 683     FILE = ".*\\b(?i:peek\\.t)"
 684 (?:    DEPTH = 0
 685     MUTEXP = $ADDR
 686     OWNER = $ADDR
 687 )?    FLAGS = 0x0
 688     OUTSIDE_SEQ = \\d+
 689     LINES = 0
 690     PADLIST = $ADDR
 691     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 692     OUTSIDE = $ADDR \\(MAIN\\)');
 693
 694 do_test('blessing to a class with embedded NUL characters',
 695         (bless {}, "\0::foo::\n::baz::\t::\0"),
 696 'SV = $RV\\($ADDR\\) at $ADDR
 697   REFCNT = 1
 698   FLAGS = \\(ROK\\)
 699   RV = $ADDR
 700   SV = PVHV\\($ADDR\\) at $ADDR
 701     REFCNT = 1
 702     FLAGS = \\(OBJECT,SHAREKEYS\\)
 703     IV = 0                                      # $] < 5.009
 704     NV = 0                                      # $] < 5.009
 705     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
 706     ARRAY = $ADDR
 707     KEYS = 0
 708     FILL = 0
 709     MAX = 7
 710     RITER = -1
 711     EITER = 0x0', '',
 712         $] > 5.009
 713         ? $] >= 5.015
 714             ?  0
 715             : 'The hash iterator used in dump.c sets the OOK flag'
 716         : "Something causes the HV's array to become allocated");
 717
 718 do_test('ENAME on a stash',
 719         \%RWOM::,
 720 'SV = $RV\\($ADDR\\) at $ADDR
 721   REFCNT = 1
 722   FLAGS = \\(ROK\\)
 723   RV = $ADDR
 724   SV = PVHV\\($ADDR\\) at $ADDR
 725     REFCNT = 2
 726     FLAGS = \\(OOK,SHAREKEYS\\)
 727     IV = 1                                      # $] < 5.009
 728     NV = $FLOAT                                 # $] < 5.009
 729     ARRAY = $ADDR
 730     KEYS = 0
 731     FILL = 0
 732     MAX = 7
 733     RITER = -1
 734     EITER = 0x0
 735     NAME = "RWOM"
 736     ENAME = "RWOM"                              # $] > 5.012
 737 ');
 738
 739 *KLANK:: = \%RWOM::;
 740
 741 do_test('ENAMEs on a stash',
 742         \%RWOM::,
 743 'SV = $RV\\($ADDR\\) at $ADDR
 744   REFCNT = 1
 745   FLAGS = \\(ROK\\)
 746   RV = $ADDR
 747   SV = PVHV\\($ADDR\\) at $ADDR
 748     REFCNT = 3
 749     FLAGS = \\(OOK,SHAREKEYS\\)
 750     IV = 1                                      # $] < 5.009
 751     NV = $FLOAT                                 # $] < 5.009
 752     ARRAY = $ADDR
 753     KEYS = 0
 754     FILL = 0
 755     MAX = 7
 756     RITER = -1
 757     EITER = 0x0
 758     NAME = "RWOM"
 759     NAMECOUNT = 2                               # $] > 5.012
 760     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 761 ');
 762
 763 undef %RWOM::;
 764
 765 do_test('ENAMEs on a stash with no NAME',
 766         \%RWOM::,
 767 'SV = $RV\\($ADDR\\) at $ADDR
 768   REFCNT = 1
 769   FLAGS = \\(ROK\\)
 770   RV = $ADDR
 771   SV = PVHV\\($ADDR\\) at $ADDR
 772     REFCNT = 3
 773     FLAGS = \\(OOK,SHAREKEYS\\)
 774     IV = 1                                      # $] < 5.009
 775     NV = $FLOAT                                 # $] < 5.009
 776     ARRAY = $ADDR
 777     KEYS = 0
 778     FILL = 0
 779     MAX = 7
 780     RITER = -1
 781     EITER = 0x0
 782     NAMECOUNT = -3                              # $] > 5.012
 783     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 784 ');
 785
 786 SKIP: {
 787     skip "Not built with usemymalloc", 1
 788       unless $Config{usemymalloc} eq 'y';
 789     my $x = __PACKAGE__;
 790     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
 791      or diag $@;
 792 }
 793
 794 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
 795 # prowess, but short of duplicating all the gubbins of this file, I can't see
 796 # a way to make a better place for it:
 797
 798 use constant {
 799     perl => 'rules',
 800     beer => 'foamy',
 801 };
 802
 803 unless ($Config{useithreads}) {
 804     # These end up as copies in pads under ithreads, which rather defeats the
 805     # the point of what we're trying to test here.
 806
 807     do_test('regular string constant', perl,
 808 'SV = PV\\($ADDR\\) at $ADDR
 809   REFCNT = 5
 810   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 811   PV = $ADDR "rules"\\\0
 812   CUR = 5
 813   LEN = \d+
 814 ');
 815
 816     eval 'index "", perl';
 817
 818     # FIXME - really this shouldn't say EVALED. It's a false posistive on
 819     # 0x40000000 being used for several things, not a flag for "I'm in a string
 820     # eval"
 821
 822     do_test('string constant now an FBM', perl,
 823 'SV = PVMG\\($ADDR\\) at $ADDR
 824   REFCNT = 5
 825   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
 826   PV = $ADDR "rules"\\\0
 827   CUR = 5
 828   LEN = \d+
 829   MAGIC = $ADDR
 830     MG_VIRTUAL = &PL_vtbl_regexp
 831     MG_TYPE = PERL_MAGIC_bm\\(B\\)
 832     MG_LEN = 256
 833     MG_PTR = $ADDR "(?:\\\\\d){256}"
 834   RARE = \d+
 835   PREVIOUS = 1
 836   USEFUL = 100
 837 ');
 838
 839     is(study perl, '', "Not allowed to study an FBM");
 840
 841     do_test('string constant still an FBM', perl,
 842 'SV = PVMG\\($ADDR\\) at $ADDR
 843   REFCNT = 5
 844   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
 845   PV = $ADDR "rules"\\\0
 846   CUR = 5
 847   LEN = \d+
 848   MAGIC = $ADDR
 849     MG_VIRTUAL = &PL_vtbl_regexp
 850     MG_TYPE = PERL_MAGIC_bm\\(B\\)
 851     MG_LEN = 256
 852     MG_PTR = $ADDR "(?:\\\\\d){256}"
 853   RARE = \d+
 854   PREVIOUS = 1
 855   USEFUL = 100
 856 ');
 857
 858     do_test('regular string constant', beer,
 859 'SV = PV\\($ADDR\\) at $ADDR
 860   REFCNT = 6
 861   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 862   PV = $ADDR "foamy"\\\0
 863   CUR = 5
 864   LEN = \d+
 865 ');
 866
 867     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
 868   REFCNT = 6
 869   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
 870   IV = 0
 871   NV = 0
 872   PV = $ADDR "foamy"\\\0
 873   CUR = 5
 874   LEN = \d+
 875   MAGIC = $ADDR
 876     MG_VIRTUAL = &PL_vtbl_regexp
 877     MG_TYPE = PERL_MAGIC_study\\(G\\)
 878     MG_LEN = 1044
 879     MG_PTR = $ADDR "\\\\377\\\\377\\\\377\\\\377.*"
 880 ';
 881
 882     is(study beer, 1, "Our studies were successful");
 883
 884     do_test('string constant now studied', beer, $want);
 885
 886     is (eval 'index "not too foamy", beer', 8, 'correct index');
 887
 888     do_test('string constant still studied', beer, $want);
 889
 890     my $pie = 'good';
 891
 892     is(study $pie, 1, "Our studies were successful");
 893
 894     do_test('string constant still studied', beer, $want);
 895
 896     do_test('second string also studied', $pie, 'SV = PVMG\\($ADDR\\) at $ADDR
 897   REFCNT = 1
 898   FLAGS = \\(PADMY,SMG,POK,pPOK,SCREAM\\)
 899   IV = 0
 900   NV = 0
 901   PV = $ADDR "good"\\\0
 902   CUR = 4
 903   LEN = \d+
 904   MAGIC = $ADDR
 905     MG_VIRTUAL = &PL_vtbl_regexp
 906     MG_TYPE = PERL_MAGIC_study\\(G\\)
 907     MG_LEN = 1040
 908     MG_PTR = $ADDR "\\\\377\\\\377\\\\377\\\\377.*"
 909 ');
 910 }
 911
 912 done_testing();