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