From: Marcus Holland-Moritz Date: Thu, 30 Oct 2008 18:55:04 +0000 (+0000) Subject: Upgrade to Devel::PPPort 3.14_04 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=db42c9028c2e0e8bf2d418f40276d99e5fbaf04c;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Devel::PPPort 3.14_04 p4raw-id: //depot/perl@34669 --- diff --git a/MANIFEST b/MANIFEST index 2992de2..b2dcdab 100644 --- a/MANIFEST +++ b/MANIFEST @@ -280,6 +280,7 @@ ext/Devel/PPPort/parts/inc/ppphbin Devel::PPPort include ext/Devel/PPPort/parts/inc/ppphdoc Devel::PPPort include ext/Devel/PPPort/parts/inc/ppphtest Devel::PPPort include ext/Devel/PPPort/parts/inc/pvs Devel::PPPort include +ext/Devel/PPPort/parts/inc/pv_tools Devel::PPPort include ext/Devel/PPPort/parts/inc/shared_pv Devel::PPPort include ext/Devel/PPPort/parts/inc/snprintf Devel::PPPort include ext/Devel/PPPort/parts/inc/sprintf Devel::PPPort include @@ -354,6 +355,7 @@ ext/Devel/PPPort/TODO Devel::PPPort Todo ext/Devel/PPPort/t/podtest.t Devel::PPPort test file ext/Devel/PPPort/t/ppphtest.t Devel::PPPort test file ext/Devel/PPPort/t/pvs.t Devel::PPPort test file +ext/Devel/PPPort/t/pv_tools.t Devel::PPPort test file ext/Devel/PPPort/t/shared_pv.t Devel::PPPort test file ext/Devel/PPPort/t/snprintf.t Devel::PPPort test file ext/Devel/PPPort/t/sprintf.t Devel::PPPort test file diff --git a/ext/Devel/PPPort/Changes b/ext/Devel/PPPort/Changes index f08dae4..7b985df 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 1420b64..321b747 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 dedc41a..99063e4 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 <= 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 0000000..8a31130 --- /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], ''); +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 146fb5f..86f24e2 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 a9d57b7..0d6b7d5 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 1116392..8e99759 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 0000000..61b0f14 --- /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 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], ''); +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... :( +