From: Hugo van der Sanden Date: Sat, 26 May 2001 17:05:12 +0000 (+0100) Subject: Re: 5.6.*, bleadperl: bugs in pp_concat X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d6d96c1bf85fd984f18f84ea834be52b168c812;p=p5sagit%2Fp5-mst-13.2.git Re: 5.6.*, bleadperl: bugs in pp_concat Message-Id: <200105261605.RAA12295@crypt.compulink.co.uk> p4raw-id: //depot/perl@10223 --- diff --git a/MANIFEST b/MANIFEST index f338082..093ed04 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1694,6 +1694,7 @@ t/op/filetest.t See if file tests work t/op/flip.t See if range operator works t/op/fork.t See if fork works t/op/glob.t See if <*> works +t/op/gmagic.t See if GMAGIC works t/op/goto.t See if goto works t/op/goto_xs.t See if "goto &sub" works on XSUBs t/op/grent.t See if getgr*() functions work diff --git a/doop.c b/doop.c index 2b504a1..a5c1ce3 100644 --- a/doop.c +++ b/doop.c @@ -667,14 +667,16 @@ Perl_do_join(pTHX_ register SV *sv, SV *del, register SV **mark, register SV **s ++mark; } + sv_setpv(sv, ""); + if (PL_tainting && SvMAGICAL(sv)) + SvTAINTED_off(sv); + if (items-- > 0) { - sv_setpv(sv, ""); if (*mark) sv_catsv(sv, *mark); mark++; } - else - sv_setpv(sv,""); + if (delimlen) { for (; items > 0; items--,mark++) { sv_catsv(sv,del); diff --git a/embed.h b/embed.h index fce8a2e..4acb7f3 100644 --- a/embed.h +++ b/embed.h @@ -642,7 +642,6 @@ #define sv_2iv Perl_sv_2iv #define sv_2mortal Perl_sv_2mortal #define sv_2nv Perl_sv_2nv -#define sv_2pv Perl_sv_2pv #define sv_2pvutf8 Perl_sv_2pvutf8 #define sv_2pvbyte Perl_sv_2pvbyte #define sv_2uv Perl_sv_2uv @@ -659,8 +658,6 @@ #define sv_catpvf Perl_sv_catpvf #define sv_vcatpvf Perl_sv_vcatpvf #define sv_catpv Perl_sv_catpv -#define sv_catpvn Perl_sv_catpvn -#define sv_catsv Perl_sv_catsv #define sv_chop Perl_sv_chop #define sv_clean_all Perl_sv_clean_all #define sv_clean_objs Perl_sv_clean_objs @@ -692,7 +689,6 @@ #define sv_peek Perl_sv_peek #define sv_pos_u2b Perl_sv_pos_u2b #define sv_pos_b2u Perl_sv_pos_b2u -#define sv_pvn_force Perl_sv_pvn_force #define sv_pvutf8n_force Perl_sv_pvutf8n_force #define sv_pvbyten_force Perl_sv_pvbyten_force #define sv_reftype Perl_sv_reftype @@ -712,7 +708,6 @@ #define sv_setref_pvn Perl_sv_setref_pvn #define sv_setpv Perl_sv_setpv #define sv_setpvn Perl_sv_setpvn -#define sv_setsv Perl_sv_setsv #define sv_taint Perl_sv_taint #define sv_tainted Perl_sv_tainted #define sv_unmagic Perl_sv_unmagic @@ -832,7 +827,6 @@ #define sv_pv Perl_sv_pv #define sv_pvutf8 Perl_sv_pvutf8 #define sv_pvbyte Perl_sv_pvbyte -#define sv_utf8_upgrade Perl_sv_utf8_upgrade #define sv_utf8_downgrade Perl_sv_utf8_downgrade #define sv_utf8_encode Perl_sv_utf8_encode #define sv_utf8_decode Perl_sv_utf8_decode @@ -1176,6 +1170,12 @@ #endif #if defined(PERL_OBJECT) #endif +#define sv_setsv_flags Perl_sv_setsv_flags +#define sv_catpvn_flags Perl_sv_catpvn_flags +#define sv_catsv_flags Perl_sv_catsv_flags +#define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags +#define sv_pvn_force_flags Perl_sv_pvn_force_flags +#define sv_2pv_flags Perl_sv_2pv_flags #define ck_anoncode Perl_ck_anoncode #define ck_bitop Perl_ck_bitop #define ck_concat Perl_ck_concat @@ -2138,7 +2138,6 @@ #define sv_2iv(a) Perl_sv_2iv(aTHX_ a) #define sv_2mortal(a) Perl_sv_2mortal(aTHX_ a) #define sv_2nv(a) Perl_sv_2nv(aTHX_ a) -#define sv_2pv(a,b) Perl_sv_2pv(aTHX_ a,b) #define sv_2pvutf8(a,b) Perl_sv_2pvutf8(aTHX_ a,b) #define sv_2pvbyte(a,b) Perl_sv_2pvbyte(aTHX_ a,b) #define sv_2uv(a) Perl_sv_2uv(aTHX_ a) @@ -2154,8 +2153,6 @@ #define sv_bless(a,b) Perl_sv_bless(aTHX_ a,b) #define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c) #define sv_catpv(a,b) Perl_sv_catpv(aTHX_ a,b) -#define sv_catpvn(a,b,c) Perl_sv_catpvn(aTHX_ a,b,c) -#define sv_catsv(a,b) Perl_sv_catsv(aTHX_ a,b) #define sv_chop(a,b) Perl_sv_chop(aTHX_ a,b) #define sv_clean_all() Perl_sv_clean_all(aTHX) #define sv_clean_objs() Perl_sv_clean_objs(aTHX) @@ -2187,7 +2184,6 @@ #define sv_peek(a) Perl_sv_peek(aTHX_ a) #define sv_pos_u2b(a,b,c) Perl_sv_pos_u2b(aTHX_ a,b,c) #define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) -#define sv_pvn_force(a,b) Perl_sv_pvn_force(aTHX_ a,b) #define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b) #define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b) #define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b) @@ -2206,7 +2202,6 @@ #define sv_setref_pvn(a,b,c,d) Perl_sv_setref_pvn(aTHX_ a,b,c,d) #define sv_setpv(a,b) Perl_sv_setpv(aTHX_ a,b) #define sv_setpvn(a,b,c) Perl_sv_setpvn(aTHX_ a,b,c) -#define sv_setsv(a,b) Perl_sv_setsv(aTHX_ a,b) #define sv_taint(a) Perl_sv_taint(aTHX_ a) #define sv_tainted(a) Perl_sv_tainted(aTHX_ a) #define sv_unmagic(a,b) Perl_sv_unmagic(aTHX_ a,b) @@ -2320,7 +2315,6 @@ #define sv_pv(a) Perl_sv_pv(aTHX_ a) #define sv_pvutf8(a) Perl_sv_pvutf8(aTHX_ a) #define sv_pvbyte(a) Perl_sv_pvbyte(aTHX_ a) -#define sv_utf8_upgrade(a) Perl_sv_utf8_upgrade(aTHX_ a) #define sv_utf8_downgrade(a,b) Perl_sv_utf8_downgrade(aTHX_ a,b) #define sv_utf8_encode(a) Perl_sv_utf8_encode(aTHX_ a) #define sv_utf8_decode(a) Perl_sv_utf8_decode(aTHX_ a) @@ -2663,6 +2657,12 @@ #endif #if defined(PERL_OBJECT) #endif +#define sv_setsv_flags(a,b,c) Perl_sv_setsv_flags(aTHX_ a,b,c) +#define sv_catpvn_flags(a,b,c,d) Perl_sv_catpvn_flags(aTHX_ a,b,c,d) +#define sv_catsv_flags(a,b,c) Perl_sv_catsv_flags(aTHX_ a,b,c) +#define sv_utf8_upgrade_flags(a,b) Perl_sv_utf8_upgrade_flags(aTHX_ a,b) +#define sv_pvn_force_flags(a,b,c) Perl_sv_pvn_force_flags(aTHX_ a,b,c) +#define sv_2pv_flags(a,b,c) Perl_sv_2pv_flags(aTHX_ a,b,c) #define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a) #define ck_bitop(a) Perl_ck_bitop(aTHX_ a) #define ck_concat(a) Perl_ck_concat(aTHX_ a) @@ -5166,6 +5166,18 @@ #endif #if defined(PERL_OBJECT) #endif +#define Perl_sv_setsv_flags CPerlObj::Perl_sv_setsv_flags +#define sv_setsv_flags Perl_sv_setsv_flags +#define Perl_sv_catpvn_flags CPerlObj::Perl_sv_catpvn_flags +#define sv_catpvn_flags Perl_sv_catpvn_flags +#define Perl_sv_catsv_flags CPerlObj::Perl_sv_catsv_flags +#define sv_catsv_flags Perl_sv_catsv_flags +#define Perl_sv_utf8_upgrade_flags CPerlObj::Perl_sv_utf8_upgrade_flags +#define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags +#define Perl_sv_pvn_force_flags CPerlObj::Perl_sv_pvn_force_flags +#define sv_pvn_force_flags Perl_sv_pvn_force_flags +#define Perl_sv_2pv_flags CPerlObj::Perl_sv_2pv_flags +#define sv_2pv_flags Perl_sv_2pv_flags #define Perl_ck_anoncode CPerlObj::Perl_ck_anoncode #define ck_anoncode Perl_ck_anoncode #define Perl_ck_bitop CPerlObj::Perl_ck_bitop diff --git a/embed.pl b/embed.pl index d98d754..91165b3 100755 --- a/embed.pl +++ b/embed.pl @@ -2000,7 +2000,7 @@ Ap |IO* |sv_2io |SV* sv Ap |IV |sv_2iv |SV* sv Apd |SV* |sv_2mortal |SV* sv Ap |NV |sv_2nv |SV* sv -Ap |char* |sv_2pv |SV* sv|STRLEN* lp +Aop |char* |sv_2pv |SV* sv|STRLEN* lp Ap |char* |sv_2pvutf8 |SV* sv|STRLEN* lp Ap |char* |sv_2pvbyte |SV* sv|STRLEN* lp Ap |UV |sv_2uv |SV* sv @@ -2017,8 +2017,8 @@ Apd |SV* |sv_bless |SV* sv|HV* stash Afpd |void |sv_catpvf |SV* sv|const char* pat|... Ap |void |sv_vcatpvf |SV* sv|const char* pat|va_list* args Apd |void |sv_catpv |SV* sv|const char* ptr -Apd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len -Apd |void |sv_catsv |SV* dsv|SV* ssv +Aopd |void |sv_catpvn |SV* sv|const char* ptr|STRLEN len +Aopd |void |sv_catsv |SV* dsv|SV* ssv Apd |void |sv_chop |SV* sv|char* ptr p |I32 |sv_clean_all p |void |sv_clean_objs @@ -2052,7 +2052,7 @@ Ap |SV* |sv_newref |SV* sv Ap |char* |sv_peek |SV* sv Ap |void |sv_pos_u2b |SV* sv|I32* offsetp|I32* lenp Ap |void |sv_pos_b2u |SV* sv|I32* offsetp -Apd |char* |sv_pvn_force |SV* sv|STRLEN* lp +Aopd |char* |sv_pvn_force |SV* sv|STRLEN* lp Apd |char* |sv_pvutf8n_force|SV* sv|STRLEN* lp Ap |char* |sv_pvbyten_force|SV* sv|STRLEN* lp Apd |char* |sv_reftype |SV* sv|int ob @@ -2073,7 +2073,7 @@ Apd |SV* |sv_setref_pvn |SV* rv|const char* classname|char* pv \ |STRLEN n Apd |void |sv_setpv |SV* sv|const char* ptr Apd |void |sv_setpvn |SV* sv|const char* ptr|STRLEN len -Apd |void |sv_setsv |SV* dsv|SV* ssv +Aopd |void |sv_setsv |SV* dsv|SV* ssv Ap |void |sv_taint |SV* sv Ap |bool |sv_tainted |SV* sv Apd |int |sv_unmagic |SV* sv|int type @@ -2204,7 +2204,7 @@ Ap |char* |sv_2pvbyte_nolen|SV* sv Ap |char* |sv_pv |SV *sv Ap |char* |sv_pvutf8 |SV *sv Ap |char* |sv_pvbyte |SV *sv -Apd |STRLEN |sv_utf8_upgrade|SV *sv +Aopd |STRLEN |sv_utf8_upgrade|SV *sv ApdM |bool |sv_utf8_downgrade|SV *sv|bool fail_ok Apd |void |sv_utf8_encode |SV *sv ApdM |bool |sv_utf8_decode |SV *sv @@ -2586,3 +2586,9 @@ s |void |xstat |int #if defined(PERL_OBJECT) }; #endif +Apd |void |sv_setsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |void |sv_catpvn_flags|SV* sv|const char* ptr|STRLEN len|I32 flags +Apd |void |sv_catsv_flags |SV* dsv|SV* ssv|I32 flags +Apd |STRLEN |sv_utf8_upgrade_flags|SV *sv|I32 flags +Apd |char* |sv_pvn_force_flags|SV* sv|STRLEN* lp|I32 flags +Ap |char* |sv_2pv_flags |SV* sv|STRLEN* lp|I32 flags diff --git a/global.sym b/global.sym index 472fff5..17e3df3 100644 --- a/global.sym +++ b/global.sym @@ -571,3 +571,9 @@ Perl_ptr_table_clear Perl_ptr_table_free Perl_sys_intern_clear Perl_sys_intern_init +Perl_sv_setsv_flags +Perl_sv_catpvn_flags +Perl_sv_catsv_flags +Perl_sv_utf8_upgrade_flags +Perl_sv_pvn_force_flags +Perl_sv_2pv_flags diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 1452243..cc12474 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -213,8 +213,8 @@ sub fileparse { } $tail .= $taint if defined $tail; # avoid warning if $tail == undef - wantarray ? ($basename . $taint, $dirpath . $taint, $tail) - : $basename . $taint; + wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail) + : $basename .= $taint; } diff --git a/objXSUB.h b/objXSUB.h index ecdaea5..c830fe1 100644 --- a/objXSUB.h +++ b/objXSUB.h @@ -2382,6 +2382,30 @@ #endif #if defined(PERL_OBJECT) #endif +#undef Perl_sv_setsv_flags +#define Perl_sv_setsv_flags pPerl->Perl_sv_setsv_flags +#undef sv_setsv_flags +#define sv_setsv_flags Perl_sv_setsv_flags +#undef Perl_sv_catpvn_flags +#define Perl_sv_catpvn_flags pPerl->Perl_sv_catpvn_flags +#undef sv_catpvn_flags +#define sv_catpvn_flags Perl_sv_catpvn_flags +#undef Perl_sv_catsv_flags +#define Perl_sv_catsv_flags pPerl->Perl_sv_catsv_flags +#undef sv_catsv_flags +#define sv_catsv_flags Perl_sv_catsv_flags +#undef Perl_sv_utf8_upgrade_flags +#define Perl_sv_utf8_upgrade_flags pPerl->Perl_sv_utf8_upgrade_flags +#undef sv_utf8_upgrade_flags +#define sv_utf8_upgrade_flags Perl_sv_utf8_upgrade_flags +#undef Perl_sv_pvn_force_flags +#define Perl_sv_pvn_force_flags pPerl->Perl_sv_pvn_force_flags +#undef sv_pvn_force_flags +#define sv_pvn_force_flags Perl_sv_pvn_force_flags +#undef Perl_sv_2pv_flags +#define Perl_sv_2pv_flags pPerl->Perl_sv_2pv_flags +#undef sv_2pv_flags +#define sv_2pv_flags Perl_sv_2pv_flags #endif /* PERL_CORE && PERL_OBJECT */ #endif /* __objXSUB_h__ */ diff --git a/perlapi.c b/perlapi.c index ac5ff3e..b839a35 100644 --- a/perlapi.c +++ b/perlapi.c @@ -4233,6 +4233,48 @@ Perl_sys_intern_init(pTHXo) #if defined(PERL_OBJECT) #endif +#undef Perl_sv_setsv_flags +void +Perl_sv_setsv_flags(pTHXo_ SV* dsv, SV* ssv, I32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_setsv_flags(dsv, ssv, flags); +} + +#undef Perl_sv_catpvn_flags +void +Perl_sv_catpvn_flags(pTHXo_ SV* sv, const char* ptr, STRLEN len, I32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_catpvn_flags(sv, ptr, len, flags); +} + +#undef Perl_sv_catsv_flags +void +Perl_sv_catsv_flags(pTHXo_ SV* dsv, SV* ssv, I32 flags) +{ + ((CPerlObj*)pPerl)->Perl_sv_catsv_flags(dsv, ssv, flags); +} + +#undef Perl_sv_utf8_upgrade_flags +STRLEN +Perl_sv_utf8_upgrade_flags(pTHXo_ SV *sv, I32 flags) +{ + return ((CPerlObj*)pPerl)->Perl_sv_utf8_upgrade_flags(sv, flags); +} + +#undef Perl_sv_pvn_force_flags +char* +Perl_sv_pvn_force_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags) +{ + return ((CPerlObj*)pPerl)->Perl_sv_pvn_force_flags(sv, lp, flags); +} + +#undef Perl_sv_2pv_flags +char* +Perl_sv_2pv_flags(pTHXo_ SV* sv, STRLEN* lp, I32 flags) +{ + return ((CPerlObj*)pPerl)->Perl_sv_2pv_flags(sv, lp, flags); +} + #undef Perl_fprintf_nocontext int Perl_fprintf_nocontext(PerlIO *stream, const char *format, ...) diff --git a/pod/perlapi.pod b/pod/perlapi.pod index af5a1bc..df6fbf4 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2608,6 +2608,20 @@ Handles 'get' magic, but not 'set' magic. See C. =for hackers Found in file sv.c +=item sv_catpvn_flags + +Concatenates the string onto the end of the string which is in the SV. The +C indicates number of bytes to copy. If the SV has the UTF8 +status set, then the bytes appended should be valid UTF8. +If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + + void sv_catpvn_flags(SV* sv, const char* ptr, STRLEN len, I32 flags) + +=for hackers +Found in file sv.c + =item sv_catpvn_mg Like C, but also handles 'set' magic. @@ -2637,6 +2651,18 @@ not 'set' magic. See C. =for hackers Found in file sv.c +=item sv_catsv_flags + +Concatenates the string from SV C onto the end of the string in +SV C. Modifies C but not C. If C has C +bit set, will C on the SVs if appropriate, else not. C +and C are implemented in terms of this function. + + void sv_catsv_flags(SV* dsv, SV* ssv, I32 flags) + +=for hackers +Found in file sv.c + =item sv_catsv_mg Like C, but also handles 'set' magic. @@ -2846,6 +2872,18 @@ Get a sensible string out of the SV somehow. =for hackers Found in file sv.c +=item sv_pvn_force_flags + +Get a sensible string out of the SV somehow. +If C has C bit set, will C on C if +appropriate, else not. C and C are +implemented in terms of this function. + + char* sv_pvn_force_flags(SV* sv, STRLEN* lp, I32 flags) + +=for hackers +Found in file sv.c + =item sv_pvutf8n_force Get a sensible UTF8-encoded string out of the SV somehow. See @@ -3083,6 +3121,19 @@ C. =for hackers Found in file sv.c +=item sv_setsv_flags + +Copies the contents of the source SV C into the destination SV C. +The source SV may be destroyed if it is mortal. Does not handle 'set' +magic. If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + + void sv_setsv_flags(SV* dsv, SV* ssv, I32 flags) + +=for hackers +Found in file sv.c + =item sv_setsv_mg Like C, but also handles 'set' magic. @@ -3242,6 +3293,20 @@ if all the bytes have hibit clear. =for hackers Found in file sv.c +=item sv_utf8_upgrade_flags + +Convert the PV of an SV to its UTF8-encoded form. +Forces the SV to string form it it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. If C has C bit set, +will C on C if appropriate, else not. C and +C are implemented in terms of this function. + + STRLEN sv_utf8_upgrade_flags(SV *sv, I32 flags) + +=for hackers +Found in file sv.c + =item sv_vcatpvfn Processes its arguments like C and appends the formatted output diff --git a/pp_hot.c b/pp_hot.c index ddb3ed7..c198b22 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -142,51 +142,56 @@ PP(pp_concat) dSP; dATARGET; tryAMAGICbin(concat,opASSIGN); { dPOPTOPssrl; - SV* rcopy = Nullsv; - - if (SvGMAGICAL(left)) - mg_get(left); - if (TARG == right && SvGMAGICAL(right)) - mg_get(right); - - if (TARG == right && left != right) - /* Clone since otherwise we cannot prepend. */ - rcopy = sv_2mortal(newSVsv(right)); - - if (TARG != left) - sv_setsv(TARG, left); + STRLEN llen; + char* lpv; + bool lbyte; + STRLEN rlen; + char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */ + bool rbyte = !SvUTF8(right); + + if (TARG == right && right != left) { + right = sv_2mortal(newSVpvn(rpv, rlen)); + rpv = SvPV(right, rlen); /* no point setting UTF8 here */ + } + + if (TARG != left) { + lpv = SvPV(left, llen); /* mg_get(left) may happen here */ + lbyte = !SvUTF8(left); + sv_setpvn(TARG, lpv, llen); + if (!lbyte) + SvUTF8_on(TARG); + else + SvUTF8_off(TARG); + } + else { /* TARG == left */ + if (SvGMAGICAL(left)) + mg_get(left); /* or mg_get(left) may happen here */ + if (!SvOK(TARG)) + sv_setpv(left, ""); + lpv = SvPV_nomg(left, llen); + lbyte = !SvUTF8(left); + } #if defined(PERL_Y2KWARN) if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) { - STRLEN n; - char *s = SvPV(TARG,n); - if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' - && (n == 2 || !isDIGIT(s[n-3]))) - { - Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", - "about to append an integer to '19'"); - } + if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' + && (llen == 2 || !isDIGIT(lpv[llen - 3]))) + { + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", + "about to append an integer to '19'"); + } } #endif - if (TARG == right) { - if (left == right) { - /* $right = $right . $right; */ - STRLEN rlen; - char *rpv = SvPV(right, rlen); - - sv_catpvn(TARG, rpv, rlen); + if (lbyte != rbyte) { + if (lbyte) + sv_utf8_upgrade_nomg(TARG); + else { + sv_utf8_upgrade_nomg(right); + rpv = SvPV(right, rlen); } - else /* $right = $left . $right; */ - sv_catsv(TARG, rcopy); - } - else { - if (!SvOK(TARG)) /* Avoid warning when concatenating to undef. */ - sv_setpv(TARG, ""); - /* $other = $left . $right; */ - /* $left = $left . $right; */ - sv_catsv(TARG, right); } + sv_catpvn_nomg(TARG, rpv, rlen); SETTARG; RETURN; diff --git a/proto.h b/proto.h index 4dbee28..c824a79 100644 --- a/proto.h +++ b/proto.h @@ -1306,3 +1306,9 @@ STATIC void S_xstat(pTHX_ int); #if defined(PERL_OBJECT) }; #endif +PERL_CALLCONV void Perl_sv_setsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags); +PERL_CALLCONV void Perl_sv_catpvn_flags(pTHX_ SV* sv, const char* ptr, STRLEN len, I32 flags); +PERL_CALLCONV void Perl_sv_catsv_flags(pTHX_ SV* dsv, SV* ssv, I32 flags); +PERL_CALLCONV STRLEN Perl_sv_utf8_upgrade_flags(pTHX_ SV *sv, I32 flags); +PERL_CALLCONV char* Perl_sv_pvn_force_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags); +PERL_CALLCONV char* Perl_sv_2pv_flags(pTHX_ SV* sv, STRLEN* lp, I32 flags); diff --git a/sv.c b/sv.c index d852712..7b53a43 100644 --- a/sv.c +++ b/sv.c @@ -2643,6 +2643,12 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { + sv_2pv_flags(sv, lp, SV_GMAGIC); +} + +char * +Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) +{ register char *s; int olderrno; SV *tsv; @@ -2654,7 +2660,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return ""; } if (SvGMAGICAL(sv)) { - mg_get(sv); + if (flags & SV_GMAGIC) + mg_get(sv); if (SvPOKp(sv)) { *lp = SvCUR(sv); return SvPVX(sv); @@ -2965,6 +2972,25 @@ if all the bytes have hibit clear. STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { + sv_utf8_upgrade_flags(sv, SV_GMAGIC); +} + +/* +=for apidoc sv_utf8_upgrade_flags + +Convert the PV of an SV to its UTF8-encoded form. +Forces the SV to string form it it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. If C has C bit set, +will C on C if appropriate, else not. C and +C are implemented in terms of this function. + +=cut +*/ + +STRLEN +Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) +{ U8 *s, *t, *e; int hibit = 0; @@ -2973,7 +2999,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv) if (!SvPOK(sv)) { STRLEN len = 0; - (void) sv_2pv(sv,&len); + (void) sv_2pv_flags(sv,&len, flags); if (!SvPOK(sv)) return len; } @@ -3149,9 +3175,30 @@ C. =cut */ +/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided + for binary compatibility only +*/ void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { + sv_setsv_flags(dstr, sstr, SV_GMAGIC); +} + +/* +=for apidoc sv_setsv_flags + +Copies the contents of the source SV C into the destination SV C. +The source SV may be destroyed if it is mortal. Does not handle 'set' +magic. If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + +=cut +*/ + +void +Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) +{ register U32 sflags; register int dtype; register int stype; @@ -3305,7 +3352,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) /* FALL THROUGH */ default: - if (SvGMAGICAL(sstr)) { + if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); @@ -3833,21 +3880,43 @@ Handles 'get' magic, but not 'set' magic. See C. =cut */ +/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided + for binary compatibility only +*/ void -Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) { - STRLEN tlen; - char *junk; + sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); +} - junk = SvPV_force(sv, tlen); - SvGROW(sv, tlen + len + 1); - if (ptr == junk) - ptr = SvPVX(sv); - Move(ptr,SvPVX(sv)+tlen,len,char); - SvCUR(sv) += len; - *SvEND(sv) = '\0'; - (void)SvPOK_only_UTF8(sv); /* validate pointer */ - SvTAINT(sv); +/* +=for apidoc sv_catpvn_flags + +Concatenates the string onto the end of the string which is in the SV. The +C indicates number of bytes to copy. If the SV has the UTF8 +status set, then the bytes appended should be valid UTF8. +If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + +=cut +*/ + +void +Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags) +{ + STRLEN dlen; + char *dstr; + + dstr = SvPV_force_flags(dsv, dlen, flags); + SvGROW(dsv, dlen + slen + 1); + if (sstr == dstr) + sstr = SvPVX(dsv); + Move(sstr, SvPVX(dsv) + dlen, slen, char); + SvCUR(dsv) += slen; + *SvEND(dsv) = '\0'; + (void)SvPOK_only_UTF8(dsv); /* validate pointer */ + SvTAINT(dsv); } /* @@ -3874,36 +3943,52 @@ not 'set' magic. See C. =cut */ +/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided + for binary compatibility only +*/ +void +Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) +{ + sv_catsv_flags(dstr, sstr, SV_GMAGIC); +} + +/* +=for apidoc sv_catsv_flags + +Concatenates the string from SV C onto the end of the string in +SV C. Modifies C but not C. If C has C +bit set, will C on the SVs if appropriate, else not. C +and C are implemented in terms of this function. + +=cut */ + void -Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv) +Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { char *spv; STRLEN slen; if (!ssv) return; if ((spv = SvPV(ssv, slen))) { - bool dutf8 = DO_UTF8(dsv); bool sutf8 = DO_UTF8(ssv); + bool dutf8; - if (dutf8 == sutf8) - sv_catpvn(dsv,spv,slen); - else { + if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) + mg_get(dsv); + dutf8 = DO_UTF8(dsv); + + if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVsv(ssv)); - char *cpv; - STRLEN clen; + SV* csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); - cpv = SvPV(csv,clen); - sv_catpvn(dsv,cpv,clen); - } - else { - sv_utf8_upgrade(dsv); - sv_catpvn(dsv,spv,slen); - SvUTF8_on(dsv); /* If dsv has no wide characters. */ + spv = SvPV(csv, slen); } + else + sv_utf8_upgrade_nomg(dsv); } + sv_catpvn_nomg(dsv, spv, slen); } } @@ -6168,6 +6253,23 @@ Get a sensible string out of the SV somehow. char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { + sv_pvn_force_flags(sv, lp, SV_GMAGIC); +} + +/* +=for apidoc sv_pvn_force_flags + +Get a sensible string out of the SV somehow. +If C has C bit set, will C on C if +appropriate, else not. C and C are +implemented in terms of this function. + +=cut +*/ + +char * +Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ char *s; if (SvTHINKFIRST(sv) && !SvROK(sv)) @@ -6182,7 +6284,7 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) PL_op_name[PL_op->op_type]); } else - s = sv_2pv(sv, lp); + s = sv_2pv_flags(sv, lp, flags); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; diff --git a/sv.h b/sv.h index fe98cfa..e1281d2 100644 --- a/sv.h +++ b/sv.h @@ -890,16 +890,51 @@ false, defined or undefined. Does not handle 'get' magic. #undef SvNV #define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)) +/* flag values for sv_*_flags functions */ +#define SV_IMMEDIATE_UNREF 1 +#define SV_GMAGIC 2 + +#define sv_setsv_macro(dsv, ssv) sv_setsv_flags(dsv, ssv, SV_GMAGIC) +#define sv_setsv_nomg(dsv, ssv) sv_setsv_flags(dsv, ssv, 0) +#define sv_catsv_macro(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC) +#define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0) +#define sv_catpvn_macro(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC) +#define sv_catpvn_nomg(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, 0) +#define sv_2pv_macro(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC) +#define sv_2pv_nomg(sv, lp) sv_2pv_flags(sv, lp, 0) +#define sv_pvn_force_macro(sv, lp) sv_pvn_force_flags(sv, lp, SV_GMAGIC) +#define sv_pvn_force_nomg(sv, lp) sv_pvn_force_flags(sv, lp, 0) +#define sv_utf8_upgrade_macro(sv) sv_utf8_upgrade_flags(sv, SV_GMAGIC) +#define sv_utf8_upgrade_nomg(sv) sv_utf8_upgrade_flags(sv, 0) + +/* function style also available for bincompat */ +#define sv_setsv(dsv, ssv) sv_setsv_macro(dsv, ssv) +#define sv_catsv(dsv, ssv) sv_catsv_macro(dsv, ssv) +#define sv_catpvn(dsv, sstr, slen) sv_catpvn_macro(dsv, sstr, slen) +#define sv_2pv(sv, lp) sv_2pv_macro(sv, lp) +#define sv_pvn_force(sv, lp) sv_pvn_force_macro(sv, lp) +#define sv_utf8_upgrade(sv) sv_utf8_upgrade_macro(sv) + #undef SvPV -#define SvPV(sv, lp) \ - ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp)) +#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC) + +#undef SvPV_nomg +#define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#undef SvPV_flags +#define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #undef SvPV_force -#define SvPV_force(sv, lp) \ +#define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#undef SvPV_force_nomg +#define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) + +#undef SvPV_force_flags +#define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ - ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp)) + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #undef SvPV_nolen #define SvPV_nolen(sv) \ @@ -1108,8 +1143,6 @@ Returns a pointer to the character buffer. #define SvGROW(sv,len) (SvLEN(sv) < (len) ? sv_grow(sv,len) : SvPVX(sv)) #define Sv_Grow sv_grow -#define SV_IMMEDIATE_UNREF 1 - #define CLONEf_COPY_STACKS 1 #define CLONEf_KEEP_PTR_TABLE 2 diff --git a/t/op/gmagic.t b/t/op/gmagic.t new file mode 100644 index 0000000..ab6d2ee --- /dev/null +++ b/t/op/gmagic.t @@ -0,0 +1,83 @@ +#!./perl -w + +BEGIN { + $| = 1; + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..18\n"; + +my $t = 1; +tie my $c => 'Tie::Monitor'; + +sub ok { + my($ok, $got, $exp, $rexp, $wexp) = @_; + my($rgot, $wgot) = (tied $c)->init(0); + print $ok ? "ok $t\n" : "# expected $exp, got $got\nnot ok $t\n"; + ++$t; + if ($rexp == $rgot && $wexp == $wgot) { + print "ok $t\n"; + } else { + print "# read $rgot expecting $rexp\n" if $rgot != $rexp; + print "# wrote $wgot expecting $wexp\n" if $wgot != $wexp; + print "not ok $t\n"; + } + ++$t; +} + +sub ok_undef { ok(!defined($_[0]), shift, "undef", @_) } +sub ok_numeric { ok($_[0] == $_[1], @_) } +sub ok_string { ok($_[0] eq $_[1], @_) } + +my($r, $s); +# the thing itself +ok_numeric($r = $c + 0, 0, 1, 0); +ok_string($r = "$c", '0', 1, 0); + +# concat +ok_string($c . 'x', '0x', 1, 0); +ok_string('x' . $c, 'x0', 1, 0); +$s = $c . $c; +ok_string($s, '00', 2, 0); +$r = 'x'; +$s = $c = $r . 'y'; +ok_string($s, 'xy', 1, 1); +$s = $c = $c . 'x'; +ok_string($s, '0x', 2, 1); +$s = $c = 'x' . $c; +ok_string($s, 'x0', 2, 1); +$s = $c = $c . $c; +ok_string($s, '00', 3, 1); + +# adapted from Tie::Counter by Abigail +package Tie::Monitor; + +sub TIESCALAR { + my($class, $value) = @_; + bless { + read => 0, + write => 0, + values => [ 0 ], + }; +} + +sub FETCH { + my $self = shift; + ++$self->{read}; + $self->{values}[$#{ $self->{values} }]; +} + +sub STORE { + my($self, $value) = @_; + ++$self->{write}; + push @{ $self->{values} }, $value; +} + +sub init { + my $self = shift; + my @results = ($self->{read}, $self->{write}); + $self->{read} = $self->{write} = 0; + $self->{values} = [ 0 ]; + @results; +} diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 3ee853f..c5a3790 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -211,6 +211,21 @@ $b = sub EXPECT ######## # pp_hot.c [pp_concat] +use warnings 'uninitialized'; +my($x, $y); +sub a { shift } +a($x . "x"); # should warn once +a($x . $y); # should warn twice +$x .= $y; # should warn once +$y .= $y; # should warn once +EXPECT +Use of uninitialized value in concatenation (.) or string at - line 5. +Use of uninitialized value in concatenation (.) or string at - line 6. +Use of uninitialized value in concatenation (.) or string at - line 6. +Use of uninitialized value in concatenation (.) or string at - line 7. +Use of uninitialized value in concatenation (.) or string at - line 8. +######## +# pp_hot.c [pp_concat] use warnings 'y2k'; use Config; BEGIN {