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 sub do_test {
  29     my $todo = $_[3];
  30     my $repeat_todo = $_[4];
  31     my $pattern = $_[2];
  32     if (open(OUT,">peek$$")) {
  33         open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
  34         Dump($_[1]);
  35         print STDERR "*****\n";
  36         Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
  37         open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
  38         close(OUT);
  39         if (open(IN, "peek$$")) {
  40             local $/;
  41             $pattern =~ s/\$ADDR/0x[[:xdigit:]]+/g;
  42             $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
  43             # handle DEBUG_LEAKING_SCALARS prefix
  44             $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
  45
  46             # Need some clear generic mechanism to eliminate (or add) lines
  47             # of dump output dependant on perl version. The (previous) use of
  48             # things like $IVNV gave the illusion that the string passed in was
  49             # a regexp into which variables were interpolated, but this wasn't
  50             # actually true as those 'variables' actually also ate the
  51             # whitespace on the line. So it seems better to mark lines that
  52             # need to be eliminated. I considered (?# ... ) and (?{ ... }),
  53             # but whilst embedded code or comment syntax would keep it as a
  54             # legitimate regexp, it still isn't true. Seems easier and clearer
  55             # things that look like comments.
  56
  57             my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/;
  58             # Could do this is in a s///mge but seems clearer like this:
  59             $pattern = join '', map {
  60                 # If we identify the version condition, take *it* out whatever
  61                 s/\s*# ($version_condition(?: && $version_condition)?)$//
  62                     ? (eval $1 ? $_ : '')
  63                     : $_ # Didn't match, so this line is in
  64             } split /^/, $pattern;
  65
  66             $pattern =~ s/\$PADMY/
  67                 ($] < 5.009) ? 'PADBUSY,PADMY' : 'PADMY';
  68             /mge;
  69             $pattern =~ s/\$PADTMP/
  70                 ($] < 5.009) ? 'PADBUSY,PADTMP' : 'PADTMP';
  71             /mge;
  72             $pattern =~ s/\$RV/
  73                 ($] < 5.011) ? 'RV' : 'IV';
  74             /mge;
  75
  76             print $pattern, "\n" if $DEBUG;
  77             my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
  78             print $dump, "\n"    if $DEBUG;
  79             like( $dump, qr/\A$pattern\Z/ms, $_[0])
  80               or note("line " . (caller)[2]);
  81
  82             local $TODO = $repeat_todo;
  83             is($dump2, $dump, "$_[0] (unchanged by dump)")
  84               or note("line " . (caller)[2]);
  85
  86             close(IN);
  87
  88             return $1;
  89         } else {
  90             die "$0: failed to open peek$$: !\n";
  91         }
  92     } else {
  93         die "$0: failed to create peek$$: $!\n";
  94     }
  95 }
  96
  97 our   $a;
  98 our   $b;
  99 my    $c;
 100 local $d = 0;
 101
 102 END {
 103     1 while unlink("peek$$");
 104 }
 105
 106 do_test('assignment of immediate constant (string)',
 107         $a = "foo",
 108 'SV = PV\\($ADDR\\) at $ADDR
 109   REFCNT = 1
 110   FLAGS = \\(POK,pPOK\\)
 111   PV = $ADDR "foo"\\\0
 112   CUR = 3
 113   LEN = \\d+'
 114        );
 115
 116 do_test('immediate constant (string)',
 117         "bar",
 118 'SV = PV\\($ADDR\\) at $ADDR
 119   REFCNT = 1
 120   FLAGS = \\(.*POK,READONLY,pPOK\\)
 121   PV = $ADDR "bar"\\\0
 122   CUR = 3
 123   LEN = \\d+');
 124
 125 do_test('assignment of immediate constant (integer)',
 126         $b = 123,
 127 'SV = IV\\($ADDR\\) at $ADDR
 128   REFCNT = 1
 129   FLAGS = \\(IOK,pIOK\\)
 130   IV = 123');
 131
 132 do_test('immediate constant (integer)',
 133         456,
 134 'SV = IV\\($ADDR\\) at $ADDR
 135   REFCNT = 1
 136   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 137   IV = 456');
 138
 139 do_test('assignment of immediate constant (integer)',
 140         $c = 456,
 141 'SV = IV\\($ADDR\\) at $ADDR
 142   REFCNT = 1
 143   FLAGS = \\($PADMY,IOK,pIOK\\)
 144   IV = 456');
 145
 146 # If perl is built with PERL_PRESERVE_IVUV then maths is done as integers
 147 # where possible and this scalar will be an IV. If NO_PERL_PRESERVE_IVUV then
 148 # maths is done in floating point always, and this scalar will be an NV.
 149 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
 150 # building subsequent regexps.
 151 my $type = do_test('result of addition',
 152         $c + $d,
 153 'SV = ([NI])V\\($ADDR\\) at $ADDR
 154   REFCNT = 1
 155   FLAGS = \\(PADTMP,\1OK,p\1OK\\)
 156   \1V = 456');
 157
 158 ($d = "789") += 0.1;
 159
 160 do_test('floating point value',
 161        $d,
 162 'SV = PVNV\\($ADDR\\) at $ADDR
 163   REFCNT = 1
 164   FLAGS = \\(NOK,pNOK\\)
 165   IV = \d+
 166   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
 167   PV = $ADDR "789"\\\0
 168   CUR = 3
 169   LEN = \\d+');
 170
 171 do_test('integer constant',
 172         0xabcd,
 173 'SV = IV\\($ADDR\\) at $ADDR
 174   REFCNT = 1
 175   FLAGS = \\(.*IOK,READONLY,pIOK\\)
 176   IV = 43981');
 177
 178 do_test('undef',
 179         undef,
 180 'SV = NULL\\(0x0\\) at $ADDR
 181   REFCNT = 1
 182   FLAGS = \\(\\)');
 183
 184 do_test('reference to scalar',
 185         \$a,
 186 'SV = $RV\\($ADDR\\) at $ADDR
 187   REFCNT = 1
 188   FLAGS = \\(ROK\\)
 189   RV = $ADDR
 190   SV = PV\\($ADDR\\) at $ADDR
 191     REFCNT = 2
 192     FLAGS = \\(POK,pPOK\\)
 193     PV = $ADDR "foo"\\\0
 194     CUR = 3
 195     LEN = \\d+');
 196
 197 my $c_pattern;
 198 if ($type eq 'N') {
 199   $c_pattern = '
 200     SV = PVNV\\($ADDR\\) at $ADDR
 201       REFCNT = 1
 202       FLAGS = \\(IOK,NOK,pIOK,pNOK\\)
 203       IV = 456
 204       NV = 456
 205       PV = 0';
 206 } else {
 207   $c_pattern = '
 208     SV = IV\\($ADDR\\) at $ADDR
 209       REFCNT = 1
 210       FLAGS = \\(IOK,pIOK\\)
 211       IV = 456';
 212 }
 213 do_test('reference to array',
 214        [$b,$c],
 215 'SV = $RV\\($ADDR\\) at $ADDR
 216   REFCNT = 1
 217   FLAGS = \\(ROK\\)
 218   RV = $ADDR
 219   SV = PVAV\\($ADDR\\) at $ADDR
 220     REFCNT = 1
 221     FLAGS = \\(\\)
 222     IV = 0                                      # $] < 5.009
 223     NV = 0                                      # $] < 5.009
 224     ARRAY = $ADDR
 225     FILL = 1
 226     MAX = 1
 227     ARYLEN = 0x0
 228     FLAGS = \\(REAL\\)
 229     Elt No. 0
 230     SV = IV\\($ADDR\\) at $ADDR
 231       REFCNT = 1
 232       FLAGS = \\(IOK,pIOK\\)
 233       IV = 123
 234     Elt No. 1' . $c_pattern);
 235
 236 do_test('reference to hash',
 237        {$b=>$c},
 238 'SV = $RV\\($ADDR\\) at $ADDR
 239   REFCNT = 1
 240   FLAGS = \\(ROK\\)
 241   RV = $ADDR
 242   SV = PVHV\\($ADDR\\) at $ADDR
 243     REFCNT = 1
 244     FLAGS = \\(SHAREKEYS\\)
 245     IV = 1                                      # $] < 5.009
 246     NV = $FLOAT                                 # $] < 5.009
 247     ARRAY = $ADDR  \\(0:7, 1:1\\)
 248     hash quality = 100.0%
 249     KEYS = 1
 250     FILL = 1
 251     MAX = 7
 252     RITER = -1
 253     EITER = 0x0
 254     Elt "123" HASH = $ADDR' . $c_pattern,
 255         '',
 256         $] > 5.009 && 'The hash iterator used in dump.c sets the OOK flag');
 257
 258 do_test('reference to anon sub with empty prototype',
 259         sub(){@_},
 260 'SV = $RV\\($ADDR\\) at $ADDR
 261   REFCNT = 1
 262   FLAGS = \\(ROK\\)
 263   RV = $ADDR
 264   SV = PVCV\\($ADDR\\) at $ADDR
 265     REFCNT = 2
 266     FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
 267     IV = 0                                      # $] < 5.009
 268     NV = 0                                      # $] < 5.009
 269     PROTOTYPE = ""
 270     COMP_STASH = $ADDR\\t"main"
 271     START = $ADDR ===> \\d+
 272     ROOT = $ADDR
 273     XSUB = 0x0                                  # $] < 5.009
 274     XSUBANY = 0                                 # $] < 5.009
 275     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
 276     FILE = ".*\\b(?i:peek\\.t)"
 277     DEPTH = 0(?:
 278     MUTEXP = $ADDR
 279     OWNER = $ADDR)?
 280     FLAGS = 0x404                               # $] < 5.009
 281     FLAGS = 0x490                               # $] >= 5.009
 282     OUTSIDE_SEQ = \\d+
 283     PADLIST = $ADDR
 284     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 285     OUTSIDE = $ADDR \\(MAIN\\)');
 286
 287 do_test('reference to named subroutine without prototype',
 288         \&do_test,
 289 'SV = $RV\\($ADDR\\) at $ADDR
 290   REFCNT = 1
 291   FLAGS = \\(ROK\\)
 292   RV = $ADDR
 293   SV = PVCV\\($ADDR\\) at $ADDR
 294     REFCNT = (3|4)
 295     FLAGS = \\(\\)
 296     IV = 0                                      # $] < 5.009
 297     NV = 0                                      # $] < 5.009
 298     COMP_STASH = $ADDR\\t"main"
 299     START = $ADDR ===> \\d+
 300     ROOT = $ADDR
 301     XSUB = 0x0                                  # $] < 5.009
 302     XSUBANY = 0                                 # $] < 5.009
 303     GVGV::GV = $ADDR\\t"main" :: "do_test"
 304     FILE = ".*\\b(?i:peek\\.t)"
 305     DEPTH = 1
 306 (?:    MUTEXP = $ADDR
 307     OWNER = $ADDR
 308 )?    FLAGS = 0x0
 309     OUTSIDE_SEQ = \\d+
 310     PADLIST = $ADDR
 311     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 312        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
 313        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
 314        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
 315       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
 316       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                       # $] < 5.009
 317       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0     # $] >= 5.009
 318       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
 319       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
 320     OUTSIDE = $ADDR \\(MAIN\\)');
 321
 322 if ($] >= 5.011) {
 323 do_test('reference to regexp',
 324         qr(tic),
 325 'SV = $RV\\($ADDR\\) at $ADDR
 326   REFCNT = 1
 327   FLAGS = \\(ROK\\)
 328   RV = $ADDR
 329   SV = REGEXP\\($ADDR\\) at $ADDR
 330     REFCNT = 1
 331     FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
 332     PV = $ADDR "\\(\\?\\^:tic\\)"
 333     CUR = 8
 334     LEN = 0
 335     STASH = $ADDR\\t"Regexp"'
 336 . ($] < 5.013 ? '' :
 337 '
 338     EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
 339     INTFLAGS = 0x0
 340     NPARENS = 0
 341     LASTPAREN = 0
 342     LASTCLOSEPAREN = 0
 343     MINLEN = 3
 344     MINLENRET = 3
 345     GOFS = 0
 346     PRE_PREFIX = 4
 347     SEEN_EVALS = 0
 348     SUBLEN = 0
 349     SUBBEG = 0x0
 350     ENGINE = $ADDR
 351     MOTHER_RE = $ADDR
 352     PAREN_NAMES = 0x0
 353     SUBSTRS = $ADDR
 354     PPRIVATE = $ADDR
 355     OFFS = $ADDR'
 356 ));
 357 } else {
 358 do_test('reference to regexp',
 359         qr(tic),
 360 'SV = $RV\\($ADDR\\) at $ADDR
 361   REFCNT = 1
 362   FLAGS = \\(ROK\\)
 363   RV = $ADDR
 364   SV = PVMG\\($ADDR\\) at $ADDR
 365     REFCNT = 1
 366     FLAGS = \\(OBJECT,SMG\\)
 367     IV = 0
 368     NV = 0
 369     PV = 0
 370     MAGIC = $ADDR
 371       MG_VIRTUAL = $ADDR
 372       MG_TYPE = PERL_MAGIC_qr\(r\)
 373       MG_OBJ = $ADDR
 374         PAT = "\(\?^:tic\)"                     # $] >= 5.009
 375         REFCNT = 2                              # $] >= 5.009
 376     STASH = $ADDR\\t"Regexp"');
 377 }
 378
 379 do_test('reference to blessed hash',
 380         (bless {}, "Tac"),
 381 'SV = $RV\\($ADDR\\) at $ADDR
 382   REFCNT = 1
 383   FLAGS = \\(ROK\\)
 384   RV = $ADDR
 385   SV = PVHV\\($ADDR\\) at $ADDR
 386     REFCNT = 1
 387     FLAGS = \\(OBJECT,SHAREKEYS\\)
 388     IV = 0                                      # $] < 5.009
 389     NV = 0                                      # $] < 5.009
 390     STASH = $ADDR\\t"Tac"
 391     ARRAY = 0x0
 392     KEYS = 0
 393     FILL = 0
 394     MAX = 7
 395     RITER = -1
 396     EITER = 0x0', '',
 397         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
 398         : "Something causes the HV's array to become allocated");
 399
 400 do_test('typeglob',
 401         *a,
 402 'SV = PVGV\\($ADDR\\) at $ADDR
 403   REFCNT = 5
 404   FLAGS = \\(MULTI(?:,IN_PAD)?\\)               # $] >= 5.009
 405   FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)       # $] < 5.009
 406   IV = 0                                        # $] < 5.009
 407   NV = 0                                        # $] < 5.009
 408   PV = 0                                        # $] < 5.009
 409   MAGIC = $ADDR                                 # $] < 5.009
 410     MG_VIRTUAL = &PL_vtbl_glob                  # $] < 5.009
 411     MG_TYPE = PERL_MAGIC_glob\(\*\)             # $] < 5.009
 412     MG_OBJ = $ADDR                              # $] < 5.009
 413   NAME = "a"
 414   NAMELEN = 1
 415   GvSTASH = $ADDR\\t"main"
 416   GP = $ADDR
 417     SV = $ADDR
 418     REFCNT = 1
 419     IO = 0x0
 420     FORM = 0x0
 421     AV = 0x0
 422     HV = 0x0
 423     CV = 0x0
 424     CVGEN = 0x0
 425     GPFLAGS = 0x0                               # $] < 5.009
 426     LINE = \\d+
 427     FILE = ".*\\b(?i:peek\\.t)"
 428     FLAGS = $ADDR
 429     EGV = $ADDR\\t"a"');
 430
 431 if (ord('A') == 193) {
 432 do_test('string with Unicode',
 433         chr(256).chr(0).chr(512),
 434 'SV = PV\\($ADDR\\) at $ADDR
 435   REFCNT = 1
 436   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 437   PV = $ADDR "\\\214\\\101\\\0\\\235\\\101"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 438   CUR = 5
 439   LEN = \\d+');
 440 } else {
 441 do_test('string with Unicode',
 442         chr(256).chr(0).chr(512),
 443 'SV = PV\\($ADDR\\) at $ADDR
 444   REFCNT = 1
 445   FLAGS = \\((?:$PADTMP,)?POK,READONLY,pPOK,UTF8\\)
 446   PV = $ADDR "\\\304\\\200\\\0\\\310\\\200"\\\0 \[UTF8 "\\\x\{100\}\\\x\{0\}\\\x\{200\}"\]
 447   CUR = 5
 448   LEN = \\d+');
 449 }
 450
 451 if (ord('A') == 193) {
 452 do_test('reference to hash containing Unicode',
 453         {chr(256)=>chr(512)},
 454 'SV = $RV\\($ADDR\\) at $ADDR
 455   REFCNT = 1
 456   FLAGS = \\(ROK\\)
 457   RV = $ADDR
 458   SV = PVHV\\($ADDR\\) at $ADDR
 459     REFCNT = 1
 460     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 461     UV = 1                                      # $] < 5.009
 462     NV = $FLOAT                                 # $] < 5.009
 463     ARRAY = $ADDR  \\(0:7, 1:1\\)
 464     hash quality = 100.0%
 465     KEYS = 1
 466     FILL = 1
 467     MAX = 7
 468     RITER = -1
 469     EITER = $ADDR
 470     Elt "\\\214\\\101" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 471     SV = PV\\($ADDR\\) at $ADDR
 472       REFCNT = 1
 473       FLAGS = \\(POK,pPOK,UTF8\\)
 474       PV = $ADDR "\\\235\\\101"\\\0 \[UTF8 "\\\x\{200\}"\]
 475       CUR = 2
 476       LEN = \\d+',
 477         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
 478         : 'sv_length has been called on the element, and cached the result in MAGIC');
 479 } else {
 480 do_test('reference to hash containing Unicode',
 481         {chr(256)=>chr(512)},
 482 'SV = $RV\\($ADDR\\) at $ADDR
 483   REFCNT = 1
 484   FLAGS = \\(ROK\\)
 485   RV = $ADDR
 486   SV = PVHV\\($ADDR\\) at $ADDR
 487     REFCNT = 1
 488     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
 489     UV = 1                                      # $] < 5.009
 490     NV = 0                                      # $] < 5.009
 491     ARRAY = $ADDR  \\(0:7, 1:1\\)
 492     hash quality = 100.0%
 493     KEYS = 1
 494     FILL = 1
 495     MAX = 7
 496     RITER = -1
 497     EITER = $ADDR
 498     Elt "\\\304\\\200" \[UTF8 "\\\x\{100\}"\] HASH = $ADDR
 499     SV = PV\\($ADDR\\) at $ADDR
 500       REFCNT = 1
 501       FLAGS = \\(POK,pPOK,UTF8\\)
 502       PV = $ADDR "\\\310\\\200"\\\0 \[UTF8 "\\\x\{200\}"\]
 503       CUR = 2
 504       LEN = \\d+', '',
 505         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
 506         : 'sv_length has been called on the element, and cached the result in MAGIC');
 507 }
 508
 509 my $x="";
 510 $x=~/.??/g;
 511 do_test('scalar with pos magic',
 512         $x,
 513 'SV = PVMG\\($ADDR\\) at $ADDR
 514   REFCNT = 1
 515   FLAGS = \\($PADMY,SMG,POK,pPOK\\)
 516   IV = 0
 517   NV = 0
 518   PV = $ADDR ""\\\0
 519   CUR = 0
 520   LEN = \d+
 521   MAGIC = $ADDR
 522     MG_VIRTUAL = &PL_vtbl_mglob
 523     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 524     MG_FLAGS = 0x01
 525       MINMATCH');
 526
 527 #
 528 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 529 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 530 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
 531 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 532 # ENV hashes is also not always null terminated.
 533 #
 534 do_test('tainted value in %ENV',
 535         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 536 'SV = PVMG\\($ADDR\\) at $ADDR
 537   REFCNT = 1
 538   FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
 539   IV = 0
 540   NV = 0
 541   PV = $ADDR "0"\\\0
 542   CUR = 1
 543   LEN = \d+
 544   MAGIC = $ADDR
 545     MG_VIRTUAL = &PL_vtbl_envelem
 546     MG_TYPE = PERL_MAGIC_envelem\\(e\\)
 547 (?:    MG_FLAGS = 0x01
 548       TAINTEDDIR
 549 )?    MG_LEN = -?\d+
 550     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
 551     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
 552       REFCNT = \d+
 553       FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
 554 (?:      IV = 0
 555 )?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
 556       CUR = \d+
 557       LEN = \d+)
 558   MAGIC = $ADDR
 559     MG_VIRTUAL = &PL_vtbl_taint
 560     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 561
 562 do_test('blessed reference',
 563         bless(\\undef, 'Foobar'),
 564 'SV = $RV\\($ADDR\\) at $ADDR
 565   REFCNT = 1
 566   FLAGS = \\(ROK\\)
 567   RV = $ADDR
 568   SV = PVMG\\($ADDR\\) at $ADDR
 569     REFCNT = 2
 570     FLAGS = \\(OBJECT,ROK\\)
 571     IV = -?\d+
 572     NV = $FLOAT
 573     RV = $ADDR
 574     SV = NULL\\(0x0\\) at $ADDR
 575       REFCNT = \d+
 576       FLAGS = \\(READONLY\\)
 577     PV = $ADDR ""
 578     CUR = 0
 579     LEN = 0
 580     STASH = $ADDR\s+"Foobar"');
 581
 582 sub const () {
 583     "Perl rules";
 584 }
 585
 586 do_test('constant subroutine',
 587         \&const,
 588 'SV = $RV\\($ADDR\\) at $ADDR
 589   REFCNT = 1
 590   FLAGS = \\(ROK\\)
 591   RV = $ADDR
 592   SV = PVCV\\($ADDR\\) at $ADDR
 593     REFCNT = (2)
 594     FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
 595     IV = 0                                      # $] < 5.009
 596     NV = 0                                      # $] < 5.009
 597     PROTOTYPE = ""
 598     COMP_STASH = 0x0
 599     ROOT = 0x0                                  # $] < 5.009
 600     XSUB = $ADDR
 601     XSUBANY = $ADDR \\(CONST SV\\)
 602     SV = PV\\($ADDR\\) at $ADDR
 603       REFCNT = 1
 604       FLAGS = \\(.*POK,READONLY,pPOK\\)
 605       PV = $ADDR "Perl rules"\\\0
 606       CUR = 10
 607       LEN = \\d+
 608     GVGV::GV = $ADDR\\t"main" :: "const"
 609     FILE = ".*\\b(?i:peek\\.t)"
 610     DEPTH = 0(?:
 611     MUTEXP = $ADDR
 612     OWNER = $ADDR)?
 613     FLAGS = 0x200                               # $] < 5.009
 614     FLAGS = 0xc00                               # $] >= 5.009 && $] < 5.013
 615     FLAGS = 0xc                                 # $] >= 5.013
 616     OUTSIDE_SEQ = 0
 617     PADLIST = 0x0
 618     OUTSIDE = 0x0 \\(null\\)');
 619
 620 do_test('isUV should show on PVMG',
 621         do { my $v = $1; $v = ~0; $v },
 622 'SV = PVMG\\($ADDR\\) at $ADDR
 623   REFCNT = 1
 624   FLAGS = \\(IOK,pIOK,IsUV\\)
 625   UV = \d+
 626   NV = 0
 627   PV = 0');
 628
 629 do_test('IO',
 630         *STDOUT{IO},
 631 'SV = $RV\\($ADDR\\) at $ADDR
 632   REFCNT = 1
 633   FLAGS = \\(ROK\\)
 634   RV = $ADDR
 635   SV = PVIO\\($ADDR\\) at $ADDR
 636     REFCNT = 3
 637     FLAGS = \\(OBJECT\\)
 638     IV = 0                                      # $] < 5.011
 639     NV = 0                                      # $] < 5.011
 640     STASH = $ADDR\s+"IO::File"
 641     IFP = $ADDR
 642     OFP = $ADDR
 643     DIRP = 0x0
 644     LINES = 0
 645     PAGE = 0
 646     PAGE_LEN = 60
 647     LINES_LEFT = 0
 648     TOP_GV = 0x0
 649     FMT_GV = 0x0
 650     BOTTOM_GV = 0x0
 651     SUBPROCESS = 0                              # $] < 5.009
 652     TYPE = \'>\'
 653     FLAGS = 0x4');
 654
 655 do_test('FORMAT',
 656         *PIE{FORMAT},
 657 'SV = $RV\\($ADDR\\) at $ADDR
 658   REFCNT = 1
 659   FLAGS = \\(ROK\\)
 660   RV = $ADDR
 661   SV = PVFM\\($ADDR\\) at $ADDR
 662     REFCNT = 2
 663     FLAGS = \\(\\)
 664     IV = 0                                      # $] < 5.009
 665     NV = 0                                      # $] < 5.009
 666 (?:    PV = 0
 667 )?    COMP_STASH = 0x0
 668     START = $ADDR ===> \\d+
 669     ROOT = $ADDR
 670     XSUB = 0x0                                  # $] < 5.009
 671     XSUBANY = 0                                 # $] < 5.009
 672     GVGV::GV = $ADDR\\t"main" :: "PIE"
 673     FILE = ".*\\b(?i:peek\\.t)"
 674 (?:    DEPTH = 0
 675     MUTEXP = $ADDR
 676     OWNER = $ADDR
 677 )?    FLAGS = 0x0
 678     OUTSIDE_SEQ = \\d+
 679     LINES = 0
 680     PADLIST = $ADDR
 681     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
 682     OUTSIDE = $ADDR \\(MAIN\\)');
 683
 684 do_test('blessing to a class with embedded NUL characters',
 685         (bless {}, "\0::foo::\n::baz::\t::\0"),
 686 'SV = $RV\\($ADDR\\) at $ADDR
 687   REFCNT = 1
 688   FLAGS = \\(ROK\\)
 689   RV = $ADDR
 690   SV = PVHV\\($ADDR\\) at $ADDR
 691     REFCNT = 1
 692     FLAGS = \\(OBJECT,SHAREKEYS\\)
 693     IV = 0                                      # $] < 5.009
 694     NV = 0                                      # $] < 5.009
 695     STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
 696     ARRAY = $ADDR
 697     KEYS = 0
 698     FILL = 0
 699     MAX = 7
 700     RITER = -1
 701     EITER = 0x0', '',
 702         $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
 703         : "Something causes the HV's array to become allocated");
 704
 705 do_test('ENAME on a stash',
 706         \%RWOM::,
 707 'SV = $RV\\($ADDR\\) at $ADDR
 708   REFCNT = 1
 709   FLAGS = \\(ROK\\)
 710   RV = $ADDR
 711   SV = PVHV\\($ADDR\\) at $ADDR
 712     REFCNT = 2
 713     FLAGS = \\(OOK,SHAREKEYS\\)
 714     IV = 1                                      # $] < 5.009
 715     NV = $FLOAT                                 # $] < 5.009
 716     ARRAY = $ADDR
 717     KEYS = 0
 718     FILL = 0
 719     MAX = 7
 720     RITER = -1
 721     EITER = 0x0
 722     NAME = "RWOM"
 723     ENAME = "RWOM"                              # $] > 5.012
 724 ');
 725
 726 *KLANK:: = \%RWOM::;
 727
 728 do_test('ENAMEs on a stash',
 729         \%RWOM::,
 730 'SV = $RV\\($ADDR\\) at $ADDR
 731   REFCNT = 1
 732   FLAGS = \\(ROK\\)
 733   RV = $ADDR
 734   SV = PVHV\\($ADDR\\) at $ADDR
 735     REFCNT = 3
 736     FLAGS = \\(OOK,SHAREKEYS\\)
 737     IV = 1                                      # $] < 5.009
 738     NV = $FLOAT                                 # $] < 5.009
 739     ARRAY = $ADDR
 740     KEYS = 0
 741     FILL = 0
 742     MAX = 7
 743     RITER = -1
 744     EITER = 0x0
 745     NAME = "RWOM"
 746     NAMECOUNT = 2                               # $] > 5.012
 747     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 748 ');
 749
 750 undef %RWOM::;
 751
 752 do_test('ENAMEs on a stash with no NAME',
 753         \%RWOM::,
 754 'SV = $RV\\($ADDR\\) at $ADDR
 755   REFCNT = 1
 756   FLAGS = \\(ROK\\)
 757   RV = $ADDR
 758   SV = PVHV\\($ADDR\\) at $ADDR
 759     REFCNT = 3
 760     FLAGS = \\(OOK,SHAREKEYS\\)
 761     IV = 1                                      # $] < 5.009
 762     NV = $FLOAT                                 # $] < 5.009
 763     ARRAY = $ADDR
 764     KEYS = 0
 765     FILL = 0
 766     MAX = 7
 767     RITER = -1
 768     EITER = 0x0
 769     NAMECOUNT = -3                              # $] > 5.012
 770     ENAME = "RWOM", "KLANK"                     # $] > 5.012
 771 ');
 772
 773 SKIP: {
 774     skip "Not built with usemymalloc", 1
 775       unless $Config{usemymalloc} eq 'y';
 776     my $x = __PACKAGE__;
 777     ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
 778      or diag $@;
 779 }
 780
 781 use constant {
 782     perl => 'rules',
 783     beer => 'foamy',
 784 };
 785
 786 unless ($Config{useithreads}) {
 787     # These end up as copies in pads under ithreads, which rather defeats the
 788     # the point of what we're trying to test here.
 789
 790     do_test('regular string constant', perl,
 791 'SV = PV\\($ADDR\\) at $ADDR
 792   REFCNT = 3
 793   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 794   PV = $ADDR "rules"\\\0
 795   CUR = 5
 796   LEN = \d+
 797 ');
 798
 799     eval 'index "", perl';
 800
 801     # FIXME - really this shouldn't say EVALED. It's a false posistive on
 802     # 0x40000000 being used for several things, not a flag for "I'm in a string
 803     # eval"
 804
 805     do_test('string constant now an FBM', perl,
 806 'SV = PVGV\\($ADDR\\) at $ADDR
 807   REFCNT = 3
 808   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
 809   PV = $ADDR "rules"\\\0
 810   CUR = 5
 811   LEN = \d+
 812   MAGIC = $ADDR
 813     MG_VIRTUAL = &PL_vtbl_bm
 814     MG_TYPE = PERL_MAGIC_bm\\(B\\)
 815   FLAGS = 0
 816   RARE = \d+
 817   PREVIOUS = 1
 818   USEFUL = 100
 819 ');
 820
 821     do_test('regular string constant', beer,
 822 'SV = PV\\($ADDR\\) at $ADDR
 823   REFCNT = 4
 824   FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
 825   PV = $ADDR "foamy"\\\0
 826   CUR = 5
 827   LEN = \d+
 828 ');
 829
 830     is(study beer, 1, "Our studies were successful");
 831
 832     do_test('string constant now studied', beer,
 833 'SV = PVMG\\($ADDR\\) at $ADDR
 834   REFCNT = 5
 835   FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
 836   IV = 0
 837   NV = 0
 838   PV = $ADDR "foamy"\\\0
 839   CUR = 5
 840   LEN = \d+
 841   MAGIC = $ADDR
 842     MG_VIRTUAL = &PL_vtbl_mglob
 843     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
 844 ');
 845 }
 846
 847 done_testing();