summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--av.c2
-rw-r--r--cpan/Compress-Raw-Bzip2/Bzip2.xs68
-rw-r--r--cpan/Compress-Raw-Zlib/Zlib.xs82
-rw-r--r--doio.c1
-rw-r--r--doop.c10
-rw-r--r--embed.fnc7
-rw-r--r--embed.h3
-rw-r--r--ext/Devel-Peek/t/Peek.t2
-rw-r--r--gv.c2
-rw-r--r--mg.c51
-rw-r--r--pp.c2
-rw-r--r--pp_ctl.c8
-rw-r--r--pp_hot.c13
-rw-r--r--pp_sys.c19
-rw-r--r--proto.h20
-rw-r--r--sv.c558
-rw-r--r--sv.h169
-rw-r--r--t/op/eval.t2
-rw-r--r--t/op/tie.t5
19 files changed, 486 insertions, 538 deletions
diff --git a/av.c b/av.c
index 05516688ce..ce7af44486 100644
--- a/av.c
+++ b/av.c
@@ -965,7 +965,7 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
mg = mg_find(sv, PERL_MAGIC_tiedelem);
if (mg) {
magic_existspack(sv, mg);
- return cBOOL(SvTRUE(sv));
+ return cBOOL(SvTRUE_nomg(sv));
}
}
diff --git a/cpan/Compress-Raw-Bzip2/Bzip2.xs b/cpan/Compress-Raw-Bzip2/Bzip2.xs
index 7c15ee68f4..128063c9b7 100644
--- a/cpan/Compress-Raw-Bzip2/Bzip2.xs
+++ b/cpan/Compress-Raw-Bzip2/Bzip2.xs
@@ -281,9 +281,8 @@ char * string;
croak("%s: buffer parameter is a reference to a reference", string) ;
}
- if (!SvOK(sv)) {
- sv = newSVpv("", 0);
- }
+ if (!SvOK(sv))
+ sv = sv_2mortal(newSVpv("", 0));
return sv ;
}
@@ -299,6 +298,7 @@ char * string ;
{
dTHX;
bool wipe = 0 ;
+ STRLEN na;
SvGETMAGIC(sv);
wipe = ! SvOK(sv) ;
@@ -323,14 +323,11 @@ char * string ;
if (SvREADONLY(sv) && PL_curcop != &PL_compiling)
croak("%s: buffer parameter is read-only", string);
- SvUPGRADE(sv, SVt_PV);
-
+ SvUPGRADE(sv, SVt_PV) ;
if (wipe)
- SvCUR_set(sv, 0);
-
- SvOOK_off(sv);
- SvPOK_only(sv);
-
+ sv_setpv(sv, "") ;
+ else
+ (void)SvPVbyte_force(sv, na) ;
return sv ;
}
@@ -496,9 +493,9 @@ bzdeflate (s, buf, output)
#ifdef UTF8_AVAILABLE
if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1))
croak("Wide character in " COMPRESS_CLASS "::bzdeflate input parameter");
-#endif
- s->stream.next_in = (char*)SvPVbyte_nolen(buf) ;
- s->stream.avail_in = SvCUR(buf) ;
+#endif
+ s->stream.next_in = SvPV_nomg_nolen(buf);
+ s->stream.avail_in = SvCUR(buf);
/* and retrieve the output buffer */
output = deRef_l(output, "deflate") ;
@@ -506,13 +503,10 @@ bzdeflate (s, buf, output)
if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1))
croak("Wide character in " COMPRESS_CLASS "::bzdeflate output parameter");
#endif
-
- if((s->flags & FLAG_APPEND_OUTPUT) != FLAG_APPEND_OUTPUT) {
+ if((s->flags & FLAG_APPEND_OUTPUT) != FLAG_APPEND_OUTPUT)
SvCUR_set(output, 0);
- /* sv_setpvn(output, "", 0); */
- }
cur_length = SvCUR(output) ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
while (s->stream.avail_in != 0) {
@@ -521,7 +515,7 @@ bzdeflate (s, buf, output)
/* out of space in the output buffer so make it bigger */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -571,12 +565,10 @@ bzclose(s, output)
if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1))
croak("Wide character in " COMPRESS_CLASS "::bzclose input parameter");
#endif
- if(! s->flags & FLAG_APPEND_OUTPUT) {
+ if(! s->flags & FLAG_APPEND_OUTPUT)
SvCUR_set(output, 0);
- /* sv_setpvn(output, "", 0); */
- }
cur_length = SvCUR(output) ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
@@ -585,7 +577,7 @@ bzclose(s, output)
/* consumed all the available output, so extend it */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -632,12 +624,10 @@ bzflush(s, output)
if (DO_UTF8(output) && !sv_utf8_downgrade(output, 1))
croak("Wide character in " COMPRESS_CLASS "::bzflush input parameter");
#endif
- if(! s->flags & FLAG_APPEND_OUTPUT) {
+ if(! s->flags & FLAG_APPEND_OUTPUT)
SvCUR_set(output, 0);
- /* sv_setpvn(output, "", 0); */
- }
cur_length = SvCUR(output) ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
@@ -646,7 +636,7 @@ bzflush(s, output)
/* consumed all the available output, so extend it */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -743,8 +733,8 @@ bzinflate (s, buf, output)
#endif
/* initialise the input buffer */
- s->stream.next_in = (char*)SvPVbyte_force(buf, stmp) ;
- s->stream.avail_in = SvCUR(buf);
+ s->stream.next_in = SvPV_nomg_nolen(buf);
+ s->stream.avail_in = stmp = SvCUR(buf);
/* and retrieve the output buffer */
output = deRef_l(output, "bzinflate") ;
@@ -774,7 +764,7 @@ bzinflate (s, buf, output)
*/
if (SvLEN(output) > cur_length + 1)
{
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length - 1;
s->stream.avail_out = increment;
}
@@ -790,7 +780,7 @@ bzinflate (s, buf, output)
/* out of space in the output buffer so make it bigger */
Sv_Grow(output, SvLEN(output) + bufinc + 1) ;
cur_length += increment ;
- s->stream.next_out = (char*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -823,21 +813,21 @@ bzinflate (s, buf, output)
SvPOK_only(output);
SvCUR_set(output, prefix_length + s->bytesInflated) ;
- *SvEND(output) = '\0';
+ *SvEND(output) = '\0' ;
#ifdef UTF8_AVAILABLE
if (out_utf8)
- sv_utf8_upgrade(output);
+ sv_utf8_upgrade(output) ;
#endif
- SvSETMAGIC(output);
+ SvSETMAGIC(output) ;
/* fix the input buffer */
if (s->flags & FLAG_CONSUME_INPUT) {
in = s->stream.avail_in ;
SvCUR_set(buf, in) ;
if (in)
- Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ;
- *SvEND(buf) = '\0';
- SvSETMAGIC(buf);
+ Move(s->stream.next_in, SvPVX(buf), in, char) ;
+ *SvEND(buf) = '\0' ;
+ SvSETMAGIC(buf) ;
}
}
OUTPUT:
diff --git a/cpan/Compress-Raw-Zlib/Zlib.xs b/cpan/Compress-Raw-Zlib/Zlib.xs
index 9c493aee2e..e57a38a852 100644
--- a/cpan/Compress-Raw-Zlib/Zlib.xs
+++ b/cpan/Compress-Raw-Zlib/Zlib.xs
@@ -575,9 +575,8 @@ char * string;
croak("%s: buffer parameter is a reference to a reference", string) ;
}
- if (!SvOK(sv)) {
- sv = newSVpv("", 0);
- }
+ if (!SvOK(sv))
+ sv = sv_2mortal(newSVpv("", 0));
return sv ;
}
@@ -593,6 +592,7 @@ char * string ;
{
dTHX;
bool wipe = 0 ;
+ STRLEN na;
SvGETMAGIC(sv);
wipe = ! SvOK(sv) ;
@@ -617,14 +617,11 @@ char * string ;
if (SvREADONLY(sv) && PL_curcop != &PL_compiling)
croak("%s: buffer parameter is read-only", string);
- SvUPGRADE(sv, SVt_PV);
-
+ SvUPGRADE(sv, SVt_PV) ;
if (wipe)
- SvCUR_set(sv, 0);
-
- SvOOK_off(sv);
- SvPOK_only(sv);
-
+ sv_setpv(sv, "") ;
+ else
+ (void)SvPVbyte_force(sv, na) ;
return sv ;
}
@@ -797,13 +794,13 @@ _deflateInit(flags,level, method, windowBits, memLevel, strategy, bufsize, dicti
/* Check if a dictionary has been specified */
- if (err == Z_OK && SvCUR(dictionary)) {
+ SvGETMAGIC(dictionary);
+ if (err == Z_OK && SvPOK(dictionary) && SvCUR(dictionary)) {
#ifdef UTF8_AVAILABLE
- if (DO_UTF8(dictionary) && !sv_utf8_downgrade(dictionary, 1))
- croak("Wide character in Compress::Raw::Zlib::Deflate::new dicrionary parameter");
+ if (DO_UTF8(dictionary) && !sv_utf8_downgrade(dictionary, 1))
+ croak("Wide character in Compress::Raw::Zlib::Deflate::new dicrionary parameter");
#endif
- err = deflateSetDictionary(&(s->stream), (const Bytef*) SvPVbyte_nolen(dictionary),
- SvCUR(dictionary)) ;
+ err = deflateSetDictionary(&(s->stream), (const Bytef*) SvPVX(dictionary), SvCUR(dictionary)) ;
s->dict_adler = s->stream.adler ;
}
@@ -926,11 +923,11 @@ deflate (s, buf, output)
Compress::Raw::Zlib::deflateStream s
SV * buf
SV * output
- uInt cur_length = NO_INIT
- uInt increment = NO_INIT
- uInt prefix = NO_INIT
- int RETVAL = 0;
- uLong bufinc = NO_INIT
+ PREINIT:
+ uInt cur_length;
+ uInt increment;
+ uInt prefix;
+ uLong bufinc;
CODE:
bufinc = s->bufsize;
@@ -942,7 +939,7 @@ deflate (s, buf, output)
if (DO_UTF8(buf) && !sv_utf8_downgrade(buf, 1))
croak("Wide character in Compress::Raw::Zlib::Deflate::deflate input parameter");
#endif
- s->stream.next_in = (Bytef*)SvPVbyte_nolen(buf) ;
+ s->stream.next_in = (Bytef*)SvPV_nomg_nolen(buf) ;
s->stream.avail_in = SvCUR(buf) ;
if (s->flags & FLAG_CRC32)
@@ -963,7 +960,7 @@ deflate (s, buf, output)
/* sv_setpvn(output, "", 0); */
}
prefix = cur_length = SvCUR(output) ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
#ifdef SETP_BYTE
@@ -994,13 +991,14 @@ deflate (s, buf, output)
s->deflateParams_out_length = 0;
}
#endif
+ RETVAL = Z_OK ;
while (s->stream.avail_in != 0) {
if (s->stream.avail_out == 0) {
/* out of space in the output buffer so make it bigger */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -1064,7 +1062,7 @@ flush(s, output, f=Z_FINISH)
/* sv_setpvn(output, "", 0); */
}
prefix = cur_length = SvCUR(output) ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length;
s->stream.avail_out = increment;
#ifdef SETP_BYTE
@@ -1101,7 +1099,7 @@ flush(s, output, f=Z_FINISH)
/* consumed all the available output, so extend it */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -1321,12 +1319,11 @@ inflate (s, buf, output, eof=FALSE)
SV * buf
SV * output
bool eof
+ PREINIT:
uInt cur_length = 0;
uInt prefix_length = 0;
int increment = 0;
- STRLEN stmp = NO_INIT
- uLong bufinc = NO_INIT
- PREINIT:
+ uLong bufinc;
#ifdef UTF8_AVAILABLE
bool out_utf8 = FALSE;
#endif
@@ -1343,7 +1340,7 @@ inflate (s, buf, output, eof=FALSE)
#endif
/* initialise the input buffer */
- s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ;
+ s->stream.next_in = (Bytef*)SvPV_nomg_nolen(buf) ;
s->stream.avail_in = SvCUR(buf) ;
/* and retrieve the output buffer */
@@ -1375,7 +1372,7 @@ inflate (s, buf, output, eof=FALSE)
*/
if (SvLEN(output) > cur_length + 1)
{
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length;
increment = SvLEN(output) - cur_length - 1;
s->stream.avail_out = increment;
}
@@ -1391,7 +1388,7 @@ inflate (s, buf, output, eof=FALSE)
/* out of space in the output buffer so make it bigger */
Sv_Grow(output, SvLEN(output) + bufinc +1) ;
cur_length += increment ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -1409,7 +1406,7 @@ Perl_sv_dump(output); */
if (RETVAL == Z_NEED_DICT && s->dictionary) {
s->dict_adler = s->stream.adler ;
RETVAL = inflateSetDictionary(&(s->stream),
- (const Bytef*)SvPVbyte_nolen(s->dictionary),
+ (const Bytef*)SvPVX(s->dictionary),
SvCUR(s->dictionary));
if (RETVAL == Z_OK)
continue;
@@ -1442,7 +1439,7 @@ Perl_sv_dump(output); */
/* out of space in the output buffer so make it bigger */
Sv_Grow(output, SvLEN(output) + bufinc) ;
cur_length += increment ;
- s->stream.next_out = (Bytef*) SvPVbyte_nolen(output) + cur_length ;
+ s->stream.next_out = (Bytef*) SvPVX(output) + cur_length ;
increment = bufinc ;
s->stream.avail_out = increment;
bufinc *= 2 ;
@@ -1472,12 +1469,12 @@ Perl_sv_dump(output); */
if (s->flags & FLAG_CRC32 )
s->crc32 = crc32(s->crc32,
- (const Bytef*)SvPVbyte_nolen(output)+prefix_length,
+ (const Bytef*)SvPVX(output)+prefix_length,
SvCUR(output)-prefix_length) ;
if (s->flags & FLAG_ADLER32)
s->adler32 = adler32(s->adler32,
- (const Bytef*)SvPVbyte_nolen(output)+prefix_length,
+ (const Bytef*)SvPVX(output)+prefix_length,
SvCUR(output)-prefix_length) ;
/* fix the input buffer */
@@ -1485,7 +1482,7 @@ Perl_sv_dump(output); */
in = s->stream.avail_in ;
SvCUR_set(buf, in) ;
if (in)
- Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ;
+ Move(s->stream.next_in, SvPVX(buf), in, char) ;
*SvEND(buf) = '\0';
SvSETMAGIC(buf);
}
@@ -1533,7 +1530,7 @@ inflateSync (s, buf)
#endif
/* initialise the input buffer */
- s->stream.next_in = (Bytef*)SvPVbyte_nolen(buf) ;
+ s->stream.next_in = (Bytef*)SvPV_nomg_nolen(buf) ;
s->stream.avail_in = SvCUR(buf) ;
/* inflateSync doesn't create any output */
@@ -1548,7 +1545,7 @@ inflateSync (s, buf)
unsigned in = s->stream.avail_in ;
SvCUR_set(buf, in) ;
if (in)
- Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ;
+ Move(s->stream.next_in, SvPVX(buf), in, char) ;
*SvEND(buf) = '\0';
SvSETMAGIC(buf);
}
@@ -1694,7 +1691,6 @@ scan(s, buf, out=NULL, eof=FALSE)
bool eof
bool eof_mode = FALSE;
int start_len = NO_INIT
- STRLEN stmp = NO_INIT
CODE:
/* If the input buffer is a reference, dereference it */
#ifndef MAGIC_APPEND
@@ -1707,7 +1703,7 @@ scan(s, buf, out=NULL, eof=FALSE)
croak("Wide character in Compress::Raw::Zlib::InflateScan::scan input parameter");
#endif
/* initialise the input buffer */
- s->stream.next_in = (Bytef*)SvPVbyte_force(buf, stmp) ;
+ s->stream.next_in = (Bytef*)SvPV_nomg_nolen(buf) ;
s->stream.avail_in = SvCUR(buf) ;
start_len = s->stream.avail_in ;
s->bytesInflated = 0 ;
@@ -1792,9 +1788,9 @@ scan(s, buf, out=NULL, eof=FALSE)
unsigned in = s->stream.avail_in ;
SvCUR_set(buf, in) ;
if (in)
- Move(s->stream.next_in, SvPVbyte_nolen(buf), in, char) ;
- *SvEND(buf) = '\0';
- SvSETMAGIC(buf);
+ Move(s->stream.next_in, SvPVX(buf), in, char) ;
+ *SvEND(buf) = '\0';
+ SvSETMAGIC(buf);
}
}
#endif
diff --git a/doio.c b/doio.c
index fd6683da26..e5098b7002 100644
--- a/doio.c
+++ b/doio.c
@@ -747,6 +747,7 @@ Perl_nextargv(pTHX_ register GV *gv)
STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
+ SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
sv_setsv(GvSVn(gv),sv);
SvSETMAGIC(GvSV(gv));
PL_oldname = SvPVx(GvSV(gv), oldlen);
diff --git a/doop.c b/doop.c
index dd6add2bc5..1593d1942b 100644
--- a/doop.c
+++ b/doop.c
@@ -1131,12 +1131,12 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
else if (lulen)
dcsave = savepvn(lc, lulen);
if (sv == left || sv == right)
- (void)sv_usepvn(sv, dcorig, needlen); /* Uses Renew(). */
+ (void)sv_usepvn(sv, dcorig, needlen); /* uses Renew(); defaults to nomg */
SvCUR_set(sv, dc - dcorig);
if (rulen)
- sv_catpvn(sv, dcsave, rulen);
+ sv_catpvn_nomg(sv, dcsave, rulen);
else if (lulen)
- sv_catpvn(sv, dcsave, lulen);
+ sv_catpvn_nomg(sv, dcsave, lulen);
else
*SvEND(sv) = '\0';
Safefree(dcsave);
@@ -1214,9 +1214,9 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
mop_up:
len = lensave;
if (rightlen > len)
- sv_catpvn(sv, rsave + len, rightlen - len);
+ sv_catpvn_nomg(sv, rsave + len, rightlen - len);
else if (leftlen > (STRLEN)len)
- sv_catpvn(sv, lsave + len, leftlen - len);
+ sv_catpvn_nomg(sv, lsave + len, leftlen - len);
else
*SvEND(sv) = '\0';
break;
diff --git a/embed.fnc b/embed.fnc
index eb81d9c168..0f19f7c58e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1373,6 +1373,9 @@ Apd |void |sv_usepvn_flags|NN SV *const sv|NULLOK char* ptr|const STRLEN len\
Apd |void |sv_vcatpvfn |NN SV *const sv|NN const char *const pat|const STRLEN patlen \
|NULLOK va_list *const args|NULLOK SV **const svargs|const I32 svmax \
|NULLOK bool *const maybe_tainted
+Apd |void |sv_vcatpvfn_flags|NN SV *const sv|NN const char *const pat|const STRLEN patlen \
+ |NULLOK va_list *const args|NULLOK SV **const svargs|const I32 svmax \
+ |NULLOK bool *const maybe_tainted|const U32 flags
Apd |void |sv_vsetpvfn |NN SV *const sv|NN const char *const pat|const STRLEN patlen \
|NULLOK va_list *const args|NULLOK SV **const svargs \
|const I32 svmax|NULLOK bool *const maybe_tainted
@@ -2213,7 +2216,9 @@ Apd |void |sv_catsv_flags |NN SV *const dsv|NULLOK SV *const ssv|const I32 flags
Apmd |STRLEN |sv_utf8_upgrade_flags|NN SV *const sv|const I32 flags
Ap |STRLEN |sv_utf8_upgrade_flags_grow|NN SV *const sv|const I32 flags|STRLEN extra
Apd |char* |sv_pvn_force_flags|NN SV *const sv|NULLOK STRLEN *const lp|const I32 flags
-Apd |void |sv_copypv |NN SV *const dsv|NN SV *const ssv
+pmb |void |sv_copypv |NN SV *const dsv|NN SV *const ssv
+Apmd |void |sv_copypv_nomg |NN SV *const dsv|NN SV *const ssv
+Apd |void |sv_copypv_flags |NN SV *const dsv|NN SV *const ssv|const I32 flags
Ap |char* |my_atof2 |NN const char *s|NN NV* value
Apn |int |my_socketpair |int family|int type|int protocol|int fd[2]
Ap |int |my_dirfd |NULLOK DIR* dir
diff --git a/embed.h b/embed.h
index 5dca8e33df..a010f2dc02 100644
--- a/embed.h
+++ b/embed.h
@@ -560,7 +560,7 @@
#define sv_clear(a) Perl_sv_clear(aTHX_ a)
#define sv_cmp_flags(a,b,c) Perl_sv_cmp_flags(aTHX_ a,b,c)
#define sv_cmp_locale_flags(a,b,c) Perl_sv_cmp_locale_flags(aTHX_ a,b,c)
-#define sv_copypv(a,b) Perl_sv_copypv(aTHX_ a,b)
+#define sv_copypv_flags(a,b,c) Perl_sv_copypv_flags(aTHX_ a,b,c)
#define sv_dec(a) Perl_sv_dec(aTHX_ a)
#define sv_dec_nomg(a) Perl_sv_dec_nomg(aTHX_ a)
#define sv_derived_from(a,b) Perl_sv_derived_from(aTHX_ a,b)
@@ -650,6 +650,7 @@
#define sv_vcatpvf(a,b,c) Perl_sv_vcatpvf(aTHX_ a,b,c)
#define sv_vcatpvf_mg(a,b,c) Perl_sv_vcatpvf_mg(aTHX_ a,b,c)
#define sv_vcatpvfn(a,b,c,d,e,f,g) Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g)
+#define sv_vcatpvfn_flags(a,b,c,d,e,f,g,h) Perl_sv_vcatpvfn_flags(aTHX_ a,b,c,d,e,f,g,h)
#define sv_vsetpvf(a,b,c) Perl_sv_vsetpvf(aTHX_ a,b,c)
#define sv_vsetpvf_mg(a,b,c) Perl_sv_vsetpvf_mg(aTHX_ a,b,c)
#define sv_vsetpvfn(a,b,c,d,e,f,g) Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index 2b5f6aa402..dd9d102c3e 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -549,7 +549,7 @@ do_test('tainted value in %ENV',
$ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value
'SV = PVMG\\($ADDR\\) at $ADDR
REFCNT = 1
- FLAGS = \\(GMG,SMG,RMG,pIOK,pPOK\\)
+ FLAGS = \\(GMG,SMG,RMG,IOK,POK,pIOK,pPOK\\)
IV = 0
NV = 0
PV = $ADDR "0"\\\0
diff --git a/gv.c b/gv.c
index e0fdc630e9..c165285262 100644
--- a/gv.c
+++ b/gv.c
@@ -1226,6 +1226,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
}
LEAVE;
varsv = GvSVn(vargv);
+ SvTAINTED_off(varsv); /* previous $AUTOLOAD taint is obsolete */
+ /* XXX: this process is not careful to avoid extra magic gets and sets; tied $AUTOLOAD will get noise */
sv_setsv(varsv, packname);
sv_catpvs(varsv, "::");
/* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
diff --git a/mg.c b/mg.c
index 1c01152496..dd8003e4c2 100644
--- a/mg.c
+++ b/mg.c
@@ -76,6 +76,7 @@ void setegid(uid_t id);
#endif
/*
+ * Pre-magic setup and post-magic takedown.
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
*/
@@ -97,6 +98,8 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
PERL_ARGS_ASSERT_SAVE_MAGIC;
+ assert(SvMAGICAL(sv));
+
/* we shouldn't really be called here with RC==0, but it can sometimes
* happen via mg_clear() (which also shouldn't be called when RC==0,
* but it can happen). Handle this case gracefully(ish) by not RC++
@@ -108,7 +111,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
bumped = TRUE;
}
- assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
if (SvIsCOW(sv))
@@ -125,10 +127,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
- /* No public flags are set, so promote any private flags to public. */
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- }
}
/*
@@ -952,21 +950,17 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
else if (PL_compiling.cop_warnings == pWARN_ALL) {
/* Get the bit mask for $warnings::Bits{all}, because
* it could have been extended by warnings::register */
- HV * const bits=get_hv("warnings::Bits", 0);
- if (bits) {
- SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
- if (bits_all)
- sv_setsv(sv, *bits_all);
- }
- else {
- sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
- }
+ HV * const bits = get_hv("warnings::Bits", 0);
+ SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
+ if (bits_all)
+ sv_copypv(sv, *bits_all);
+ else
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
*PL_compiling.cop_warnings);
}
- SvPOK_only(sv);
}
break;
case '\015': /* $^MATCH */
@@ -1078,6 +1072,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
case '\\':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
+ else
+ sv_setsv(sv, &PL_sv_undef);
break;
case '$': /* $$ */
{
@@ -1106,8 +1102,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
- if (SvPOKp(sv))
- SvPOK_on(sv); /* may have got removed during taint processing */
RESTORE_ERRNO;
}
@@ -2140,7 +2134,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
found->mg_len = -1;
return 0;
}
- len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
+ len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv);
pos = SvIV(sv);
@@ -3249,31 +3243,20 @@ S_restore_magic(pTHX_ const void *p)
if (!sv)
return;
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
#ifdef PERL_OLD_COPY_ON_WRITE
/* While magic was saved (and off) sv_setsv may well have seen
this SV as a prime candidate for COW. */
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
#endif
-
if (mgs->mgs_readonly)
SvREADONLY_on(sv);
if (mgs->mgs_magical)
SvFLAGS(sv) |= mgs->mgs_magical;
else
mg_magical(sv);
- if (SvGMAGICAL(sv)) {
- /* downgrade public flags to private,
- and discard any other private flags */
-
- const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
- if (pubflags) {
- SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
- SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
- }
- }
}
bumped = mgs->mgs_bumped;
@@ -3302,12 +3285,8 @@ S_restore_magic(pTHX_ const void *p)
So artificially keep it alive a bit longer.
We avoid turning on the TEMP flag, which can cause the SV's
buffer to get stolen (and maybe other stuff). */
- int was_temp = SvTEMP(sv);
sv_2mortal(sv);
- if (!was_temp) {
- SvTEMP_off(sv);
- }
- SvOK_off(sv);
+ SvTEMP_off(sv);
}
else
SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
diff --git a/pp.c b/pp.c
index 661c055ffa..0def4ac35f 100644
--- a/pp.c
+++ b/pp.c
@@ -991,7 +991,7 @@ PP(pp_postinc)
if (SvROK(TOPs))
TARG = sv_newmortal();
sv_setsv(TARG, TOPs);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
diff --git a/pp_ctl.c b/pp_ctl.c
index 826a772938..f2119a77d1 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -225,9 +225,9 @@ PP(pp_substcont)
assert(cx->sb_strend >= s);
if(cx->sb_strend > s) {
if (DO_UTF8(dstr) && !SvUTF8(targ))
- sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
else
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
}
if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
cx->sb_rxtainted |= SUBST_TAINT_PAT;
@@ -296,9 +296,9 @@ PP(pp_substcont)
cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
if (m > s) {
if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg(dstr, s, m-s);
}
cx->sb_s = RX_OFFS(rx)[0].end + orig;
{ /* Update the pos() information. */
diff --git a/pp_hot.c b/pp_hot.c
index 1c0acb92b0..e04d5ca7ed 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -370,7 +370,7 @@ PP(pp_preinc)
PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
Perl_croak_no_modify(aTHX);
- if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
@@ -1592,6 +1592,7 @@ Perl_do_readline(pTHX)
if (av_len(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
+ SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
fp = IoIFP(io);
@@ -2358,20 +2359,20 @@ PP(pp_subst)
}
m = RX_OFFS(rx)[0].start + orig;
if (doutf8 && !SvUTF8(dstr))
- sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
else
- sv_catpvn(dstr, s, m-s);
+ sv_catpvn_nomg(dstr, s, m-s);
s = RX_OFFS(rx)[0].end + orig;
if (clen)
- sv_catpvn(dstr, c, clen);
+ sv_catpvn_nomg(dstr, c, clen);
if (once)
break;
} while (CALLREGEXEC(rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
if (doutf8 && !DO_UTF8(TARG))
- sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
+ sv_catpvn_nomg_utf8_upgrade(dstr, s, strend - s, nsv);
else
- sv_catpvn(dstr, s, strend - s);
+ sv_catpvn_nomg(dstr, s, strend - s);
if (rpm->op_pmflags & PMf_NONDESTRUCT) {
/* From here on down we're using the copy, and leaving the original
diff --git a/pp_sys.c b/pp_sys.c
index f0a799e238..76bd1acbf2 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1630,6 +1630,8 @@ PP(pp_sysread)
if (! SvOK(bufsv))
sv_setpvs(bufsv, "");
length = SvIVx(*++MARK);
+ if (length < 0)
+ DIE(aTHX_ "Negative length");
SETERRNO(0,0);
if (MARK < SP)
offset = SvIVx(*++MARK);
@@ -1651,13 +1653,19 @@ PP(pp_sysread)
buffer = SvPV_force(bufsv, blen);
buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
}
- if (length < 0)
- DIE(aTHX_ "Negative length");
- wanted = length;
+ if (DO_UTF8(bufsv)) {
+ /* offset adjust in characters not bytes */
+ /* SV's length cache is only safe for non-magical values */
+ if (SvGMAGICAL(bufsv))
+ blen = utf8_length((const U8 *)buffer, (const U8 *)buffer + blen);
+ else
+ blen = sv_len_utf8(bufsv);
+ }
charstart = TRUE;
charskip = 0;
skip = 0;
+ wanted = length;
#ifdef HAS_SOCKET
if (PL_op->op_type == OP_RECV) {
@@ -1700,10 +1708,6 @@ PP(pp_sysread)
RETURN;
}
#endif
- if (DO_UTF8(bufsv)) {
- /* offset adjust in characters not bytes */
- blen = sv_len_utf8(bufsv);
- }
if (offset < 0) {
if (-offset > (SSize_t)blen)
DIE(aTHX_ "Offset outside string");
@@ -2819,6 +2823,7 @@ PP(pp_stat)
goto do_fstat_have_io;
}
+ SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
PL_statgv = NULL;
PL_laststype = PL_op->op_type;
diff --git a/proto.h b/proto.h
index 946e9fe76e..db957ac456 100644
--- a/proto.h
+++ b/proto.h
@@ -3885,12 +3885,22 @@ PERL_CALLCONV I32 Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2);
PERL_CALLCONV I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
PERL_CALLCONV I32 Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2);
PERL_CALLCONV I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const U32 flags);
-PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
+/* PERL_CALLCONV void Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
__attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
+ __attribute__nonnull__(pTHX_2); */
#define PERL_ARGS_ASSERT_SV_COPYPV \
assert(dsv); assert(ssv)
+PERL_CALLCONV void Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_COPYPV_FLAGS \
+ assert(dsv); assert(ssv)
+
+/* PERL_CALLCONV void Perl_sv_copypv_nomg(pTHX_ SV *const dsv, SV *const ssv)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2); */
+
PERL_CALLCONV void Perl_sv_dec(pTHX_ SV *const sv);
PERL_CALLCONV void Perl_sv_dec_nomg(pTHX_ SV *const sv);
PERL_CALLCONV void Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
@@ -4398,6 +4408,12 @@ PERL_CALLCONV void Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, c
#define PERL_ARGS_ASSERT_SV_VCATPVFN \
assert(sv); assert(pat)
+PERL_CALLCONV void Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted, const U32 flags)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS \
+ assert(sv); assert(pat)
+
PERL_CALLCONV void Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
diff --git a/sv.c b/sv.c
index 9caaa4da54..25de4ac77f 100644
--- a/sv.c
+++ b/sv.c
@@ -2256,22 +2256,37 @@ IV
Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV * tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvIV(tmpstr);
+ }
+ }
+ return PTR2IV(SvRV(sv));
+ }
+
+ if (SvVALID(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs.
In practice they are extremely unlikely to actually get anywhere
accessible by user Perl code - the only way that I'm aware of is when
a constant subroutine which is used as the second argument to index.
*/
- if (flags & SV_GMAGIC)
- mg_get(sv);
if (SvIOKp(sv))
return SvIVX(sv);
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv))
return I_V(SvNVX(sv));
- }
if (SvPOKp(sv) && SvLEN(sv)) {
UV value;
const int numtype
@@ -2294,25 +2309,12 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
}
return I_V(Atof(SvPVX_const(sv)));
}
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV * tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvIV(tmpstr);
- }
- }
- return PTR2IV(SvRV(sv));
- }
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+
+ if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
@@ -2322,10 +2324,12 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags)
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
}
+
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
PTR2UV(sv),SvIVX(sv)));
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
@@ -2367,13 +2371,29 @@ UV
Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
{
dVAR;
+
if (!sv)
return 0;
- if (SvGMAGICAL(sv) || SvVALID(sv)) {
+
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return 0;
+ tmpstr = AMG_CALLunary(sv, numer_amg);
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ return SvUV(tmpstr);
+ }
+ }
+ return PTR2UV(SvRV(sv));
+ }
+
+ if (SvVALID(sv)) {
/* FBMs use the space for SvIVX and SvNVX for other purposes, and use
the same flag bit as SVf_IVisUV, so must not let them cache IVs. */
- if (flags & SV_GMAGIC)
- mg_get(sv);
if (SvIOKp(sv))
return SvUVX(sv);
if (SvNOKp(sv))
@@ -2395,25 +2415,12 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
}
return U_V(Atof(SvPVX_const(sv)));
}
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit inside S_sv_2iuv_common. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return 0;
- tmpstr = AMG_CALLunary(sv, numer_amg);
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- return SvUV(tmpstr);
- }
- }
- return PTR2UV(SvRV(sv));
- }
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(sv);
+ return 0;
+ }
+
+ if (SvTHINKFIRST(sv)) {
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
@@ -2423,6 +2430,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags)
return 0;
}
}
+
if (!SvIOKp(sv)) {
if (S_sv_2iuv_common(aTHX_ sv))
return 0;
@@ -2744,190 +2752,143 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
*lp = 0;
return (char *)"";
}
- if (SvGMAGICAL(sv)) {
- if (flags & SV_GMAGIC)
- mg_get(sv);
- if (SvPOKp(sv)) {
- if (lp)
- *lp = SvCUR(sv);
- if (flags & SV_MUTABLE_RETURN)
- return SvPVX_mutable(sv);
- if (flags & SV_CONST_RETURN)
- return (char *)SvPVX_const(sv);
- return SvPVX(sv);
- }
- if (SvIOKp(sv) || SvNOKp(sv)) {
- char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
- STRLEN len;
-
- if (SvIOKp(sv)) {
- len = SvIsUV(sv)
- ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
- : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
- } else if(SvNVX(sv) == 0.0) {
- tbuf[0] = '0';
- tbuf[1] = 0;
- len = 1;
- } else {
- Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
- len = strlen(tbuf);
- }
- assert(!SvROK(sv));
- {
- dVAR;
+ if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
+ mg_get(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ SV *tmpstr;
+ if (flags & SV_SKIP_OVERLOAD)
+ return NULL;
+ tmpstr = AMG_CALLunary(sv, string_amg);
+ TAINT_IF(tmpstr && SvTAINTED(tmpstr));
+ if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
+ /* Unwrap this: */
+ /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
+ */
- SvUPGRADE(sv, SVt_PV);
- if (lp)
- *lp = len;
- s = SvGROW_mutable(sv, len + 1);
- SvCUR_set(sv, len);
- SvPOKp_on(sv);
- return (char*)memcpy(s, tbuf, len + 1);
- }
- }
- if (SvROK(sv)) {
- goto return_rok;
- }
- assert(SvTYPE(sv) >= SVt_PVMG);
- /* This falls through to the report_uninit near the end of the
- function. */
- } else if (SvTHINKFIRST(sv)) {
- if (SvROK(sv)) {
- return_rok:
- if (SvAMAGIC(sv)) {
- SV *tmpstr;
- if (flags & SV_SKIP_OVERLOAD)
- return NULL;
- tmpstr = AMG_CALLunary(sv, string_amg);
- TAINT_IF(tmpstr && SvTAINTED(tmpstr));
- if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) {
- /* Unwrap this: */
- /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr);
- */
-
- char *pv;
- if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
- if (flags & SV_CONST_RETURN) {
- pv = (char *) SvPVX_const(tmpstr);
- } else {
- pv = (flags & SV_MUTABLE_RETURN)
- ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
- }
- if (lp)
- *lp = SvCUR(tmpstr);
+ char *pv;
+ if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) {
+ if (flags & SV_CONST_RETURN) {
+ pv = (char *) SvPVX_const(tmpstr);
} else {
- pv = sv_2pv_flags(tmpstr, lp, flags);
+ pv = (flags & SV_MUTABLE_RETURN)
+ ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr);
}
- if (SvUTF8(tmpstr))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return pv;
+ if (lp)
+ *lp = SvCUR(tmpstr);
+ } else {
+ pv = sv_2pv_flags(tmpstr, lp, flags);
}
+ if (SvUTF8(tmpstr))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
+ return pv;
}
- {
- STRLEN len;
- char *retval;
- char *buffer;
- SV *const referent = SvRV(sv);
-
- if (!referent) {
- len = 7;
- retval = buffer = savepvn("NULLREF", len);
- } else if (SvTYPE(referent) == SVt_REGEXP && (
- !(PL_curcop->cop_hints & HINT_NO_AMAGIC)
- || amagic_is_enabled(string_amg)
- )) {
- REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
-
- assert(re);
+ }
+ {
+ STRLEN len;
+ char *retval;
+ char *buffer;
+ SV *const referent = SvRV(sv);
+
+ if (!referent) {
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
+ } else if (SvTYPE(referent) == SVt_REGEXP &&
+ (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) ||
+ amagic_is_enabled(string_amg))) {
+ REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent);
+
+ assert(re);
- /* If the regex is UTF-8 we want the containing scalar to
- have an UTF-8 flag too */
- if (RX_UTF8(re))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
+ /* If the regex is UTF-8 we want the containing scalar to
+ have an UTF-8 flag too */
+ if (RX_UTF8(re))
+ SvUTF8_on(sv);
+ else
+ SvUTF8_off(sv);
- if (lp)
- *lp = RX_WRAPLEN(re);
+ if (lp)
+ *lp = RX_WRAPLEN(re);
- return RX_WRAPPED(re);
- } else {
- const char *const typestr = sv_reftype(referent, 0);
- const STRLEN typelen = strlen(typestr);
- UV addr = PTR2UV(referent);
- const char *stashname = NULL;
- STRLEN stashnamelen = 0; /* hush, gcc */
- const char *buffer_end;
-
- if (SvOBJECT(referent)) {
- const HEK *const name = HvNAME_HEK(SvSTASH(referent));
-
- if (name) {
- stashname = HEK_KEY(name);
- stashnamelen = HEK_LEN(name);
-
- if (HEK_UTF8(name)) {
- SvUTF8_on(sv);
- } else {
- SvUTF8_off(sv);
- }
+ return RX_WRAPPED(re);
+ } else {
+ const char *const typestr = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
+
+ if (SvOBJECT(referent)) {
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
} else {
- stashname = "__ANON__";
- stashnamelen = 8;
+ SvUTF8_off(sv);
}
- len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
} else {
- len = typelen + 3 /* (0x */
- + 2 * sizeof(UV) + 2 /* )\0 */;
- }
-
- Newx(buffer, len, char);
- buffer_end = retval = buffer + len;
-
- /* Working backwards */
- *--retval = '\0';
- *--retval = ')';
- do {
- *--retval = PL_hexdigit[addr & 15];
- } while (addr >>= 4);
- *--retval = 'x';
- *--retval = '0';
- *--retval = '(';
-
- retval -= typelen;
- memcpy(retval, typestr, typelen);
-
- if (stashname) {
- *--retval = '=';
- retval -= stashnamelen;
- memcpy(retval, stashname, stashnamelen);
+ stashname = "__ANON__";
+ stashnamelen = 8;
}
- /* retval may not necessarily have reached the start of the
- buffer here. */
- assert (retval >= buffer);
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ }
- len = buffer_end - retval - 1; /* -1 for that \0 */
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
}
- if (lp)
- *lp = len;
- SAVEFREEPV(buffer);
- return retval;
+ /* retval may not necessarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
- }
- if (SvREADONLY(sv) && !SvOK(sv)) {
if (lp)
- *lp = 0;
- if (flags & SV_UNDEF_RETURNS_NULL)
- return NULL;
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
- return (char *)"";
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
- if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
+
+ if (SvPOKp(sv)) {
+ if (lp)
+ *lp = SvCUR(sv);
+ if (flags & SV_MUTABLE_RETURN)
+ return SvPVX_mutable(sv);
+ if (flags & SV_CONST_RETURN)
+ return (char *)SvPVX_const(sv);
+ return SvPVX(sv);
+ }
+
+ if (SvIOK(sv)) {
/* I'm assuming that if both IV and NV are equally valid then
converting the IV is going to be more efficient */
const U32 isUIOK = SvIsUV(sv);
@@ -2945,7 +2906,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
s += len;
*s = '\0';
}
- else if (SvNOKp(sv)) {
+ else if (SvNOK(sv)) {
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
if (SvNVX(sv) == 0.0) {
@@ -2966,32 +2927,32 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags
*--s = '\0';
#endif
}
- else {
- if (isGV_with_GP(sv)) {
- GV *const gv = MUTABLE_GV(sv);
- SV *const buffer = sv_newmortal();
-
- gv_efullname3(buffer, gv, "*");
+ else if (isGV_with_GP(sv)) {
+ GV *const gv = MUTABLE_GV(sv);
+ SV *const buffer = sv_newmortal();
- assert(SvPOK(buffer));
- if (lp) {
- *lp = SvCUR(buffer);
- }
- if ( SvUTF8(buffer) ) SvUTF8_on(sv);
- return SvPVX(buffer);
- }
+ gv_efullname3(buffer, gv, "*");
+ assert(SvPOK(buffer));
+ if (SvUTF8(buffer))
+ SvUTF8_on(sv);
+ if (lp)
+ *lp = SvCUR(buffer);
+ return SvPVX(buffer);
+ }
+ else {
if (lp)
*lp = 0;
if (flags & SV_UNDEF_RETURNS_NULL)
return NULL;
if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- if (SvTYPE(sv) < SVt_PV)
- /* Typically the caller expects that sv_any is not NULL now. */
+ /* Typically the caller expects that sv_any is not NULL now. */
+ if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
sv_upgrade(sv, SVt_PV);
return (char *)"";
}
+
{
const STRLEN len = s - SvPVX_const(sv);
if (lp)
@@ -3019,17 +2980,37 @@ sv_2pv[_flags] but operates directly on an SV instead of just the
string. Mostly uses sv_2pv_flags to do its work, except when that
would lose the UTF-8'ness of the PV.
+=for apidoc sv_copypv_nomg
+
+Like sv_copypv, but doesn't invoke get magic first.
+
+=for apidoc sv_copypv_flags
+
+Implementation of sv_copypv and sv_copypv_nomg. Calls get magic iff flags
+include SV_GMAGIC.
+
=cut
*/
void
Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv)
{
+ PERL_ARGS_ASSERT_SV_COPYPV;
+
+ sv_copypv_flags(dsv, ssv, 0);
+}
+
+void
+Perl_sv_copypv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags)
+{
STRLEN len;
- const char * const s = SvPV_const(ssv,len);
+ const char *s;
- PERL_ARGS_ASSERT_SV_COPYPV;
+ PERL_ARGS_ASSERT_SV_COPYPV_FLAGS;
+ if ((flags & SV_GMAGIC) && SvGMAGICAL(ssv))
+ mg_get(ssv);
+ s = SvPV_nomg_const(ssv,len);
sv_setpvn(dsv,s,len);
if (SvUTF8(ssv))
SvUTF8_on(dsv);
@@ -3082,9 +3063,9 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
sv = sv_mortalcopy(sv);
- sv_utf8_upgrade(sv);
- if (SvGMAGICAL(sv)) SvFLAGS(sv) &= ~SVf_POK;
- assert(SvPOKp(sv));
+ else
+ SvGETMAGIC(sv);
+ sv_utf8_upgrade_nomg(sv);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
@@ -3125,30 +3106,7 @@ Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
}
return SvRV(sv) != 0;
}
- if (SvPOKp(sv)) {
- register XPV* const Xpvtmp = (XPV*)SvANY(sv);
- if (Xpvtmp &&
- (*sv->sv_u.svu_pv > '0' ||
- Xpvtmp->xpv_cur > 1 ||
- (Xpvtmp->xpv_cur && *sv->sv_u.svu_pv != '0')))
- return 1;
- else
- return 0;
- }
- else {
- if (SvIOKp(sv))
- return SvIVX(sv) != 0;
- else {
- if (SvNOKp(sv))
- return SvNVX(sv) != 0.0;
- else {
- if (isGV_with_GP(sv))
- return TRUE;
- else
- return FALSE;
- }
- }
- }
+ return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
/*
@@ -5065,18 +5023,19 @@ Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, re
/*
=for apidoc sv_catsv
-Concatenates the string from SV C<ssv> onto the end of the string in
-SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
-not 'set' magic. See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+Handles 'get' magic on both SVs, but no 'set' magic. See C<sv_catsv_mg> and
+C<sv_catsv_nomg>.
=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 C<ssv>, if appropriate, before
-reading it. If the C<flags> contain C<SV_SMAGIC>, C<mg_set> will be
-called on the modified SV afterward, if appropriate. C<sv_catsv>
-and C<sv_catsv_nomg> are implemented in terms of this function.
+Concatenates the string from SV C<ssv> onto the end of the string in SV
+C<dsv>. If C<ssv> is null, does nothing; otherwise modifies only C<dsv>.
+If C<flags> include C<SV_GMAGIC> bit set, will call C<mg_get> on both SVs if
+appropriate. If C<flags> include C<SV_SMAGIC>, C<mg_set> will be called on
+the modified SV afterward, if appropriate. C<sv_catsv>, C<sv_catsv_nomg>,
+and C<sv_catsv_mg> are implemented in terms of this function.
=cut */
@@ -5087,18 +5046,18 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
- if (ssv) {
+ if (ssv) {
STRLEN slen;
const char *spv = SvPV_flags_const(ssv, slen, flags);
if (spv) {
- if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
- mg_get(dsv);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(dsv);
sv_catpvn_flags(dsv, spv, slen,
DO_UTF8(ssv) ? SV_CATUTF8 : SV_CATBYTES);
- }
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(dsv);
+ }
}
- if (flags & SV_SMAGIC)
- SvSETMAGIC(dsv);
}
/*
@@ -5286,8 +5245,6 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
mg->mg_virtual = (MGVTBL *) vtable;
mg_magical(sv);
- if (SvGMAGICAL(sv))
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
return mg;
}
@@ -5354,13 +5311,8 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
/* sv_magic() refuses to add a magic of the same 'how' as an
existing one
*/
- if (how == PERL_MAGIC_taint) {
+ if (how == PERL_MAGIC_taint)
mg->mg_len |= 1;
- /* Any scalar which already had taint magic on which someone
- (erroneously?) did SvIOK_on() or similar will now be
- incorrectly sporting public "OK" flags. */
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
- }
return;
}
}
@@ -7901,9 +7853,9 @@ screamer2:
if (cnt < 0)
cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */
if (append)
- sv_catpvn(sv, (char *) buf, cnt);
+ sv_catpvn_nomg(sv, (char *) buf, cnt);
else
- sv_setpvn(sv, (char *) buf, cnt);
+ sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */
if (i != EOF && /* joy */
(!rslen ||
@@ -9969,7 +9921,7 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
PERL_ARGS_ASSERT_SV_VSETPVFN;
sv_setpvs(sv, "");
- sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
}
@@ -10043,18 +9995,21 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len)
/*
=for apidoc sv_vcatpvfn
+=for apidoc sv_vcatpvfn_flags
+
Processes its arguments like C<vsprintf> and appends the formatted output
to an SV. Uses an array of SVs if the C style variable argument list is
missing (NULL). When running with taint checks enabled, indicates via
C<maybe_tainted> if results are untrustworthy (often due to the use of
locales).
+If called as C<sv_vcatpvfn> or flags include C<SV_GMAGIC>, calls get magic.
+
Usually used via one of its frontends C<sv_vcatpvf> and C<sv_vcatpvf_mg>.
=cut
*/
-
#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\
vecstr = (U8*)SvPV_const(vecsv,veclen);\
vec_utf8 = DO_UTF8(vecsv);
@@ -10065,6 +10020,16 @@ void
Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted)
{
+ PERL_ARGS_ASSERT_SV_VCATPVFN;
+
+ sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
+}
+
+void
+Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
+ va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
+ const U32 flags)
+{
dVAR;
char *p;
char *q;
@@ -10083,11 +10048,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
- PERL_ARGS_ASSERT_SV_VCATPVFN;
+ PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
+ if (flags & SV_GMAGIC)
+ SvGETMAGIC(sv);
+
/* no matter what, this is a string now */
- (void)SvPV_force(sv, origlen);
+ (void)SvPV_force_nomg(sv, origlen);
/* special-case "", "%s", and "%-p" (SVf - see below) */
if (patlen == 0)
@@ -10095,10 +10063,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
if (args) {
const char * const s = va_arg(*args, char*);
- sv_catpv(sv, s ? s : nullstr);
+ sv_catpv_nomg(sv, s ? s : nullstr);
}
else if (svix < svmax) {
- sv_catsv(sv, *svargs);
+ /* we want get magic on the source but not the target. sv_catsv can't do that, though */
+ SvGETMAGIC(*svargs);
+ sv_catsv_nomg(sv, *svargs);
}
else
S_vcatpvfn_missing_argument(aTHX);
@@ -10107,7 +10077,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
argsv = MUTABLE_SV(va_arg(*args, void*));
- sv_catsv(sv, argsv);
+ sv_catsv_nomg(sv, argsv);
return;
}
@@ -10130,7 +10100,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
Gconvert(nv, (int)digits, 0, ebuf);
- sv_catpv(sv, ebuf);
+ sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
}
@@ -10138,7 +10108,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
STRLEN l;
if ((p = F0convert(nv, ebuf + sizeof ebuf, &l))) {
- sv_catpvn(sv, p, l);
+ sv_catpvn_nomg(sv, p, l);
return;
}
}
@@ -10209,9 +10179,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
if (has_utf8 && !pat_utf8)
- sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
+ sv_catpvn_nomg_utf8_upgrade(sv, p, q - p, nsv);
else
- sv_catpvn(sv, p, q - p);
+ sv_catpvn_nomg(sv, p, q - p);
p = q;
}
if (q++ >= patend)
@@ -11085,7 +11055,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
sv_catpvs(msg, "\"%");
for (f = fmtstart; f < fmtend; f++) {
if (isPRINT(*f)) {
- sv_catpvn(msg, f, 1);
+ sv_catpvn_nomg(msg, f, 1);
} else {
Perl_sv_catpvf(aTHX_ msg,
"\\%03"UVof, (UV)*f & 0xFF);
diff --git a/sv.h b/sv.h
index 1eeda1cc5d..c841c3e246 100644
--- a/sv.h
+++ b/sv.h
@@ -905,6 +905,25 @@ in gv.h: */
#define HvAMAGIC_on(hv) (SvFLAGS(hv) |= SVf_AMAGIC)
#define HvAMAGIC_off(hv) (SvFLAGS(hv) &=~ SVf_AMAGIC)
+
+#define SvPOK_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVs_GMG)) == SVf_POK)
+#define SvIOK_nog(sv) ((SvFLAGS(sv) & (SVf_IOK|SVs_GMG)) == SVf_IOK)
+#define SvUOK_nog(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV|SVs_GMG)) == (SVf_IOK|SVf_IVisUV))
+#define SvNOK_nog(sv) ((SvFLAGS(sv) & (SVf_NOK|SVs_GMG)) == SVf_NOK)
+#define SvNIOK_nog(sv) (SvNIOK(sv) && !(SvFLAGS(sv) & SVs_GMG))
+
+#define SvPOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+#define SvIOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_THINKFIRST|SVs_GMG)) == SVf_IOK)
+#define SvUOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV|SVf_THINKFIRST|SVs_GMG)) == (SVf_IOK|SVf_IVisUV))
+#define SvNOK_nogthink(sv) ((SvFLAGS(sv) & (SVf_NOK|SVf_THINKFIRST|SVs_GMG)) == SVf_NOK)
+#define SvNIOK_nogthink(sv) (SvNIOK(sv) && !(SvFLAGS(sv) & (SVf_THINKFIRST|SVs_GMG)))
+
+#define SvPOK_utf8_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVs_GMG)) == (SVf_POK|SVf_UTF8))
+#define SvPOK_utf8_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST|SVs_GMG)) == (SVf_POK|SVf_UTF8))
+
+#define SvPOK_byte_nog(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVs_GMG)) == SVf_POK)
+#define SvPOK_byte_nogthink(sv) ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST|SVs_GMG)) == SVf_POK)
+
/*
=for apidoc Am|U32|SvGAMAGIC|SV* sv
@@ -1568,9 +1587,9 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
*/
/* Let us hope that bitmaps for UV and IV are the same */
-#define SvIV(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv))
-#define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
-#define SvNV(sv) (SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv))
+#define SvIV(sv) (SvIOK_nog(sv) ? SvIVX(sv) : sv_2iv(sv))
+#define SvUV(sv) (SvUOK_nog(sv) ? SvUVX(sv) : sv_2uv(sv))
+#define SvNV(sv) (SvNOK_nog(sv) ? SvNVX(sv) : sv_2nv(sv))
#define SvIV_nomg(sv) (SvIOK(sv) ? SvIVX(sv) : sv_2iv_flags(sv, 0))
#define SvUV_nomg(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv_flags(sv, 0))
@@ -1578,23 +1597,23 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
/* ----*/
-#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
-#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
+#define SvPV(sv, lp) SvPV_flags(sv, lp, SV_GMAGIC)
+#define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC)
#define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC)
#define SvPV_flags(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags))
#define SvPV_flags_const(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \
(const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN))
#define SvPV_flags_const_nolen(sv, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX_const(sv) : \
(const char*) sv_2pv_flags(sv, 0, flags|SV_CONST_RETURN))
#define SvPV_flags_mutable(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \
sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
@@ -1606,26 +1625,28 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
#define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0)
#define SvPV_force_flags(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+ (SvPOK_nogthink(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags))
+
#define SvPV_force_flags_nolen(sv, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags))
+ (SvPOK_nogthink(sv) \
+ ? SvPVX(sv) : sv_pvn_force_flags(sv, 0, flags))
+
#define SvPV_force_flags_mutable(sv, lp, flags) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
- ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
+ (SvPOK_nogthink(sv) \
+ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \
: sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN))
#define SvPV_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC))
#define SvPV_nomg_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX(sv) : sv_2pv_flags(sv, 0, 0))
#define SvPV_nolen_const(sv) \
- ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
+ (SvPOK_nog(sv) \
? SvPVX_const(sv) : sv_2pv_flags(sv, 0, SV_GMAGIC|SV_CONST_RETURN))
#define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0)
@@ -1635,33 +1656,31 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
/* ----*/
#define SvPVutf8(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8) \
+ (SvPOK_utf8_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvutf8(sv, &lp))
#define SvPVutf8_force(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK|SVf_UTF8) \
+ (SvPOK_utf8_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvutf8n_force(sv, &lp))
-
#define SvPVutf8_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK|SVf_UTF8)\
+ (SvPOK_utf8_nog(sv) \
? SvPVX(sv) : sv_2pvutf8(sv, 0))
/* ----*/
#define SvPVbyte(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
+ (SvPOK_byte_nog(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
#define SvPVbyte_force(sv, lp) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8|SVf_THINKFIRST)) == (SVf_POK) \
+ (SvPOK_byte_nogthink(sv) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvbyten_force(sv, &lp))
#define SvPVbyte_nolen(sv) \
- ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK)\
+ (SvPOK_byte_nog(sv) \
? SvPVX(sv) : sv_2pvbyte(sv, 0))
-
/* define FOOx(): idempotent versions of FOO(). If possible, use a local
* var to evaluate the arg once; failing that, use a global if possible;
@@ -1672,6 +1691,17 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
#define SvPVutf8x_force(sv, lp) sv_pvutf8n_force(sv, &lp)
#define SvPVbytex_force(sv, lp) sv_pvbyten_force(sv, &lp)
+#define SvTRUE(sv) ((sv) && (SvGMAGICAL(sv) ? sv_2bool(sv) : SvTRUE_common(sv, sv_2bool_nomg(sv))))
+#define SvTRUE_nomg(sv) ((sv) && ( SvTRUE_common(sv, sv_2bool_nomg(sv))))
+#define SvTRUE_common(sv,fallback) ( \
+ !SvOK(sv) \
+ ? 0 \
+ : (SvFLAGS(sv) & (SVf_POK|SVf_IOK|SVf_NOK)) \
+ ? ( (SvPOK(sv) && SvPVXtrue(sv)) \
+ || (SvIOK(sv) && SvIVX(sv) != 0) \
+ || (SvNOK(sv) && SvNVX(sv) != 0.0)) \
+ : (fallback))
+
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
# define SvIVx(sv) ({SV *_sv = MUTABLE_SV(sv); SvIV(_sv); })
@@ -1684,39 +1714,13 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
# define SvPVutf8x(sv, lp) ({SV *_sv = (sv); SvPVutf8(_sv, lp); })
# define SvPVbytex(sv, lp) ({SV *_sv = (sv); SvPVbyte(_sv, lp); })
# define SvPVbytex_nolen(sv) ({SV *_sv = (sv); SvPVbyte_nolen(_sv); })
-# define SvTRUE(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? (({XPV *nxpv = (XPV*)SvANY(sv); \
- nxpv && \
- (nxpv->xpv_cur > 1 || \
- (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool(sv) )
-# define SvTRUE_nomg(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? (({XPV *nxpv = (XPV*)SvANY(sv); \
- nxpv && \
- (nxpv->xpv_cur > 1 || \
- (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool_flags(sv,0) )
-# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
+# define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
+# define SvTRUEx_nomg(sv) ({SV *_sv = (sv); SvTRUE_nomg(_sv); })
+# define SvPVXtrue(sv) \
+ ({XPV *nxpv; \
+ (nxpv = (XPV*)SvANY(sv)) \
+ && (nxpv->xpv_cur > 1 \
+ || (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0'));})
#else /* __GNUC__ */
@@ -1733,37 +1737,12 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>.
# define SvPVutf8x(sv, lp) ((PL_Sv = (sv)), SvPVutf8(PL_Sv, lp))
# define SvPVbytex(sv, lp) ((PL_Sv = (sv)), SvPVbyte(PL_Sv, lp))
# define SvPVbytex_nolen(sv) ((PL_Sv = (sv)), SvPVbyte_nolen(PL_Sv))
-# define SvTRUE(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) && \
- (PL_Xpv->xpv_cur > 1 || \
- (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool(sv) )
-# define SvTRUE_nomg(sv) ( \
- !sv \
- ? 0 \
- : SvPOK(sv) \
- ? ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) && \
- (PL_Xpv->xpv_cur > 1 || \
- (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')) \
- ? 1 \
- : 0) \
- : \
- SvIOK(sv) \
- ? SvIVX(sv) != 0 \
- : SvNOK(sv) \
- ? SvNVX(sv) != 0.0 \
- : sv_2bool_flags(sv,0) )
-# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+# define SvTRUEx(sv) ((PL_Sv = (sv)), SvTRUE(PL_Sv))
+# define SvTRUEx_nomg(sv) ((PL_Sv = (sv)), SvTRUE_nomg(PL_Sv))
+# define SvPVXtrue(sv) \
+ ((PL_Xpv = (XPV*)SvANY(PL_Sv = (sv))) \
+ && (PL_Xpv->xpv_cur > 1 \
+ || (PL_Xpv->xpv_cur && *PL_Sv->sv_u.svu_pv != '0')))
#endif /* __GNU__ */
#define SvIsCOW(sv) ((SvFLAGS(sv) & (SVf_FAKE | SVf_READONLY)) == \
@@ -1873,8 +1852,9 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
#define sv_catsv_nomg(dsv, ssv) sv_catsv_flags(dsv, ssv, 0)
#define sv_catsv_mg(dsv, ssv) sv_catsv_flags(dsv, ssv, SV_GMAGIC|SV_SMAGIC)
#define sv_catpvn(dsv, sstr, slen) sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC)
-#define sv_catpvn_mg(sv, sstr, slen) \
- sv_catpvn_flags(sv, sstr, slen, SV_GMAGIC|SV_SMAGIC);
+#define sv_catpvn_mg(sv, sstr, slen) sv_catpvn_flags(sv, sstr, slen, SV_GMAGIC|SV_SMAGIC);
+#define sv_copypv(dsv, ssv) sv_copypv_flags(dsv, ssv, SV_GMAGIC)
+#define sv_copypv_nomg(dsv, ssv) sv_copypv_flags(dsv, ssv, 0)
#define sv_2pv(sv, lp) sv_2pv_flags(sv, lp, SV_GMAGIC)
#define sv_2pv_nolen(sv) sv_2pv(sv, 0)
#define sv_2pvbyte_nolen(sv) sv_2pvbyte(sv, 0)
@@ -1890,12 +1870,13 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
#define sv_cmp_locale(sv1, sv2) sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC)
#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC)
#define sv_2bool(sv) sv_2bool_flags(sv, SV_GMAGIC)
+#define sv_2bool_nomg(sv) sv_2bool_flags(sv, 0)
#define sv_insert(bigstr, offset, len, little, littlelen) \
Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little), \
(littlelen), SV_GMAGIC)
/* Should be named SvCatPVN_utf8_upgrade? */
-#define sv_catpvn_utf8_upgrade(dsv, sstr, slen, nsv) \
+#define sv_catpvn_nomg_utf8_upgrade(dsv, sstr, slen, nsv) \
STMT_START { \
if (!(nsv)) \
nsv = newSVpvn_flags(sstr, slen, SVs_TEMP); \
@@ -1903,7 +1884,7 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
sv_setpvn(nsv, sstr, slen); \
SvUTF8_off(nsv); \
sv_utf8_upgrade(nsv); \
- sv_catsv(dsv, nsv); \
+ sv_catsv_nomg(dsv, nsv); \
} STMT_END
/*
diff --git a/t/op/eval.t b/t/op/eval.t
index 20f459a9cc..9866ca7130 100644
--- a/t/op/eval.t
+++ b/t/op/eval.t
@@ -496,7 +496,7 @@ END_EVAL_TEST
is($tombstone, "Done\n", 'Program completed successfully');
- $first =~ s/,pNOK//;
+ $first =~ s/p?[NI]OK,//g;
s/ PV = 0x[0-9a-f]+/ PV = 0x/ foreach $first, $second;
s/ LEN = [0-9]+/ LEN = / foreach $first, $second;
# Dump may double newlines through pipes, though not files
diff --git a/t/op/tie.t b/t/op/tie.t
index 3b5fc533e2..a997c416f9 100644
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -273,12 +273,13 @@ EXPECT
0
########
#
-# FETCH freeing tie'd SV
+# FETCH freeing tie'd SV still works
sub TIESCALAR { bless [] }
-sub FETCH { *a = \1; 1 }
+sub FETCH { *a = \1; 2 }
tie $a, 'main';
print $a;
EXPECT
+2
########
# [20020716.007] - nested FETCHES
View Lorry Controller Status