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
  11 use Test::More;
  12
  13 use Devel::Peek;
  14
  15 our $DEBUG = 0;
  16 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
  17
  18 # If I reference any lexicals in this, I get the entire outer subroutine (or
  19 # MAIN) dumped too, which isn't really what I want, as it's a lot of faff to
  20 # maintain that.
  21 format PIE =
  22 Pie     @<<<<<
  23 $::type
  24 Good    @>>>>>
  25 $::mmmm
  26 .
  27
  28 use constant thr => $Config{useithreads};
  29
  30 sub do_test {
  31     my $todo = $_[3];
  32     my $repeat_todo = $_[4];
  33     my $pattern = $_[2];
  34     if (open(OUT,">peek$$")) {
  35         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
  36         Dump($_[1]);
  37         print STDERR "*****\n";
  38         Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
  39         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
  40         close(OUT);
  41         if (open(IN, "peek$$")) {
  42             local $/;
  43             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
  44             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
  45             # handle DEBUG_LEAKING_SCALARS prefix
  46             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
  47
  48             # Need some clear generic mechanism to eliminate (or add) lines
  49             # of dump output dependant on perl version. The (previous) use of
  50             # things like $IVNV gave the illusion that the string passed in was
  51             # a regexp into which variables were interpolated, but this wasn't
  52             # actually true as those 'variables' actually also ate the
  53             # whitespace on the line. So it seems better to mark lines that
  54             # need to be eliminated. I considered (?# ... ) and (?{ ... }),
  55             # but whilst embedded code or comment syntax would keep it as a
  56             # legitimate regexp, it still isn't true. Seems easier and clearer
  57             # things that look like comments.
  58
  59             # Could do this is in a s///mge but seems clearer like this:
  60             $pattern = join '', map {
  61                 # If we identify the version condition, take *it* out whatever
  62                 s/\s*# (\$].*)$//
  63                     ? (eval $1 ? $_ : '')
  64                     : $_ # Didn't match, so this line is in
  65             } split /^/, $pattern;
  66
  67             $pattern =~ s/\$PADMY/
  68                 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
  69             /mge;
  70             $pattern =~ s/\$PADTMP/
  71                 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
  72             /mge;
  73             $pattern =~ s/\$RV/
  74                 ($] < 5.011) ? 'RV' : 'IV';
  75             /mge;
  76
  77             print $pattern, "\n" if $DEBUG;
  78             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
  79             print $dump, "\n"    if $DEBUG;
  80             like( $dump, qr/\A$pattern\Z/ms, $_[0])
  81               or note("line " . (caller)[2]);
  82
  83             local $TODO = $repeat_todo;
  84             is($dump2, $dump, "$_[0] (unchanged by dump)")
  85               or note("line " . (caller)[2]);
  86
  87             close(IN);
  88
  89             return $1;
  90         } else {
  91             die "$0: failed to open peek$$: !\n";
  92         }
  93     } else {
  94         die "$0: failed to create peek$$: $!\n";
  95     }
  96 }
  97
  98 our   $a;
  99 our   $b;
 100 my    $c;
 101 local $d = 0;
 102
 103 END {
 104     1 while unlink("peek$$");
 105 }
 106
 107 do_test('assignment of immediate constant (string)',
 108         $a = "foo",
 109 'SV = PV\\($ADDR\\) at $ADDR
 110   REFCNT = 1
 111   FLAGS = \\(POK,pPOK\\)
 112   PV = $ADDR "foo"\\\0
 113   CUR = 3
 114   LEN = \\d+'
 115        );
 116
 117 do_test('immediate constant (string)',
 118         "bar",
 119 'SV = PV\\($ADDR\\) at $ADDR
 120   REFCNT = 1
 121   FLAGS = \\(.*POK,READONLY,pPOK\\)
 122   PV = $ADDR "bar"\\\0
 123   CUR = 3
 124   LEN = \\d+');
 125
 126 do_test('assignment of immediate constant (integer)',
 127         $b = 123,
 128 'SV = IV\\($ADDR\\) at $ADDR
 129   REFCNT = 1
 130   FLAGS = \\(IOK,pIOK\\)
 131   IV = 123');
 132
 133 do_test('immediate constant (integer)',
 134         456,
 135 'SV = IV\\($ADDR\\) at $ADDR
 136   REFCNT = 1
 137   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 138   IV = 456');
 139
 140 do_test('assignment of immediate constant (integer)',
 141         $c = 456,
 142 'SV = IV\\($ADDR\\) at $ADDR
 143   REFCNT = 1
 144   FLAGS = \\($PADMY,IOK,pIOK\\)
 145   IV = 456');
 146
 147 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
 148 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
 149 # maths is done in floating point always, and this scalar will be an NV.
 150 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
 151 # building subsequent regexps.
 152 my $type = do_test('result of addition',
 153         $c + $d,
 154 'SV = ([NI])V\\($ADDR\\) at $ADDR
 155   REFCNT = 1
 156   FLAGS = \\(PADTMP,\1OK,p\1OK\\)               # $] < 5.019003
 157   FLAGS = \\(\1OK,p\1OK\\)                      # $] >=5.019003
 158   \1V = 456');
 159
 160 ($d = "789") += 0.1;
 161
 162 do_test('floating point value',
 163        $d,
 164 'SV = PVNV\\($ADDR\\) at $ADDR
 165   REFCNT = 1
 166   FLAGS = \\(NOK,pNOK\\)
 167   IV = \d+
 168   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
 169   PV = $ADDR "789"\\\0
 170   CUR = 3
 171   LEN = \\d+');
 172
 173 do_test('integer constant',
 174         0xabcd,
 175 'SV = IV\\($ADDR\\) at $ADDR
 176   REFCNT = 1
 177   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 178   IV = 43981');
 179
 180 do_test('undef',
 181         undef,
 182 'SV = NULL\\(0x0\\) at $ADDR
 183   REFCNT = 1
 184   FLAGS = \\(\\)');
 185
 186 do_test('reference to scalar',
 187         \$a,
 188 'SV = $RV\\($ADDR\\) at $ADDR
 189   REFCNT = 1
 190   FLAGS = \\(ROK\\)
 191   RV = $ADDR
 192   SV = PV\\($ADDR\\) at $ADDR
 193     REFCNT = 2
 194     FLAGS = \\(POK,pPOK\\)
 195     PV = $ADDR "foo"\\\0
 196     CUR = 3
 197     LEN = \\d+');
 198
 199 my $c_pattern;
 200 if ($type eq 'N') {
 201   $c_pattern = '
 202     SV = PVNV\\($ADDR\\) at $ADDR
 203       REFCNT = 1
 204       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
 205       IV = 456
 206       NV = 456
 207       PV = 0';
 208 } else {
 209   $c_pattern = '
 210     SV = IV\\($ADDR\\) at $ADDR
 211       REFCNT = 1
 212       FLAGS = \\(IOK,pIOK\\)
 213       IV = 456';
 214 }
 215 do_test('reference to array',
 216        [$b,$c],
 217 'SV = $RV\\($ADDR\\) at $ADDR
 218   REFCNT = 1
 219   FLAGS = \\(ROK\\)
 220   RV = $ADDR
 221   SV = PVAV\\($ADDR\\) at $ADDR
 222     REFCNT = 1
 223     FLAGS = \\(\\)
 224     IV = 0                                      # $] < 5.009
 225     NV = 0                                      # $] < 5.009
 226     ARRAY = $ADDR
 227     FILL = 1
 228     MAX = 1
 229     ARYLEN = 0x0
 230     FLAGS = \\(REAL\\)
 231     Elt No. 0
 232     SV = IV\\($ADDR\\) at $ADDR
 233       REFCNT = 1
 234       FLAGS = \\(IOK,pIOK\\)
 235       IV = 123
 236     Elt No. 1' . $c_pattern);
 237
 238 do_test('reference to hash',
 239        {$b=>$c},
 240 'SV = $RV\\($ADDR\\) at $ADDR
 241   REFCNT = 1
 242   FLAGS = \\(ROK\\)
 243   RV = $ADDR
 244   SV = PVHV\\($ADDR\\) at $ADDR
 245     REFCNT = [12]
 246     FLAGS = \\(SHAREKEYS\\)
 247     IV = 1                                      # $] < 5.009
 248     NV = $FLOAT                                 # $] < 5.009
 249     ARRAY = $ADDR  \\(0:7, 1:1\\)
 250     hash quality = 100.0%
 251     KEYS = 1
 252     FILL = 1
 253     MAX = 7
 254     Elt "123" HASH = $ADDR' . $c_pattern,
 255         '',
 256         $] > 5.009 && $] < 5.015
 257          && 'The hash iterator used in dump.c sets the OOK flag');
 258
 259 do_test('reference to anon sub with empty prototype',
 260         sub(){@_},
 261 'SV = $RV\\($ADDR\\) at $ADDR
 262   REFCNT = 1
 263   FLAGS = \\(ROK\\)
 264   RV = $ADDR
 265   SV = PVCV\\($ADDR\\) at $ADDR
 266     REFCNT = 2
 267     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\) # $] < 5.015 || !thr
 268     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC,DYNFILE\\) # $] >= 5.015 && thr
 269     IV = 0                                      # $] < 5.009
 270     NV = 0                                      # $] < 5.009
 271     PROTOTYPE = ""
 272     COMP_STASH = $ADDR\\t"main"
 273     START = $ADDR ===> \\d+
 274     ROOT = $ADDR
 275     XSUB = 0x0                                  # $] < 5.009
 276     XSUBANY = 0                                 # $] < 5.009
 277     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
 278     FILE = ".*\\b(?i:peek\\.t)"
 279     DEPTH = 0(?:
 280     MUTEXP = $ADDR
 281     OWNER = $ADDR)?
 282     FLAGS = 0x404                               # $] < 5.009
 283     FLAGS = 0x490               # $] >= 5.009 && ($] < 5.015 || !thr)
 284     FLAGS = 0x1490                              # $] >= 5.015 && thr
 285     OUTSIDE_SEQ = \\d+
 286     PADLIST = $ADDR
 287     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 288     OUTSIDE = $ADDR \\(MAIN\\)');
 289
 290 do_test('reference to named subroutine without prototype',
 291         \&do_test,
 292 'SV = $RV\\($ADDR\\) at $ADDR
 293   REFCNT = 1
 294   FLAGS = \\(ROK\\)
 295   RV = $ADDR
 296   SV = PVCV\\($ADDR\\) at $ADDR
 297     REFCNT = (3|4)
 298     FLAGS = \\((?:HASEVAL)?\\)                  # $] < 5.015 || !thr
 299     FLAGS = \\(DYNFILE(?:,HASEVAL)?\\)          # $] >= 5.015 && thr
 300     IV = 0                                      # $] < 5.009
 301     NV = 0                                      # $] < 5.009
 302     COMP_STASH = $ADDR\\t"main"
 303     START = $ADDR ===> \\d+
 304     ROOT = $ADDR
 305     XSUB = 0x0                                  # $] < 5.009
 306     XSUBANY = 0                                 # $] < 5.009
 307     GVGV::GV = $ADDR\\t"main" :: "do_test"
 308     FILE = ".*\\b(?i:peek\\.t)"
 309     DEPTH = 1(?:
 310     MUTEXP = $ADDR
 311     OWNER = $ADDR)?
 312     FLAGS = 0x(?:400)?0                         # $] < 5.015 || !thr
 313     FLAGS = 0x[145]000                          # $] >= 5.015 && thr
 314     OUTSIDE_SEQ = \\d+
 315     PADLIST = $ADDR
 316     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 317        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
 318        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
 319        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
 320       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
 321       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
 322       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
 323       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
 324     OUTSIDE = $ADDR \\(MAIN\\)');
 325
 326 if ($] >= 5.011) {
 327 do_test('reference to regexp',
 328         qr(tic),
 329 'SV = $RV\\($ADDR\\) at $ADDR
 330   REFCNT = 1
 331   FLAGS = \\(ROK\\)
 332   RV = $ADDR
 333   SV = REGEXP\\($ADDR\\) at $ADDR
 334     REFCNT = 1
 335     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)          # $] < 5.017006
 336     FLAGS = \\(OBJECT,FAKE\\)                   # $] >= 5.017006
 337     PV = $ADDR "\\(\\?\\^:tic\\)"
 338     CUR = 8
 339     LEN = 0                                     # $] < 5.017006
 340     STASH = $ADDR\\t"Regexp"'
 341 . ($] < 5.013 ? '' :
 342 '
 343     COMPFLAGS = 0x0 \(\)
 344     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
 345     INTFLAGS = 0x0
 346     NPARENS = 0
 347     LASTPAREN = 0
 348     LASTCLOSEPAREN = 0
 349     MINLEN = 3
 350     MINLENRET = 3
 351     GOFS = 0
 352     PRE_PREFIX = 4
 353     SUBLEN = 0
 354     SUBOFFSET = 0
 355     SUBCOFFSET = 0
 356     SUBBEG = 0x0
 357     ENGINE = $ADDR
 358     MOTHER_RE = $ADDR
 359     PAREN_NAMES = 0x0
 360     SUBSTRS = $ADDR
 361     PPRIVATE = $ADDR
 362     OFFS = $ADDR
 363     QR_ANONCV = 0x0(?:
 364     SAVED_COPY = 0x0)?'
 365 ));
 366 } else {
 367 do_test('reference to regexp',
 368         qr(tic),
 369 'SV = $RV\\($ADDR\\) at $ADDR
 370   REFCNT = 1
 371   FLAGS = \\(ROK\\)
 372   RV = $ADDR
 373   SV = PVMG\\($ADDR\\) at $ADDR
 374     REFCNT = 1
 375     FLAGS = \\(OBJECT,SMG\\)
 376     IV = 0
 377     NV = 0
 378     PV = 0
 379     MAGIC = $ADDR
 380       MG_VIRTUAL = $ADDR
 381       MG_TYPE = PERL_MAGIC_qr\(r\)
 382       MG_OBJ = $ADDR
 383         PAT = "\(\?^:tic\)"                     # $] >= 5.009
 384         REFCNT = 2                              # $] >= 5.009
 385     STASH = $ADDR\\t"Regexp"');
 386 }
 387
 388 do_test('reference to blessed hash',
 389         (bless {}, "Tac"),
 390 'SV = $RV\\($ADDR\\) at $ADDR
 391   REFCNT = 1
 392   FLAGS = \\(ROK\\)
 393   RV = $ADDR
 394   SV = PVHV\\($ADDR\\) at $ADDR
 395     REFCNT = [12]
 396     FLAGS = \\(OBJECT,SHAREKEYS\\)
 397     IV = 0                                      # $] < 5.009
 398     NV = 0                                      # $] < 5.009
 399     STASH = $ADDR\\t"Tac"
 400     ARRAY = 0x0
 401     KEYS = 0
 402     FILL = 0
 403     MAX = 7', '',
 404         $] > 5.009
 405         ? $] >= 5.015
 406              ? 0
 407              : 'The hash iterator used in dump.c sets the OOK flag'
 408         : "Something causes the HV's array to become allocated");
 409
 410 do_test('typeglob',
 411         *a,
 412 'SV = PVGV\\($ADDR\\) at $ADDR
 413   REFCNT = 5
 414   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
 415   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
 416   IV = 0                                        # $] < 5.009
 417   NV = 0                                        # $] < 5.009
 418   PV = 0                                        # $] < 5.009
 419   MAGIC = $ADDR                                 # $] < 5.009
 420     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
 421     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
 422     MG_OBJ = $ADDR                              # $] < 5.009
 423   NAME = "a"
 424   NAMELEN = 1
 425   GvSTASH = $ADDR\\t"main"
 426   GP = $ADDR
 427     SV = $ADDR
 428     REFCNT = 1
 429     IO = 0x0
 430     FORM = 0x0
 431     AV = 0x0
 432     HV = 0x0
 433     CV = 0x0
 434     CVGEN = 0x0
 435     GPFLAGS = 0x0                               # $] < 5.009
 436     LINE = \\d+
 437     FILE = ".*\\b(?i:peek\\.t)"
 438     FLAGS = $ADDR
 439     EGV = $ADDR\\t"a"');
 440
 441 if (ord('A') == 193) {
 442 do_test('string with Unicode',
 443         chr(256).chr(0).chr(512),
 444 'SV = PV\\($ADDR\\) at $ADDR
 445   REFCNT = 1
 446   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
 447   FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\)              # $] >=5.019003
 448   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 449   CUR = 5
 450   LEN = \\d+');
 451 } else {
 452 do_test('string with Unicode',
 453         chr(256).chr(0).chr(512),
 454 'SV = PV\\($ADDR\\) at $ADDR
 455   REFCNT = 1
 456   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)     # $] < 5.019003
 457   FLAGS = \\((?:$PADTMP,)?POK,pPOK,UTF8\\)              # $] >=5.019003
 458   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 459   CUR = 5
 460   LEN = \\d+');
 461 }
 462
 463 if (ord('A') == 193) {
 464 do_test('reference to hash containing Unicode',
 465         {chr(256)=>chr(512)},
 466 'SV = $RV\\($ADDR\\) at $ADDR
 467   REFCNT = 1
 468   FLAGS = \\(ROK\\)
 469   RV = $ADDR
 470   SV = PVHV\\($ADDR\\) at $ADDR
 471     REFCNT = [12]
 472     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 473     UV = 1                                      # $] < 5.009
 474     NV = $FLOAT                                 # $] < 5.009
 475     ARRAY = $ADDR  \\(0:7, 1:1\\)
 476     hash quality = 100.0%
 477     KEYS = 1
 478     FILL = 1
 479     MAX = 7
 480     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 481     SV = PV\\($ADDR\\) at $ADDR
 482       REFCNT = 1
 483       FLAGS = \\(POK,pPOK,UTF8\\)
 484       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 485       CUR = 2
 486       LEN = \\d+',
 487         $] > 5.009
 488         ? $] >= 5.015
 489             ?  0
 490             : 'The hash iterator used in dump.c sets the OOK flag'
 491         : 'sv_length has been called on the element, and cached the result in MAGIC');
 492 } else {
 493 do_test('reference to hash containing Unicode',
 494         {chr(256)=>chr(512)},
 495 'SV = $RV\\($ADDR\\) at $ADDR
 496   REFCNT = 1
 497   FLAGS = \\(ROK\\)
 498   RV = $ADDR
 499   SV = PVHV\\($ADDR\\) at $ADDR
 500     REFCNT = [12]
 501     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 502     UV = 1                                      # $] < 5.009
 503     NV = 0                                      # $] < 5.009
 504     ARRAY = $ADDR  \\(0:7, 1:1\\)
 505     hash quality = 100.0%
 506     KEYS = 1
 507     FILL = 1
 508     MAX = 7
 509     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 510     SV = PV\\($ADDR\\) at $ADDR
 511       REFCNT = 1
 512       FLAGS = \\(POK,pPOK,UTF8\\)
 513       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 514       CUR = 2
 515       LEN = \\d+', '',
 516         $] > 5.009
 517         ? $] >= 5.015
 518             ?  0
 519             : 'The hash iterator used in dump.c sets the OOK flag'
 520         : 'sv_length has been called on the element, and cached the result in MAGIC');
 521 }
 522
 523 my $x="";
 524 $x=~/.??/g;
 525 do_test('scalar with pos magic',
 526         $x,
 527 'SV = PVMG\\($ADDR\\) at $ADDR
 528   REFCNT = 1
 529   FLAGS = \\($PADMY,SMG,POK,(?:IsCOW,)?pPOK\\)
 530   IV = \d+
 531   NV = 0
 532   PV = $ADDR ""\\\0
 533   CUR = 0
 534   LEN = \d+(?:
 535   COW_REFCNT = 1)?
 536   MAGIC = $ADDR
 537     MG_VIRTUAL = &PL_vtbl_mglob
 538     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 539     MG_FLAGS = 0x01
 540       MINMATCH');
 541
 542 #
 543 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 544 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 545 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
 546 # Perl 5.18 ensures all env vars end up as strings only, hence the (?:,pIOK)?
 547 # Perl 5.18 ensures even magic vars have public OK, hence the (?:,POK)?
 548 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 549 # ENV hashes is also not always null terminated.
 550 #
 551 if (${^TAINT}) {
 552   do_test('tainted value in %ENV',
 553           $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 554 'SV = PVMG\\($ADDR\\) at $ADDR
 555   REFCNT = 1
 556   FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\)
 557   IV = 0
 558   NV = 0
 559   PV = $ADDR "0"\\\0
 560   CUR = 1
 561   LEN = \d+
 562   MAGIC = $ADDR
 563     MG_VIRTUAL = &PL_vtbl_envelem
 564     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 565 (?:    MG_FLAGS = 0x01
 566       TAINTEDDIR
 567 )?    MG_LEN = -?\d+
 568     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
 569     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
 570       REFCNT = \d+
 571       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
 572 (?:      IV = 0
 573 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
 574       CUR = \d+
 575       LEN = \d+)
 576   MAGIC = $ADDR
 577     MG_VIRTUAL = &PL_vtbl_taint
 578     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 579 }
 580
 581 do_test('blessed reference',
 582         bless(\\undef, 'Foobar'),
 583 'SV = $RV\\($ADDR\\) at $ADDR
 584   REFCNT = 1
 585   FLAGS = \\(ROK\\)
 586   RV = $ADDR
 587   SV = PVMG\\($ADDR\\) at $ADDR
 588     REFCNT = 2
 589     FLAGS = \\(OBJECT,ROK\\)
 590     IV = -?\d+
 591     NV = $FLOAT
 592     RV = $ADDR
 593     SV = NULL\\(0x0\\) at $ADDR
 594       REFCNT = \d+
 595       FLAGS = \\(READONLY\\)
 596     PV = $ADDR ""
 597     CUR = 0
 598     LEN = 0
 599     STASH = $ADDR\s+"Foobar"');
 600
 601 sub const () {
 602     "Perl rules";
 603 }
 604
 605 do_test('constant subroutine',
 606         \&const,
 607 'SV = $RV\\($ADDR\\) at $ADDR
 608   REFCNT = 1
 609   FLAGS = \\(ROK\\)
 610   RV = $ADDR
 611   SV = PVCV\\($ADDR\\) at $ADDR
 612     REFCNT = (2)
 613     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)         # $] < 5.015
 614     FLAGS = \\(POK,pPOK,CONST,DYNFILE,ISXSUB\\) # $] >= 5.015
 615     IV = 0                                      # $] < 5.009
 616     NV = 0                                      # $] < 5.009
 617     PROTOTYPE = ""
 618     COMP_STASH = 0x0
 619     ROOT = 0x0                                  # $] < 5.009
 620     XSUB = $ADDR
 621     XSUBANY = $ADDR \\(CONST SV\\)
 622     SV = PV\\($ADDR\\) at $ADDR
 623       REFCNT = 1
 624       FLAGS = \\(.*POK,READONLY,pPOK\\)
 625       PV = $ADDR "Perl rules"\\\0
 626       CUR = 10
 627       LEN = \\d+
 628     GVGV::GV = $ADDR\\t"main" :: "const"
 629     FILE = ".*\\b(?i:peek\\.t)"
 630     DEPTH = 0(?:
 631     MUTEXP = $ADDR
 632     OWNER = $ADDR)?
 633     FLAGS = 0x200                               # $] < 5.009
 634     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
 635     FLAGS = 0xc                                 # $] >= 5.013 && $] < 5.015
 636     FLAGS = 0x100c                              # $] >= 5.015
 637     OUTSIDE_SEQ = 0
 638     PADLIST = 0x0
 639     OUTSIDE = 0x0 \\(null\\)');
 640
 641 do_test('isUV should show on PVMG',
 642         do { my $v = $1; $v = ~0; $v },
 643 'SV = PVMG\\($ADDR\\) at $ADDR
 644   REFCNT = 1
 645   FLAGS = \\(IOK,pIOK,IsUV\\)
 646   UV = \d+
 647   NV = 0
 648   PV = 0');
 649
 650 do_test('IO',
 651         *STDOUT{IO},
 652 'SV = $RV\\($ADDR\\) at $ADDR
 653   REFCNT = 1
 654   FLAGS = \\(ROK\\)
 655   RV = $ADDR
 656   SV = PVIO\\($ADDR\\) at $ADDR
 657     REFCNT = 3
 658     FLAGS = \\(OBJECT\\)
 659     IV = 0                                      # $] < 5.011
 660     NV = 0                                      # $] < 5.011
 661     STASH = $ADDR\s+"IO::File"
 662     IFP = $ADDR
 663     OFP = $ADDR
 664     DIRP = 0x0
 665     LINES = 0
 666     PAGE = 0
 667     PAGE_LEN = 60
 668     LINES_LEFT = 0
 669     TOP_GV = 0x0
 670     FMT_GV = 0x0
 671     BOTTOM_GV = 0x0
 672     SUBPROCESS = 0                              # $] < 5.009
 673     TYPE = \'>\'
 674     FLAGS = 0x4');
 675
 676 do_test('FORMAT',
 677         *PIE{FORMAT},
 678 'SV = $RV\\($ADDR\\) at $ADDR
 679   REFCNT = 1
 680   FLAGS = \\(ROK\\)
 681   RV = $ADDR
 682   SV = PVFM\\($ADDR\\) at $ADDR
 683     REFCNT = 2
 684     FLAGS = \\(\\)                              # $] < 5.015 || !thr
 685     FLAGS = \\(DYNFILE\\)                       # $] >= 5.015 && thr
 686     IV = 0                                      # $] < 5.009
 687     NV = 0                                      # $] < 5.009
 688 (?:    PV = 0
 689 )?    COMP_STASH = 0x0
 690     START = $ADDR ===> \\d+
 691     ROOT = $ADDR
 692     XSUB = 0x0                                  # $] < 5.009
 693     XSUBANY = 0                                 # $] < 5.009
 694     GVGV::GV = $ADDR\\t"main" :: "PIE"
 695     FILE = ".*\\b(?i:peek\\.t)"(?:
 696     DEPTH = 0)?(?:
 697     MUTEXP = $ADDR
 698     OWNER = $ADDR)?
 699     FLAGS = 0x0                                 # $] < 5.015 || !thr
 700     FLAGS = 0x1000                              # $] >= 5.015 && thr
 701     OUTSIDE_SEQ = \\d+
 702     LINES = 0                                   # $] < 5.017_003
 703     PADLIST = $ADDR
 704     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 705     OUTSIDE = $ADDR \\(MAIN\\)');
 706
 707 do_test('blessing to a class with embedded NUL characters',
 708         (bless {}, "\0::foo::\n::baz::\t::\0"),
 709 'SV = $RV\\($ADDR\\) at $ADDR
 710   REFCNT = 1
 711   FLAGS = \\(ROK\\)
 712   RV = $ADDR
 713   SV = PVHV\\($ADDR\\) at $ADDR
 714     REFCNT = [12]
 715     FLAGS = \\(OBJECT,SHAREKEYS\\)
 716     IV = 0                                      # $] < 5.009
 717     NV = 0                                      # $] < 5.009
 718     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
 719     ARRAY = $ADDR
 720     KEYS = 0
 721     FILL = 0
 722     MAX = 7', '',
 723         $] > 5.009
 724         ? $] >= 5.015
 725             ?  0
 726             : 'The hash iterator used in dump.c sets the OOK flag'
 727         : "Something causes the HV's array to become allocated");
 728
 729 do_test('ENAME on a stash',
 730         \%RWOM::,
 731 'SV = $RV\\($ADDR\\) at $ADDR
 732   REFCNT = 1
 733   FLAGS = \\(ROK\\)
 734   RV = $ADDR
 735   SV = PVHV\\($ADDR\\) at $ADDR
 736     REFCNT = 2
 737     FLAGS = \\(OOK,SHAREKEYS\\)
 738     IV = 1                                      # $] < 5.009
 739     NV = $FLOAT                                 # $] < 5.009
 740     ARRAY = $ADDR
 741     KEYS = 0
 742     FILL = 0 \(cached = 0\)
 743     MAX = 7
 744     RITER = -1
 745     EITER = 0x0
 746     RAND = $ADDR
 747     NAME = "RWOM"
 748     ENAME = "RWOM"                              # $] > 5.012
 749 ');
 750
 751 *KLANK:: = \%RWOM::;
 752
 753 do_test('ENAMEs on a stash',
 754         \%RWOM::,
 755 'SV = $RV\\($ADDR\\) at $ADDR
 756   REFCNT = 1
 757   FLAGS = \\(ROK\\)
 758   RV = $ADDR
 759   SV = PVHV\\($ADDR\\) at $ADDR
 760     REFCNT = 3
 761     FLAGS = \\(OOK,SHAREKEYS\\)
 762     IV = 1                                      # $] < 5.009
 763     NV = $FLOAT                                 # $] < 5.009
 764     ARRAY = $ADDR
 765     KEYS = 0
 766     FILL = 0 \(cached = 0\)
 767     MAX = 7
 768     RITER = -1
 769     EITER = 0x0
 770     RAND = $ADDR
 771     NAME = "RWOM"
 772     NAMECOUNT = 2                               # $] > 5.012
 773     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 774 ');
 775
 776 undef %RWOM::;
 777
 778 do_test('ENAMEs on a stash with no NAME',
 779         \%RWOM::,
 780 'SV = $RV\\($ADDR\\) at $ADDR
 781   REFCNT = 1
 782   FLAGS = \\(ROK\\)
 783   RV = $ADDR
 784   SV = PVHV\\($ADDR\\) at $ADDR
 785     REFCNT = 3
 786     FLAGS = \\(OOK,SHAREKEYS\\)                 # $] < 5.017
 787     FLAGS = \\(OOK,OVERLOAD,SHAREKEYS\\)        # $] >=5.017
 788     IV = 1                                      # $] < 5.009
 789     NV = $FLOAT                                 # $] < 5.009
 790     ARRAY = $ADDR
 791     KEYS = 0
 792     FILL = 0 \(cached = 0\)
 793     MAX = 7
 794     RITER = -1
 795     EITER = 0x0
 796     RAND = $ADDR
 797     NAMECOUNT = -3                              # $] > 5.012
 798     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 799 ');
 800
 801 my %small = ("Perl", "Rules", "Beer", "Foamy");
 802 my $b = %small;
 803 do_test('small hash',
 804         \%small,
 805 'SV = $RV\\($ADDR\\) at $ADDR
 806   REFCNT = 1
 807   FLAGS = \\(ROK\\)
 808   RV = $ADDR
 809   SV = PVHV\\($ADDR\\) at $ADDR
 810     REFCNT = 2
 811     FLAGS = \\(PADMY,SHAREKEYS\\)
 812     IV = 1                                      # $] < 5.009
 813     NV = $FLOAT                                 # $] < 5.009
 814     ARRAY = $ADDR  \\(0:[67],.*\\)
 815     hash quality = [0-9.]+%
 816     KEYS = 2
 817     FILL = [12]
 818     MAX = 7
 819 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 820     SV = PV\\($ADDR\\) at $ADDR
 821       REFCNT = 1
 822       FLAGS = \\(POK,pPOK\\)
 823       PV = $ADDR "(?:Rules|Foamy)"\\\0
 824       CUR = \d+
 825       LEN = \d+
 826 ){2}');
 827
 828 $b = keys %small;
 829
 830 do_test('small hash after keys',
 831         \%small,
 832 'SV = $RV\\($ADDR\\) at $ADDR
 833   REFCNT = 1
 834   FLAGS = \\(ROK\\)
 835   RV = $ADDR
 836   SV = PVHV\\($ADDR\\) at $ADDR
 837     REFCNT = 2
 838     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
 839     IV = 1                                      # $] < 5.009
 840     NV = $FLOAT                                 # $] < 5.009
 841     ARRAY = $ADDR  \\(0:[67],.*\\)
 842     hash quality = [0-9.]+%
 843     KEYS = 2
 844     FILL = [12] \\(cached = 0\\)
 845     MAX = 7
 846     RITER = -1
 847     EITER = 0x0
 848     RAND = $ADDR
 849 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 850     SV = PV\\($ADDR\\) at $ADDR
 851       REFCNT = 1
 852       FLAGS = \\(POK,pPOK\\)
 853       PV = $ADDR "(?:Rules|Foamy)"\\\0
 854       CUR = \d+
 855       LEN = \d+
 856 ){2}');
 857
 858 $b = %small;
 859
 860 do_test('small hash after keys and scalar',
 861         \%small,
 862 'SV = $RV\\($ADDR\\) at $ADDR
 863   REFCNT = 1
 864   FLAGS = \\(ROK\\)
 865   RV = $ADDR
 866   SV = PVHV\\($ADDR\\) at $ADDR
 867     REFCNT = 2
 868     FLAGS = \\(PADMY,OOK,SHAREKEYS\\)
 869     IV = 1                                      # $] < 5.009
 870     NV = $FLOAT                                 # $] < 5.009
 871     ARRAY = $ADDR  \\(0:[67],.*\\)
 872     hash quality = [0-9.]+%
 873     KEYS = 2
 874     FILL = ([12]) \\(cached = \1\\)
 875     MAX = 7
 876     RITER = -1
 877     EITER = 0x0
 878     RAND = $ADDR
 879 (?:    Elt "(?:Perl|Beer)" HASH = $ADDR
 880     SV = PV\\($ADDR\\) at $ADDR
 881       REFCNT = 1
 882       FLAGS = \\(POK,pPOK\\)
 883       PV = $ADDR "(?:Rules|Foamy)"\\\0
 884       CUR = \d+
 885       LEN = \d+
 886 ){2}');
 887
 888 # This should immediately start with the FILL cached correctly.
 889 my %large = (0..1999);
 890 $b = %large;
 891 do_test('large hash',
 892         \%large,
 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,OOK,SHAREKEYS\\)
 900     IV = 1                                      # $] < 5.009
 901     NV = $FLOAT                                 # $] < 5.009
 902     ARRAY = $ADDR  \\(0:\d+,.*\\)
 903     hash quality = \d+\\.\d+%
 904     KEYS = 1000
 905     FILL = (\d+) \\(cached = \1\\)
 906     MAX = 1023
 907     RITER = -1
 908     EITER = 0x0
 909     RAND = $ADDR
 910     Elt .*
 911 ');
 912
 913 SKIP: {
 914     skip "Not built with usemymalloc", 1
 915       unless $Config{usemymalloc} eq 'y';
 916     my $x = __PACKAGE__;
 917     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
 918      or diag $@;
 919 }
 920
 921 # This is more a test of fbm_compile/pp_study (non) interaction than dumping
 922 # prowess, but short of duplicating all the gubbins of this file, I can't see
 923 # a way to make a better place for it:
 924
 925 use constant {
 926     perl => 'rules',
 927     beer => 'foamy',
 928 };
 929
 930 unless ($Config{useithreads}) {
 931     # These end up as copies in pads under ithreads, which rather defeats the
 932     # the point of what we're trying to test here.
 933
 934     do_test('regular string constant', perl,
 935 'SV = PV\\($ADDR\\) at $ADDR
 936   REFCNT = 5
 937   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 938   PV = $ADDR "rules"\\\0
 939   CUR = 5
 940   LEN = \d+
 941 ');
 942
 943     eval 'index "", perl';
 944
 945     # FIXME - really this shouldn't say EVALED. It's a false posistive on
 946     # 0x40000000 being used for several things, not a flag for "I'm in a string
 947     # eval"
 948
 949     do_test('string constant now an FBM', perl,
 950 'SV = PVMG\\($ADDR\\) at $ADDR
 951   REFCNT = 5
 952   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
 953   PV = $ADDR "rules"\\\0
 954   CUR = 5
 955   LEN = \d+
 956   MAGIC = $ADDR
 957     MG_VIRTUAL = &PL_vtbl_regexp
 958     MG_TYPE = PERL_MAGIC_bm\\(B\\)
 959     MG_LEN = 256
 960     MG_PTR = $ADDR "(?:\\\\\d){256}"
 961   RARE = \d+                                    # $] < 5.019002
 962   PREVIOUS = 1                                  # $] < 5.019002
 963   USEFUL = 100
 964 ');
 965
 966     is(study perl, '', "Not allowed to study an FBM");
 967
 968     do_test('string constant still an FBM', perl,
 969 'SV = PVMG\\($ADDR\\) at $ADDR
 970   REFCNT = 5
 971   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
 972   PV = $ADDR "rules"\\\0
 973   CUR = 5
 974   LEN = \d+
 975   MAGIC = $ADDR
 976     MG_VIRTUAL = &PL_vtbl_regexp
 977     MG_TYPE = PERL_MAGIC_bm\\(B\\)
 978     MG_LEN = 256
 979     MG_PTR = $ADDR "(?:\\\\\d){256}"
 980   RARE = \d+                                    # $] < 5.019002
 981   PREVIOUS = 1                                  # $] < 5.019002
 982   USEFUL = 100
 983 ');
 984
 985     do_test('regular string constant', beer,
 986 'SV = PV\\($ADDR\\) at $ADDR
 987   REFCNT = 6
 988   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 989   PV = $ADDR "foamy"\\\0
 990   CUR = 5
 991   LEN = \d+
 992 ');
 993
 994     is(study beer, 1, "Our studies were successful");
 995
 996     do_test('string constant quite unaffected', beer, 'SV = PV\\($ADDR\\) at $ADDR
 997   REFCNT = 6
 998   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 999   PV = $ADDR "foamy"\\\0
1000   CUR = 5
1001   LEN = \d+
1002 ');
1003
1004     my $want = 'SV = PVMG\\($ADDR\\) at $ADDR
1005   REFCNT = 6
1006   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
1007   PV = $ADDR "foamy"\\\0
1008   CUR = 5
1009   LEN = \d+
1010   MAGIC = $ADDR
1011     MG_VIRTUAL = &PL_vtbl_regexp
1012     MG_TYPE = PERL_MAGIC_bm\\(B\\)
1013     MG_LEN = 256
1014     MG_PTR = $ADDR "(?:\\\\\d){256}"
1015   RARE = \d+                                    # $] < 5.019002
1016   PREVIOUS = \d+                                # $] < 5.019002
1017   USEFUL = 100
1018 ';
1019
1020     is (eval 'index "not too foamy", beer', 8, 'correct index');
1021
1022     do_test('string constant now FBMed', beer, $want);
1023
1024     my $pie = 'good';
1025
1026     is(study $pie, 1, "Our studies were successful");
1027
1028     do_test('string constant still FBMed', beer, $want);
1029
1030     do_test('second string also unaffected', $pie, 'SV = PV\\($ADDR\\) at $ADDR
1031   REFCNT = 1
1032   FLAGS = \\(PADMY,POK,pPOK\\)
1033   PV = $ADDR "good"\\\0
1034   CUR = 4
1035   LEN = \d+
1036 ');
1037 }
1038
1039 # (One block of study tests removed when study was made a no-op.)
1040
1041 {
1042     open(OUT,">peek$$") or die "Failed to open peek $$: $!";
1043     open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
1044     DeadCode();
1045     open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
1046     pass "no crash with DeadCode";
1047     close OUT;
1048 }
1049
1050 do_test('UTF-8 in a regular expression',
1051         qr/\x{100}/,
1052 'SV = IV\($ADDR\) at $ADDR
1053   REFCNT = 1
1054   FLAGS = \(ROK\)
1055   RV = $ADDR
1056   SV = REGEXP\($ADDR\) at $ADDR
1057     REFCNT = 1
1058     FLAGS = \(OBJECT,FAKE,UTF8\)
1059     PV = $ADDR "\(\?\^u:\\\\\\\\x\{100\}\)" \[UTF8 "\(\?\^u:\\\\\\\\x\{100\}\)"\]
1060     CUR = 13
1061     STASH = $ADDR       "Regexp"
1062     COMPFLAGS = 0x0 \(\)
1063     EXTFLAGS = 0x680040 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
1064     INTFLAGS = 0x0
1065     NPARENS = 0
1066     LASTPAREN = 0
1067     LASTCLOSEPAREN = 0
1068     MINLEN = 1
1069     MINLENRET = 1
1070     GOFS = 0
1071     PRE_PREFIX = 5
1072     SUBLEN = 0
1073     SUBOFFSET = 0
1074     SUBCOFFSET = 0
1075     SUBBEG = 0x0
1076     ENGINE = $ADDR
1077     MOTHER_RE = $ADDR
1078     PAREN_NAMES = 0x0
1079     SUBSTRS = $ADDR
1080     PPRIVATE = $ADDR
1081     OFFS = $ADDR
1082     QR_ANONCV = 0x0(?:
1083     SAVED_COPY = 0x0)?
1084 ');
1085
1086 { # perl #117793: Extend SvREFCNT* to work on any perl variable type
1087   my %hash;
1088   my $base_count = Devel::Peek::SvREFCNT(%hash);
1089   my $ref = \%hash;
1090   is(Devel::Peek::SvREFCNT(%hash), $base_count + 1, "SvREFCNT on non-scalar");
1091 }
1092
1093 done_testing();