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