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     package t;
  11        my $core = !!$ENV{PERL_CORE};
  12        require($core ? '../../t/test.pl' : './t/test.pl');
  13     }
  14 }
  15
  16 use Test::More;
  17
  18 use Devel::Peek;
  19
  20 our $DEBUG = 0;
  21 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
  22
  23 # If I reference any lexicals in this, I get the entire outer subroutine (or
  24 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
  25 # maintain that.
  26 format PIE =
  27 Pie     @<<<<<
  28 $::type
  29 Good    @>>>>>
  30 $::mmmm
  31 .
  32
  33 use constant thr => $Config{useithreads};
  34
  35 sub do_test {
  36     my $todo = $_[3];
  37     my $repeat_todo = $_[4];
  38     my $pattern = $_[2];
  39     my $do_eval = $_[5];
  40     if (open(OUT,'>', "peek$$")) {
  41         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
  42         if ($do_eval) {
  43             my $sub = eval "sub { Dump $_[1] }";
  44             $sub->();
  45             print STDERR "*****\n";
  46             # second dump to compare with the first to make sure nothing
  47             # changed.
  48             $sub->();
  49         }
  50         else {
  51             Dump($_[1]);
  52             print STDERR "*****\n";
  53             # second dump to compare with the first to make sure nothing
  54             # changed.
  55             Dump($_[1]);
  56         }
  57         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
  58         close(OUT);
  59         if (open(IN, '<', "peek$$")) {
  60             local $/;
  61             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
  62             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
  63             # handle DEBUG_LEAKING_SCALARS prefix
  64             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
  65
  66             # Need some clear generic mechanism to eliminate (or add) lines
  67             # of dump output dependant on perl version. The (previous) use of
  68             # things like $IVNV gave the illusion that the string passed in was
  69             # a regexp into which variables were interpolated, but this wasn't
  70             # actually true as those 'variables' actually also ate the
  71             # whitespace on the line. So it seems better to mark lines that
  72             # need to be eliminated. I considered (?# ... ) and (?{ ... }),
  73             # but whilst embedded code or comment syntax would keep it as a
  74             # legitimate regexp, it still isn't true. Seems easier and clearer
  75             # things that look like comments.
  76
  77             # Could do this is in a s///mge but seems clearer like this:
  78             $pattern = join '', map {
  79                 # If we identify the version condition, take *it* out whatever
  80                 s/\s*# (\$\].*)$//
  81                     ? (eval $1 ? $_ : '')
  82                     : $_ # Didn't match, so this line is in
  83             } split /^/, $pattern;
  84
  85             $pattern =~ s/\$PADMY,/
  86                 $] < 5.012005 ? 'PADMY,' : '';
  87             /mge;
  88             $pattern =~ s/\$RV/
  89                 ($] < 5.011) ? 'RV' : 'IV';
  90             /mge;
  91             $pattern =~ s/^\h+COW_REFCNT = .*\n//mg
  92                 if $Config{ccflags} =~
  93                         /-DPERL_(?:OLD_COPY_ON_WRITE|NO_COW)\b/
  94                             || $] < 5.019003;
  95             print $pattern, "\n" if $DEBUG;
  96             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
  97             print $dump, "\n"    if $DEBUG;
  98             like( $dump, qr/\A$pattern\Z/ms, $_[0])
  99               or note("line " . (caller)[2]);
 100
 101             local $TODO = $repeat_todo;
 102             is($dump2, $dump, "$_[0] (unchanged by dump)")
 103               or note("line " . (caller)[2]);
 104
 105             close(IN);
 106
 107             return $1;
 108         } else {
 109             die "$0: failed to open peek$$: !\n";
 110         }
 111     } else {
 112         die "$0: failed to create peek$$: $!\n";
 113     }
 114 }
 115
 116 our   $a;
 117 our   $b;
 118 my    $c;
 119 local $d = 0;
 120
 121 END {
 122     1 while unlink("peek$$");
 123 }
 124
 125 do_test('assignment of immediate constant (string)',
 126         $a = "foo",
 127 'SV = PV\\($ADDR\\) at $ADDR
 128   REFCNT = 1
 129   FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
 130   PV = $ADDR "foo"\\\0
 131   CUR = 3
 132   LEN = \\d+
 133   COW_REFCNT = 1
 134 ');
 135
 136 do_test('immediate constant (string)',
 137         "bar",
 138 'SV = PV\\($ADDR\\) at $ADDR
 139   REFCNT = 1
 140   FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)          # $] < 5.021005
 141   FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\)  # $] >=5.021005
 142   PV = $ADDR "bar"\\\0
 143   CUR = 3
 144   LEN = \\d+
 145   COW_REFCNT = 0
 146 ');
 147
 148 do_test('assignment of immediate constant (integer)',
 149         $b = 123,
 150 'SV = IV\\($ADDR\\) at $ADDR
 151   REFCNT = 1
 152   FLAGS = \\(IOK,pIOK\\)
 153   IV = 123');
 154
 155 do_test('immediate constant (integer)',
 156         456,
 157 'SV = IV\\($ADDR\\) at $ADDR
 158   REFCNT = 1
 159   FLAGS = \\(.*IOK,READONLY,pIOK\\)             # $] < 5.021005
 160   FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\)     # $] >=5.021005
 161   IV = 456');
 162
 163 do_test('assignment of immediate constant (integer)',
 164         $c = 456,
 165 'SV = IV\\($ADDR\\) at $ADDR
 166   REFCNT = 1
 167   FLAGS = \\($PADMY,IOK,pIOK\\)
 168   IV = 456');
 169
 170 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
 171 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
 172 # maths is done in floating point always, and this scalar will be an NV.
 173 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
 174 # building subsequent regexps.
 175 my $type = do_test('result of addition',
 176         $c + $d,
 177 'SV = ([NI])V\\($ADDR\\) at $ADDR
 178   REFCNT = 1
 179   FLAGS = \\(PADTMP,\1OK,p\1OK\\)               # $] < 5.019003
 180   FLAGS = \\(\1OK,p\1OK\\)                      # $] >=5.019003
 181   \1V = 456');
 182
 183 ($d = "789") += 0.1;
 184
 185 do_test('floating point value',
 186        $d,
 187        $] < 5.019003
 188         || $Config{ccflags} =~ /-DPERL_(?:NO_COW|OLD_COPY_ON_WRITE)\b/
 189        ?
 190 'SV = PVNV\\($ADDR\\) at $ADDR
 191   REFCNT = 1
 192   FLAGS = \\(NOK,pNOK\\)
 193   IV = \d+
 194   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
 195   PV = $ADDR "789"\\\0
 196   CUR = 3
 197   LEN = \\d+'
 198        :
 199 'SV = PVNV\\($ADDR\\) at $ADDR
 200   REFCNT = 1
 201   FLAGS = \\(NOK,pNOK\\)
 202   IV = \d+
 203   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
 204   PV = 0');
 205
 206 do_test('integer constant',
 207         0xabcd,
 208 'SV = IV\\($ADDR\\) at $ADDR
 209   REFCNT = 1
 210   FLAGS = \\(.*IOK,READONLY,pIOK\\)             # $] < 5.021005
 211   FLAGS = \\(.*IOK,READONLY,PROTECT,pIOK\\)     # $] >=5.021005
 212   IV = 43981');
 213
 214 do_test('undef',
 215         undef,
 216 'SV = NULL\\(0x0\\) at $ADDR
 217   REFCNT = \d+
 218   FLAGS = \\(READONLY\\)                        # $] < 5.021005
 219   FLAGS = \\(READONLY,PROTECT\\)                # $] >=5.021005
 220 ');
 221
 222 do_test('reference to scalar',
 223         \$a,
 224 'SV = $RV\\($ADDR\\) at $ADDR
 225   REFCNT = 1
 226   FLAGS = \\(ROK\\)
 227   RV = $ADDR
 228   SV = PV\\($ADDR\\) at $ADDR
 229     REFCNT = 2
 230     FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
 231     PV = $ADDR "foo"\\\0
 232     CUR = 3
 233     LEN = \\d+
 234     COW_REFCNT = 1
 235 ');
 236
 237 my $c_pattern;
 238 if ($type eq 'N') {
 239   $c_pattern = '
 240     SV = PVNV\\($ADDR\\) at $ADDR
 241       REFCNT = 1
 242       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
 243       IV = 456
 244       NV = 456
 245       PV = 0';
 246 } else {
 247   $c_pattern = '
 248     SV = IV\\($ADDR\\) at $ADDR
 249       REFCNT = 1
 250       FLAGS = \\(IOK,pIOK\\)
 251       IV = 456';
 252 }
 253 do_test('reference to array',
 254        [$b,$c],
 255 'SV = $RV\\($ADDR\\) at $ADDR
 256   REFCNT = 1
 257   FLAGS = \\(ROK\\)
 258   RV = $ADDR
 259   SV = PVAV\\($ADDR\\) at $ADDR
 260     REFCNT = 1
 261     FLAGS = \\(\\)
 262     ARRAY = $ADDR
 263     FILL = 1
 264     MAX = 1
 265     FLAGS = \\(REAL\\)
 266     Elt No. 0
 267     SV = IV\\($ADDR\\) at $ADDR
 268       REFCNT = 1
 269       FLAGS = \\(IOK,pIOK\\)
 270       IV = 123
 271     Elt No. 1' . $c_pattern);
 272
 273 do_test('reference to hash',
 274        {$b=>$c},
 275 'SV = $RV\\($ADDR\\) at $ADDR
 276   REFCNT = 1
 277   FLAGS = \\(ROK\\)
 278   RV = $ADDR
 279   SV = PVHV\\($ADDR\\) at $ADDR
 280     REFCNT = [12]
 281     FLAGS = \\(SHAREKEYS\\)
 282     ARRAY = $ADDR  \\(0:7, 1:1\\)
 283     hash quality = 100.0%
 284     KEYS = 1
 285     FILL = 1
 286     MAX = 7
 287     Elt "123" HASH = $ADDR' . $c_pattern,
 288         '',
 289         ($] < 5.015) ? 'The hash iterator used in dump.c sets the OOK flag' : undef);
 290
 291 do_test('reference to anon sub with empty prototype',
 292         sub(){@_},
 293 'SV = $RV\\($ADDR\\) at $ADDR
 294   REFCNT = 1
 295   FLAGS = \\(ROK\\)
 296   RV = $ADDR
 297   SV = PVCV\\($ADDR\\) at $ADDR
 298     REFCNT = 2
 299     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
 300     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
 301     PROTOTYPE = ""
 302     COMP_STASH = $ADDR\\t"main"
 303     START = $ADDR ===> \\d+
 304     ROOT = $ADDR
 305     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
 306     FILE = ".*\\b(?i:peek\\.t)"
 307     DEPTH = 0(?:
 308     MUTEXP = $ADDR
 309     OWNER = $ADDR)?
 310     FLAGS = 0x490                               # $] < 5.015 || !thr
 311     FLAGS = 0x1490                              # $] >= 5.015 && thr
 312     OUTSIDE_SEQ = \\d+
 313     PADLIST = $ADDR
 314     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 315     OUTSIDE = $ADDR \\(MAIN\\)');
 316
 317 do_test('reference to named subroutine without prototype',
 318         \&do_test,
 319 'SV = $RV\\($ADDR\\) at $ADDR
 320   REFCNT = 1
 321   FLAGS = \\(ROK\\)
 322   RV = $ADDR
 323   SV = PVCV\\($ADDR\\) at $ADDR
 324     REFCNT = (3|4)
 325     FLAGS = \\((?:HASEVAL(?:,NAMED)?)?\\)       # $] < 5.015 || !thr
 326     FLAGS = \\(DYNFILE(?:,HASEVAL(?:,NAMED)?)?\\) # $] >= 5.015 && thr
 327     COMP_STASH = $ADDR\\t"main"
 328     START = $ADDR ===> \\d+
 329     ROOT = $ADDR
 330     NAME = "do_test"                            # $] >=5.021004
 331     GVGV::GV = $ADDR\\t"main" :: "do_test"      # $] < 5.021004
 332     FILE = ".*\\b(?i:peek\\.t)"
 333     DEPTH = 1(?:
 334     MUTEXP = $ADDR
 335     OWNER = $ADDR)?
 336     FLAGS = 0x(?:[c4]00)?0                      # $] < 5.015 || !thr
 337     FLAGS = 0x[cd145]000                        # $] >= 5.015 && thr
 338     OUTSIDE_SEQ = \\d+
 339     PADLIST = $ADDR
 340     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 341        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
 342        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
 343        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
 344        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
 345       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
 346       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
 347       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
 348       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
 349     OUTSIDE = $ADDR \\(MAIN\\)');
 350
 351 if ($] >= 5.011) {
 352 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
 353 do_test('reference to regexp',
 354         qr(tic),
 355 'SV = $RV\\($ADDR\\) at $ADDR
 356   REFCNT = 1
 357   FLAGS = \\(ROK\\)
 358   RV = $ADDR
 359   SV = REGEXP\\($ADDR\\) at $ADDR
 360     REFCNT = 1
 361     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
 362     PV = $ADDR "\\(\\?\\^:tic\\)"
 363     CUR = 8
 364     LEN = 0
 365     STASH = $ADDR\\t"Regexp"'
 366 . ($] < 5.013 ? '' :
 367 '
 368     COMPFLAGS = 0x0 \(\)
 369     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
 370 (?:    ENGINE = $ADDR \(STANDARD\)
 371 )?    INTFLAGS = 0x0(?: \(\))?
 372     NPARENS = 0
 373     LASTPAREN = 0
 374     LASTCLOSEPAREN = 0
 375     MINLEN = 3
 376     MINLENRET = 3
 377     GOFS = 0
 378     PRE_PREFIX = 4
 379     SUBLEN = 0
 380     SUBOFFSET = 0
 381     SUBCOFFSET = 0
 382     SUBBEG = 0x0
 383 (?:    ENGINE = $ADDR
 384 )?    MOTHER_RE = $ADDR'
 385 . ($] < 5.019003 ? '' : '
 386     SV = REGEXP\($ADDR\) at $ADDR
 387       REFCNT = 2
 388       FLAGS = \(POK,pPOK\)
 389       PV = $ADDR "\(\?\^:tic\)"
 390       CUR = 8
 391       LEN = \d+
 392       COMPFLAGS = 0x0 \(\)
 393       EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
 394 (?:      ENGINE = $ADDR \(STANDARD\)
 395 )?      INTFLAGS = 0x0(?: \(\))?
 396       NPARENS = 0
 397       LASTPAREN = 0
 398       LASTCLOSEPAREN = 0
 399       MINLEN = 3
 400       MINLENRET = 3
 401       GOFS = 0
 402       PRE_PREFIX = 4
 403       SUBLEN = 0
 404       SUBOFFSET = 0
 405       SUBCOFFSET = 0
 406       SUBBEG = 0x0
 407 (?:    ENGINE = $ADDR
 408 )?      MOTHER_RE = 0x0
 409       PAREN_NAMES = 0x0
 410       SUBSTRS = $ADDR
 411       PPRIVATE = $ADDR
 412       OFFS = $ADDR
 413       QR_ANONCV = 0x0(?:
 414       SAVED_COPY = 0x0)?') . '
 415     PAREN_NAMES = 0x0
 416     SUBSTRS = $ADDR
 417     PPRIVATE = $ADDR
 418     OFFS = $ADDR
 419     QR_ANONCV = 0x0(?:
 420     SAVED_COPY = 0x0)?'
 421 ));
 422 } else {
 423 do_test('reference to regexp',
 424         qr(tic),
 425 'SV = $RV\\($ADDR\\) at $ADDR
 426   REFCNT = 1
 427   FLAGS = \\(ROK\\)
 428   RV = $ADDR
 429   SV = PVMG\\($ADDR\\) at $ADDR
 430     REFCNT = 1
 431     FLAGS = \\(OBJECT,SMG\\)
 432     IV = 0
 433     NV = 0
 434     PV = 0
 435     MAGIC = $ADDR
 436       MG_VIRTUAL = $ADDR
 437       MG_TYPE = PERL_MAGIC_qr\(r\)
 438       MG_OBJ = $ADDR
 439         PAT = "\(\?^:tic\)"
 440         REFCNT = 2
 441     STASH = $ADDR\\t"Regexp"');
 442 }
 443
 444 do_test('reference to blessed hash',
 445         (bless {}, "Tac"),
 446 'SV = $RV\\($ADDR\\) at $ADDR
 447   REFCNT = 1
 448   FLAGS = \\(ROK\\)
 449   RV = $ADDR
 450   SV = PVHV\\($ADDR\\) at $ADDR
 451     REFCNT = [12]
 452     FLAGS = \\(OBJECT,SHAREKEYS\\)
 453     STASH = $ADDR\\t"Tac"
 454     ARRAY = 0x0
 455     KEYS = 0
 456     FILL = 0
 457     MAX = 7', '',
 458         $] >= 5.015
 459              ? undef
 460              : 'The hash iterator used in dump.c sets the OOK flag');
 461
 462 do_test('typeglob',
 463         *a,
 464 'SV = PVGV\\($ADDR\\) at $ADDR
 465   REFCNT = 5
 466   FLAGS = \\(MULTI(?:,IN_PAD)?\\)
 467   NAME = "a"
 468   NAMELEN = 1
 469   GvSTASH = $ADDR\\t"main"
 470   FLAGS = $ADDR                                 # $] >=5.021004
 471   GP = $ADDR
 472     SV = $ADDR
 473     REFCNT = 1
 474     IO = 0x0
 475     FORM = 0x0
 476     AV = 0x0
 477     HV = 0x0
 478     CV = 0x0
 479     CVGEN = 0x0
 480     GPFLAGS = 0x0 \(\)                          # $] >= 5.021004
 481     LINE = \\d+
 482     FILE = ".*\\b(?i:peek\\.t)"
 483     FLAGS = $ADDR                               # $] < 5.021004
 484     EGV = $ADDR\\t"a"');
 485
 486 if (ord('A') == 193) {
 487 do_test('string with Unicode',
 488         chr(256).chr(0).chr(512),
 489 'SV = PV\\($ADDR\\) at $ADDR
 490   REFCNT = 1
 491   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)      # $] < 5.019003
 492   FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)    # $] >=5.019003
 493   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 494   CUR = 5
 495   LEN = \\d+
 496   COW_REFCNT = 1                                        # $] < 5.019007
 497 ');
 498 } else {
 499 do_test('string with Unicode',
 500         chr(256).chr(0).chr(512),
 501 'SV = PV\\($ADDR\\) at $ADDR
 502   REFCNT = 1
 503   FLAGS = \\((?:PADTMP,)?POK,READONLY,pPOK,UTF8\\)      # $] < 5.019003
 504   FLAGS = \\((?:PADTMP,)?POK,(?:IsCOW,)?pPOK,UTF8\\)    # $] >=5.019003
 505   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 506   CUR = 5
 507   LEN = \\d+
 508   COW_REFCNT = 1                                        # $] < 5.019007
 509 ');
 510 }
 511
 512 if (ord('A') == 193) {
 513 do_test('reference to hash containing Unicode',
 514         {chr(256)=>chr(512)},
 515 'SV = $RV\\($ADDR\\) at $ADDR
 516   REFCNT = 1
 517   FLAGS = \\(ROK\\)
 518   RV = $ADDR
 519   SV = PVHV\\($ADDR\\) at $ADDR
 520     REFCNT = [12]
 521     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 522     ARRAY = $ADDR  \\(0:7, 1:1\\)
 523     hash quality = 100.0%
 524     KEYS = 1
 525     FILL = 1
 526     MAX = 7
 527     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 528     SV = PV\\($ADDR\\) at $ADDR
 529       REFCNT = 1
 530       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
 531       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 532       CUR = 2
 533       LEN = \\d+
 534       COW_REFCNT = 1                            # $] < 5.019007
 535 ',      '',
 536         $] >= 5.015
 537             ? undef
 538             : 'The hash iterator used in dump.c sets the OOK flag');
 539 } else {
 540 do_test('reference to hash containing Unicode',
 541         {chr(256)=>chr(512)},
 542 'SV = $RV\\($ADDR\\) at $ADDR
 543   REFCNT = 1
 544   FLAGS = \\(ROK\\)
 545   RV = $ADDR
 546   SV = PVHV\\($ADDR\\) at $ADDR
 547     REFCNT = [12]
 548     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 549     ARRAY = $ADDR  \\(0:7, 1:1\\)
 550     hash quality = 100.0%
 551     KEYS = 1
 552     FILL = 1
 553     MAX = 7
 554     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 555     SV = PV\\($ADDR\\) at $ADDR
 556       REFCNT = 1
 557       FLAGS = \\(POK,(?:IsCOW,)?pPOK,UTF8\\)
 558       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 559       CUR = 2
 560       LEN = \\d+
 561       COW_REFCNT = 1                            # $] < 5.019007
 562 ',      '',
 563         $] >= 5.015
 564             ? undef
 565             : 'The hash iterator used in dump.c sets the OOK flag');
 566 }
 567
 568 my $x="";
 569 $x=~/.??/g;
 570 do_test('scalar with pos magic',
 571         $x,
 572 'SV = PVMG\\($ADDR\\) at $ADDR
 573   REFCNT = 1
 574   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
 575   IV = \d+
 576   NV = 0
 577   PV = $ADDR ""\\\0
 578   CUR = 0
 579   LEN = \d+
 580   COW_REFCNT = [12]
 581   MAGIC = $ADDR
 582     MG_VIRTUAL = &PL_vtbl_mglob
 583     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 584     MG_FLAGS = 0x01                                     # $] < 5.019003
 585     MG_FLAGS = 0x41                                     # $] >=5.019003
 586       MINMATCH
 587       BYTES                                             # $] >=5.019003
 588 ');
 589
 590 #
 591 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 592 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 593 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
 594 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
 595 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
 596 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 597 # ENV hashes is also not always null terminated.
 598 #
 599 if (${^TAINT}) {
 600   # Save and restore PATH, since fresh_perl ends up using that in Windows.
 601   my $path = $ENV{PATH};
 602   do_test('tainted value in %ENV',
 603           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 604 'SV = PVMG\\($ADDR\\) at $ADDR
 605   REFCNT = 1
 606   FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
 607   IV = 0
 608   NV = 0
 609   PV = $ADDR "0"\\\0
 610   CUR = 1
 611   LEN = \d+
 612   MAGIC = $ADDR
 613     MG_VIRTUAL = &PL_vtbl_envelem
 614     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 615 (?:    MG_FLAGS = 0x01
 616       TAINTEDDIR
 617 )?    MG_LEN = -?\d+
 618     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
 619     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
 620       REFCNT = \d+
 621       FLAGS = \\((?:TEMP,)?POK,(?:FAKE,READONLY,)?pPOK\\)
 622 (?:      IV = 0
 623 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
 624       CUR = \d+
 625       LEN = \d+)
 626   MAGIC = $ADDR
 627     MG_VIRTUAL = &PL_vtbl_taint
 628     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 629     $ENV{PATH} = $path;
 630 }
 631
 632 do_test('blessed reference',
 633         bless(\\undef, 'Foobar'),
 634 'SV = $RV\\($ADDR\\) at $ADDR
 635   REFCNT = 1
 636   FLAGS = \\(ROK\\)
 637   RV = $ADDR
 638   SV = PVMG\\($ADDR\\) at $ADDR
 639     REFCNT = 2
 640     FLAGS = \\(OBJECT,ROK\\)
 641     IV = -?\d+
 642     NV = $FLOAT
 643     RV = $ADDR
 644     SV = NULL\\(0x0\\) at $ADDR
 645       REFCNT = \d+
 646       FLAGS = \\(READONLY\\)                    # $] < 5.021005
 647       FLAGS = \\(READONLY,PROTECT\\)            # $] >=5.021005
 648     PV = $ADDR ""
 649     CUR = 0
 650     LEN = 0
 651     STASH = $ADDR\s+"Foobar"');
 652
 653 sub const () {
 654     "Perl rules";
 655 }
 656
 657 do_test('constant subroutine',
 658         \&const,
 659 'SV = $RV\\($ADDR\\) at $ADDR
 660   REFCNT = 1
 661   FLAGS = \\(ROK\\)
 662   RV = $ADDR
 663   SV = PVCV\\($ADDR\\) at $ADDR
 664     REFCNT = (2)
 665     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)         # $] < 5.015
 666     FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
 667     PROTOTYPE = ""
 668     COMP_STASH = 0x0                            # $] < 5.021004
 669     COMP_STASH = $ADDR  "main"                  # $] >=5.021004
 670     XSUB = $ADDR
 671     XSUBANY = $ADDR \\(CONST SV\\)
 672     SV = PV\\($ADDR\\) at $ADDR
 673       REFCNT = 1
 674       FLAGS = \\(.*POK,READONLY,(?:IsCOW,)?pPOK\\)         # $] < 5.021005
 675       FLAGS = \\(.*POK,(?:IsCOW,)?READONLY,PROTECT,pPOK\\) # $] >=5.021005
 676       PV = $ADDR "Perl rules"\\\0
 677       CUR = 10
 678       LEN = \\d+
 679       COW_REFCNT = 0
 680     GVGV::GV = $ADDR\\t"main" :: "const"
 681     FILE = ".*\\b(?i:peek\\.t)"
 682     DEPTH = 0(?:
 683     MUTEXP = $ADDR
 684     OWNER = $ADDR)?
 685     FLAGS = 0xc00                               # $] < 5.013
 686     FLAGS = 0xc                                 # $] >= 5.013 && $] < 5.015
 687     FLAGS = 0x100c                              # $] >= 5.015
 688     OUTSIDE_SEQ = 0
 689     PADLIST = 0x0                               # $] < 5.021006
 690     HSCXT = $ADDR                               # $] >= 5.021006
 691     OUTSIDE = 0x0 \\(null\\)');
 692
 693 do_test('isUV should show on PVMG',
 694         do { my $v = $1; $v = ~0; $v },
 695 'SV = PVMG\\($ADDR\\) at $ADDR
 696   REFCNT = 1
 697   FLAGS = \\(IOK,pIOK,IsUV\\)
 698   UV = \d+
 699   NV = 0
 700   PV = 0');
 701
 702 do_test('IO',
 703         *STDOUT{IO},
 704 'SV = $RV\\($ADDR\\) at $ADDR
 705   REFCNT = 1
 706   FLAGS = \\(ROK\\)
 707   RV = $ADDR
 708   SV = PVIO\\($ADDR\\) at $ADDR
 709     REFCNT = 3
 710     FLAGS = \\(OBJECT\\)
 711     IV = 0                                      # $] < 5.011
 712     NV = 0                                      # $] < 5.011
 713     STASH = $ADDR\s+"IO::File"
 714     IFP = $ADDR
 715     OFP = $ADDR
 716     DIRP = 0x0
 717     LINES = 0
 718     PAGE = 0
 719     PAGE_LEN = 60
 720     LINES_LEFT = 0
 721     TOP_GV = 0x0
 722     FMT_GV = 0x0
 723     BOTTOM_GV = 0x0
 724     TYPE = \'>\'
 725     FLAGS = 0x4');
 726
 727 do_test('FORMAT',
 728         *PIE{FORMAT},
 729 'SV = $RV\\($ADDR\\) at $ADDR
 730   REFCNT = 1
 731   FLAGS = \\(ROK\\)
 732   RV = $ADDR
 733   SV = PVFM\\($ADDR\\) at $ADDR
 734     REFCNT = 2
 735     FLAGS = \\(\\)                              # $] < 5.015 || !thr
 736     FLAGS = \\(DYNFILE\\)                       # $] >= 5.015 && thr
 737 (?:    PV = 0
 738 )?    COMP_STASH = 0x0
 739     START = $ADDR ===> \\d+
 740     ROOT = $ADDR
 741     GVGV::GV = $ADDR\\t"main" :: "PIE"
 742     FILE = ".*\\b(?i:peek\\.t)"(?:
 743     DEPTH = 0)?(?:
 744     MUTEXP = $ADDR
 745     OWNER = $ADDR)?
 746     FLAGS = 0x0                                 # $] < 5.015 || !thr
 747     FLAGS = 0x1000                              # $] >= 5.015 && thr
 748     OUTSIDE_SEQ = \\d+
 749     LINES = 0                                   # $] < 5.017_003
 750     PADLIST = $ADDR
 751     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 752     OUTSIDE = $ADDR \\(MAIN\\)');
 753
 754 do_test('blessing to a class with embedded NUL characters',
 755         (bless {}, "\0::foo::\n::baz::\t::\0"),
 756 'SV = $RV\\($ADDR\\) at $ADDR
 757   REFCNT = 1
 758   FLAGS = \\(ROK\\)
 759   RV = $ADDR
 760   SV = PVHV\\($ADDR\\) at $ADDR
 761     REFCNT = [12]
 762     FLAGS = \\(OBJECT,SHAREKEYS\\)
 763     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
 764     ARRAY = $ADDR
 765     KEYS = 0
 766     FILL = 0
 767     MAX = 7', '',
 768         $] >= 5.015
 769             ? undef
 770             : 'The hash iterator used in dump.c sets the OOK flag');
 771
 772 do_test('ENAME on a stash',
 773         \%RWOM::,
 774 'SV = $RV\\($ADDR\\) at $ADDR
 775   REFCNT = 1
 776   FLAGS = \\(ROK\\)
 777   RV = $ADDR
 778   SV = PVHV\\($ADDR\\) at $ADDR
 779     REFCNT = 2
 780     FLAGS = \\(OOK,SHAREKEYS\\)
 781     AUX_FLAGS = 0                               # $] > 5.019008
 782     ARRAY = $ADDR
 783     KEYS = 0
 784     FILL = 0
 785     MAX = 7
 786     RITER = -1
 787     EITER = 0x0
 788     RAND = $ADDR
 789     NAME = "RWOM"
 790     ENAME = "RWOM"                              # $] > 5.012
 791 ');
 792
 793 *KLANK:: = \%RWOM::;
 794
 795 do_test('ENAMEs on a stash',
 796         \%RWOM::,
 797 'SV = $RV\\($ADDR\\) at $ADDR
 798   REFCNT = 1
 799   FLAGS = \\(ROK\\)
 800   RV = $ADDR
 801   SV = PVHV\\($ADDR\\) at $ADDR
 802     REFCNT = 3
 803     FLAGS = \\(OOK,SHAREKEYS\\)
 804     AUX_FLAGS = 0                               # $] > 5.019008
 805     ARRAY = $ADDR
 806     KEYS = 0
 807     FILL = 0
 808     MAX = 7
 809     RITER = -1
 810     EITER = 0x0
 811     RAND = $ADDR
 812     NAME = "RWOM"
 813     NAMECOUNT = 2                               # $] > 5.012
 814     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 815 ');
 816
 817 undef %RWOM::;
 818
 819 do_test('ENAMEs on a stash with no NAME',
 820         \%RWOM::,
 821 'SV = $RV\\($ADDR\\) at $ADDR
 822   REFCNT = 1
 823   FLAGS = \\(ROK\\)
 824   RV = $ADDR
 825   SV = PVHV\\($ADDR\\) at $ADDR
 826     REFCNT = 3
 827     FLAGS = \\(OOK,SHAREKEYS\\)                 # $] < 5.017
 828     FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\)        # $] >=5.017 && $]<5.021005
 829     FLAGS = \\(OOK,SHAREKEYS,OVERLOAD\\)        # $] >=5.021005
 830     AUX_FLAGS = 0                               # $] > 5.019008
 831     ARRAY = $ADDR
 832     KEYS = 0
 833     FILL = 0
 834     MAX = 7
 835     RITER = -1
 836     EITER = 0x0
 837     RAND = $ADDR
 838     NAMECOUNT = -3                              # $] > 5.012
 839     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 840 ');
 841
 842 my %small = ("Perl", "Rules", "Beer", "Foamy");
 843 my $b = %small;
 844 do_test('small hash',
 845         \%small,
 846 'SV = $RV\\($ADDR\\) at $ADDR
 847   REFCNT = 1
 848   FLAGS = \\(ROK\\)
 849   RV = $ADDR
 850   SV = PVHV\\($ADDR\\) at $ADDR
 851     REFCNT = 2
 852     FLAGS = \\($PADMY,SHAREKEYS\\)
 853     ARRAY = $ADDR  \\(0:[67],.*\\)
 854     hash quality = [0-9.]+%
 855     KEYS = 2
 856     FILL = [12]
 857     MAX = 7
 858 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 859     SV = PV\\($ADDR\\) at $ADDR
 860       REFCNT = 1
 861       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
 862       PV = $ADDR "(?:Rules|Foamy)"\\\0
 863       CUR = \d+
 864       LEN = \d+
 865       COW_REFCNT = 1
 866 ){2}');
 867
 868 $b = keys %small;
 869
 870 do_test('small hash after keys',
 871         \%small,
 872 'SV = $RV\\($ADDR\\) at $ADDR
 873   REFCNT = 1
 874   FLAGS = \\(ROK\\)
 875   RV = $ADDR
 876   SV = PVHV\\($ADDR\\) at $ADDR
 877     REFCNT = 2
 878     FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
 879     AUX_FLAGS = 0                               # $] > 5.019008
 880     ARRAY = $ADDR  \\(0:[67],.*\\)
 881     hash quality = [0-9.]+%
 882     KEYS = 2
 883     FILL = [12]
 884     MAX = 7
 885     RITER = -1
 886     EITER = 0x0
 887     RAND = $ADDR
 888 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 889     SV = PV\\($ADDR\\) at $ADDR
 890       REFCNT = 1
 891       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
 892       PV = $ADDR "(?:Rules|Foamy)"\\\0
 893       CUR = \d+
 894       LEN = \d+
 895       COW_REFCNT = 1
 896 ){2}');
 897
 898 $b = %small;
 899
 900 do_test('small hash after keys and scalar',
 901         \%small,
 902 'SV = $RV\\($ADDR\\) at $ADDR
 903   REFCNT = 1
 904   FLAGS = \\(ROK\\)
 905   RV = $ADDR
 906   SV = PVHV\\($ADDR\\) at $ADDR
 907     REFCNT = 2
 908     FLAGS = \\($PADMY,OOK,SHAREKEYS\\)
 909     AUX_FLAGS = 0                               # $] > 5.019008
 910     ARRAY = $ADDR  \\(0:[67],.*\\)
 911     hash quality = [0-9.]+%
 912     KEYS = 2
 913     FILL = ([12])
 914     MAX = 7
 915     RITER = -1
 916     EITER = 0x0
 917     RAND = $ADDR
 918 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 919     SV = PV\\($ADDR\\) at $ADDR
 920       REFCNT = 1
 921       FLAGS = \\(POK,(?:IsCOW,)?pPOK\\)
 922       PV = $ADDR "(?:Rules|Foamy)"\\\0
 923       CUR = \d+
 924       LEN = \d+
 925       COW_REFCNT = 1
 926 ){2}');
 927
 928 # Dump with arrays, hashes, and operator return values
 929 @array = 1..3;
 930 do_test('Dump @array', '@array', <<'ARRAY', '', undef, 1);
 931 SV = PVAV\($ADDR\) at $ADDR
 932   REFCNT = 1
 933   FLAGS = \(\)
 934   ARRAY = $ADDR
 935   FILL = 2
 936   MAX = 3
 937   FLAGS = \(REAL\)
 938   Elt No. 0
 939   SV = IV\($ADDR\) at $ADDR
 940     REFCNT = 1
 941     FLAGS = \(IOK,pIOK\)
 942     IV = 1
 943   Elt No. 1
 944   SV = IV\($ADDR\) at $ADDR
 945     REFCNT = 1
 946     FLAGS = \(IOK,pIOK\)
 947     IV = 2
 948   Elt No. 2
 949   SV = IV\($ADDR\) at $ADDR
 950     REFCNT = 1
 951     FLAGS = \(IOK,pIOK\)
 952     IV = 3
 953 ARRAY
 954
 955 do_test('Dump @array,1', '@array,1', <<'ARRAY', '', undef, 1);
 956 SV = PVAV\($ADDR\) at $ADDR
 957   REFCNT = 1
 958   FLAGS = \(\)
 959   ARRAY = $ADDR
 960   FILL = 2
 961   MAX = 3
 962   FLAGS = \(REAL\)
 963   Elt No. 0
 964   SV = IV\($ADDR\) at $ADDR
 965     REFCNT = 1
 966     FLAGS = \(IOK,pIOK\)
 967     IV = 1
 968 ARRAY
 969
 970 %hash = 1..2;
 971 do_test('Dump %hash', '%hash', <<'HASH', '', undef, 1);
 972 SV = PVHV\($ADDR\) at $ADDR
 973   REFCNT = 1
 974   FLAGS = \(SHAREKEYS\)
 975   ARRAY = $ADDR  \(0:7, 1:1\)
 976   hash quality = 100.0%
 977   KEYS = 1
 978   FILL = 1
 979   MAX = 7
 980   Elt "1" HASH = $ADDR
 981   SV = IV\($ADDR\) at $ADDR
 982     REFCNT = 1
 983     FLAGS = \(IOK,pIOK\)
 984     IV = 2
 985 HASH
 986
 987 $_ = "hello";
 988 do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', undef, 1);
 989 SV = PV\($ADDR\) at $ADDR
 990   REFCNT = 1
 991   FLAGS = \(PADTMP,POK,pPOK\)
 992   PV = $ADDR "el"\\0
 993   CUR = 2
 994   LEN = \d+
 995 SUBSTR
 996
 997 # Dump with no arguments
 998 eval 'Dump';
 999 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;';
1000 eval 'Dump()';
1001 like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()';
1002
1003 SKIP: {
1004     skip "Not built with usemymalloc", 2
1005       unless $Config{usemymalloc} eq 'y';
1006     my $x = __PACKAGE__;
1007     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
1008      or diag $@;
1009     my $y;
1010     ok eval { fill_mstats($y); 1 }, 'fill_mstats on undef scalar';
1011 }
1012
1013 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
1014 # prowess, but short of duplicating all the gubbins of this file, I can't see
1015 # a way to make a better place for it:
1016
1017 use constant {
1018
1019     # The length of the rhs string must be such that if chr() is applied to it
1020     # doesn't yield a character with a backslash mnemonic.  For example, if it
1021     # were 'rules' instead of 'rule', it would have 5 characters, and on
1022     # EBCDIC, chr(5) is \t.  The dumping code would translate all the 5's in
1023     # MG_PTR into "\t", and this test code would be expecting \5's, so the
1024     # tests would fail.  No platform that Perl works on translates chr(4) into
1025     # a mnemonic.
1026     perl => 'rule',
1027     beer => 'foam',
1028 };
1029
1030 unless ($Config{useithreads}) {
1031     # These end up as copies in pads under ithreads, which rather defeats the
1032     # the point of what we're trying to test here.
1033
1034     do_test('regular string constant', perl,
1035 'SV = PV\\($ADDR\\) at $ADDR
1036   REFCNT = 5
1037   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)      # $] < 5.021005
1038   FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\)            # $] >=5.021005
1039   PV = $ADDR "rule"\\\0
1040   CUR = 4
1041   LEN = \d+
1042   COW_REFCNT = 0
1043 ');
1044
1045     eval 'index "", perl';
1046
1047     do_test('string constant now an FBM', perl,
1048 'SV = PVMG\\($ADDR\\) at $ADDR
1049   REFCNT = 5
1050   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1051   PV = $ADDR "rule"\\\0
1052   CUR = 4
1053   LEN = \d+
1054   COW_REFCNT = 0
1055   MAGIC = $ADDR
1056     MG_VIRTUAL = &PL_vtbl_regexp
1057     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1058     MG_LEN = 256
1059     MG_PTR = $ADDR "(?:\\\\\d){256}"
1060   RARE = \d+                                    # $] < 5.019002
1061   PREVIOUS = 1                                  # $] < 5.019002
1062   USEFUL = 100
1063 ');
1064
1065     is(study perl, '', "Not allowed to study an FBM");
1066
1067     do_test('string constant still an FBM', perl,
1068 'SV = PVMG\\($ADDR\\) at $ADDR
1069   REFCNT = 5
1070   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1071   PV = $ADDR "rule"\\\0
1072   CUR = 4
1073   LEN = \d+
1074   COW_REFCNT = 0
1075   MAGIC = $ADDR
1076     MG_VIRTUAL = &PL_vtbl_regexp
1077     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1078     MG_LEN = 256
1079     MG_PTR = $ADDR "(?:\\\\\d){256}"
1080   RARE = \d+                                    # $] < 5.019002
1081   PREVIOUS = 1                                  # $] < 5.019002
1082   USEFUL = 100
1083 ');
1084
1085     do_test('regular string constant', beer,
1086 'SV = PV\\($ADDR\\) at $ADDR
1087   REFCNT = 6
1088   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)      # $] < 5.021005
1089   FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\)            # $] >=5.021005
1090   PV = $ADDR "foam"\\\0
1091   CUR = 4
1092   LEN = \d+
1093   COW_REFCNT = 0
1094 ');
1095
1096     is(study beer, 1, "Our studies were successful");
1097
1098     do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
1099   REFCNT = 6
1100   FLAGS = \\(PADMY,POK,READONLY,(?:IsCOW,)?pPOK\\)      # $] < 5.021005
1101   FLAGS = \\(POK,(?:IsCOW,)?READONLY,pPOK\\)            # $] >=5.021005
1102   PV = $ADDR "foam"\\\0
1103   CUR = 4
1104   LEN = \d+
1105   COW_REFCNT = 0
1106 ');
1107
1108     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1109   REFCNT = 6
1110   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?READONLY,(?:IsCOW,)?pPOK\\)
1111   PV = $ADDR "foam"\\\0
1112   CUR = 4
1113   LEN = \d+
1114   COW_REFCNT = 0
1115   MAGIC = $ADDR
1116     MG_VIRTUAL = &PL_vtbl_regexp
1117     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1118     MG_LEN = 256
1119     MG_PTR = $ADDR "(?:\\\\\d){256}"
1120   RARE = \d+                                    # $] < 5.019002
1121   PREVIOUS = \d+                                # $] < 5.019002
1122   USEFUL = 100
1123 ';
1124
1125     is (eval 'index "not too foamy", beer', 8, 'correct index');
1126
1127     do_test('string constant now FBMed', beer, $want);
1128
1129     my $pie = 'good';
1130
1131     is(study $pie, 1, "Our studies were successful");
1132
1133     do_test('string constant still FBMed', beer, $want);
1134
1135     do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1136   REFCNT = 1
1137   FLAGS = \\($PADMY,POK,(?:IsCOW,)?pPOK\\)
1138   PV = $ADDR "good"\\\0
1139   CUR = 4
1140   LEN = \d+
1141   COW_REFCNT = 1
1142 ');
1143 }
1144
1145 # (One block of study tests removed when study was made a no-op.)
1146
1147 {
1148     open(OUT, '>', "peek$$") or die "Failed to open peek $$: $!";
1149     open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1150     DeadCode();
1151     open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1152     pass "no crash with DeadCode";
1153     close OUT;
1154 }
1155 # note the conditionals on ENGINE and INTFLAGS were introduced in 5.19.9
1156 do_test('UTF-8 in a regular expression',
1157         qr/\x{100}/,
1158 'SV = IV\($ADDR\) at $ADDR
1159   REFCNT = 1
1160   FLAGS = \(ROK\)
1161   RV = $ADDR
1162   SV = REGEXP\($ADDR\) at $ADDR
1163     REFCNT = 1
1164     FLAGS = \(OBJECT,POK,FAKE,pPOK,UTF8\)
1165     PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1166     CUR = 13
1167     LEN = 0
1168     STASH = $ADDR       "Regexp"
1169     COMPFLAGS = 0x0 \(\)
1170     EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1171 (?:    ENGINE = $ADDR \(STANDARD\)
1172 )?    INTFLAGS = 0x0(?: \(\))?
1173     NPARENS = 0
1174     LASTPAREN = 0
1175     LASTCLOSEPAREN = 0
1176     MINLEN = 1
1177     MINLENRET = 1
1178     GOFS = 0
1179     PRE_PREFIX = 5
1180     SUBLEN = 0
1181     SUBOFFSET = 0
1182     SUBCOFFSET = 0
1183     SUBBEG = 0x0
1184 (?:    ENGINE = $ADDR
1185 )?    MOTHER_RE = $ADDR'
1186 . ($] < 5.019003 ? '' : '
1187     SV = REGEXP\($ADDR\) at $ADDR
1188       REFCNT = 2
1189       FLAGS = \(POK,pPOK,UTF8\)
1190       PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1191       CUR = 13
1192       LEN = \d+
1193       COMPFLAGS = 0x0 \(\)
1194       EXTFLAGS = $ADDR \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1195 (?:      ENGINE = $ADDR \(STANDARD\)
1196 )?      INTFLAGS = 0x0(?: \(\))?
1197       NPARENS = 0
1198       LASTPAREN = 0
1199       LASTCLOSEPAREN = 0
1200       MINLEN = 1
1201       MINLENRET = 1
1202       GOFS = 0
1203       PRE_PREFIX = 5
1204       SUBLEN = 0
1205       SUBOFFSET = 0
1206       SUBCOFFSET = 0
1207       SUBBEG = 0x0
1208 (?:    ENGINE = $ADDR
1209 )?      MOTHER_RE = 0x0
1210       PAREN_NAMES = 0x0
1211       SUBSTRS = $ADDR
1212       PPRIVATE = $ADDR
1213       OFFS = $ADDR
1214       QR_ANONCV = 0x0(?:
1215       SAVED_COPY = 0x0)?') . '
1216     PAREN_NAMES = 0x0
1217     SUBSTRS = $ADDR
1218     PPRIVATE = $ADDR
1219     OFFS = $ADDR
1220     QR_ANONCV = 0x0(?:
1221     SAVED_COPY = 0x0)?
1222 ');
1223
1224 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1225   my %hash;
1226   my $base_count = Devel::Peek::SvREFCNT(%hash);
1227   my $ref = \%hash;
1228   is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1229   ok(!eval { &Devel::Peek::SvREFCNT(1) }, "requires prototype");
1230 }
1231 {
1232 # utf8 tests
1233 use utf8;
1234
1235 sub _dump {
1236    open(OUT, '>', "peek$$") or die $!;
1237    open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1238    Dump($_[0]);
1239    open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1240    close(OUT);
1241    open(IN, '<', "peek$$") or die $!;
1242    my $dump = do { local $/; <IN> };
1243    close(IN);
1244    1 while unlink "peek$$";
1245    return $dump;
1246 }
1247
1248 sub _get_coderef {
1249    my $x = $_[0];
1250    utf8::upgrade($x);
1251    eval "sub $x {}; 1" or die $@;
1252    return *{$x}{CODE};
1253 }
1254
1255 like(
1256    _dump(_get_coderef("\x{df}::\xdf")),
1257    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\xdf"/,
1258    "GVGV's are correctly escaped for latin1 :: latin1",
1259 );
1260
1261 like(
1262    _dump(_get_coderef("\x{30cd}::\x{30cd}")),
1263    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\x{30cd}"/,
1264    "GVGV's are correctly escaped for UTF8 :: UTF8",
1265 );
1266
1267 like(
1268    _dump(_get_coderef("\x{df}::\x{30cd}")),
1269    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\xdf" :: "\x{30cd}"/,
1270    "GVGV's are correctly escaped for latin1 :: UTF8",
1271 );
1272
1273 like(
1274    _dump(_get_coderef("\x{30cd}::\x{df}")),
1275    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cd}" :: "\xdf"/,
1276    "GVGV's are correctly escaped for UTF8 :: latin1",
1277 );
1278
1279 like(
1280    _dump(_get_coderef("\x{30cb}::\x{df}::\x{30cd}")),
1281    qr/GVGV::GV = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}" :: "\x{30cd}"/,
1282    "GVGV's are correctly escaped for UTF8 :: latin 1 :: UTF8",
1283 );
1284
1285 my $dump = _dump(*{"\x{30cb}::\x{df}::\x{30dc}"});
1286
1287 like(
1288    $dump,
1289    qr/NAME = \Q"\x{30dc}"/,
1290    "NAME is correctly escaped for UTF8 globs",
1291 );
1292
1293 like(
1294    $dump,
1295    qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\x{30cb}::\x{df}"/,
1296    "GvSTASH is correctly escaped for UTF8 globs"
1297 );
1298
1299 like(
1300    $dump,
1301    qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30dc}"/,
1302    "EGV is correctly escaped for UTF8 globs"
1303 );
1304
1305 $dump = _dump(*{"\x{df}::\x{30cc}"});
1306
1307 like(
1308    $dump,
1309    qr/NAME = \Q"\x{30cc}"/,
1310    "NAME is correctly escaped for UTF8 globs with latin1 stashes",
1311 );
1312
1313 like(
1314    $dump,
1315    qr/GvSTASH = 0x[[:xdigit:]]+\s+\Q"\xdf"/,
1316    "GvSTASH is correctly escaped for UTF8 globs with latin1 stashes"
1317 );
1318
1319 like(
1320    $dump,
1321    qr/EGV = 0x[[:xdigit:]]+\s+\Q"\x{30cc}"/,
1322    "EGV is correctly escaped for UTF8 globs with latin1 stashes"
1323 );
1324
1325 like(
1326    _dump(bless {}, "\0::\1::\x{30cd}"),
1327    qr/STASH = 0x[[:xdigit:]]+\s+\Q"\0::\x{01}::\x{30cd}"/,
1328    "STASH for blessed hashrefs is correct"
1329 );
1330
1331 BEGIN { $::{doof} = "\0\1\x{30cd}" }
1332 like(
1333    _dump(\&doof),
1334    qr/PROTOTYPE = \Q"\0\x{01}\x{30cd}"/,
1335    "PROTOTYPE is escaped correctly"
1336 );
1337
1338 {
1339     my $coderef = eval <<"EOP";
1340     use feature 'lexical_subs';
1341     no warnings 'experimental::lexical_subs';
1342     my sub bar (\$\x{30cd}) {1}; \\&bar
1343 EOP
1344     like(
1345        _dump($coderef),
1346        qr/PROTOTYPE = "\$\Q\x{30cd}"/,
1347        "PROTOTYPE works on lexical subs"
1348     )
1349 }
1350
1351 sub get_outside {
1352    eval "sub $_[0] { my \$x; \$x++; return sub { eval q{\$x} } } $_[0]()";
1353 }
1354 sub basic { my $x; return eval q{sub { eval q{$x} }} }
1355 like(
1356     _dump(basic()),
1357     qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(basic)/,
1358     'OUTSIDE works'
1359 );
1360
1361 like(
1362     _dump(get_outside("\x{30ce}")),
1363     qr/OUTSIDE = 0x[[:xdigit:]]+\s+\Q(\x{30ce})/,
1364     'OUTSIDE + UTF8 works'
1365 );
1366
1367 # TODO AUTOLOAD = stashname, which requires using a XS autoload
1368 # and calling Dump() on the cv
1369
1370
1371
1372 sub test_utf8_stashes {
1373    my ($stash_name, $test) = @_;
1374
1375    $dump = _dump(\%{"${stash_name}::"});
1376
1377    my $format = utf8::is_utf8($stash_name) ? '\x{%2x}' : '\x%2x';
1378    $escaped_stash_name = join "", map {
1379          $_ eq ':' ? $_ : sprintf $format, ord $_
1380    } split //, $stash_name;
1381
1382    like(
1383       $dump,
1384       qr/\QNAME = "$escaped_stash_name"/,
1385       "NAME is correct escaped for $test"
1386    );
1387
1388    like(
1389       $dump,
1390       qr/\QENAME = "$escaped_stash_name"/,
1391       "ENAME is correct escaped for $test"
1392    );
1393 }
1394
1395 for my $test (
1396   [ "\x{30cd}", "UTF8 stashes" ],
1397    [ "\x{df}", "latin 1 stashes" ],
1398    [ "\x{df}::\x{30cd}", "latin1 + UTF8 stashes" ],
1399    [ "\x{30cd}::\x{df}", "UTF8 + latin1 stashes" ],
1400 ) {
1401    test_utf8_stashes(@$test);
1402 }
1403
1404 }
1405
1406 my $runperl_args = { switches => ['-Ilib'] };
1407 sub test_DumpProg {
1408     my ($prog, $expected, $name, $test) = @_;
1409     $test ||= 'like';
1410
1411     my $u = 'use Devel::Peek "DumpProg"; DumpProg();';
1412
1413     # Interface between Test::Builder & test.pl
1414     my $builder = Test::More->builder();
1415     t::curr_test($builder->current_test() + 1);
1416
1417     utf8::encode($prog);
1418
1419     if ( $test eq 'is' ) {
1420         t::fresh_perl_is($prog . $u, $expected, $runperl_args, $name)
1421     }
1422     else {
1423         t::fresh_perl_like($prog . $u, $expected, $runperl_args, $name)
1424     }
1425
1426     $builder->current_test(t::curr_test() - 1);
1427 }
1428
1429 my $threads = $Config{'useithreads'};
1430
1431 for my $test (
1432 [
1433     "package test;",
1434     qr/PACKAGE = "test"/,
1435     "DumpProg() + package declaration"
1436 ],
1437 [
1438     "use utf8; package \x{30cd};",
1439     qr/PACKAGE = "\\x\Q{30cd}"/,
1440     "DumpProg() + UTF8 package declaration"
1441 ],
1442 [
1443     "use utf8; sub \x{30cc}::\x{30cd} {1}; \x{30cc}::\x{30cd};",
1444     ($threads ? qr/PADIX = \d+/ : qr/GV = \Q\x{30cc}::\x{30cd}\E/)
1445 ],
1446 [
1447     "use utf8; \x{30cc}: { last \x{30cc} }",
1448     qr/LABEL = \Q"\x{30cc}"/
1449 ],
1450 )
1451 {
1452    test_DumpProg(@$test);
1453 }
1454
1455 {
1456     local $TODO = 'This gets mangled by the current pipe implementation' if $^O eq 'VMS';
1457     my $e = <<'EODUMP';
1458 dumpindent is 4 at -e line 1.
1459
1460 1    leave LISTOP(0xNNN) ===> [0x0]
1461      PARENT ===> [0x0]
1462      TARG = 1
1463      FLAGS = (VOID,KIDS,PARENS,SLABBED)
1464      PRIVATE = (REFC)
1465      REFCNT = 1
1466      |
1467 2    +--enter OP(0xNNN) ===> 3 [nextstate 0xNNN]
1468      |   FLAGS = (UNKNOWN,SLABBED,MORESIB)
1469      |
1470 3    +--nextstate COP(0xNNN) ===> 4 [pushmark 0xNNN]
1471      |   FLAGS = (VOID,SLABBED,MORESIB)
1472      |   LINE = 1
1473      |   PACKAGE = "t"
1474      |     |
1475 5    +--entersub UNOP(0xNNN) ===> 1 [leave 0xNNN]
1476          TARG = 1
1477          FLAGS = (VOID,KIDS,STACKED,SLABBED)
1478          PRIVATE = (TARG)
1479          |
1480 6        +--null (ex-list) UNOP(0xNNN) ===> 5 [entersub 0xNNN]
1481              FLAGS = (UNKNOWN,KIDS,SLABBED)
1482              |
1483 4            +--pushmark OP(0xNNN) ===> 7 [gv 0xNNN]
1484              |   FLAGS = (SCALAR,SLABBED,MORESIB)
1485              |
1486 8            +--null (ex-rv2cv) UNOP(0xNNN) ===> 6 [null 0xNNN]
1487                  FLAGS = (SCALAR,KIDS,SLABBED)
1488                  PRIVATE = (0x1)
1489                  |
1490 7                +--gv SVOP(0xNNN) ===> 5 [entersub 0xNNN]
1491                      FLAGS = (SCALAR,SLABBED)
1492                      GV_OR_PADIX
1493 EODUMP
1494
1495     $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
1496     $e =~ s/SVOP/PADOP/g if $threads;
1497     my $out = t::runperl
1498                  switches => ['-Ilib'],
1499                  prog => 'package t; use Devel::Peek q-DumpProg-; DumpProg();',
1500                  stderr=>1;
1501     $out =~ s/ *SEQ = .*\n//;
1502     $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g;
1503     $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g;
1504     is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
1505 }
1506 done_testing();