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;
/*
=for apidoc mg_magical
-Turns on the magical status of an SV. See C<sv_magic>.
+Turns on the magical status of an SV. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_get
Do magic before a value is retrieved from the SV. The type of SV must
-be >= SVt_PVMG. See C<sv_magic>.
+be >= C<SVt_PVMG>. See C<L</sv_magic>>.
=cut
*/
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);
}
}
/*
=for apidoc mg_set
-Do magic after a value is assigned to the SV. See C<sv_magic>.
+Do magic after a value is assigned to the SV. See C<L</sv_magic>>.
=cut
*/
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))
=for apidoc mg_length
Reports on the SV's length in bytes, calling length magic if available,
-but does not set the UTF8 flag on the sv. It will fall back to 'get'
+but does not set the UTF8 flag on C<sv>. It will fall back to 'get'
magic if there is no 'length' magic, but with no indication as to
-whether it called 'get' magic. It assumes the sv is a PVMG or
-higher. Use sv_len() instead.
+whether it called 'get' magic. It assumes C<sv> is a C<PVMG> or
+higher. Use C<sv_len()> instead.
=cut
*/
U32
Perl_mg_length(pTHX_ SV *sv)
{
- dVAR;
MAGIC* mg;
STRLEN len;
/*
=for apidoc mg_clear
-Clear something magical that the SV represents. See C<sv_magic>.
+Clear something magical that the SV represents. See C<L</sv_magic>>.
=cut
*/
if (sv) {
MAGIC *mg;
- assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv)));
-
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) {
return mg;
/*
=for apidoc mg_find
-Finds the magic pointer for type matching the SV. See C<sv_magic>.
+Finds the magic pointer for C<type> matching the SV. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_findext
Finds the magic pointer of C<type> with the given C<vtbl> for the C<SV>. See
-C<sv_magicext>.
+C<L</sv_magicext>>.
=cut
*/
/*
=for apidoc mg_copy
-Copies the magic from one SV to another. See C<sv_magic>.
+Copies the magic from one SV to another. See C<L</sv_magic>>.
=cut
*/
=for apidoc mg_localize
Copy some of the magic from an existing SV to new localized version of that
-SV. Container magic (eg %ENV, $1, tie)
-gets copied, value magic doesn't (eg
-taint, pos).
+SV. Container magic (I<e.g.>, C<%ENV>, C<$1>, C<tie>)
+gets copied, value magic doesn't (I<e.g.>,
+C<taint>, C<pos>).
-If setmagic is false then no set magic will be called on the new (empty) SV.
-This typically means that assignment will soon follow (e.g. 'local $x = $y'),
+If C<setmagic> is false then no set magic will be called on the new (empty) SV.
+This typically means that assignment will soon follow (e.g. S<C<'local $x = $y'>>),
and that will handle the magic.
=cut
void
Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_MG_LOCALIZE;
/*
=for apidoc mg_free
-Free any magic storage used by the SV. See C<sv_magic>.
+Free any magic storage used by the SV. See C<L</sv_magic>>.
=cut
*/
/*
=for apidoc Am|void|mg_free_type|SV *sv|int how
-Remove any magic of type I<how> from the SV I<sv>. See L</sv_magic>.
+Remove any magic of type C<how> from the SV C<sv>. See L</sv_magic>.
=cut
*/
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) {
* case we should turn on that flag. This didn't use to happen, and to
* 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) */
+ * an entirely invariant 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_invariant_string((U8*) SvPVX_const(sv), SvCUR(sv))
&& is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
{
SvUTF8_on(sv);
}
}
+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 */
+
+ dVAR;
+ 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
#include <descrip.h>
#include <starlet.h>
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
I32 paren;
const char *s = NULL;
REGEXP *rx;
case '\005': /* ^E */
if (nextchar != '\0') {
if (strEQ(remaining, "NCODING"))
- sv_setsv(sv, PL_encoding);
+ sv_setsv(sv, _get_encoding());
+ else if (strEQ(remaining, "_NCODING"))
+ sv_setsv(sv, NULL);
break;
}
*PL_compiling.cop_warnings);
}
}
+#ifdef WIN32
+ else if (strEQ(remaining, "IN32_SLOPPY_STAT")) {
+ sv_setiv(sv, w32_sloppystat);
+ }
+#endif
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
case ':':
- break;
case '/':
break;
case '[':
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 = "";
}
#endif
-#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS)
+#if !defined(OS2) && !defined(WIN32) && !defined(MSDOS)
/* And you'll never guess what the dog had */
/* in its mouth... */
if (TAINTING_get) {
}
}
}
-#endif /* neither OS2 nor AMIGAOS nor WIN32 nor MSDOS */
+#endif /* neither OS2 nor WIN32 nor MSDOS */
return 0;
}
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(HAS_SIGACTION) && defined(SA_SIGINFO)
#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
+#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
if (PL_sig_ignoring[sig]) return;
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 */
The arguments themselves are any values following the C<flags> argument.
-Returns the SV (if any) returned by the method, or NULL on failure.
+Returns the SV (if any) returned by the method, or C<NULL> on failure.
=cut
Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags,
U32 argc, ...)
{
- dVAR;
dSP;
SV* ret = NULL;
PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- EXTEND(SP, argc+1);
+ /* EXTEND() expects a signed argc; don't wrap when casting */
+ assert(argc <= I32_MAX);
+ EXTEND(SP, (I32)argc+1);
PUSHs(SvTIED_obj(sv, mg));
if (flags & G_UNDEF_FILL) {
while (argc--) {
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;
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:
+ (void)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) == '_') {
+ if (CopSTASH(PL_curcop) != get_hv("encoding::",0))
+ Perl_croak_no_modify();
+ 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)) {
+ if (PL_localizing != 2) {
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Setting ${^ENCODING} is deprecated");
+ }
+ PL_encoding = newSVsv(sv);
+ }
+ else {
+ PL_encoding = NULL;
+ }
+ }
+ }
+ }
break;
case '\006': /* ^F */
PL_maxsysfd = SvIV(sv);
}
}
}
+#ifdef WIN32
+ else if (strEQ(mg->mg_ptr+1, "IN32_SLOPPY_STAT")) {
+ w32_sloppystat = (bool)sv_true(sv);
+ }
+#endif
break;
case '.':
if (PL_localizing) {
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"
);
}
} else {
+ sv_setsv(sv, PL_rs);
/* diag_listed_as: Setting $/ to %s reference is forbidden */
Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden",
*reftype == 'A' ? "n" : "", reftype);
}
case ')':
{
+/* (hv) best guess: maybe we'll need configure probes to do a better job,
+ * but you can override it if you need to.
+ */
+#ifndef INVALID_GID
+#define INVALID_GID ((Gid_t)-1)
+#endif
/* 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;
+ UV uv;
#ifdef _SC_NGROUPS_MAX
int maxgrp = sysconf(_SC_NGROUPS_MAX);
while (isSPACE(*p))
++p;
- new_egid = (Gid_t)Atol(p);
+ if (grok_atoUV(p, &uv, &endptr))
+ new_egid = (Gid_t)uv;
+ else {
+ new_egid = INVALID_GID;
+ endptr = NULL;
+ }
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);
+ if (grok_atoUV(p, &uv, &endptr))
+ gary[i] = (Groups_t)uv;
+ else {
+ gary[i] = INVALID_GID;
+ endptr = NULL;
+ }
}
if (i)
PERL_UNUSED_RESULT(setgroups(i, gary));
}
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], HEKfARG(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;
}
}
}
-cleanup:
+ cleanup:
/* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
PL_savestack_ix = old_ss_ix;
if (flags & 8)
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 (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;
+ 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. */
/*
=for apidoc magic_sethint
-Triggered by a store to %^H, records the key/value pair to
+Triggered by a store to C<%^H>, records the key/value pair to
C<PL_compiling.cop_hints_hash>. It is assumed that hints aren't storing
anything that would need a deep copy. Maybe we should warn if we find a
reference.
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);
/*
=for apidoc magic_clearhint
-Triggered by a delete from %^H, records the key to
+Triggered by a delete from C<%^H>, records the key to
C<PL_compiling.cop_hints_hash>.
=cut
int
Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR;
-
PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
PERL_UNUSED_ARG(sv);
/*
=for apidoc magic_clearhints
-Triggered by clearing
%^H, resets C<PL_compiling.cop_hints_hash>.
+Triggered by clearing
C<%^H>, resets C<PL_compiling.cop_hints_hash>.
=cut
*/
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
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff