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