const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
+ bool taint_only = TRUE; /* the only get method seen is taint */
MAGIC *newmg, *head, *cur, *mg;
PERL_ARGS_ASSERT_MG_GET;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
/* taint's mg get is so dumb it doesn't need flag saving */
- if (!saved && mg->mg_type != PERL_MAGIC_taint) {
- save_magic(mgs_ix, sv);
- saved = TRUE;
- }
+ if (mg->mg_type != PERL_MAGIC_taint) {
+ taint_only = FALSE;
+ if (!saved) {
+ save_magic(mgs_ix, sv);
+ saved = TRUE;
+ }
+ }
vtbl->svt_get(aTHX_ sv, mg);
~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
- /* get-magic can reallocate the PV */
- magic_setutf8(sv, mg);
+ /* get-magic can reallocate the PV, unless there's only taint
+ * magic */
+ if (taint_only) {
+ MAGIC *mg2;
+ for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) {
+ if ( mg2->mg_type != PERL_MAGIC_taint
+ && !(mg2->mg_flags & MGf_GSKIP)
+ && mg2->mg_virtual
+ && mg2->mg_virtual->svt_get
+ ) {
+ taint_only = FALSE;
+ break;
+ }
+ }
+ }
+ if (!taint_only)
+ magic_setutf8(sv, mg);
}
mg = nextmg;
MAGIC *mg, *prevmg, *moremg;
PERL_ARGS_ASSERT_MG_FREE_TYPE;
for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
- MAGIC *newhead;
moremg = mg->mg_moremagic;
if (mg->mg_type == how) {
+ MAGIC *newhead;
+ /* temporarily move to the head of the magic chain, in case
+ custom free code relies on this historical aspect of mg_free */
+ if (prevmg) {
+ prevmg->mg_moremagic = moremg;
+ mg->mg_moremagic = SvMAGIC(sv);
+ SvMAGIC_set(sv, mg);
+ }
+ newhead = mg->mg_moremagic;
+ mg_free_struct(sv, mg);
+ SvMAGIC_set(sv, newhead);
+ mg = prevmg;
+ }
+ }
+ mg_magical(sv);
+}
+
+/*
+=for apidoc mg_freeext
+
+Remove any magic of type C<how> using virtual table C<vtbl> from the
+SV C<sv>. See L</sv_magic>.
+
+C<mg_freeext(sv, how, NULL)> is equivalent to C<mg_free_type(sv, how)>.
+
+=cut
+*/
+
+void
+Perl_mg_freeext(pTHX_ SV *sv, int how, const MGVTBL *vtbl)
+{
+ MAGIC *mg, *prevmg, *moremg;
+ PERL_ARGS_ASSERT_MG_FREEEXT;
+ for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) {
+ MAGIC *newhead;
+ moremg = mg->mg_moremagic;
+ if (mg->mg_type == how && (vtbl == NULL || mg->mg_virtual == vtbl)) {
/* temporarily move to the head of the magic chain, in case
custom free code relies on this historical aspect of mg_free */
if (prevmg) {
if (PL_curpm) {
REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- UV uv= (UV)mg->mg_obj;
- if (uv == '+') { /* @+ */
+ const SSize_t n = (SSize_t)mg->mg_obj;
+ if (n == '+') { /* @+ */
/* return the number possible */
return RX_NPARENS(rx);
} else { /* @- @^CAPTURE @{^CAPTURE} */
&& (RX_OFFS(rx)[paren].start == -1
|| RX_OFFS(rx)[paren].end == -1) )
paren--;
- if (uv == '-') {
+ if (n == '-') {
/* @- */
return (U32)paren;
} else {
if (PL_curpm) {
REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- const UV uv= (UV)mg->mg_obj;
+ const SSize_t n = (SSize_t)mg->mg_obj;
/* @{^CAPTURE} does not contain $&, so we need to increment by 1 */
const I32 paren = mg->mg_len
- + (uv == '\003' ? 1 : 0);
+ + (n == '\003' ? 1 : 0);
SSize_t s;
SSize_t t;
if (paren < 0)
{
SSize_t i;
- if (uv == '+') /* @+ */
+ if (n == '+') /* @+ */
i = t;
- else if (uv == '-') /* @- */
+ else if (n == '-') /* @- */
i = s;
else { /* @^CAPTURE @{^CAPTURE} */
CALLREG_NUMBUF_FETCH(rx,paren,sv);
}
}
}
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
return 0;
}
* UTF-8 validity test"
* (http://en.wikipedia.org/wiki/Charset_detection). There is a
* potential that we will get it wrong however, especially on short
- * error message text. (If it turns out to be necessary, we could also
- * keep track if the current LC_MESSAGES locale is UTF-8) */
- if (! IN_BYTES /* respect 'use bytes' */
- && ! is_utf8_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
- && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
- {
+ * error message text, so do an additional check. */
+ if ( ! IN_BYTES /* respect 'use bytes' */
+ && is_utf8_non_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
+
+#ifdef USE_LOCALE_MESSAGES
+
+ && _is_cur_LC_category_utf8(LC_MESSAGES)
+
+#elif defined(USE_LOCLAE_CTYPE)
+
+ /* For systems that don't have a separate message category,
+ * this assumes that they follow the CTYPE one */
+ && _is_cur_LC_category_utf8(LC_CTYPE)
+
+#endif
+
+ ) {
SvUTF8_on(sv);
}
}
}
+/*
+=for apidoc Am|SV *|sv_string_from_errnum|int errnum|SV *tgtsv
+
+Generates the message string describing an OS error and returns it as
+an SV. C<errnum> must be a value that C<errno> could take, identifying
+the type of error.
+
+If C<tgtsv> is non-null then the string will be written into that SV
+(overwriting existing content) and it will be returned. If C<tgtsv>
+is a null pointer then the string will be written into a new mortal SV
+which will be returned.
+
+The message will be taken from whatever locale would be used by C<$!>,
+and will be encoded in the SV in whatever manner would be used by C<$!>.
+The details of this process are subject to future change. Currently,
+the message is taken from the C locale by default (usually producing an
+English message), and from the currently selected locale when in the scope
+of the C<use locale> pragma. A heuristic attempt is made to decode the
+message from the locale's character encoding, but it will only be decoded
+as either UTF-8 or ISO-8859-1. It is always correctly decoded in a UTF-8
+locale, usually in an ISO-8859-1 locale, and never in any other locale.
+
+The SV is always returned containing an actual string, and with no other
+OK bits set. Unlike C<$!>, a message is even yielded for C<errnum> zero
+(meaning success), and if no useful message is available then a useless
+string (currently empty) is returned.
+
+=cut
+*/
+
+SV *
+Perl_sv_string_from_errnum(pTHX_ int errnum, SV *tgtsv)
+{
+ char const *errstr;
+ if(!tgtsv)
+ tgtsv = sv_newmortal();
+ errstr = my_strerror(errnum);
+ if(errstr) {
+ sv_setpv(tgtsv, errstr);
+ fixup_errno_string(tgtsv);
+ } else {
+ SvPVCLEAR(tgtsv);
+ }
+ return tgtsv;
+}
+
#ifdef VMS
#include <descrip.h>
#include <starlet.h>
case '\005': /* ^E */
if (nextchar != '\0') {
if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
break;
}
break;
#endif /* End of platforms with special handling for $^E; others just fall
through to $! */
+ /* FALLTHROUGH */
case '!':
{
SvPVCLEAR(sv);
}
else {
-
- /* Strerror can return NULL on some platforms, which will
- * result in 'sv' not being considered SvOK. The SvNOK_on()
+ sv_string_from_errnum(errno, sv);
+ /* If no useful string is available, don't
+ * claim to have a string part. The SvNOK_on()
* below will cause just the number part to be valid */
- sv_setpv(sv, my_strerror(errno));
- if (SvOK(sv)) {
- fixup_errno_string(sv);
- }
+ if (!SvCUR(sv))
+ SvPOK_off(sv);
}
RESTORE_ERRNO;
}
}
break;
case '\010': /* ^H */
- sv_setiv(sv, (IV)PL_hints);
+ sv_setuv(sv, PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\014': /* ^LAST_FH */
if (strEQ(remaining, "AST_FH")) {
- if (PL_last_in_gv) {
+ if (PL_last_in_gv && (SV*)PL_last_in_gv != &PL_sv_undef) {
assert(isGV_with_GP(PL_last_in_gv));
SV_CHECK_THINKFIRST_COW_DROP(sv);
prepare_SV_for_RV(sv);
SvROK_on(sv);
sv_rvweaken(sv);
}
- else sv_setsv_nomg(sv, NULL);
+ else
+ sv_set_undef(sv);
}
break;
case '\017': /* ^O & ^OPEN */
break;
case '\027': /* ^W & $^WARNING_BITS */
if (nextchar == '\0')
- sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
+ sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON));
else if (strEQ(remaining, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
goto set_undef;
}
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);
- 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);
+ sv_setpvn(sv, WARN_ALLstring, WARNsize);
}
else {
sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i;
I32 num_groups = getgroups(0, gary);
if (num_groups > 0) {
+ I32 i;
Newx(gary, num_groups, Groups_t);
num_groups = getgroups(num_groups, gary);
for (i = 0; i < num_groups; i++)
* access to a known hint bit in a known OP, we can't
* tell whether HINT_STRICT_REFS is in force or not.
*/
- if (!strchr(s,':') && !strchr(s,'\''))
+ if (!memchr(s, ':', len) && !memchr(s, '\'', len))
Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
SV_GMAGIC);
if (i)
if (obj) {
sv_setiv(sv, AvFILL(obj));
} else {
- sv_setsv(sv, NULL);
+ sv_set_undef(sv);
}
return 0;
}
PERL_UNUSED_CONTEXT;
/* Reset the iterator when the array is cleared */
-#if IVSIZE == I32SIZE
- *((IV *) &(mg->mg_len)) = 0;
-#else
- if (mg->mg_ptr)
- *((IV *) mg->mg_ptr) = 0;
-#endif
+ if (sizeof(IV) == sizeof(SSize_t)) {
+ *((IV *) &(mg->mg_len)) = 0;
+ } else {
+ if (mg->mg_ptr)
+ *((IV *) mg->mg_ptr) = 0;
+ }
return 0;
}
sv_setuv(sv, i);
return 0;
}
- sv_setsv(sv,NULL);
+ sv_set_undef(sv);
return 0;
}
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
- STRLEN ulen = 0;
MAGIC* found;
const char *s;
pos = SvIV(sv);
if (DO_UTF8(lsv)) {
- ulen = sv_or_pv_len_utf8(lsv, s, len);
+ const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
if (ulen)
len = ulen;
}
const char * const tmps = SvPV_const(lsv,len);
STRLEN offs = LvTARGOFF(sv);
STRLEN rem = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool negrem = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
SV * const lsv = LvTARG(sv);
STRLEN lvoff = LvTARGOFF(sv);
STRLEN lvlen = LvTARGLEN(sv);
- const bool negoff = LvFLAGS(sv) & 1;
- const bool neglen = LvFLAGS(sv) & 2;
+ const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF;
+ const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN;
PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+ char errflags = LvFLAGS(sv);
PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+ /* non-zero errflags implies deferred out-of-range condition */
+ assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE)));
+ sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
FmLINES(PL_bodytarget) = 0;
if (SvPOK(PL_bodytarget)) {
char *s = SvPVX(PL_bodytarget);
- while ( ((s = strchr(s, '\n'))) ) {
+ char *e = SvEND(PL_bodytarget);
+ while ( ((s = (char *) memchr(s, '\n', e - s))) ) {
FmLINES(PL_bodytarget)++;
s++;
}
if (*(mg->mg_ptr+1) == '\0') {
#ifdef VMS
set_vaxc_errno(SvIV(sv));
-#else
-# ifdef WIN32
+#elif defined(WIN32)
SetLastError( SvIV(sv) );
-# else
-# ifdef OS2
+#elif defined(OS2)
os2_setsyserrno(SvIV(sv));
-# else
+#else
/* will anyone ever use this? */
SETERRNO(SvIV(sv), 4);
-# endif
-# endif
#endif
}
- else {
- if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
- if (PL_localizing != 2) {
- deprecate_fatal_in("5.28",
- "${^ENCODING} is no longer supported");
- }
- }
+ else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv))
+ Perl_croak(aTHX_ "${^ENCODING} is no longer supported");
break;
case '\006': /* ^F */
PL_maxsysfd = SvIV(sv);
break;
case '\010': /* ^H */
- PL_hints = SvIV(sv);
+ {
+ U32 save_hints = PL_hints;
+ PL_hints = SvUV(sv);
+
+ /* If wasn't UTF-8, and now is, notify the parser */
+ if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) {
+ notify_parser_that_changed_to_utf8();
+ }
+ }
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
Safefree(PL_inplace);
}
{
STRLEN len, i;
- int accumulate = 0 ;
- int any_fatals = 0 ;
- const char * const ptr = SvPV_const(sv, len) ;
+ int not_none = 0, not_all = 0;
+ const U8 * const ptr = (const U8 *)SvPV_const(sv, len) ;
for (i = 0 ; i < len ; ++i) {
- accumulate |= ptr[i] ;
- any_fatals |= (ptr[i] & 0xAA) ;
+ not_none |= ptr[i];
+ not_all |= ptr[i] ^ 0x55;
}
- if (!accumulate) {
+ if (!not_none) {
if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE;
- }
- /* Yuck. I can't see how to abstract this: */
- else if (isWARN_on(
- ((STRLEN *)SvPV_nolen_const(sv)) - 1,
- WARN_ALL)
- && !any_fatals)
- {
- if (!specialWARN(PL_compiling.cop_warnings))
+ } else if (len >= WARNsize && !not_all) {
+ if (!specialWARN(PL_compiling.cop_warnings))
PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
break;
case '/':
{
- SV *tmpsv= sv;
if (SvROK(sv)) {
- SV *referent= SvRV(sv);
- const char *reftype= sv_reftype(referent, 0);
- /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative
- * is to copy pretty much the entire sv_reftype() into this routine, or to do
- * a full string comparison on the return of sv_reftype() both of which
- * make me feel worse! NOTE, do not modify this comment without reviewing the
- * corresponding comment in sv_reftype(). - Yves */
+ SV *referent = SvRV(sv);
+ const char *reftype = sv_reftype(referent, 0);
+ /* XXX: dodgy type check: This leaves me feeling dirty, but
+ * the alternative is to copy pretty much the entire
+ * sv_reftype() into this routine, or to do a full string
+ * comparison on the return of sv_reftype() both of which
+ * make me feel worse! NOTE, do not modify this comment
+ * without reviewing the corresponding comment in
+ * sv_reftype(). - Yves */
if (reftype[0] == 'S' || reftype[0] == 'L') {
- IV val= SvIV(referent);
+ IV val = SvIV(referent);
if (val <= 0) {
- tmpsv= &PL_sv_undef;
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef. This will be fatal in Perl 5.28",
- SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
- );
+ sv_setsv(sv, PL_rs);
+ Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden",
+ val < 0 ? "a negative integer" : "zero");
}
} else {
sv_setsv(sv, PL_rs);
- /* diag_listed_as: Setting $/ to %s reference is forbidden */
+ /* diag_listed_as: Setting $/ to %s reference is forbidden */
Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
*reftype == 'A' ? "n" : "", reftype);
}
}
SvREFCNT_dec(PL_rs);
- PL_rs = newSVsv(tmpsv);
+ PL_rs = newSVsv(sv);
}
break;
case '\\':
}
#ifdef HAS_SETRUID
PERL_UNUSED_RESULT(setruid(new_uid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
-#ifdef PERL_DARWIN
+# ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
PERL_UNUSED_RESULT(PerlProc_setuid(0));
-#endif
+# endif
PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '>':
}
#ifdef HAS_SETEUID
PERL_UNUSED_RESULT(seteuid(new_euid));
-#else
-#ifdef HAS_SETREUID
+#elif defined(HAS_SETREUID)
PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
-#else
-#ifdef HAS_SETRESUID
+#elif defined(HAS_SETRESUID)
PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case '(':
}
#ifdef HAS_SETRGID
PERL_UNUSED_RESULT(setrgid(new_gid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ')':
}
#ifdef HAS_SETEGID
PERL_UNUSED_RESULT(setegid(new_egid));
-#else
-#ifdef HAS_SETREGID
+#elif defined(HAS_SETREGID)
PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
-#else
-#ifdef HAS_SETRESGID
+#elif defined(HAS_SETRESGID)
PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
-#endif
-#endif
break;
}
case ':':
https://perl5.git.perl.org / perl5.git / blobdiff