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