/*
=head1 Magical Functions
-
"Magic" is special data attached to SV structures in order to give them
"magical" properties. When any Perl code tries to read from, or assign to,
an SV marked as magical, it calls the 'get' or 'set' function associated
a MAGIC structure that contains a pointer to the object associated with the
tie.
+=cut
+
*/
#include "EXTERN.h"
struct magic_state {
SV* mgs_sv;
I32 mgs_ss_ix;
- U32 mgs_magical;
- bool mgs_readonly;
+ U32 mgs_flags;
bool mgs_bumped;
};
/* MGS is typedef'ed to struct magic_state in perl.h */
STATIC void
S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
{
- dVAR;
MGS* mgs;
bool bumped = FALSE;
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
- mgs->mgs_magical = SvMAGICAL(sv);
- mgs->mgs_readonly = SvREADONLY(sv) != 0;
+ mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
mgs->mgs_bumped = bumped;
*/
void
-Perl_mg_magical(pTHX_ SV *sv)
+Perl_mg_magical(SV *sv)
{
const MAGIC* mg;
PERL_ARGS_ASSERT_MG_MAGICAL;
- PERL_UNUSED_CONTEXT;
SvMAGICAL_off(sv);
if ((mg = SvMAGIC(sv))) {
int
Perl_mg_get(pTHX_ SV *sv)
{
- dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
bool saved = FALSE;
bool have_new = 0;
/* guard against magic having been deleted - eg FETCH calling
* untie */
if (!SvMAGIC(sv)) {
- (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
+ /* recalculate flags */
+ (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
break;
}
/* recalculate flags if this entry was deleted. */
if (mg->mg_flags & MGf_GSKIP)
- (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
+ (SSPTR(mgs_ix, MGS *))->mgs_flags &=
+ ~(SVs_GMG|SVs_SMG|SVs_RMG);
}
else if (vtbl == &PL_vtbl_utf8) {
/* get-magic can reallocate the PV */
have_new = 1;
cur = mg;
mg = newmg;
- (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
+ /* recalculate flags */
+ (SSPTR(mgs_ix, MGS *))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
}
}
int
Perl_mg_set(pTHX_ SV *sv)
{
- dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC* nextmg;
nextmg = mg->mg_moremagic; /* it may delete itself */
if (mg->mg_flags & MGf_GSKIP) {
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
- (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
+ (SSPTR(mgs_ix, MGS*))->mgs_flags &= ~(SVs_GMG|SVs_SMG|SVs_RMG);
}
if (PL_localizing == 2
&& PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
U32
Perl_mg_length(pTHX_ SV *sv)
{
- dVAR;
MAGIC* mg;
STRLEN len;
/* FIXME */
default:
Perl_croak(aTHX_ "Size magic not implemented");
- break;
+
}
- return 0;
+ NOT_REACHED; /* NOTREACHED */
}
/*
}
static MAGIC*
-S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
+S_mg_findext_flags(const SV *sv, int type, const MGVTBL *vtbl, U32 flags)
{
- PERL_UNUSED_CONTEXT;
-
assert(flags <= 1);
if (sv) {
*/
MAGIC*
-Perl_mg_find(pTHX_ const SV *sv, int type)
+Perl_mg_find(const SV *sv, int type)
{
- return S_mg_findext_flags(aTHX_ sv, type, NULL, 0);
+ return S_mg_findext_flags(sv, type, NULL, 0);
}
/*
*/
MAGIC*
-Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
+Perl_mg_findext(const SV *sv, int type, const MGVTBL *vtbl)
{
- return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
+ return S_mg_findext_flags(sv, type, vtbl, 1);
}
MAGIC *
sv = LvTARG(sv);
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
- return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
+ return S_mg_findext_flags(sv, PERL_MAGIC_regex_global, 0, 0);
return NULL;
}
void
Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_MG_LOCALIZE;
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_UNUSED_ARG(sv);
PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
if (PL_curpm) {
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
Perl_croak_no_modify();
if(strEQ(SvPVX(sv), "")) {
sv_catpv(sv, UNKNOWN_ERRNO_MSG);
}
-#if 0
- /* This is disabled to get v5.20 out the door. It means that $! behaves as
- * if in the scope of both 'use locale' and 'use bytes'. This can cause
- * mixed encodings and double utf8 upgrading, See towards the end of the
- * thread for [perl #119499] */
else {
/* In some locales the error string may come back as UTF-8, in which
* case we should turn on that flag. This didn't use to happen, and to
- * avoid any possible backward compatibility issues, we don't turn on
- * the flag unless we have to. So the flag stays off for an entirely
- * ASCII string. We assume that if the string looks like UTF-8, it
- * really is UTF-8: "text in any other encoding that uses bytes with
- * the high bit set is extremely unlikely to pass a 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) */
+ * avoid as many possible backward compatibility issues as possible, we
+ * don't turn on the flag unless we have to. So the flag stays off for
+ * an entirely ASCII string. We assume that if the string looks like
+ * UTF-8, it really is UTF-8: "text in any other encoding that uses
+ * bytes with the high bit set is extremely unlikely to pass a 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_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
&& is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
SvUTF8_on(sv);
}
}
-#endif
+}
+
+SV*
+Perl__get_encoding(pTHX)
+{
+ /* For core Perl use only: Returns the $^ENCODING or 'use encoding' in
+ * effect; NULL if none.
+ *
+ * $^ENCODING maps to PL_encoding, and is the old way to do things, and is
+ * retained for backwards compatibility. Now, there is a shadow variable
+ * ${^E_NCODING} set only by the encoding pragma, used to give this pragma
+ * lexical scope, unlike the global scope it (shudder) used to have. This
+ * variable maps to PL_lex_encoding. Again for backwards compatibility,
+ * PL_encoding has precedence over PL_lex_encoding. The hints hash is used
+ * to determine if PL_lex_encoding is in scope, and hence valid. The hints
+ * hash only accepts simple values, so we can't put an Encode object into
+ * it, so we put the object into the global, and put a simple boolean into
+ * the hints hash giving whether the global is valid or not */
+
+ SV *is_encoding;
+
+ if (PL_encoding) {
+ return PL_encoding;
+ }
+
+ if (! PL_lex_encoding) {
+ return NULL;
+ }
+
+ is_encoding = cop_hints_fetch_pvs(PL_curcop, "encoding", 0);
+ if ( is_encoding
+ && is_encoding != &PL_sv_placeholder
+ && SvIOK(is_encoding)
+ && SvIV(is_encoding)) /* non-zero mean valid */
+ {
+ return PL_lex_encoding;
+ }
+
+ return NULL;
}
#ifdef VMS
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 paren;
const char *s = NULL;
REGEXP *rx;
break;
case '\005': /* ^E */
if (nextchar != '\0') {
+ /* We shouldn't be trying to retrieve this shadow variable */
+ assert(strNE(remaining, "_NCODING"));
+
if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, PL_encoding);
+ sv_setsv(sv, _get_encoding());
break;
}
#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
sv_setnv(sv, (NV)errno);
- sv_setpv(sv, errno ? Strerror(errno) : "");
+ sv_setpv(sv, errno ? my_strerror(errno) : "");
} else {
if (errno != errno_isOS2) {
const int tmp = _syserrno();
/* Strerror can return NULL on some platforms, which will
* result in 'sv' not being considered SvOK. The SvNOK_on()
* below will cause just the number part to be valid */
- sv_setpv(sv, Strerror(errno));
+ sv_setpv(sv, my_strerror(errno));
if (SvOK(sv)) {
fixup_errno_string(sv);
}
#ifdef HAS_GETGROUPS
{
Groups_t *gary = NULL;
- I32 i, num_groups = getgroups(0, gary);
- Newx(gary, num_groups, Groups_t);
- num_groups = getgroups(num_groups, gary);
- for (i = 0; i < num_groups; i++)
- Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
- Safefree(gary);
+ I32 i;
+ I32 num_groups = getgroups(0, gary);
+ if (num_groups > 0) {
+ Newx(gary, num_groups, Groups_t);
+ num_groups = getgroups(num_groups, gary);
+ for (i = 0; i < num_groups; i++)
+ Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+ Safefree(gary);
+ }
}
(void)SvIOK_on(sv); /* what a wonderful hack! */
#endif
int
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
STRLEN len = 0, klen;
const char * const key = MgPV_const(mg,klen);
const char *s = "";
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV;
PERL_UNUSED_ARG(mg);
#if defined(VMS)
int
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
/* Are we fetching a signal entry? */
int i = (I16)mg->mg_private;
#else
dTHX;
#endif
+#if defined(__cplusplus) && defined(__GNUC__)
+ /* g++ doesn't support PERL_UNUSED_DECL, so the sip and uap
+ * parameters would be warned about. */
+ PERL_UNUSED_ARG(sip);
+ PERL_UNUSED_ARG(uap);
+#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
static void
unblock_sigmask(pTHX_ void* newset)
{
+ PERL_UNUSED_CONTEXT;
sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL);
}
#endif
void
Perl_despatch_signals(pTHX)
{
- dVAR;
int sig;
PL_sig_pending = 0;
for (sig = 1; sig < SIG_SIZE; sig++) {
int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
PERL_ARGS_ASSERT_MAGIC_SETISA;
PERL_UNUSED_ARG(sv);
int
Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
HV* stash;
-
PERL_ARGS_ASSERT_MAGIC_CLEARISA;
/* Bail out if destruction is going on */
same function. */
mg = mg_find(mg->mg_obj, PERL_MAGIC_isa);
+ assert(mg);
if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */
SV **svp = AvARRAY((AV *)mg->mg_obj);
I32 items = AvFILLp((AV *)mg->mg_obj) + 1;
Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
U32 argc, ...)
{
- dVAR;
dSP;
SV* ret = NULL;
if (flags & G_WRITING_TO_STDERR) {
SAVETMPS;
- save_re_context();
SAVESPTR(PL_stderrgv);
PL_stderrgv = NULL;
}
S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
int n, SV *val)
{
- dVAR;
SV* arg1 = NULL;
PERL_ARGS_ASSERT_MAGIC_METHCALL1;
STATIC int
S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
{
- dVAR;
SV* ret;
PERL_ARGS_ASSERT_MAGIC_METHPACK;
int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
MAGIC *tmg;
SV *val;
U32
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 retval = 0;
SV* retsv;
int
Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0);
int
Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
{
- dVAR;
SV* ret;
PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
SV *
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
- dVAR;
SV *retval;
SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
HV * const pkg = SvSTASH((const SV *)SvRV(tied));
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV **svp;
PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
int
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
- dVAR;
AV * const obj = MUTABLE_AV(mg->mg_obj);
PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
AV * const obj = MUTABLE_AV(mg->mg_obj);
PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
int
Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_CONTEXT;
/* Reset the iterator when the array is cleared */
#if IVSIZE == I32SIZE
int
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
PERL_UNUSED_ARG(sv);
int
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV* const lsv = LvTARG(sv);
MAGIC * const found = mg_find_mglob(lsv);
int
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
int
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
STRLEN len, lsv_len, oldtarglen, newtarglen;
const char * const tmps = SvPV_const(sv, len);
SV * const lsv = LvTARG(sv);
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_ARG(mg);
#endif
- TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
+ TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1) && IN_PERL_RUNTIME);
return 0;
}
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_SETTAINT;
PERL_UNUSED_ARG(sv);
SV *
Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV *targ = NULL;
PERL_ARGS_ASSERT_DEFELEM_TARGET;
if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
- dVAR;
MAGIC *mg;
SV *value = NULL;
}
int
+Perl_magic_setlvref(pTHX_ SV *sv, MAGIC *mg)
+{
+ const char *bad = NULL;
+ PERL_ARGS_ASSERT_MAGIC_SETLVREF;
+ if (!SvROK(sv)) Perl_croak(aTHX_ "Assigned value is not a reference");
+ switch (mg->mg_private & OPpLVREF_TYPE) {
+ case OPpLVREF_SV:
+ if (SvTYPE(SvRV(sv)) > SVt_PVLV)
+ bad = " SCALAR";
+ break;
+ case OPpLVREF_AV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVAV)
+ bad = "n ARRAY";
+ break;
+ case OPpLVREF_HV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVHV)
+ bad = " HASH";
+ break;
+ case OPpLVREF_CV:
+ if (SvTYPE(SvRV(sv)) != SVt_PVCV)
+ bad = " CODE";
+ }
+ if (bad)
+ /* diag_listed_as: Assigned value is not %s reference */
+ Perl_croak(aTHX_ "Assigned value is not a%s reference", bad);
+ switch (mg->mg_obj ? SvTYPE(mg->mg_obj) : 0) {
+ case 0:
+ {
+ SV * const old = PAD_SV(mg->mg_len);
+ PAD_SETSV(mg->mg_len, SvREFCNT_inc_NN(SvRV(sv)));
+ SvREFCNT_dec(old);
+ break;
+ }
+ case SVt_PVGV:
+ gv_setref(mg->mg_obj, sv);
+ SvSETMAGIC(mg->mg_obj);
+ break;
+ case SVt_PVAV:
+ av_store((AV *)mg->mg_obj, SvIV((SV *)mg->mg_ptr),
+ SvREFCNT_inc_simple_NN(SvRV(sv)));
+ break;
+ case SVt_PVHV:
+ hv_store_ent((HV *)mg->mg_obj, (SV *)mg->mg_ptr,
+ SvREFCNT_inc_simple_NN(SvRV(sv)), 0);
+ }
+ if (mg->mg_flags & MGf_PERSIST)
+ NOOP; /* This sv is in use as an iterator var and will be reused,
+ so we must leave the magic. */
+ else
+ /* This sv could be returned by the assignment op, so clear the
+ magic, as lvrefs are an implementation detail that must not be
+ leaked to the user. */
+ sv_unmagic(sv, PERL_MAGIC_lvref);
+ return 0;
+}
+
+int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
+#ifdef USE_ITHREADS
dVAR;
+#endif
const char *s;
I32 paren;
const REGEXP * rx;
# endif
#endif
}
- else if (strEQ(mg->mg_ptr+1, "NCODING")) {
- SvREFCNT_dec(PL_encoding);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
- PL_encoding = newSVsv(sv);
- }
- else {
- PL_encoding = NULL;
- }
- }
+ else {
+ unsigned int offset = 1;
+ bool lex = FALSE;
+
+ /* It may be the shadow variable ${E_NCODING} which has lexical
+ * scope. See comments at Perl__get_encoding in this file */
+ if (*(mg->mg_ptr + 1) == '_') {
+ lex = TRUE;
+ offset++;
+ }
+ if (strEQ(mg->mg_ptr + offset, "NCODING")) {
+ if (lex) { /* Use the shadow global */
+ SvREFCNT_dec(PL_lex_encoding);
+ if (SvOK(sv) || SvGMAGICAL(sv)) {
+ PL_lex_encoding = newSVsv(sv);
+ }
+ else {
+ PL_lex_encoding = NULL;
+ }
+ }
+ else { /* Use the regular global */
+ SvREFCNT_dec(PL_encoding);
+ if (SvOK(sv) || SvGMAGICAL(sv)) {
+ PL_encoding = newSVsv(sv);
+ }
+ else {
+ PL_encoding = NULL;
+ }
+ }
+ }
+ }
break;
case '\006': /* ^F */
PL_maxsysfd = SvIV(sv);
IV val= SvIV(referent);
if (val <= 0) {
tmpsv= &PL_sv_undef;
- Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef",
SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero"
);
break;
case '<':
{
- int rc = 0;
+ /* XXX $< currently silently ignores failures */
const Uid_t new_uid = SvUID(sv);
PL_delaymagic_uid = new_uid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRUID
- rc = setruid(new_uid);
+ PERL_UNUSED_RESULT(setruid(new_uid));
#else
#ifdef HAS_SETREUID
- rc = setreuid(new_uid, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setreuid(new_uid, (Uid_t)-1));
#else
#ifdef HAS_SETRESUID
- rc = setresuid(new_uid, (Uid_t)-1, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setresuid(new_uid, (Uid_t)-1, (Uid_t)-1));
#else
if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */
#ifdef PERL_DARWIN
/* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
if (new_uid != 0 && PerlProc_getuid() == 0)
- rc = PerlProc_setuid(0);
+ PERL_UNUSED_RESULT(PerlProc_setuid(0));
#endif
- rc = PerlProc_setuid(new_uid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_uid));
} else {
Perl_croak(aTHX_ "setruid() not implemented");
}
#endif
#endif
#endif
- /* XXX $< currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case '>':
{
- int rc = 0;
+ /* XXX $> currently silently ignores failures */
const Uid_t new_euid = SvUID(sv);
PL_delaymagic_euid = new_euid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETEUID
- rc = seteuid(new_euid);
+ PERL_UNUSED_RESULT(seteuid(new_euid));
#else
#ifdef HAS_SETREUID
- rc = setreuid((Uid_t)-1, new_euid);
+ PERL_UNUSED_RESULT(setreuid((Uid_t)-1, new_euid));
#else
#ifdef HAS_SETRESUID
- rc = setresuid((Uid_t)-1, new_euid, (Uid_t)-1);
+ PERL_UNUSED_RESULT(setresuid((Uid_t)-1, new_euid, (Uid_t)-1));
#else
if (new_euid == PerlProc_getuid()) /* special case $> = $< */
- rc = PerlProc_setuid(new_euid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(new_euid));
else {
Perl_croak(aTHX_ "seteuid() not implemented");
}
#endif
#endif
#endif
- /* XXX $> currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case '(':
{
- int rc = 0;
+ /* XXX $( currently silently ignores failures */
const Gid_t new_gid = SvGID(sv);
PL_delaymagic_gid = new_gid;
if (PL_delaymagic) {
break; /* don't do magic till later */
}
#ifdef HAS_SETRGID
- rc = setrgid(new_gid);
+ PERL_UNUSED_RESULT(setrgid(new_gid));
#else
#ifdef HAS_SETREGID
- rc = setregid(new_gid, (Gid_t)-1);
+ PERL_UNUSED_RESULT(setregid(new_gid, (Gid_t)-1));
#else
#ifdef HAS_SETRESGID
- rc = setresgid(new_gid, (Gid_t)-1, (Gid_t) -1);
+ PERL_UNUSED_RESULT(setresgid(new_gid, (Gid_t)-1, (Gid_t) -1));
#else
if (new_gid == PerlProc_getegid()) /* special case $( = $) */
- rc = PerlProc_setgid(new_gid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_gid));
else {
Perl_croak(aTHX_ "setrgid() not implemented");
}
#endif
#endif
#endif
- /* XXX $( currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case ')':
{
- int rc = 0;
+ /* XXX $) currently silently ignores failures */
Gid_t new_egid;
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
Groups_t *gary = NULL;
+ const char* endptr;
#ifdef _SC_NGROUPS_MAX
int maxgrp = sysconf(_SC_NGROUPS_MAX);
while (isSPACE(*p))
++p;
- new_egid = (Gid_t)Atol(p);
+ new_egid = (Gid_t)grok_atou(p, &endptr);
for (i = 0; i < maxgrp; ++i) {
- while (*p && !isSPACE(*p))
- ++p;
+ if (endptr == NULL)
+ break;
+ p = endptr;
while (isSPACE(*p))
++p;
if (!*p)
break;
- if(!gary)
+ if (!gary)
Newx(gary, i + 1, Groups_t);
else
Renew(gary, i + 1, Groups_t);
- gary[i] = (Groups_t)Atol(p);
+ gary[i] = (Groups_t)grok_atou(p, &endptr);
}
if (i)
- rc = setgroups(i, gary);
+ PERL_UNUSED_RESULT(setgroups(i, gary));
Safefree(gary);
}
#else /* HAS_SETGROUPS */
break; /* don't do magic till later */
}
#ifdef HAS_SETEGID
- rc = setegid(new_egid);
+ PERL_UNUSED_RESULT(setegid(new_egid));
#else
#ifdef HAS_SETREGID
- rc = setregid((Gid_t)-1, new_egid);
+ PERL_UNUSED_RESULT(setregid((Gid_t)-1, new_egid));
#else
#ifdef HAS_SETRESGID
- rc = setresgid((Gid_t)-1, new_egid, (Gid_t)-1);
+ PERL_UNUSED_RESULT(setresgid((Gid_t)-1, new_egid, (Gid_t)-1));
#else
if (new_egid == PerlProc_getgid()) /* special case $) = $( */
- rc = PerlProc_setgid(new_egid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(new_egid));
else {
Perl_croak(aTHX_ "setegid() not implemented");
}
#endif
#endif
#endif
- /* XXX $) currently silently ignores failures */
- PERL_UNUSED_VAR(rc);
break;
}
case ':':
const char *sigpv;
STRLEN siglen;
PERL_ARGS_ASSERT_WHICHSIG_SV;
- PERL_UNUSED_CONTEXT;
sigpv = SvPV_const(sigsv, siglen);
return whichsig_pvn(sigpv, siglen);
}
Perl_whichsig_pv(pTHX_ const char *sig)
{
PERL_ARGS_ASSERT_WHICHSIG_PV;
- PERL_UNUSED_CONTEXT;
return whichsig_pvn(sig, strlen(sig));
}
}
if (!cv || !CvROOT(cv)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
- PL_sig_name[sig], (gv ? GvENAME(gv)
- : ((cv && CvGV(cv))
- ? GvENAME(CvGV(cv))
- : "__ANON__")));
+ const HEK * const hek = gv
+ ? GvENAME_HEK(gv)
+ : cv && CvNAMED(cv)
+ ? CvNAME_HEK(cv)
+ : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL;
+ if (hek)
+ Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "SIG%s handler \"%"HEKf"\" not defined.\n",
+ PL_sig_name[sig], hek);
+ /* diag_listed_as: SIG%s handler "%s" not defined */
+ else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "SIG%s handler \"__ANON__\" not defined.\n",
+ PL_sig_name[sig]);
goto cleanup;
}
static void
S_restore_magic(pTHX_ const void *p)
{
- dVAR;
MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
SV* const sv = mgs->mgs_sv;
bool bumped;
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;
+ if (mgs->mgs_flags)
+ SvFLAGS(sv) |= mgs->mgs_flags;
else
mg_magical(sv);
}
static void
S_unwind_handler_stack(pTHX_ const void *p)
{
- dVAR;
PERL_UNUSED_ARG(p);
PL_savestack_ix -= 5; /* Unprotect save in progress. */
int
Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
: newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
int
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
nmg = mg_find(nsv, mg->mg_type);
+ assert(nmg);
if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
nmg->mg_ptr = mg->mg_ptr;
nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
return 1;
}
+int
+Perl_magic_setdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_SETDEBUGVAR;
+
+#if DBVARMG_SINGLE != 0
+ assert(mg->mg_private >= DBVARMG_SINGLE);
+#endif
+ assert(mg->mg_private < DBVARMG_COUNT);
+
+ PL_DBcontrol[mg->mg_private] = SvIV_nomg(sv);
+
+ return 1;
+}
+
+int
+Perl_magic_getdebugvar(pTHX_ SV *sv, MAGIC *mg) {
+ PERL_ARGS_ASSERT_MAGIC_GETDEBUGVAR;
+
+#if DBVARMG_SINGLE != 0
+ assert(mg->mg_private >= DBVARMG_SINGLE);
+#endif
+ assert(mg->mg_private < DBVARMG_COUNT);
+ sv_setiv(sv, PL_DBcontrol[mg->mg_private]);
+
+ return 0;
+}
+
/*
* Local variables:
* c-indentation-style: bsd