From f9c176361812c812337c3bbb31fab20482edbede Mon Sep 17 00:00:00 2001
From: "H.Merijn Brand" <h.m.brand@xs4all.nl>
Date: Thu, 25 Sep 2008 12:54:16 +0000
Subject: [PATCH 1/1] New XS::APItest's for sv_peek based on my DDumper work

p4raw-id: //depot/perl@34417
---
 ext/XS/APItest/APItest.pm |  3 +-
 ext/XS/APItest/APItest.xs |  8 ++++
 ext/XS/APItest/t/svpeek.t | 96 +++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 106 insertions(+), 1 deletion(-)
 create mode 100644 ext/XS/APItest/t/svpeek.t

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 31d5628..12d0a03 100644
--- 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
--- 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
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;
-- 
1.8.3.1