This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Eliminate SVt_RV, and use SVt_IV to store plain references.
[perl5.git] / ext / Devel / Peek / t / Peek.t
diff --git a/ext/Devel/Peek/t/Peek.t b/ext/Devel/Peek/t/Peek.t
index 835166a..76118d1 100644 (file)
--- a/ext/Devel/Peek/t/Peek.t
+++ b/ext/Devel/Peek/t/Peek.t
@@ -4,15 +4,17 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require Config; import Config;
-    if ($Config{'extensions'} !~ /\bPeek\b/) {
+    if ($Config{'extensions'} !~ /\bDevel\/Peek\b/) {
         print "1..0 # Skip: Devel::Peek was not built\n";
         exit 0;
     }
 }
 
+BEGIN { require "./test.pl"; }
+
 use Devel::Peek;
 
-print "1..22\n";
+plan(48);
 
 our $DEBUG = 0;
 open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
@@ -22,6 +24,8 @@ sub do_test {
     if (open(OUT,">peek$$")) {
        open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
        Dump($_[1]);
+        print STDERR "*****\n";
+        Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
        open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
        close(OUT);
        if (open(IN, "peek$$")) {
@@ -30,13 +34,28 @@ sub do_test {
            $pattern =~ s/\$FLOAT/(?:\\d*\\.\\d+(?:e[-+]\\d+)?|\\d+)/g;
            # handle DEBUG_LEAKING_SCALARS prefix
            $pattern =~ s/^(\s*)(SV =.* at )/(?:$1ALLOCATED at .*?\n)?$1$2/mg;
+
+           $pattern =~ s/^ *\$XSUB *\n/
+               ($] < 5.009) ? "    XSUB = 0\n    XSUBANY = 0\n" : '';
+           /mge;
+           $pattern =~ s/^ *\$ROOT *\n/
+               ($] < 5.009) ? "    ROOT = 0x0\n" : '';
+           /mge;
+           $pattern =~ s/^ *\$IVNV *\n/
+               ($] < 5.009) ? "    IV = 0\n    NV = 0\n" : '';
+           /mge;
+           $pattern =~ s/\$RV/IV/g if $] >= 5.011;
+
            print $pattern, "\n" if $DEBUG;
-           my $dump = <IN>;
+           my ($dump, $dump2) = split m/\*\*\*\*\*\n/, scalar <IN>;
            print $dump, "\n"    if $DEBUG;
-           print "got:\n[\n$dump\n]\nexpected:\n[\n$pattern\n]\nnot "
-               unless $dump =~ /\A$pattern\Z/ms;
-           print "ok $_[0]\n";
+           like( $dump, qr/\A$pattern\Z/ms );
+
+            local $TODO = $dump2 =~ /OOK/ ? "The hash iterator used in dump.c sets the OOK flag" : undef;
+            is($dump2, $dump);
+
            close(IN);
+
             return $1;
        } else {
            die "$0: failed to open peek$$: !\n";
@@ -51,6 +70,10 @@ our   $b;
 my    $c;
 local $d = 0;
 
+END {
+    1 while unlink("peek$$");
+}
+
 do_test( 1,
        $a = "foo",
 'SV = PV\\($ADDR\\) at $ADDR
@@ -110,7 +133,7 @@ do_test( 7,
 'SV = PVNV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(NOK,pNOK\\)
-  IV = 0
+  IV = \d+
   NV = 789\\.(?:1(?:000+\d+)?|0999+\d+)
   PV = $ADDR "789"\\\0
   CUR = 3
@@ -131,7 +154,7 @@ do_test( 9,
 
 do_test(10,
         \$a,
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
@@ -160,12 +183,12 @@ if ($type eq 'N') {
 }
 do_test(11,
        [$b,$c],
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVAV\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(\\)
     ARRAY = $ADDR
     FILL = 1
@@ -181,12 +204,12 @@ do_test(11,
 
 do_test(12,
        {$b=>$c},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(SHAREKEYS\\)
     ARRAY = $ADDR  \\(0:7, 1:1\\)
     hash quality = 100.0%
@@ -199,27 +222,25 @@ do_test(12,
 
 do_test(13,
         sub(){@_},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = 2
     FLAGS = \\(PADMY,POK,pPOK,ANON,WEAKOUTSIDE\\)
-    IV = 0
-    NV = 0
+    $IVNV
     PROTOTYPE = ""
     COMP_STASH = $ADDR\\t"main"
     START = $ADDR ===> \\d+
     ROOT = $ADDR
-    XSUB = 0x0
-    XSUBANY = 0
+    $XSUB
     GVGV::GV = $ADDR\\t"main" :: "__ANON__[^"]*"
     FILE = ".*\\b(?i:peek\\.t)"
     DEPTH = 0
 (?:    MUTEXP = $ADDR
     OWNER = $ADDR
-)?    FLAGS = 0x404
+)?    FLAGS = 0x90
     OUTSIDE_SEQ = \\d+
     PADLIST = $ADDR
     PADNAME = $ADDR\\($ADDR\\) PAD = $ADDR\\($ADDR\\)
@@ -227,20 +248,18 @@ do_test(13,
 
 do_test(14,
         \&do_test,
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVCV\\($ADDR\\) at $ADDR
     REFCNT = (3|4)
     FLAGS = \\(\\)
-    IV = 0
-    NV = 0
+    $IVNV
     COMP_STASH = $ADDR\\t"main"
     START = $ADDR ===> \\d+
     ROOT = $ADDR
-    XSUB = 0x0
-    XSUBANY = 0
+    $XSUB
     GVGV::GV = $ADDR\\t"main" :: "do_test"
     FILE = ".*\\b(?i:peek\\.t)"
     DEPTH = 1
@@ -253,11 +272,12 @@ do_test(14,
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
+      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump2"
     OUTSIDE = $ADDR \\(MAIN\\)');
 
 do_test(15,
         qr(tic),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
@@ -271,16 +291,18 @@ do_test(15,
       MG_VIRTUAL = $ADDR
       MG_TYPE = PERL_MAGIC_qr\(r\)
       MG_OBJ = $ADDR
+        PAT = "\(\?-xism:tic\)"
+        REFCNT = 2
     STASH = $ADDR\\t"Regexp"');
 
 do_test(16,
         (bless {}, "Tac"),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(OBJECT,SHAREKEYS\\)
     STASH = $ADDR\\t"Tac"
     ARRAY = 0x0
@@ -294,13 +316,7 @@ do_test(17,
        *a,
 'SV = PVGV\\($ADDR\\) at $ADDR
   REFCNT = 5
-  FLAGS = \\(GMG,SMG,MULTI(?:,IN_PAD)?\\)
-  IV = 0
-  NV = 0
-  MAGIC = $ADDR
-    MG_VIRTUAL = &PL_vtbl_glob
-    MG_TYPE = PERL_MAGIC_glob\(\*\)
-    MG_OBJ = $ADDR
+  FLAGS = \\(MULTI(?:,IN_PAD)?\\)
   NAME = "a"
   NAMELEN = 1
   GvSTASH = $ADDR\\t"main"
@@ -341,12 +357,12 @@ do_test(18,
 if (ord('A') == 193) {
 do_test(19,
        {chr(256)=>chr(512)},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
     ARRAY = $ADDR  \\(0:7, 1:1\\)
     hash quality = 100.0%
@@ -365,12 +381,12 @@ do_test(19,
 } else {
 do_test(19,
        {chr(256)=>chr(512)},
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
   SV = PVHV\\($ADDR\\) at $ADDR
-    REFCNT = 2
+    REFCNT = 1
     FLAGS = \\(SHAREKEYS,HASKFLAGS\\)
     ARRAY = $ADDR  \\(0:7, 1:1\\)
     hash quality = 100.0%
@@ -410,6 +426,8 @@ do_test(20,
 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS
 # environment variables may be invisibly case-forced, hence the (?i:PATH)
 # C<scalar(@ARGV)> is turned into an IV on VMS hence the (?:IV)?
+# VMS is setting FAKE and READONLY flags.  What VMS uses for storing
+# ENV hashes is also not always null terminated.
 #
 do_test(21,
         $ENV{PATH}=@ARGV,  # scalar(@ARGV) is a handy known tainted value
@@ -430,23 +448,19 @@ do_test(21,
     MG_PTR = $ADDR (?:"(?i:PATH)"|=> HEf_SVKEY
     SV = PV(?:IV)?\\($ADDR\\) at $ADDR
       REFCNT = \d+
-      FLAGS = \\(TEMP,POK,pPOK\\)
+      FLAGS = \\(TEMP,POK,(?:FAKE,READONLY,)?pPOK\\)
 (?:      IV = 0
-)?      PV = $ADDR "(?i:PATH)"\\\0
+)?      PV = $ADDR "(?i:PATH)"(?:\\\0)?
       CUR = \d+
       LEN = \d+)
   MAGIC = $ADDR
     MG_VIRTUAL = &PL_vtbl_taint
     MG_TYPE = PERL_MAGIC_taint\\(t\\)');
 
-END {
-  1 while unlink("peek$$");
-}
-
 # blessed refs
 do_test(22,
        bless(\\undef, 'Foobar'),
-'SV = RV\\($ADDR\\) at $ADDR
+'SV = $RV\\($ADDR\\) at $ADDR
   REFCNT = 1
   FLAGS = \\(ROK\\)
   RV = $ADDR
@@ -463,3 +477,50 @@ do_test(22,
     CUR = 0
     LEN = 0
     STASH = $ADDR\s+"Foobar"');
+
+# Constant subroutines
+
+sub const () {
+    "Perl rules";
+}
+
+do_test(23,
+       \&const,
+'SV = $RV\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(ROK\\)
+  RV = $ADDR
+  SV = PVCV\\($ADDR\\) at $ADDR
+    REFCNT = (2)
+    FLAGS = \\(POK,pPOK,CONST\\)
+    $IVNV
+    PROTOTYPE = ""
+    COMP_STASH = 0x0
+    $ROOT
+    XSUB = $ADDR
+    XSUBANY = $ADDR \\(CONST SV\\)
+    SV = PV\\($ADDR\\) at $ADDR
+      REFCNT = 1
+      FLAGS = \\(.*POK,READONLY,pPOK\\)
+      PV = $ADDR "Perl rules"\\\0
+      CUR = 10
+      LEN = \\d+
+    GVGV::GV = $ADDR\\t"main" :: "const"
+    FILE = ".*\\b(?i:peek\\.t)"
+    DEPTH = 0
+(?:    MUTEXP = $ADDR
+    OWNER = $ADDR
+)?    FLAGS = 0xc00
+    OUTSIDE_SEQ = 0
+    PADLIST = 0x0
+    OUTSIDE = 0x0 \\(null\\)');        
+
+# isUV should show on PVMG
+do_test(24,
+       do { my $v = $1; $v = ~0; $v },
+'SV = PVMG\\($ADDR\\) at $ADDR
+  REFCNT = 1
+  FLAGS = \\(IOK,pIOK,IsUV\\)
+  UV = \d+
+  NV = 0
+  PV = 0');
Unnamed repository; edit this file 'description' to name the repository.