In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/422d053b400e15f0154beccd0cbcd57e26d0a23a?hp=84556172294db864f27a4b5df6dac9127e1e7205>
- Log ----------------------------------------------------------------- commit 422d053b400e15f0154beccd0cbcd57e26d0a23a Author: Nicholas Clark <[email protected]> Date: Sun Oct 24 14:23:43 2010 +0200 Refactor B::cchar() to create a temporary directly, and use Perl_sv_catpvf(). M ext/B/B.xs commit 01c3a48515f35a9a4fccaee79fafa1c4d6165b08 Author: Nicholas Clark <[email protected]> Date: Sun Oct 24 14:07:26 2010 +0200 Tests for B::cchar(). M ext/B/t/b.t commit 09e97b95012fac4378b4ff659a3f0bb1146f4eda Author: Nicholas Clark <[email protected]> Date: Sun Oct 24 13:50:52 2010 +0200 In B.xs, refactor cstring() to return a mortal, which simplifies the XS code. M ext/B/B.xs commit 36e7580ac7e8aba1094ccb8123ff9916580249bf Author: Nicholas Clark <[email protected]> Date: Sun Oct 24 13:49:12 2010 +0200 Test NUL bytes with B::cstring() and B::perlstring(). M ext/B/t/b.t ----------------------------------------------------------------------- Summary of changes: ext/B/B.xs | 62 ++++++++++++++++++++++++---------------------------------- ext/B/t/b.t | 13 +++++++++++- 2 files changed, 38 insertions(+), 37 deletions(-) diff --git a/ext/B/B.xs b/ext/B/B.xs index 92b45b4..5b1688a 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -331,15 +331,17 @@ make_mg_object(pTHX_ SV *arg, MAGIC *mg) static SV * cstring(pTHX_ SV *sv, bool perlstyle) { - SV *sstr = newSVpvs(""); + SV *sstr; if (!SvOK(sv)) - sv_setpvs(sstr, "0"); - else if (perlstyle && SvUTF8(sv)) { + return newSVpvs_flags("0", SVs_TEMP); + + sstr = newSVpvs_flags("\"", SVs_TEMP); + + if (perlstyle && SvUTF8(sv)) { SV *tmpsv = sv_newmortal(); /* Temporary SV to feed sv_uni_display */ const STRLEN len = SvCUR(sv); const char *s = sv_uni_display(tmpsv, sv, 8*len, UNI_DISPLAY_QQ); - sv_setpvs(sstr,"\""); while (*s) { if (*s == '"') @@ -359,15 +361,12 @@ cstring(pTHX_ SV *sv, bool perlstyle) sv_catpvn(sstr, s, 1); ++s; } - sv_catpvs(sstr, "\""); - return sstr; } else { /* XXX Optimise? */ STRLEN len; const char *s = SvPV(sv, len); - sv_catpvs(sstr, "\""); for (; len; len--, s++) { /* At least try a little for readability */ @@ -411,50 +410,45 @@ cstring(pTHX_ SV *sv, bool perlstyle) } /* XXX Add line breaks if string is long */ } - sv_catpvs(sstr, "\""); } + sv_catpvs(sstr, "\""); return sstr; } static SV * cchar(pTHX_ SV *sv) { - SV *sstr = newSVpvs("'"); + SV *sstr = newSVpvs_flags("'", SVs_TEMP); const char *s = SvPV_nolen(sv); + /* Don't want promotion of a signed -1 char in sprintf args */ + const unsigned char c = (unsigned char) *s; - if (*s == '\'') + if (c == '\'') sv_catpvs(sstr, "\\'"); - else if (*s == '\\') + else if (c == '\\') sv_catpvs(sstr, "\\\\"); #ifdef EBCDIC - else if (isPRINT(*s)) + else if (isPRINT(c)) #else - else if (*s >= ' ' && *s < 127) + else if (c >= ' ' && c < 127) #endif /* EBCDIC */ sv_catpvn(sstr, s, 1); - else if (*s == '\n') + else if (c == '\n') sv_catpvs(sstr, "\\n"); - else if (*s == '\r') + else if (c == '\r') sv_catpvs(sstr, "\\r"); - else if (*s == '\t') + else if (c == '\t') sv_catpvs(sstr, "\\t"); - else if (*s == '\a') + else if (c == '\a') sv_catpvs(sstr, "\\a"); - else if (*s == '\b') + else if (c == '\b') sv_catpvs(sstr, "\\b"); - else if (*s == '\f') + else if (c == '\f') sv_catpvs(sstr, "\\f"); - else if (*s == '\v') + else if (c == '\v') sv_catpvs(sstr, "\\v"); else - { - /* no trigraph support */ - char escbuff[5]; /* to fit backslash, 3 octals + trailing \0 */ - /* Don't want promotion of a signed -1 char in sprintf args */ - unsigned char c = (unsigned char) *s; - const STRLEN oct_len = my_sprintf(escbuff, "\\%03o", c); - sv_catpvn(sstr, escbuff, oct_len); - } + Perl_sv_catpvf(aTHX_ sstr, "\\%03o", c); sv_catpvs(sstr, "'"); return sstr; } @@ -813,18 +807,14 @@ cstring(sv) SV * sv ALIAS: perlstring = 1 - CODE: - RETVAL = cstring(aTHX_ sv, ix); - OUTPUT: - RETVAL + PPCODE: + PUSHs(cstring(aTHX_ sv, ix)); SV * cchar(sv) SV * sv - CODE: - RETVAL = cchar(aTHX_ sv); - OUTPUT: - RETVAL + PPCODE: + PUSHs(cchar(aTHX_ sv)); void threadsv_names() diff --git a/ext/B/t/b.t b/ext/B/t/b.t index 7691e97..b32ce31 100644 --- a/ext/B/t/b.t +++ b/ext/B/t/b.t @@ -162,7 +162,8 @@ like(B::hash("wibble"), qr/0x[0-9a-f]*/, "Testing B::hash()"); is(B::perlstring(undef), '0', "Testing B::perlstring(undef)"); my @common = map {eval $_, $_} - '"wibble"', '"\""', '"\'"', '"\\\\"', '"\\n\\r\\t\\b\\a\\f"', '"\\177"'; + '"wibble"', '"\""', '"\'"', '"\\\\"', '"\\n\\r\\t\\b\\a\\f"', '"\\177"', + '"\000"', '"\000\000"', '"\000Bing\000"'; my $oct = sprintf "\\%03o", ord '?'; my @tests = (@common, '$_', '"$_"', '@_', '"@_"', '??N', qq{"$oct?N"}, @@ -182,6 +183,16 @@ like(B::hash("wibble"), qr/0x[0-9a-f]*/, "Testing B::hash()"); is(B::perlstring($test), $expect, "B::perlstring($expect) (Unicode)"); } } +{ + my @tests = (map {eval(qq{"$_"}), $_} '\\n', '\\r', '\\t', + '\\b', '\\a', '\\f', '\\000', '\\\'', '?'), '"', '"', + ord 'N' == 78 ? (chr 11, q{'\013"'}, "\177", "'\\177'") : (); + + while (my ($test, $expect) = splice @tests, 0, 2) { + is(B::cchar($test), "'${expect}'", "B::cchar(qq{$expect})"); + } +} + is(B::class(bless {}, "Wibble::Bibble"), "Bibble", "Testing B::class()"); is(B::cast_I32(3.14), 3, "Testing B::cast_I32()"); is(B::opnumber("chop"), 38, "Testing opnumber with opname (chop)"); -- Perl5 Master Repository
