Upgrade to Devel::PPPort 3.14_04

p4raw-id: //depot/perl@34669

9 files changed, 428 insertions, 13 deletions

diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes
index f08dae4d3e..7b985dfcf7 100755
--- a/ext/Devel/PPPort/Changes
+++ b/ext/Devel/PPPort/Changes
@@ -1,3 +1,33 @@
+3.14_04 - 2008-10-30
+
+    * added support for the following API
+        isALNUMC  [depend]
+        isASCII
+        isBLANK
+        isCNTRL
+        isGRAPH
+        isPRINT
+        isPSXSPC
+        isPUNCT
+        isXDIGIT
+        PERL_PV_ESCAPE_ALL
+        PERL_PV_ESCAPE_FIRSTCHAR
+        PERL_PV_ESCAPE_NOBACKSLASH
+        PERL_PV_ESCAPE_NOCLEAR
+        PERL_PV_ESCAPE_QUOTE
+        PERL_PV_ESCAPE_RE
+        PERL_PV_ESCAPE_UNI
+        PERL_PV_ESCAPE_UNI_DETECT
+        PERL_PV_PRETTY_DUMP
+        PERL_PV_PRETTY_ELLIPSES
+        PERL_PV_PRETTY_LTGT
+        PERL_PV_PRETTY_NOCLEAR
+        PERL_PV_PRETTY_QUOTE
+        PERL_PV_PRETTY_REGPROP
+        pv_display
+        pv_escape
+        pv_pretty
+
 3.14_03 - 2008-10-21
 
     * fix C++ compilation issue with last release
diff --git a/ext/Devel/PPPort/PPPort_pm.PL b/ext/Devel/PPPort/PPPort_pm.PL
index 1420b64328..321b74716c 100644
--- a/ext/Devel/PPPort/PPPort_pm.PL
+++ b/ext/Devel/PPPort/PPPort_pm.PL
@@ -4,9 +4,9 @@
 #
 ################################################################################
 #
-#  $Revision: 62 $
+#  $Revision: 63 $
 #  $Author: mhx $
-#  $Date: 2008/10/21 23:12:30 +0200 $
+#  $Date: 2008/10/30 01:47:31 +0100 $
 #
 ################################################################################
 #
@@ -372,9 +372,9 @@ __DATA__
 #
 ################################################################################
 #
-#  $Revision: 62 $
+#  $Revision: 63 $
 #  $Author: mhx $
-#  $Date: 2008/10/21 23:12:30 +0200 $
+#  $Date: 2008/10/30 01:47:31 +0100 $
 #
 ################################################################################
 #
@@ -535,7 +535,7 @@ package Devel::PPPort;
 use strict;
 use vars qw($VERSION $data);
 
-$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.14_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+$VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.14_04 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 
 sub _init_data
 {
@@ -656,6 +656,8 @@ __DATA__
 
 %include strlfuncs
 
+%include pv_tools
+
 #endif /* _P_P_PORTABILITY_H_ */
 
 /* End of File ppport.h */
diff --git a/ext/Devel/PPPort/parts/apicheck.pl b/ext/Devel/PPPort/parts/apicheck.pl
index dedc41a637..99063e498b 100644
--- a/ext/Devel/PPPort/parts/apicheck.pl
+++ b/ext/Devel/PPPort/parts/apicheck.pl
@@ -5,9 +5,9 @@
 #
 ################################################################################
 #
-#  $Revision: 32 $
+#  $Revision: 33 $
 #  $Author: mhx $
-#  $Date: 2008/10/12 20:50:38 +0200 $
+#  $Date: 2008/10/30 01:47:30 +0100 $
 #
 ################################################################################
 #
@@ -157,6 +157,9 @@ print OUT <<HEAD;
 #define NEED_newCONSTSUB
 #define NEED_newRV_noinc
 #define NEED_newSVpvn_share
+#define NEED_pv_display
+#define NEED_pv_escape
+#define NEED_pv_pretty
 #define NEED_sv_2pv_flags
 #define NEED_sv_2pvbyte
 #define NEED_sv_catpvf_mg
diff --git a/ext/Devel/PPPort/parts/inc/misc b/ext/Devel/PPPort/parts/inc/misc
index 6f3a7cf122..ac09a548a7 100644
--- a/ext/Devel/PPPort/parts/inc/misc
+++ b/ext/Devel/PPPort/parts/inc/misc
@@ -1,8 +1,8 @@
 ################################################################################
 ##
-##  $Revision: 47 $
+##  $Revision: 48 $
 ##  $Author: mhx $
-##  $Date: 2008/10/21 23:14:09 +0200 $
+##  $Date: 2008/10/30 01:46:33 +0100 $
 ##
 ################################################################################
 ##
@@ -250,6 +250,34 @@ typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);
 
 #endif
 
+__UNDEFINED__ isPSXSPC(c)	(isSPACE(c) || (c) == '\v')
+__UNDEFINED__ isBLANK(c)	((c) == ' ' || (c) == '\t')
+#ifdef EBCDIC
+__UNDEFINED__ isALNUMC(c)	isalnum(c)
+__UNDEFINED__ isASCII(c)	isascii(c)
+__UNDEFINED__ isCNTRL(c)	iscntrl(c)
+__UNDEFINED__ isGRAPH(c)	isgraph(c)
+__UNDEFINED__ isPRINT(c)	isprint(c)
+__UNDEFINED__ isPUNCT(c)	ispunct(c)
+__UNDEFINED__ isXDIGIT(c)	isxdigit(c)
+#else
+# if { VERSION < 5.10.0 }
+/* Hint: isPRINT
+ * The implementation in older perl versions includes all of the
+ * isSPACE() characters, which is wrong. The version provided by
+ * Devel::PPPort always overrides a present buggy version.
+ */
+#  undef isPRINT
+# endif
+__UNDEFINED__ isALNUMC(c)	(isALPHA(c) || isDIGIT(c))
+__UNDEFINED__ isASCII(c)	((c) <= 127)
+__UNDEFINED__ isCNTRL(c)	((c) < ' ' || (c) == 127)
+__UNDEFINED__ isGRAPH(c)	(isALNUM(c) || isPUNCT(c))
+__UNDEFINED__ isPRINT(c)	(((c) >= 32 && (c) < 127))
+__UNDEFINED__ isPUNCT(c)	(((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64)  || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
+__UNDEFINED__ isXDIGIT(c)	(isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
+#endif
+
 =xsmisc
 
 XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
diff --git a/ext/Devel/PPPort/parts/inc/pv_tools b/ext/Devel/PPPort/parts/inc/pv_tools
new file mode 100644
index 0000000000..8a31130743
--- /dev/null
+++ b/ext/Devel/PPPort/parts/inc/pv_tools
@@ -0,0 +1,281 @@
+################################################################################
+##
+##  $Revision: 3 $
+##  $Author: mhx $
+##  $Date: 2008/10/30 19:42:36 +0100 $
+##
+################################################################################
+##
+##  Version 3.x, Copyright (C) 2004-2008, Marcus Holland-Moritz.
+##  Version 2.x, Copyright (C) 2001, Paul Marquess.
+##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
+##
+##  This program is free software; you can redistribute it and/or
+##  modify it under the same terms as Perl itself.
+##
+################################################################################
+
+=provides
+
+__UNDEFINED__
+pv_escape
+pv_pretty
+pv_display
+
+=implementation
+
+__UNDEFINED__ PERL_PV_ESCAPE_QUOTE		0x0001
+__UNDEFINED__ PERL_PV_PRETTY_QUOTE		PERL_PV_ESCAPE_QUOTE
+__UNDEFINED__ PERL_PV_PRETTY_ELLIPSES		0x0002
+__UNDEFINED__ PERL_PV_PRETTY_LTGT		0x0004
+__UNDEFINED__ PERL_PV_ESCAPE_FIRSTCHAR		0x0008
+__UNDEFINED__ PERL_PV_ESCAPE_UNI		0x0100
+__UNDEFINED__ PERL_PV_ESCAPE_UNI_DETECT		0x0200
+__UNDEFINED__ PERL_PV_ESCAPE_ALL		0x1000
+__UNDEFINED__ PERL_PV_ESCAPE_NOBACKSLASH	0x2000
+__UNDEFINED__ PERL_PV_ESCAPE_NOCLEAR		0x4000
+__UNDEFINED__ PERL_PV_ESCAPE_RE			0x8000
+__UNDEFINED__ PERL_PV_PRETTY_NOCLEAR		PERL_PV_ESCAPE_NOCLEAR
+
+__UNDEFINED__ PERL_PV_PRETTY_DUMP		PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
+__UNDEFINED__ PERL_PV_PRETTY_REGPROP		PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
+
+/* Hint: pv_escape
+ * Note that unicode functionality is only backported to
+ * those perl versions that support it. For older perl
+ * versions, the implementation will fall back to bytes.
+ */
+
+#ifndef pv_escape
+#if { NEED pv_escape }
+
+char *
+pv_escape(pTHX_ SV *dsv, char const * const str,
+  const STRLEN count, const STRLEN max,
+  STRLEN * const escaped, const U32 flags)
+{
+    const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\';
+    const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc;
+    char octbuf[32] = "%123456789ABCDF";
+    STRLEN wrote = 0;
+    STRLEN chsize = 0;
+    STRLEN readsize = 1;
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+    bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0;
+#endif
+    const char *pv  = str;
+    const char * const end = pv + count;
+    octbuf[0] = esc;
+
+    if (!(flags & PERL_PV_ESCAPE_NOCLEAR))
+	sv_setpvs(dsv, "");
+
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+    if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count))
+        isuni = 1;
+#endif
+
+    for (; pv < end && (!max || wrote < max) ; pv += readsize) {
+        const UV u =
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+		     isuni ? utf8_to_uvchr((U8*)pv, &readsize) :
+#endif
+			     (U8)*pv;
+        const U8 c = (U8)u & 0xFF;
+
+        if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) {
+            if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
+                chsize = my_snprintf(octbuf, sizeof octbuf,
+                                      "%"UVxf, u);
+            else
+                chsize = my_snprintf(octbuf, sizeof octbuf,
+                                      "%cx{%"UVxf"}", esc, u);
+        } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) {
+            chsize = 1;
+        } else {
+            if (c == dq || c == esc || !isPRINT(c)) {
+	        chsize = 2;
+                switch (c) {
+		case '\\' : /* fallthrough */
+		case '%'  : if (c == esc)
+		                octbuf[1] = esc;
+		            else
+		                chsize = 1;
+		            break;
+		case '\v' : octbuf[1] = 'v'; break;
+		case '\t' : octbuf[1] = 't'; break;
+		case '\r' : octbuf[1] = 'r'; break;
+		case '\n' : octbuf[1] = 'n'; break;
+		case '\f' : octbuf[1] = 'f'; break;
+                case '"'  : if (dq == '"')
+				octbuf[1] = '"';
+			    else
+				chsize = 1;
+			    break;
+		default:    chsize = my_snprintf(octbuf, sizeof octbuf,
+				pv < end && isDIGIT((U8)*(pv+readsize))
+				? "%c%03o" : "%c%o", esc, c);
+                }
+            } else {
+                chsize = 1;
+            }
+	}
+	if (max && wrote + chsize > max) {
+	    break;
+        } else if (chsize > 1) {
+            sv_catpvn(dsv, octbuf, chsize);
+            wrote += chsize;
+	} else {
+	    char tmp[2];
+	    my_snprintf(tmp, sizeof tmp, "%c", c);
+            sv_catpvn(dsv, tmp, 1);
+	    wrote++;
+	}
+        if (flags & PERL_PV_ESCAPE_FIRSTCHAR)
+            break;
+    }
+    if (escaped != NULL)
+        *escaped= pv - str;
+    return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+#ifndef pv_pretty
+#if { NEED pv_pretty }
+
+char *
+pv_pretty(pTHX_ SV *dsv, char const * const str, const STRLEN count,
+  const STRLEN max, char const * const start_color, char const * const end_color,
+  const U32 flags)
+{
+    const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%';
+    STRLEN escaped;
+
+    if (!(flags & PERL_PV_PRETTY_NOCLEAR))
+	sv_setpvs(dsv, "");
+
+    if (dq == '"')
+        sv_catpvs(dsv, "\"");
+    else if (flags & PERL_PV_PRETTY_LTGT)
+        sv_catpvs(dsv, "<");
+
+    if (start_color != NULL)
+        sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color));
+
+    pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR);
+
+    if (end_color != NULL)
+        sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color));
+
+    if (dq == '"')
+	sv_catpvs(dsv, "\"");
+    else if (flags & PERL_PV_PRETTY_LTGT)
+        sv_catpvs(dsv, ">");
+
+    if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count)
+	sv_catpvs(dsv, "...");
+
+    return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+#ifndef pv_display
+#if { NEED pv_display }
+
+char *
+pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
+{
+    pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP);
+    if (len > cur && pv[cur] == '\0')
+	sv_catpvs(dsv, "\\0");
+    return SvPVX(dsv);
+}
+
+#endif
+#endif
+
+=xsinit
+
+#define NEED_pv_escape
+#define NEED_pv_pretty
+#define NEED_pv_display
+
+=xsubs
+
+void
+pv_escape_can_unicode()
+	PPCODE:
+#if defined(is_utf8_string) && defined(utf8_to_uvchr)
+		XSRETURN_YES;
+#else
+		XSRETURN_NO;
+#endif
+
+void
+pv_pretty()
+	PREINIT:
+		char *rv;
+	PPCODE:
+		EXTEND(SP, 8);
+		ST(0) = sv_newmortal();
+		rv = pv_pretty(ST(0), "foobarbaz",
+				9, 40, NULL, NULL, 0);
+		ST(1) = sv_2mortal(newSVpv(rv, 0));
+		ST(2) = sv_newmortal();
+		rv = pv_pretty(ST(2), "pv_p\retty\n",
+				10, 40, "left", "right", PERL_PV_PRETTY_LTGT);
+		ST(3) = sv_2mortal(newSVpv(rv, 0));
+		ST(4) = sv_newmortal();
+		rv = pv_pretty(ST(4), "N\303\275 Batter\303\255",
+				16, 20, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT);
+		ST(5) = sv_2mortal(newSVpv(rv, 0));
+		ST(6) = sv_newmortal();
+		rv = pv_pretty(ST(6), "\303\201g\303\246tis Byrjun",
+				16, 20, NULL, NULL, PERL_PV_ESCAPE_UNI_DETECT|PERL_PV_PRETTY_ELLIPSES);
+		ST(7) = sv_2mortal(newSVpv(rv, 0));
+		XSRETURN(8);
+
+void
+pv_display()
+	PREINIT:
+		char *rv;
+	PPCODE:
+		EXTEND(SP, 4);
+		ST(0) = sv_newmortal();
+		rv = pv_display(ST(0), "foob\0rbaz", 9, 10, 20);
+		ST(1) = sv_2mortal(newSVpv(rv, 0));
+		ST(2) = sv_newmortal();
+		rv = pv_display(ST(2), "pv_display", 10, 11, 5);
+		ST(3) = sv_2mortal(newSVpv(rv, 0));
+		XSRETURN(4);
+
+=tests plan => 13
+
+my $uni = &Devel::PPPort::pv_escape_can_unicode();
+
+# sanity check
+ok($uni ? $] >= 5.006 : $] < 5.008);
+
+my @r;
+
+@r = &Devel::PPPort::pv_pretty();
+ok($r[0], $r[1]);
+ok($r[0], "foobarbaz");
+ok($r[2], $r[3]);
+ok($r[2], '<leftpv_p\retty\nright>');
+ok($r[4], $r[5]);
+ok($r[4], $uni ? 'N\375 Batter\355\0' : 'N\303\275 Batter\303');
+ok($r[6], $r[7]);
+ok($r[6], $uni ? '\\301g\\346tis Byrjun...' : '\303\201g\303\246tis...');
+
+@r = &Devel::PPPort::pv_display();
+ok($r[0], $r[1]);
+ok($r[0], '"foob\0rbaz"\0');
+ok($r[2], $r[3]);
+ok($r[2] eq '"pv_di"...\0' ||
+   $r[2] eq '"pv_d"...\0');  # some perl implementations are broken... :(
+
diff --git a/ext/Devel/PPPort/parts/todo/5006000 b/ext/Devel/PPPort/parts/todo/5006000
index 146fb5fbbc..86f24e2b02 100644
--- a/ext/Devel/PPPort/parts/todo/5006000
+++ b/ext/Devel/PPPort/parts/todo/5006000
@@ -100,7 +100,6 @@ new_numeric                    # U (perl_new_numeric)
 op_dump                        # U
 perl_parse                     # E (perl_parse)
 pmop_dump                      # U
-pv_display                     # U
 re_intuit_string               # U
 reginitcolors                  # U
 require_pv                     # U (perl_require_pv)
diff --git a/ext/Devel/PPPort/parts/todo/5009004 b/ext/Devel/PPPort/parts/todo/5009004
index a9d57b7292..0d6b7d5051 100644
--- a/ext/Devel/PPPort/parts/todo/5009004
+++ b/ext/Devel/PPPort/parts/todo/5009004
@@ -3,8 +3,6 @@ PerlIO_context_layers          # U
 gv_name_set                    # U
 my_vsnprintf                   # U
 newXS_flags                    # U
-pv_escape                      # U
-pv_pretty                      # U
 regclass_swash                 # E (Perl_regclass_swash)
 sv_does                        # U
 sv_usepvn_flags                # U
diff --git a/ext/Devel/PPPort/soak b/ext/Devel/PPPort/soak
index 11163926f1..8e99759236 100644
--- a/ext/Devel/PPPort/soak
+++ b/ext/Devel/PPPort/soak
@@ -33,7 +33,7 @@ use File::Find;
 use List::Util qw(max);
 use Config;
 
-my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.14_03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+my $VERSION = do { my @r = '$Snapshot: /Devel-PPPort/3.14_04 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
 
 $| = 1;
 my %OPT = (
diff --git a/ext/Devel/PPPort/t/pv_tools.t b/ext/Devel/PPPort/t/pv_tools.t
new file mode 100644
index 0000000000..61b0f1462b
--- /dev/null
+++ b/ext/Devel/PPPort/t/pv_tools.t
@@ -0,0 +1,74 @@
+################################################################################
+#
+#            !!!!!   Do NOT edit this file directly!   !!!!!
+#
+#            Edit mktests.PL and/or parts/inc/pv_tools instead.
+#
+#  This file was automatically generated from the definition files in the
+#  parts/inc/ subdirectory by mktests.PL. To learn more about how all this
+#  works, please read the F<HACKERS> file that came with this distribution.
+#
+################################################################################
+
+BEGIN {
+  if ($ENV{'PERL_CORE'}) {
+    chdir 't' if -d 't';
+    @INC = ('../lib', '../ext/Devel/PPPort/t') if -d '../lib' && -d '../ext';
+    require Config; import Config;
+    use vars '%Config';
+    if (" $Config{'extensions'} " !~ m[ Devel/PPPort ]) {
+      print "1..0 # Skip -- Perl configured without Devel::PPPort module\n";
+      exit 0;
+    }
+  }
+  else {
+    unshift @INC, 't';
+  }
+
+  sub load {
+    eval "use Test";
+    require 'testutil.pl' if $@;
+  }
+
+  if (13) {
+    load();
+    plan(tests => 13);
+  }
+}
+
+use Devel::PPPort;
+use strict;
+$^W = 1;
+
+package Devel::PPPort;
+use vars '@ISA';
+require DynaLoader;
+@ISA = qw(DynaLoader);
+bootstrap Devel::PPPort;
+
+package main;
+
+my $uni = &Devel::PPPort::pv_escape_can_unicode();
+
+# sanity check
+ok($uni ? $] >= 5.006 : $] < 5.008);
+
+my @r;
+
+@r = &Devel::PPPort::pv_pretty();
+ok($r[0], $r[1]);
+ok($r[0], "foobarbaz");
+ok($r[2], $r[3]);
+ok($r[2], '<leftpv_p\retty\nright>');
+ok($r[4], $r[5]);
+ok($r[4], $uni ? 'N\375 Batter\355\0' : 'N\303\275 Batter\303');
+ok($r[6], $r[7]);
+ok($r[6], $uni ? '\\301g\\346tis Byrjun...' : '\303\201g\303\246tis...');
+
+@r = &Devel::PPPort::pv_display();
+ok($r[0], $r[1]);
+ok($r[0], '"foob\0rbaz"\0');
+ok($r[2], $r[3]);
+ok($r[2] eq '"pv_di"...\0' ||
+   $r[2] eq '"pv_d"...\0');  # some perl implementations are broken... :(
+