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