New XS::APItest's for sv_peek based on my DDumper work

p4raw-id: //depot/perl@34417

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 31d5628..12d0a03 100644 (file)
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -23,9 +23,10 @@ our @EXPORT = qw( print_double print_int print_long
                  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
                  sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
                  rmagical_cast rmagical_flags
+                 DPeek
 );
 
-our $VERSION = '0.14';
+our $VERSION = '0.15';
 
 use vars '$WARNINGS_ON_BOOTSTRAP';
 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 99af4a0..b81e86d 100644 (file)
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -852,6 +852,14 @@ rmagical_flags(sv)
         XSRETURN(3);
 
 void
+DPeek (sv)
+    SV   *sv
+
+  PPCODE:
+    ST (0) = newSVpv (Perl_sv_peek (sv), 0);
+    XSRETURN (1);
+
+void
 BEGIN()
     CODE:
        sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));

diff --git a/ext/XS/APItest/t/svpeek.t b/ext/XS/APItest/t/svpeek.t
new file mode 100644 (file)
index 0000000..cf66f65
--- /dev/null
+++ b/ext/XS/APItest/t/svpeek.t
@@ -0,0 +1,96 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 49;
+
+BEGIN { use_ok('XS::APItest') };
+
+$| = 1;
+
+  is (DPeek ($/),    'PVMG("\n"\0)',           '$/');
+  is (DPeek ($\),    'PVMG()',                 '$\\');
+  is (DPeek ($.),    'PVMG()',                 '$.');
+  is (DPeek ($,),    'PVMG()',                 '$,');
+  is (DPeek ($;),    'PV("\34"\0)',            '$;');
+  is (DPeek ($"),    'PV(" "\0)',              '$"');
+  is (DPeek ($:),    'PVMG(" \n-"\0)',         '$:');
+  is (DPeek ($~),    'PVMG()',                 '$~');
+  is (DPeek ($^),    'PVMG()',                 '$^');
+  is (DPeek ($=),    'PVMG()',                 '$=');
+  is (DPeek ($-),    'PVMG()',                 '$-');
+  is (DPeek ($!),    'PVMG(""\0)',             '$!');
+  is (DPeek ($?),    'PVMG()',                 '$?');
+  is (DPeek ($|),    'PVMG(1)',                        '$|');
+
+  "abc" =~ m/(b)/;     # Don't know why these magic vars have this content
+# is (DPeek ($1),    'PVMG("$"\0)',            ' $1');
+  is (DPeek ($`),    'PVMG()',                 ' $`');
+  is (DPeek ($&),    'PVMG()',                 ' $&');
+  is (DPeek ($'),    'PVMG()',                 " \$'");
+
+  is (DPeek (undef), 'SV_UNDEF',               'undef');
+  is (DPeek (1),     'IV(1)',                  'constant 1');
+  is (DPeek (""),    'PV(""\0)',               'constant ""');
+  is (DPeek (1.),    'NV(1)',                  'constant 1.');
+  is (DPeek (\1),    '\IV(1)',                 'constant \1');
+  is (DPeek (\\1),   '\\\IV(1)',               'constant \\\1');
+
+  is (DPeek (\@ARGV),  '\AV()',                '\@ARGV');
+  is (DPeek (\@INC),   '\AV()',                '\@INC');
+  is (DPeek (\%INC),   '\HV()',                '\%INC');
+  is (DPeek (*STDOUT), 'GV()',                 '*STDOUT');
+  is (DPeek (sub {}),  '\CV(__ANON__)',        'sub {}');
+
+{ our ($VAR, @VAR, %VAR);
+  open VAR, ">VAR.txt";
+  sub VAR {}
+  format VAR =
+.
+  END { unlink "VAR.txt" };
+
+  is (DPeek ( $VAR),   'UNDEF',                ' $VAR undef');
+  is (DPeek (\$VAR),   '\UNDEF',               '\$VAR undef');
+  $VAR = 1;
+  is (DPeek ($VAR),    'IV(1)',                ' $VAR 1');
+  is (DPeek (\$VAR),   '\IV(1)',               '\$VAR 1');
+  $VAR = "";
+  is (DPeek ($VAR),    'PVIV(""\0)',           ' $VAR ""');
+  is (DPeek (\$VAR),   '\PVIV(""\0)',          '\$VAR ""');
+  $VAR = "\xa8";
+  is (DPeek ($VAR),    'PVIV("\250"\0)',       ' $VAR "\xa8"');
+  is (DPeek (\$VAR),   '\PVIV("\250"\0)',      '\$VAR "\xa8"');
+  SKIP: {
+      $] <= 5.008001 and skip "UTF8 tests useless in this ancient perl version", 1;
+      $VAR = "a\x0a\x{20ac}";
+      is (DPeek ($VAR), 'PVIV("a\n\342\202\254"\0) [UTF8 "a\n\x{20ac}"]',
+                                                 ' $VAR "a\x0a\x{20ac}"');
+      }
+  $VAR = sub { "VAR" };
+  is (DPeek ($VAR),    '\CV(__ANON__)',        ' $VAR sub { "VAR" }');
+  is (DPeek (\$VAR),   '\\\CV(__ANON__)',      '\$VAR sub { "VAR" }');
+  $VAR = 0;
+
+  is (DPeek (\&VAR),   '\CV(VAR)',             '\&VAR');
+  is (DPeek ( *VAR),   'GV()',                 ' *VAR');
+
+  is (DPeek (*VAR{GLOB}),      '\GV()',        ' *VAR{GLOB}');
+like (DPeek (*VAR{SCALAR}), qr'\\PV(IV|MG)\(0\)',' *VAR{SCALAR}');
+  is (DPeek (*VAR{ARRAY}),     '\AV()',        ' *VAR{ARRAY}');
+  is (DPeek (*VAR{HASH}),      '\HV()',        ' *VAR{HASH}');
+  is (DPeek (*VAR{CODE}),      '\CV(VAR)',     ' *VAR{CODE}');
+  is (DPeek (*VAR{IO}),                '\IO()',        ' *VAR{IO}');
+  is (DPeek (*VAR{FORMAT}),$]<5.008?'SV_UNDEF':'\FM()',' *VAR{FORMAT}');
+  }
+
+1;