This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Store the BM table in mg_ptr instead of after SvCUR().
[perl5.git] / ext / Devel-Peek / t / Peek.t
index 4a4d274..c0cfa93 100644 (file)
@@ -8,12 +8,10 @@ BEGIN {
     }
 }
 
-BEGIN { require "../../t/test.pl"; }
+use Test::More;
 
 use Devel::Peek;
 
-plan(52);
-
 our $DEBUG = 0;
 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
 
@@ -50,16 +48,17 @@ sub do_test {
            # things like $IVNV gave the illusion that the string passed in was
            # a regexp into which variables were interpolated, but this wasn't
            # actually true as those 'variables' actually also ate the
-           # whitspace on the line. So it seems better to mark lines that
+           # whitespace on the line. So it seems better to mark lines that
            # need to be eliminated. I considered (?# ... ) and (?{ ... }),
            # but whilst embedded code or comment syntax would keep it as a
            # legitimate regexp, it still isn't true. Seems easier and clearer
            # things that look like comments.
 
+           my $version_condition = qr/\$] [<>]=? 5\.\d\d\d/;
            # Could do this is in a s///mge but seems clearer like this:
            $pattern = join '', map {
                # If we identify the version condition, take *it* out whatever
-               s/\s*# (\$] [<>]=? 5\.\d\d\d)$//
+               s/\s*# ($version_condition(?: && $version_condition)?)$//
                    ? (eval $1 ? $_ : '')
                    : $_ # Didn't match, so this line is in
            } split /^/, $pattern;
@@ -77,10 +76,12 @@ sub do_test {
            print $pattern, "\n" if $DEBUG;
            my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
            print $dump, "\n"    if $DEBUG;
-           like( $dump, qr/\A$pattern\Z/ms );
+           like( $dump, qr/\A$pattern\Z/ms, $_[0])
+             or note("line " . (caller)[2]);
 
             local $TODO = $repeat_todo;
-            is($dump2, $dump);
+            is($dump2, $dump, "$_[0] (unchanged by dump)")
+             or note("line " . (caller)[2]);
 
            close(IN);
 
@@ -102,7 +103,7 @@ END {
     1 while unlink("peek$$");
 }
 
-do_test( 1,
+do_test('assignment of immediate constant (string)',
        $a = "foo",
 'SV = PV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -112,7 +113,7 @@ do_test( 1,
   LEN = \\d+'
        );
 
-do_test( 2,
+do_test('immediate constant (string)',
         "bar",
 'SV = PV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -121,21 +122,21 @@ do_test( 2,
   CUR = 3
   LEN = \\d+');
 
-do_test( 3,
+do_test('assignment of immediate constant (integer)',
         $b = 123,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(IOK,pIOK\\)
   IV = 123');
 
-do_test( 4,
+do_test('immediate constant (integer)',
         456,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(.*IOK,READONLY,pIOK\\)
   IV = 456');
 
-do_test( 5,
+do_test('assignment of immediate constant (integer)',
         $c = 456,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -147,7 +148,7 @@ do_test( 5,
 # maths is done in floating point always, and this scalar will be an NV.
 # ([NI]) captures the type, referred to by \1 in this regexp and $type for
 # building subsequent regexps.
-my $type = do_test( 6,
+my $type = do_test('result of addition',
         $c + $d,
 'SV = ([NI])V\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -156,7 +157,7 @@ my $type = do_test( 6,
 
 ($d = "789") += 0.1;
 
-do_test( 7,
+do_test('floating point value',
        $d,
 'SV = PVNV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -167,20 +168,20 @@ do_test( 7,
   CUR = 3
   LEN = \\d+');
 
-do_test( 8,
+do_test('integer constant',
         0xabcd,
 'SV = IV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(.*IOK,READONLY,pIOK\\)
   IV = 43981');
 
-do_test( 9,
+do_test('undef',
         undef,
 'SV = NULL\\(0x0\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(\\)');
 
-do_test(10,
+do_test('reference to scalar',
         \$a,
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -209,7 +210,7 @@ if ($type eq 'N') {
       FLAGS = \\(IOK,pIOK\\)
       IV = 456';
 }
-do_test(11,
+do_test('reference to array',
        [$b,$c],
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -232,7 +233,7 @@ do_test(11,
       IV = 123
     Elt No. 1' . $c_pattern);
 
-do_test(12,
+do_test('reference to hash',
        {$b=>$c},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -254,7 +255,7 @@ do_test(12,
        '',
        $] > 5.009 && 'The hash iterator used in dump.c sets the OOK flag');
 
-do_test(13,
+do_test('reference to anon sub with empty prototype',
         sub(){@_},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -262,7 +263,7 @@ do_test(13,
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = 2
-    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
+    FLAGS = \\($PADMY,POK,pPOK,ANON,WEAKOUTSIDE,CVGV_RC\\)
     IV = 0                                     # $] < 5.009
     NV = 0                                     # $] < 5.009
     PROTOTYPE = ""
@@ -277,13 +278,13 @@ do_test(13,
     MUTEXP = $ADDR
     OWNER = $ADDR)?
     FLAGS = 0x404                              # $] < 5.009
-    FLAGS = 0x90                               # $] >= 5.009
+    FLAGS = 0x490                              # $] >= 5.009
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
     OUTSIDE = $ADDR \\(MAIN\\)');
 
-do_test(14,
+do_test('reference to named subroutine without prototype',
         \&do_test,
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -311,6 +312,7 @@ do_test(14,
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
+      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$version_condition"
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"                      # $] < 5.009
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0    # $] >= 5.009
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
@@ -318,22 +320,42 @@ do_test(14,
     OUTSIDE = $ADDR \\(MAIN\\)');
 
 if ($] >= 5.011) {
-do_test(15,
+do_test('reference to regexp',
         qr(tic),
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = REGEXP\\($ADDR\\) at $ADDR
-    REFCNT = 2
-    FLAGS = \\(OBJECT,POK,pPOK\\)
-    IV = 0
-    PV = $ADDR "\\(\\?-xism:tic\\)"\\\0
-    CUR = 12
-    LEN = \\d+
-    STASH = $ADDR\\t"Regexp"');
+    REFCNT = 1
+    FLAGS = \\(OBJECT,POK,FAKE,pPOK\\)
+    PV = $ADDR "\\(\\?\\^:tic\\)"
+    CUR = 8
+    LEN = 0
+    STASH = $ADDR\\t"Regexp"'
+. ($] < 5.013 ? '' :
+'
+    EXTFLAGS = 0x680000 \(CHECK_ALL,USE_INTUIT_NOML,USE_INTUIT_ML\)
+    INTFLAGS = 0x0
+    NPARENS = 0
+    LASTPAREN = 0
+    LASTCLOSEPAREN = 0
+    MINLEN = 3
+    MINLENRET = 3
+    GOFS = 0
+    PRE_PREFIX = 4
+    SEEN_EVALS = 0
+    SUBLEN = 0
+    SUBBEG = 0x0
+    ENGINE = $ADDR
+    MOTHER_RE = $ADDR
+    PAREN_NAMES = 0x0
+    SUBSTRS = $ADDR
+    PPRIVATE = $ADDR
+    OFFS = $ADDR'
+));
 } else {
-do_test(15,
+do_test('reference to regexp',
         qr(tic),
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -349,12 +371,12 @@ do_test(15,
       MG_VIRTUAL = $ADDR
       MG_TYPE = PERL_MAGIC_qr\(r\)
       MG_OBJ = $ADDR
-        PAT = "\(\?-xism:tic\)"                        # $] >= 5.009
+        PAT = "\(\?^:tic\)"                    # $] >= 5.009
         REFCNT = 2                             # $] >= 5.009
     STASH = $ADDR\\t"Regexp"');
 }
 
-do_test(16,
+do_test('reference to blessed hash',
         (bless {}, "Tac"),
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -375,7 +397,7 @@ do_test(16,
        $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
        : "Something causes the HV's array to become allocated");
 
-do_test(17,
+do_test('typeglob',
        *a,
 'SV = PVGV\\($ADDR\\) at $ADDR
   REFCNT = 5
@@ -407,7 +429,7 @@ do_test(17,
     EGV = $ADDR\\t"a"');
 
 if (ord('A') == 193) {
-do_test(18,
+do_test('string with Unicode',
        chr(256).chr(0).chr(512),
 'SV = PV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -416,7 +438,7 @@ do_test(18,
   CUR = 5
   LEN = \\d+');
 } else {
-do_test(18,
+do_test('string with Unicode',
        chr(256).chr(0).chr(512),
 'SV = PV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -427,7 +449,7 @@ do_test(18,
 }
 
 if (ord('A') == 193) {
-do_test(19,
+do_test('reference to hash containing Unicode',
        {chr(256)=>chr(512)},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -455,7 +477,7 @@ do_test(19,
        $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
        : 'sv_length has been called on the element, and cached the result in MAGIC');
 } else {
-do_test(19,
+do_test('reference to hash containing Unicode',
        {chr(256)=>chr(512)},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -486,7 +508,7 @@ do_test(19,
 
 my $x="";
 $x=~/.??/g;
-do_test(20,
+do_test('scalar with pos magic',
         $x,
 'SV = PVMG\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -509,7 +531,7 @@ do_test(20,
 # VMS is setting FAKE and READONLY flags.  What VMS uses for storing
 # ENV hashes is also not always null terminated.
 #
-do_test(21,
+do_test('tainted value in %ENV',
         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
 'SV = PVMG\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -537,8 +559,7 @@ do_test(21,
     MG_VIRTUAL = &PL_vtbl_taint
     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 
-# blessed refs
-do_test(22,
+do_test('blessed reference',
        bless(\\undef, 'Foobar'),
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -558,13 +579,11 @@ do_test(22,
     LEN = 0
     STASH = $ADDR\s+"Foobar"');
 
-# Constant subroutines
-
 sub const () {
     "Perl rules";
 }
 
-do_test(23,
+do_test('constant subroutine',
        \&const,
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -572,7 +591,7 @@ do_test(23,
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (2)
-    FLAGS = \\(POK,pPOK,CONST\\)
+    FLAGS = \\(POK,pPOK,CONST,ISXSUB\\)
     IV = 0                                     # $] < 5.009
     NV = 0                                     # $] < 5.009
     PROTOTYPE = ""
@@ -592,13 +611,13 @@ do_test(23,
     MUTEXP = $ADDR
     OWNER = $ADDR)?
     FLAGS = 0x200                              # $] < 5.009
-    FLAGS = 0xc00                              # $] >= 5.009
+    FLAGS = 0xc00                              # $] >= 5.009 && $] < 5.013
+    FLAGS = 0xc                                        # $] >= 5.013
     OUTSIDE_SEQ = 0
     PADLIST = 0x0
     OUTSIDE = 0x0 \\(null\\)');        
 
-# isUV should show on PVMG
-do_test(24,
+do_test('isUV should show on PVMG',
        do { my $v = $1; $v = ~0; $v },
 'SV = PVMG\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -607,7 +626,7 @@ do_test(24,
   NV = 0
   PV = 0');
 
-do_test(25,
+do_test('IO',
        *STDOUT{IO},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -616,9 +635,9 @@ do_test(25,
   SV = PVIO\\($ADDR\\) at $ADDR
     REFCNT = 3
     FLAGS = \\(OBJECT\\)
-    IV = 0
+    IV = 0                                     # $] < 5.011
     NV = 0                                     # $] < 5.011
-    STASH = $ADDR\s+"IO::Handle"
+    STASH = $ADDR\s+"IO::File"
     IFP = $ADDR
     OFP = $ADDR
     DIRP = 0x0
@@ -631,9 +650,9 @@ do_test(25,
     BOTTOM_GV = 0x0
     SUBPROCESS = 0                             # $] < 5.009
     TYPE = \'>\'
-    FLAGS = 0x0');
+    FLAGS = 0x4');
 
-do_test(26,
+do_test('FORMAT',
        *PIE{FORMAT},
 'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
@@ -661,3 +680,208 @@ do_test(26,
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
     OUTSIDE = $ADDR \\(MAIN\\)');
+
+do_test('blessing to a class with embedded NUL characters',
+        (bless {}, "\0::foo::\n::baz::\t::\0"),
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = PVHV\\($ADDR\\) at $ADDR
+    REFCNT = 1
+    FLAGS = \\(OBJECT,SHAREKEYS\\)
+    IV = 0                                     # $] < 5.009
+    NV = 0                                     # $] < 5.009
+    STASH = $ADDR\\t"\\\\0::foo::\\\\n::baz::\\\\t::\\\\0"
+    ARRAY = $ADDR
+    KEYS = 0
+    FILL = 0
+    MAX = 7
+    RITER = -1
+    EITER = 0x0', '',
+       $] > 5.009 ? 'The hash iterator used in dump.c sets the OOK flag'
+       : "Something causes the HV's array to become allocated");
+
+do_test('ENAME on a stash',
+        \%RWOM::,
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = PVHV\\($ADDR\\) at $ADDR
+    REFCNT = 2
+    FLAGS = \\(OOK,SHAREKEYS\\)
+    IV = 1                                     # $] < 5.009
+    NV = $FLOAT                                        # $] < 5.009
+    ARRAY = $ADDR
+    KEYS = 0
+    FILL = 0
+    MAX = 7
+    RITER = -1
+    EITER = 0x0
+    NAME = "RWOM"
+    ENAME = "RWOM"                             # $] > 5.012
+');
+
+*KLANK:: = \%RWOM::;
+
+do_test('ENAMEs on a stash',
+        \%RWOM::,
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = PVHV\\($ADDR\\) at $ADDR
+    REFCNT = 3
+    FLAGS = \\(OOK,SHAREKEYS\\)
+    IV = 1                                     # $] < 5.009
+    NV = $FLOAT                                        # $] < 5.009
+    ARRAY = $ADDR
+    KEYS = 0
+    FILL = 0
+    MAX = 7
+    RITER = -1
+    EITER = 0x0
+    NAME = "RWOM"
+    NAMECOUNT = 2                              # $] > 5.012
+    ENAME = "RWOM", "KLANK"                    # $] > 5.012
+');
+
+undef %RWOM::;
+
+do_test('ENAMEs on a stash with no NAME',
+        \%RWOM::,
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = PVHV\\($ADDR\\) at $ADDR
+    REFCNT = 3
+    FLAGS = \\(OOK,SHAREKEYS\\)
+    IV = 1                                     # $] < 5.009
+    NV = $FLOAT                                        # $] < 5.009
+    ARRAY = $ADDR
+    KEYS = 0
+    FILL = 0
+    MAX = 7
+    RITER = -1
+    EITER = 0x0
+    NAMECOUNT = -3                             # $] > 5.012
+    ENAME = "RWOM", "KLANK"                    # $] > 5.012
+');
+
+SKIP: {
+    skip "Not built with usemymalloc", 1
+      unless $Config{usemymalloc} eq 'y';
+    my $x = __PACKAGE__;
+    ok eval { fill_mstats($x); 1 }, 'fill_mstats on COW scalar'
+     or diag $@;
+}
+
+# This is more a test of fbm_compile/pp_study (non) interaction than dumping
+# prowess, but short of duplicating all the gubbins of this file, I can't see
+# a way to make a better place for it:
+
+use constant {
+    perl => 'rules',
+    beer => 'foamy',
+};
+
+unless ($Config{useithreads}) {
+    # These end up as copies in pads under ithreads, which rather defeats the
+    # the point of what we're trying to test here.
+
+    do_test('regular string constant', perl,
+'SV = PV\\($ADDR\\) at $ADDR
+  REFCNT = 5
+  FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
+  PV = $ADDR "rules"\\\0
+  CUR = 5
+  LEN = \d+
+');
+
+    eval 'index "", perl';
+
+    # FIXME - really this shouldn't say EVALED. It's a false posistive on
+    # 0x40000000 being used for several things, not a flag for "I'm in a string
+    # eval"
+
+    do_test('string constant now an FBM', perl,
+'SV = PVGV\\($ADDR\\) at $ADDR
+  REFCNT = 5
+  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
+  PV = $ADDR "rules"\\\0
+  CUR = 5
+  LEN = \d+
+  MAGIC = $ADDR
+    MG_VIRTUAL = &PL_vtbl_bm
+    MG_TYPE = PERL_MAGIC_bm\\(B\\)
+    MG_LEN = 256
+    MG_PTR = $ADDR "(?:\\\\\d){256}"
+  RARE = \d+
+  PREVIOUS = 1
+  USEFUL = 100
+');
+
+    is(study perl, '', "Not allowed to study an FBM");
+
+    do_test('string constant still an FBM', perl,
+'SV = PVGV\\($ADDR\\) at $ADDR
+  REFCNT = 5
+  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,VALID,EVALED\\)
+  PV = $ADDR "rules"\\\0
+  CUR = 5
+  LEN = \d+
+  MAGIC = $ADDR
+    MG_VIRTUAL = &PL_vtbl_bm
+    MG_TYPE = PERL_MAGIC_bm\\(B\\)
+    MG_LEN = 256
+    MG_PTR = $ADDR "(?:\\\\\d){256}"
+  RARE = \d+
+  PREVIOUS = 1
+  USEFUL = 100
+');
+
+    do_test('regular string constant', beer,
+'SV = PV\\($ADDR\\) at $ADDR
+  REFCNT = 5
+  FLAGS = \\(PADMY,POK,READONLY,pPOK\\)
+  PV = $ADDR "foamy"\\\0
+  CUR = 5
+  LEN = \d+
+');
+
+    is(study beer, 1, "Our studies were successful");
+
+    do_test('string constant now studied', beer,
+'SV = PVMG\\($ADDR\\) at $ADDR
+  REFCNT = 6
+  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
+  IV = 0
+  NV = 0
+  PV = $ADDR "foamy"\\\0
+  CUR = 5
+  LEN = \d+
+  MAGIC = $ADDR
+    MG_VIRTUAL = &PL_vtbl_mglob
+    MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
+');
+
+    is (eval 'index "not too foamy", beer', 8, 'correct index');
+
+    do_test('string constant still studied', beer,
+'SV = PVMG\\($ADDR\\) at $ADDR
+  REFCNT = 6
+  FLAGS = \\(PADMY,SMG,POK,READONLY,pPOK,SCREAM\\)
+  IV = 0
+  NV = 0
+  PV = $ADDR "foamy"\\\0
+  CUR = 5
+  LEN = \d+
+  MAGIC = $ADDR
+    MG_VIRTUAL = &PL_vtbl_mglob
+    MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
+');
+}
+
+done_testing();