summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST1
-rw-r--r--doop.c8
-rw-r--r--embed.h36
-rwxr-xr-xembed.pl18
-rw-r--r--global.sym6
-rw-r--r--lib/File/Basename.pm4
-rw-r--r--objXSUB.h24
-rw-r--r--perlapi.c42
-rw-r--r--pod/perlapi.pod65
-rw-r--r--pp_hot.c79
-rw-r--r--proto.h6
-rw-r--r--sv.c164
-rw-r--r--sv.h47
-rw-r--r--t/op/gmagic.t83
-rw-r--r--t/pragma/warn/pp_hot15
15 files changed, 500 insertions, 98 deletions
diff --git a/MANIFEST b/MANIFEST
index f338082ebd..093ed04ebc 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 2b504a1b69..a5c1ce3a7c 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 fce8a2ee02..4acb7f3f0c 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 d98d754394..91165b3e0f 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 472fff50bb..17e3df3104 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 14522437e9..cc124744ca 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 ecdaea5236..c830fe1542 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 ac5ff3ecb1..b839a354b0 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 af5a1bc803..df6fbf4feb 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -2608,6 +2608,20 @@ Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=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<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> 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<sv_catpvn>, but also handles 'set' magic.
@@ -2637,6 +2651,18 @@ not 'set' magic. See C<sv_catsv_mg>.
=for hackers
Found in file sv.c
+=item sv_catsv_flags
+
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+and C<sv_catsv_nomg> 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<sv_catsv>, 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<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> 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<sv_setsv_mg>.
=for hackers
Found in file sv.c
+=item sv_setsv_flags
+
+Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal. Does not handle 'set'
+magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
+appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> 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<sv_setsv>, 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<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+C<sv_utf8_upgrade_nomg> 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<vsprintf> and appends the formatted output
diff --git a/pp_hot.c b/pp_hot.c
index ddb3ed7f03..c198b22866 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 4dbee28c84..c824a79c06 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 d8527126a7..7b53a43d1a 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<flags> has C<SV_GMAGIC> bit set,
+will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
+C<sv_utf8_upgrade_nomg> 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<sv_setsv_mg>.
=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<ssv> into the destination SV C<dsv>.
+The source SV may be destroyed if it is mortal. Does not handle 'set'
+magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
+appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> 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<sv_catpvn_mg>.
=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<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
+appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> 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<sv_catsv_mg>.
=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<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
+bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
+and C<sv_catsv_nomg> 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<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
+appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> 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 fe98cfa591..e1281d28dc 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 0000000000..ab6d2ee3e6
--- /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 3ee853f6e2..c5a3790587 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 {
View Lorry Controller Status