diff options
author | Chip Salzenberg <chip@pobox.com> | 2012-06-22 15:18:18 -0700 |
---|---|---|
committer | Chip Salzenberg <chip@pobox.com> | 2012-07-15 15:29:02 -0700 |
commit | 4bac9ae47b5ad7845a24e26b0e95609805de688a (patch) | |
tree | 3ec050044b0c6d7f3688cd9037e85d10c601eb78 | |
parent | b8a55fe78ae4ecc0a81a2d98dba9fead6df06efb (diff) | |
download | perl-4bac9ae47b5ad7845a24e26b0e95609805de688a.tar.gz |
Magic flags harmonization.
In restore_magic(), which is called after any magic processing, all of
the public OK flags have been shifted into the private OK flags. Thus
the lack of an appropriate public OK flags was used to trigger both get
magic and required conversions. This scheme did not cover ROK, however,
so all properly written code had to make sure mg_get was called the right
number of times anyway. Meanwhile the private OK flags gained a second
purpose of marking converted but non-authoritative values (e.g. the IV
conversion of an NV), and the inadequate flag shift mechanic broke this
in some cases.
This patch removes the shift mechanic for magic flags, thus exposing (and
fixing) some improper usage of magic SVs in which mg_get() was not called
correctly. It also has the side effect of making magic get functions
specifically set their SVs to undef if that is desired, as the new behavior
of empty get functions is to leave the value unchanged. This is a feature,
as now get magic that does not modify its value, e.g. tainting, does not
have to be special cased.
The changes to cpan/ here are only temporary, for development only, to
keep blead working until upstream applies them (or something like them).
Thanks to Rik and Father C for review input.
-rw-r--r-- | av.c | 2 | ||||
-rw-r--r-- | cpan/Compress-Raw-Bzip2/Bzip2.xs | 68 | ||||
-rw-r--r-- | cpan/Compress-Raw-Zlib/Zlib.xs | 82 | ||||
-rw-r--r-- | doio.c | 1 | ||||
-rw-r--r-- | doop.c | 10 | ||||
-rw-r--r-- | embed.fnc | 7 | ||||
-rw-r--r-- | embed.h | 3 | ||||
-rw-r--r-- | ext/Devel-Peek/t/Peek.t | 2 | ||||
-rw-r--r-- | gv.c | 2 | ||||
-rw-r--r-- | mg.c | 51 | ||||
-rw-r--r-- | pp.c | 2 | ||||
-rw-r--r-- | pp_ctl.c | 8 | ||||
-rw-r--r-- | pp_hot.c | 13 | ||||
-rw-r--r-- | pp_sys.c | 19 | ||||
-rw-r--r-- | proto.h | 20 | ||||
-rw-r--r-- | sv.c | 558 | ||||
-rw-r--r-- | sv.h | 169 | ||||
-rw-r--r-- | t/op/eval.t | 2 | ||||
-rw-r--r-- | t/op/tie.t | 5 |
19 files changed, 486 insertions, 538 deletions
@@ -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 @@ -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); @@ -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; @@ -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 @@ -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 @@ -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 @@ -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() */ @@ -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)); @@ -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. */ @@ -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 @@ -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; @@ -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); @@ -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); @@ -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 |