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