/* mg.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "Sam sat on the ground and put his head in his hands. 'I wish I had never
- * come here, and I don't want to see no more magic,' he said, and fell silent."
+ * Sam sat on the ground and put his head in his hands. 'I wish I had never
+ * come here, and I don't want to see no more magic,' he said, and fell silent.
+ *
+ * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
*/
/*
# include <sys/pstat.h>
#endif
+#ifdef HAS_PRCTL_SET_NAME
+# include <sys/prctl.h>
+#endif
+
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Signal_t Perl_csighandler(int sig, ...);
+Signal_t Perl_csighandler(int sig, siginfo_t *, void *);
#else
Signal_t Perl_csighandler(int sig);
#endif
struct magic_state {
SV* mgs_sv;
- U32 mgs_flags;
I32 mgs_ss_ix;
+ U32 mgs_magical;
+ bool mgs_readonly;
};
/* MGS is typedef'ed to struct magic_state in perl.h */
{
dVAR;
MGS* mgs;
+
+ PERL_ARGS_ASSERT_SAVE_MAGIC;
+
assert(SvMAGICAL(sv));
/* Turning READONLY off for a copy-on-write scalar (including shared
hash keys) is a bad idea. */
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
- mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
+ mgs->mgs_magical = SvMAGICAL(sv);
+ mgs->mgs_readonly = SvREADONLY(sv) != 0;
mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ 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;
+ }
}
/*
Perl_mg_magical(pTHX_ SV *sv)
{
const MAGIC* mg;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
- if (vtbl) {
- if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
- SvGMAGICAL_on(sv);
- if (vtbl->svt_set)
- SvSMAGICAL_on(sv);
- if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
- SvRMAGICAL_on(sv);
- }
+ PERL_ARGS_ASSERT_MG_MAGICAL;
+ PERL_UNUSED_CONTEXT;
+
+ SvMAGICAL_off(sv);
+ if ((mg = SvMAGIC(sv))) {
+ do {
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if (vtbl) {
+ if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
+ SvGMAGICAL_on(sv);
+ if (vtbl->svt_set)
+ SvSMAGICAL_on(sv);
+ if (vtbl->svt_clear)
+ SvRMAGICAL_on(sv);
+ }
+ } while ((mg = mg->mg_moremagic));
+ if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
+ SvRMAGICAL_on(sv);
+ }
+}
+
+
+/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
+
+STATIC bool
+S_is_container_magic(const MAGIC *mg)
+{
+ assert(mg);
+ switch (mg->mg_type) {
+ case PERL_MAGIC_bm:
+ case PERL_MAGIC_fm:
+ case PERL_MAGIC_regex_global:
+ case PERL_MAGIC_nkeys:
+#ifdef USE_LOCALE_COLLATE
+ case PERL_MAGIC_collxfrm:
+#endif
+ case PERL_MAGIC_qr:
+ case PERL_MAGIC_taint:
+ case PERL_MAGIC_vec:
+ case PERL_MAGIC_vstring:
+ case PERL_MAGIC_utf8:
+ case PERL_MAGIC_substr:
+ case PERL_MAGIC_defelem:
+ case PERL_MAGIC_arylen:
+ case PERL_MAGIC_pos:
+ case PERL_MAGIC_backref:
+ case PERL_MAGIC_arylen_p:
+ case PERL_MAGIC_rhash:
+ case PERL_MAGIC_symtab:
+ return 0;
+ default:
+ return 1;
}
}
{
dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
- const bool was_temp = (bool)SvTEMP(sv);
- int have_new = 0;
+ const bool was_temp = cBOOL(SvTEMP(sv));
+ bool have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
/* guard against sv having being freed midway by holding a private
reference. */
+ PERL_ARGS_ASSERT_MG_GET;
+
/* sv_2mortal has this side effect of turning on the TEMP flag, which can
cause the SV's buffer to get stolen (and maybe other stuff).
So restore it.
*/
- sv_2mortal(SvREFCNT_inc(sv));
+ sv_2mortal(SvREFCNT_inc_simple_NN(sv));
if (!was_temp) {
SvTEMP_off(sv);
}
newmg = cur = head = mg = SvMAGIC(sv);
while (mg) {
const MGVTBL * const vtbl = mg->mg_virtual;
+ MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
/* guard against magic having been deleted - eg FETCH calling
* untie */
- if (!SvMAGIC(sv))
+ if (!SvMAGIC(sv)) {
+ (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
break;
+ }
- /* Don't restore the flags for this entry if it was deleted. */
+ /* recalculate flags if this entry was deleted. */
if (mg->mg_flags & MGf_GSKIP)
- (SSPTR(mgs_ix, MGS *))->mgs_flags = 0;
+ (SSPTR(mgs_ix, MGS *))->mgs_magical = 0;
}
- mg = mg->mg_moremagic;
+ mg = nextmg;
if (have_new) {
/* Have we finished with the new entries we saw? Start again
have_new = 1;
cur = mg;
mg = newmg;
+ (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */
}
}
MAGIC* mg;
MAGIC* nextmg;
+ PERL_ARGS_ASSERT_MG_SET;
+
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = 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_flags = 0;
+ (SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
}
+ if (PL_localizing == 2 && !S_is_container_magic(mg))
+ continue;
if (vtbl && vtbl->svt_set)
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
MAGIC* mg;
STRLEN len;
+ PERL_ARGS_ASSERT_MG_LENGTH;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL * const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
}
}
- if (DO_UTF8(sv)) {
+ {
+ /* You can't know whether it's UTF-8 until you get the string again...
+ */
const U8 *s = (U8*)SvPV_const(sv, len);
- len = Perl_utf8_length(aTHX_ s, s + len);
+
+ if (DO_UTF8(sv)) {
+ len = utf8_length(s, s + len);
+ }
}
- else
- (void)SvPV_const(sv, len);
return len;
}
{
MAGIC* mg;
+ PERL_ARGS_ASSERT_MG_SIZE;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
switch(SvTYPE(sv)) {
case SVt_PVAV:
- return AvFILLp((AV *) sv); /* Fallback to non-tied array */
+ return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
case SVt_PVHV:
/* FIXME */
default:
{
const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
+ MAGIC *nextmg;
+
+ PERL_ARGS_ASSERT_MG_CLEAR;
save_magic(mgs_ix, sv);
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ for (mg = SvMAGIC(sv); mg; mg = nextmg) {
const MGVTBL* const vtbl = mg->mg_virtual;
/* omit GSKIP -- never set here */
+ nextmg = mg->mg_moremagic; /* it may delete itself */
+
if (vtbl && vtbl->svt_clear)
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
MAGIC*
Perl_mg_find(pTHX_ const SV *sv, int type)
{
+ PERL_UNUSED_CONTEXT;
if (sv) {
MAGIC *mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
return mg;
}
}
- return 0;
+ return NULL;
}
/*
{
int count = 0;
MAGIC* mg;
+
+ PERL_ARGS_ASSERT_MG_COPY;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
}
else {
const char type = mg->mg_type;
- if (isUPPER(type)) {
+ if (isUPPER(type) && type != PERL_MAGIC_uvar) {
sv_magic(nsv,
(type == PERL_MAGIC_tied)
? SvTIED_obj(sv, mg)
/*
=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).
+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).
+
+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'),
+and that will handle the magic.
=cut
*/
void
-Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
+Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
{
dVAR;
MAGIC *mg;
+
+ PERL_ARGS_ASSERT_MG_LOCALIZE;
+
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* const vtbl = mg->mg_virtual;
- switch (mg->mg_type) {
- /* value magic types: don't copy */
- case PERL_MAGIC_bm:
- case PERL_MAGIC_fm:
- case PERL_MAGIC_regex_global:
- case PERL_MAGIC_nkeys:
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
-#endif
- case PERL_MAGIC_qr:
- case PERL_MAGIC_taint:
- case PERL_MAGIC_vec:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_utf8:
- case PERL_MAGIC_substr:
- case PERL_MAGIC_defelem:
- case PERL_MAGIC_arylen:
- case PERL_MAGIC_pos:
- case PERL_MAGIC_backref:
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
+ const MGVTBL* const vtbl = mg->mg_virtual;
+ if (!S_is_container_magic(mg))
continue;
- }
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
(void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
SvFLAGS(nsv) |= SvMAGICAL(sv);
- PL_localizing = 1;
- SvSETMAGIC(nsv);
- PL_localizing = 0;
+ if (setmagic) {
+ PL_localizing = 1;
+ SvSETMAGIC(nsv);
+ PL_localizing = 0;
+ }
}
}
{
MAGIC* mg;
MAGIC* moremagic;
+
+ PERL_ARGS_ASSERT_MG_FREE;
+
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
moremagic = mg->mg_moremagic;
if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
- SvREFCNT_dec((SV*)mg->mg_ptr);
+ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
}
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
+ SvMAGIC_set(sv, moremagic);
}
SvMAGIC_set(sv, NULL);
+ SvMAGICAL_off(sv);
return 0;
}
dVAR;
PERL_UNUSED_ARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
- return mg->mg_obj
- ? rx->nparens /* @+ */
- : rx->lastparen; /* @- */
+ if (mg->mg_obj) { /* @+ */
+ /* return the number possible */
+ return RX_NPARENS(rx);
+ } else { /* @- */
+ I32 paren = RX_LASTPAREN(rx);
+
+ /* return the last filled */
+ while ( paren >= 0
+ && (RX_OFFS(rx)[paren].start == -1
+ || RX_OFFS(rx)[paren].end == -1) )
+ paren--;
+ return (U32)paren;
+ }
}
}
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET;
+
if (PL_curpm) {
register const REGEXP * const rx = PM_GETRE(PL_curpm);
if (rx) {
register I32 t;
if (paren < 0)
return 0;
- if (paren <= (I32)rx->nparens &&
- (s = rx->startp[paren]) != -1 &&
- (t = rx->endp[paren]) != -1)
+ if (paren <= (I32)RX_NPARENS(rx) &&
+ (s = RX_OFFS(rx)[paren].start) != -1 &&
+ (t = RX_OFFS(rx)[paren].end) != -1)
{
register I32 i;
if (mg->mg_obj) /* @+ */
i = s;
if (i > 0 && RX_MATCH_UTF8(rx)) {
- const char * const b = rx->subbeg;
+ const char * const b = RX_SUBBEG(rx);
if (b)
- i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+ i = utf8_length((U8*)b, (U8*)(b+i));
}
sv_setiv(sv, i);
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
- PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
- Perl_croak(aTHX_ PL_no_modify);
+ PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
+ Perl_croak(aTHX_ "%s", PL_no_modify);
NORETURN_FUNCTION_END;
}
dVAR;
register I32 paren;
register I32 i;
- register const REGEXP *rx;
- I32 s1, t1;
+ register const REGEXP * rx;
+ const char * const remaining = mg->mg_ptr + 1;
+
+ PERL_ARGS_ASSERT_MAGIC_LEN;
switch (*mg->mg_ptr) {
+ case '\020':
+ if (*remaining == '\0') { /* ^P */
+ break;
+ } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
+ goto do_prematch;
+ } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
+ goto do_postmatch;
+ }
+ break;
+ case '\015': /* $^MATCH */
+ if (strEQ(remaining, "ATCH")) {
+ goto do_match;
+ } else {
+ break;
+ }
+ case '`':
+ do_prematch:
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto maybegetparen;
+ case '\'':
+ do_postmatch:
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto maybegetparen;
+ case '&':
+ do_match:
+ paren = RX_BUFF_IDX_FULLMATCH;
+ goto maybegetparen;
case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9': case '&':
+ case '5': case '6': case '7': case '8': case '9':
+ paren = atoi(mg->mg_ptr);
+ maybegetparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ getparen:
+ i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- getparen:
- if (paren <= (I32)rx->nparens &&
- (s1 = rx->startp[paren]) != -1 &&
- (t1 = rx->endp[paren]) != -1)
- {
- i = t1 - s1;
- getlen:
- if (i > 0 && RX_MATCH_UTF8(rx)) {
- const char * const s = rx->subbeg + s1;
- const U8 *ep;
- STRLEN el;
-
- i = t1 - s1;
- if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
- i = el;
- }
if (i < 0)
Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
return i;
- }
- else {
+ } else {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- }
- }
- else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(sv);
+ return 0;
}
- return 0;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastparen;
+ paren = RX_LASTPAREN(rx);
if (paren)
goto getparen;
}
return 0;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastcloseparen;
+ paren = RX_LASTCLOSEPAREN(rx);
if (paren)
goto getparen;
}
return 0;
- case '`':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->startp[0] != -1) {
- i = rx->startp[0];
- if (i > 0) {
- s1 = 0;
- t1 = i;
- goto getlen;
- }
- }
- }
- return 0;
- case '\'':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->endp[0] != -1) {
- i = rx->sublen - rx->endp[0];
- if (i > 0) {
- s1 = rx->endp[0];
- t1 = rx->sublen;
- goto getlen;
- }
- }
- }
- return 0;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
}
#define SvRTRIM(sv) STMT_START { \
- STRLEN len = SvCUR(sv); \
- char * const p = SvPVX(sv); \
- if (p) { \
+ if (SvPOK(sv)) { \
+ STRLEN len = SvCUR(sv); \
+ char * const p = SvPVX(sv); \
while (len > 0 && isSPACE(p[len-1])) \
--len; \
SvCUR_set(sv, len); \
} \
} STMT_END
+void
+Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
+{
+ PERL_ARGS_ASSERT_EMULATE_COP_IO;
+
+ if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT)))
+ sv_setsv(sv, &PL_sv_undef);
+ else {
+ sv_setpvs(sv, "");
+ SvUTF8_off(sv);
+ if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) {
+ SV *const value = Perl_refcounted_he_fetch(aTHX_
+ c->cop_hints_hash,
+ 0, "open<", 5, 0, 0);
+ assert(value);
+ sv_catsv(sv, value);
+ }
+ sv_catpvs(sv, "\0");
+ if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) {
+ SV *const value = Perl_refcounted_he_fetch(aTHX_
+ c->cop_hints_hash,
+ 0, "open>", 5, 0, 0);
+ assert(value);
+ sv_catsv(sv, value);
+ }
+ }
+}
+
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
register I32 paren;
register char *s = NULL;
- register I32 i;
register REGEXP *rx;
const char * const remaining = mg->mg_ptr + 1;
const char nextchar = *remaining;
+ PERL_ARGS_ASSERT_MAGIC_GET;
+
switch (*mg->mg_ptr) {
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
break;
case '\005': /* ^E */
if (nextchar == '\0') {
-#ifdef MACOS_TRADITIONAL
- {
- char msg[256];
-
- sv_setnv(sv,(double)gMacPerl_OSErr);
- sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
- }
-#else
-#ifdef VMS
+#if defined(VMS)
{
# include <descrip.h>
# include <starlet.h>
if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
else
- sv_setpvn(sv,"",0);
+ sv_setpvs(sv,"");
}
-#else
-#ifdef OS2
+#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
sv_setnv(sv, (NV)Perl_rc);
sv_setpv(sv, os2error(Perl_rc));
}
-#else
-#ifdef WIN32
+#elif defined(WIN32)
{
- DWORD dwErr = GetLastError();
+ const DWORD dwErr = GetLastError();
sv_setnv(sv, (NV)dwErr);
if (dwErr) {
PerlProc_GetOSError(sv, dwErr);
}
else
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
SetLastError(dwErr);
}
#else
{
- const int saveerrno = errno;
+ dSAVE_ERRNO;
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
- errno = saveerrno;
+ RESTORE_ERRNO;
}
#endif
-#endif
-#endif
-#endif
SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
}
sv_setiv(sv, (IV)PL_hints);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
- if (PL_inplace)
- sv_setpv(sv, PL_inplace);
- else
- sv_setsv(sv, &PL_sv_undef);
+ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */
break;
case '\017': /* ^O & ^OPEN */
if (nextchar == '\0') {
SvTAINTED_off(sv);
}
else if (strEQ(remaining, "PEN")) {
- if (!PL_compiling.cop_io)
- sv_setsv(sv, &PL_sv_undef);
- else {
- sv_setsv(sv, PL_compiling.cop_io);
- }
+ Perl_emulate_cop_io(aTHX_ &PL_compiling, sv);
}
break;
- case '\020': /* ^P */
- sv_setiv(sv, (IV)PL_perldb);
+ case '\020':
+ if (nextchar == '\0') { /* ^P */
+ sv_setiv(sv, (IV)PL_perldb);
+ } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
+ goto do_prematch_fetch;
+ } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
+ goto do_postmatch_fetch;
+ }
break;
case '\023': /* ^S */
if (nextchar == '\0') {
- if (PL_lex_state != LEX_NOTPARSING)
+ if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING)
SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
- case '\025': /* $^UNICODE, $^UTF8LOCALE */
+ case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */
if (strEQ(remaining, "NICODE"))
sv_setuv(sv, (UV) PL_unicode);
else if (strEQ(remaining, "TF8LOCALE"))
sv_setuv(sv, (UV) PL_utf8locale);
+ else if (strEQ(remaining, "TF8CACHE"))
+ sv_setiv(sv, (IV) PL_utf8cache);
break;
case '\027': /* ^W & $^WARNING_BITS */
if (nextchar == '\0')
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 */
- SV **bits_all;
- HV * const bits=get_hv("warnings::Bits", FALSE);
- if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
- sv_setsv(sv, *bits_all);
+ 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) ;
}
}
else {
- sv_setsv(sv, PL_compiling.cop_warnings);
+ sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+ *PL_compiling.cop_warnings);
}
SvPOK_only(sv);
}
break;
+ case '\015': /* $^MATCH */
+ if (strEQ(remaining, "ATCH")) {
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- I32 s1, t1;
-
- /*
- * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj));
- * XXX Does the new way break anything?
- */
- paren = atoi(mg->mg_ptr); /* $& is in [0] */
- getparen:
- if (paren <= (I32)rx->nparens &&
- (s1 = rx->startp[paren]) != -1 &&
- (t1 = rx->endp[paren]) != -1)
- {
- i = t1 - s1;
- s = rx->subbeg + s1;
- if (!rx->subbeg)
- break;
-
- getrx:
- if (i >= 0) {
- const int oldtainted = PL_tainted;
- TAINT_NOT;
- sv_setpvn(sv, s, i);
- PL_tainted = oldtainted;
- if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- if (PL_tainting) {
- if (RX_MATCH_TAINTED(rx)) {
- MAGIC* const mg = SvMAGIC(sv);
- MAGIC* mgt;
- PL_tainted = 1;
- SvMAGIC_set(sv, mg->mg_moremagic);
- SvTAINT(sv);
- if ((mgt = SvMAGIC(sv))) {
- mg->mg_moremagic = mgt;
- SvMAGIC_set(sv, mg);
- }
- } else
- SvTAINTED_off(sv);
- }
- break;
- }
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ /*
+ * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj));
+ * XXX Does the new way break anything?
+ */
+ paren = atoi(mg->mg_ptr); /* $& is in [0] */
+ CALLREG_NUMBUF_FETCH(rx,paren,sv);
+ break;
}
+ sv_setsv(sv,&PL_sv_undef);
}
- sv_setsv(sv,&PL_sv_undef);
break;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastparen;
- if (paren)
- goto getparen;
+ if (RX_LASTPAREN(rx)) {
+ CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv);
+ break;
+ }
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = rx->lastcloseparen;
- if (paren)
- goto getparen;
+ if (RX_LASTCLOSEPAREN(rx)) {
+ CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv);
+ break;
+ }
+
}
sv_setsv(sv,&PL_sv_undef);
break;
case '`':
+ do_prematch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if ((s = rx->subbeg) && rx->startp[0] != -1) {
- i = rx->startp[0];
- goto getrx;
- }
+ CALLREG_NUMBUF_FETCH(rx,-2,sv);
+ break;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\'':
+ do_postmatch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (rx->subbeg && rx->endp[0] != -1) {
- s = rx->subbeg + rx->endp[0];
- i = rx->sublen - rx->endp[0];
- goto getrx;
- }
+ CALLREG_NUMBUF_FETCH(rx,-1,sv);
+ break;
}
sv_setsv(sv,&PL_sv_undef);
break;
{
sv_setiv(sv, (IV)STATUS_CURRENT);
#ifdef COMPLEX_STATUS
+ SvUPGRADE(sv, SVt_PVLV);
LvTARGOFF(sv) = PL_statusvalue;
LvTARGLEN(sv) = PL_statusvalue_vms;
#endif
}
break;
case '^':
- if (GvIOp(PL_defoutgv))
- s = IoTOP_NAME(GvIOp(PL_defoutgv));
+ if (!isGV_with_GP(PL_defoutgv))
+ s = "";
+ else if (GvIOp(PL_defoutgv))
+ s = IoTOP_NAME(GvIOp(PL_defoutgv));
if (s)
sv_setpv(sv,s);
else {
sv_setpv(sv,GvENAME(PL_defoutgv));
- sv_catpv(sv,"_TOP");
+ sv_catpvs(sv,"_TOP");
}
break;
case '~':
- if (GvIOp(PL_defoutgv))
+ if (!isGV_with_GP(PL_defoutgv))
+ s = "";
+ else if (GvIOp(PL_defoutgv))
s = IoFMT_NAME(GvIOp(PL_defoutgv));
if (!s)
s = GvENAME(PL_defoutgv);
sv_setpv(sv,s);
break;
case '=':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
break;
case '-':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv)));
break;
case '%':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
case ':':
case '/':
break;
case '[':
- WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase));
+ sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
break;
case '|':
- if (GvIOp(PL_defoutgv))
+ if (GvIO(PL_defoutgv))
sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
break;
- case ',':
- break;
case '\\':
if (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
break;
case '!':
+ {
+ dSAVE_ERRNO;
#ifdef VMS
sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
- sv_setpv(sv, errno ? Strerror(errno) : "");
#else
- {
- const int saveerrno = errno;
sv_setnv(sv, (NV)errno);
+#endif
#ifdef OS2
if (errno == errno_isOS2 || errno == errno_isOS2_set)
sv_setpv(sv, os2error(Perl_rc));
else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
- errno = saveerrno;
+ if (SvPOKp(sv))
+ SvPOK_on(sv); /* may have got removed during taint processing */
+ RESTORE_ERRNO;
}
-#endif
+
SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
break;
(void)SvIOK_on(sv); /* what a wonderful hack! */
#endif
break;
-#ifndef MACOS_TRADITIONAL
case '0':
break;
-#endif
}
return 0;
}
{
struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_GETUVAR;
+
if (uf && uf->uf_val)
(*uf->uf_val)(aTHX_ uf->uf_index, sv);
return 0;
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- STRLEN len, klen;
- const char *s = SvPV_const(sv,len);
+ STRLEN len = 0, klen;
+ const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
const char * const ptr = MgPV_const(mg,klen);
my_setenv(ptr, s);
+ PERL_ARGS_ASSERT_MAGIC_SETENV;
+
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
if (valp)
- s = SvPV_const(*valp, len);
+ s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
#endif
Stat_t sbuf;
int i = 0, j = 0;
- strncpy(eltbuf, s, 255);
- eltbuf[255] = 0;
+ my_strlcpy(eltbuf, s, sizeof(eltbuf));
elt = eltbuf;
do { /* DCL$PATH may be a search list */
while (1) { /* as may dev portion of any element */
return 0;
}
}
- if ((cp = strchr(elt, ':')) != Nullch)
+ if ((cp = strchr(elt, ':')) != NULL)
*cp = '\0';
if (my_trnlnm(elt, eltbuf, j++))
elt = eltbuf;
char tmpbuf[256];
Stat_t st;
I32 i;
+#ifdef VMS /* Hmm. How do we get $Config{path_sep} from C? */
+ const char path_sep = '|';
+#else
+ const char path_sep = ':';
+#endif
s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
- s, strend, ':', &i);
+ s, strend, path_sep, &i);
s++;
- if (i >= sizeof tmpbuf /* too long -- assume the worst */
- || *tmpbuf != '/'
+ if (i >= (I32)sizeof tmpbuf /* too long -- assume the worst */
+#ifdef VMS
+ || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
+#else
+ || *tmpbuf != '/' /* no starting slash -- assume relative path */
+#endif
|| (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
return 0;
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARENV;
PERL_UNUSED_ARG(sv);
- my_setenv(MgPV_nolen_const(mg),Nullch);
+ my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
}
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)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
if (PL_localizing) {
HE* entry;
my_clearenv();
- hv_iterinit((HV*)sv);
- while ((entry = hv_iternext((HV*)sv))) {
+ hv_iterinit(MUTABLE_HV(sv));
+ while ((entry = hv_iternext(MUTABLE_HV(sv)))) {
I32 keylen;
my_setenv(hv_iterkey(entry, &keylen),
- SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
+ SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry)));
}
}
#endif
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);
#if defined(VMS)
restore_sigmask(pTHX_ SV *save_sv)
{
const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
- (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
}
#endif
int
{
dVAR;
/* Are we fetching a signal entry? */
- const I32 i = whichsig(MgPV_nolen_const(mg));
+ int i = (I16)mg->mg_private;
+
+ PERL_ARGS_ASSERT_MAGIC_GETSIG;
+
+ if (!i) {
+ mg->mg_private = i = whichsig(MgPV_nolen_const(mg));
+ }
+
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
else {
- Sighandler_t sigstate;
- sigstate = rsignal_state(i);
+ Sighandler_t sigstate = rsignal_state(i);
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
+ if (PL_sig_handlers_initted && PL_sig_ignoring[i])
+ sigstate = SIG_IGN;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
+ if (PL_sig_handlers_initted && PL_sig_defaulting[i])
+ sigstate = SIG_DFL;
#endif
/* cache state so we don't fetch it again */
if(sigstate == (Sighandler_t) SIG_IGN)
- sv_setpv(sv,"IGNORE");
+ sv_setpvs(sv,"IGNORE");
else
sv_setsv(sv,&PL_sv_undef);
- PL_psig_ptr[i] = SvREFCNT_inc(sv);
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
SvTEMP_off(sv);
}
}
int
Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
{
- /* XXX Some of this code was copied from Perl_magic_setsig. A little
- * refactoring might be in order.
- */
- dVAR;
- register const char * const s = MgPV_nolen_const(mg);
+ PERL_ARGS_ASSERT_MAGIC_CLEARSIG;
PERL_UNUSED_ARG(sv);
- if (*s == '_') {
- SV** svp = NULL;
- if (strEQ(s,"__DIE__"))
- svp = &PL_diehook;
- else if (strEQ(s,"__WARN__"))
- svp = &PL_warnhook;
- else
- Perl_croak(aTHX_ "No such hook: %s", s);
- if (svp && *svp) {
- SV * const to_dec = *svp;
- *svp = NULL;
- SvREFCNT_dec(to_dec);
- }
- }
- else {
- /* Are we clearing a signal entry? */
- const I32 i = whichsig(s);
- if (i > 0) {
-#ifdef HAS_SIGPROCMASK
- sigset_t set, save;
- SV* save_sv;
- /* Avoid having the signal arrive at a bad time, if possible. */
- sigemptyset(&set);
- sigaddset(&set,i);
- sigprocmask(SIG_BLOCK, &set, &save);
- ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
- SAVEFREESV(save_sv);
- SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
-#endif
- PERL_ASYNC_CHECK();
-#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
- if (!PL_sig_handlers_initted) Perl_csighandler_init();
-#endif
-#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- PL_sig_defaulting[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
-#else
- (void)rsignal(i, (Sighandler_t) SIG_DFL);
-#endif
- if(PL_psig_name[i]) {
- SvREFCNT_dec(PL_psig_name[i]);
- PL_psig_name[i]=0;
- }
- if(PL_psig_ptr[i]) {
- SV * const to_dec=PL_psig_ptr[i];
- PL_psig_ptr[i]=0;
- LEAVE;
- SvREFCNT_dec(to_dec);
- }
- else
- LEAVE;
- }
- }
- return 0;
-}
-static void
-S_raise_signal(pTHX_ int sig)
-{
- dVAR;
- /* Set a flag to say this signal is pending */
- PL_psig_pend[sig]++;
- /* And one to say _a_ signal is pending */
- PL_sig_pending = 1;
+ magic_setsig(NULL, mg);
+ return sv_unmagic(sv, mg->mg_type);
}
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_csighandler(int sig, ...)
+Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL)
#else
Perl_csighandler(int sig)
#endif
exit(1);
#endif
#endif
- if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ if (
+#ifdef SIGILL
+ sig == SIGILL ||
+#endif
+#ifdef SIGBUS
+ sig == SIGBUS ||
+#endif
+#ifdef SIGSEGV
+ sig == SIGSEGV ||
+#endif
+ (PL_signals & PERL_SIGNALS_UNSAFE_FLAG))
/* Call the perl level handler now--
- * with risk we may be in malloc() etc. */
+ * with risk we may be in malloc() or being destructed etc. */
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
- else
- S_raise_signal(aTHX_ sig);
+#endif
+ else {
+ if (!PL_psig_pend) return;
+ /* Set a flag to say this signal is pending, that is awaiting delivery after
+ * the current Perl opcode completes */
+ PL_psig_pend[sig]++;
+
+#ifndef SIG_PENDING_DIE_COUNT
+# define SIG_PENDING_DIE_COUNT 120
+#endif
+ /* Add one to say _a_ signal is pending */
+ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+ Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+ (unsigned long)SIG_PENDING_DIE_COUNT);
+ }
}
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
PERL_BLOCKSIG_ADD(set, sig);
PL_psig_pend[sig] = 0;
PERL_BLOCKSIG_BLOCK(set);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ (*PL_sighandlerp)(sig, NULL, NULL);
+#else
(*PL_sighandlerp)(sig);
+#endif
PERL_BLOCKSIG_UNBLOCK(set);
}
}
}
+/* sv of NULL signifies that we're acting as magic_clearsig. */
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
sigset_t set, save;
SV* save_sv;
#endif
-
register const char *s = MgPV_const(mg,len);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSIG;
+
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__"))
+ else if (strEQ(s,"__WARN__")
+ && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) {
+ /* Merge the existing behaviours, which are as follows:
+ magic_setsig, we always set svp to &PL_warnhook
+ (hence we always change the warnings handler)
+ For magic_clearsig, we don't change the warnings handler if it's
+ set to the &PL_warnhook. */
svp = &PL_warnhook;
- else
+ } else if (sv)
Perl_croak(aTHX_ "No such hook: %s", s);
i = 0;
- if (*svp) {
- to_dec = *svp;
+ if (svp && *svp) {
+ if (*svp != PERL_WARNHOOK_FATAL)
+ to_dec = *svp;
*svp = NULL;
}
}
else {
- i = whichsig(s); /* ...no, a brick */
+ i = (I16)mg->mg_private;
+ if (!i) {
+ i = whichsig(s); /* ...no, a brick */
+ mg->mg_private = (U16)i;
+ }
if (i <= 0) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
+ if (sv)
+ Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
return 0;
}
#ifdef HAS_SIGPROCMASK
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
- save_sv = newSVpv((char *)(&save), sizeof(sigset_t));
+ save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 0;
#endif
- SvREFCNT_dec(PL_psig_name[i]);
to_dec = PL_psig_ptr[i];
- PL_psig_ptr[i] = SvREFCNT_inc(sv);
- SvTEMP_off(sv); /* Make sure it doesn't go away on us */
- PL_psig_name[i] = newSVpvn(s, len);
- SvREADONLY_on(PL_psig_name[i]);
+ if (sv) {
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
+ SvTEMP_off(sv); /* Make sure it doesn't go away on us */
+
+ /* Signals don't change name during the program's execution, so once
+ they're cached in the appropriate slot of PL_psig_name, they can
+ stay there.
+
+ Ideally we'd find some way of making SVs at (C) compile time, or
+ at least, doing most of the work. */
+ if (!PL_psig_name[i]) {
+ PL_psig_name[i] = newSVpvn(s, len);
+ SvREADONLY_on(PL_psig_name[i]);
+ }
+ } else {
+ SvREFCNT_dec(PL_psig_name[i]);
+ PL_psig_name[i] = NULL;
+ PL_psig_ptr[i] = NULL;
+ }
}
- if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
+ if (sv && (isGV_with_GP(sv) || SvROK(sv))) {
if (i) {
(void)rsignal(i, PL_csighandlerp);
-#ifdef HAS_SIGPROCMASK
- LEAVE;
-#endif
}
else
- *svp = SvREFCNT_inc(sv);
- if(to_dec)
- SvREFCNT_dec(to_dec);
- return 0;
- }
- s = SvPV_force(sv,len);
- if (strEQ(s,"IGNORE")) {
- if (i) {
+ *svp = SvREFCNT_inc_simple_NN(sv);
+ } else {
+ if (sv && SvOK(sv)) {
+ s = SvPV_force(sv, len);
+ } else {
+ sv = NULL;
+ }
+ if (sv && strEQ(s,"IGNORE")) {
+ if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- PL_sig_ignoring[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
+ PL_sig_ignoring[i] = 1;
+ (void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, (Sighandler_t) SIG_IGN);
+ (void)rsignal(i, (Sighandler_t) SIG_IGN);
#endif
+ }
}
- }
- else if (strEQ(s,"DEFAULT") || !*s) {
- if (i)
+ else if (!sv || strEQ(s,"DEFAULT") || !len) {
+ if (i) {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- {
- PL_sig_defaulting[i] = 1;
- (void)rsignal(i, PL_csighandlerp);
- }
+ PL_sig_defaulting[i] = 1;
+ (void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, (Sighandler_t) SIG_DFL);
+ (void)rsignal(i, (Sighandler_t) SIG_DFL);
#endif
+ }
+ }
+ else {
+ /*
+ * We should warn if HINT_STRICT_REFS, but without
+ * 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,'\''))
+ Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"),
+ SV_GMAGIC);
+ if (i)
+ (void)rsignal(i, PL_csighandlerp);
+ else
+ *svp = SvREFCNT_inc_simple_NN(sv);
+ }
}
- else {
- /*
- * We should warn if HINT_STRICT_REFS, but without
- * 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,'\''))
- Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
- if (i)
- (void)rsignal(i, PL_csighandlerp);
- else
- *svp = SvREFCNT_inc(sv);
- }
+
#ifdef HAS_SIGPROCMASK
if(i)
LEAVE;
#endif
- if(to_dec)
- SvREFCNT_dec(to_dec);
+ SvREFCNT_dec(to_dec);
return 0;
}
#endif /* !PERL_MICRO */
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SETISA;
PERL_UNUSED_ARG(sv);
- PERL_UNUSED_ARG(mg);
- PL_sub_generation++;
+
+ /* Skip _isaelem because _isa will handle it shortly */
+ if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem)
+ return 0;
+
+ return magic_clearisa(NULL, mg);
+}
+
+/* sv of NULL signifies that we're acting as magic_setisa. */
+int
+Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+ HV* stash;
+
+ PERL_ARGS_ASSERT_MAGIC_CLEARISA;
+
+ /* Bail out if destruction is going on */
+ if(PL_dirty) return 0;
+
+ if (sv)
+ av_clear(MUTABLE_AV(sv));
+
+ /* XXX Once it's possible, we need to
+ detect that our @ISA is aliased in
+ other stashes, and act on the stashes
+ of all of the aliases */
+
+ /* The first case occurs via setisa,
+ the second via setisa_elem, which
+ calls this same magic */
+ stash = GvSTASH(
+ SvTYPE(mg->mg_obj) == SVt_PVGV
+ ? (const GV *)mg->mg_obj
+ : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
+ );
+
+ if (stash)
+ mro_isa_changed_in(stash);
+
return 0;
}
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+ PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
- /* HV_badAMAGIC_on(Sv_STASH(sv)); */
PL_amagic_generation++;
return 0;
int
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
- HV * const hv = (HV*)LvTARG(sv);
+ HV * const hv = MUTABLE_HV(LvTARG(sv));
I32 i = 0;
+
+ PERL_ARGS_ASSERT_MAGIC_GETNKEYS;
PERL_UNUSED_ARG(mg);
if (hv) {
(void) hv_iterinit(hv);
- if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
+ if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
i = HvKEYS(hv);
else {
while (hv_iternext(hv))
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETNKEYS;
PERL_UNUSED_ARG(mg);
if (LvTARG(sv)) {
- hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
+ hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv));
}
return 0;
}
-/* caller is responsible for stack switching/cleanup */
-STATIC int
-S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
+/*
+=for apidoc magic_methcall
+
+Invoke a magic method (like FETCH).
+
+* sv and mg are the tied thinggy and the tie magic;
+* meth is the name of the method to call;
+* n, arg1, arg2 are the number of args (in addition to $self) to pass to
+ the method, and the args themselves (negative n is special-cased);
+* flags:
+ G_DISCARD: invoke method with G_DISCARD flag and don't return a value
+
+Returns the SV (if any) returned by the method, or NULL on failure.
+
+
+=cut
+*/
+
+SV*
+Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
+ int n, SV *arg1, SV *arg2)
{
dVAR;
dSP;
+ SV* ret = NULL;
+ PERL_ARGS_ASSERT_MAGIC_METHCALL;
+
+ ENTER;
+ PUSHSTACKi(PERLSI_MAGIC);
PUSHMARK(SP);
- EXTEND(SP, n);
- PUSHs(SvTIED_obj(sv, mg));
- if (n > 1) {
- if (mg->mg_ptr) {
- if (mg->mg_len >= 0)
- PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len)));
- else if (mg->mg_len == HEf_SVKEY)
- PUSHs((SV*)mg->mg_ptr);
- }
- else if (mg->mg_type == PERL_MAGIC_tiedelem) {
- PUSHs(sv_2mortal(newSViv(mg->mg_len)));
+
+ if (n < 0) {
+ /* special case for UNSHIFT */
+ EXTEND(SP,-n+1);
+ PUSHs(SvTIED_obj(sv, mg));
+ while (n++ < 0) {
+ PUSHs(&PL_sv_undef);
}
}
- if (n > 2) {
- PUSHs(val);
+ else {
+ EXTEND(SP,n+1);
+ PUSHs(SvTIED_obj(sv, mg));
+ if (n > 0) {
+ PUSHs(arg1);
+ if (n > 1) PUSHs(arg2);
+ assert(n <= 2);
+ }
}
PUTBACK;
+ if (flags & G_DISCARD) {
+ call_method(meth, G_SCALAR|G_DISCARD);
+ }
+ else {
+ if (call_method(meth, G_SCALAR))
+ ret = *PL_stack_sp--;
+ }
+ POPSTACK;
+ LEAVE;
+ return ret;
+}
- return call_method(meth, flags);
+
+/* wrapper for magic_methcall that creates the first arg */
+
+STATIC SV*
+S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags,
+ int n, SV *val)
+{
+ dVAR;
+ SV* arg1 = NULL;
+
+ PERL_ARGS_ASSERT_MAGIC_METHCALL1;
+
+ if (mg->mg_ptr) {
+ if (mg->mg_len >= 0) {
+ arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
+ }
+ else if (mg->mg_len == HEf_SVKEY)
+ arg1 = MUTABLE_SV(mg->mg_ptr);
+ }
+ else if (mg->mg_type == PERL_MAGIC_tiedelem) {
+ arg1 = newSViv((IV)(mg->mg_len));
+ sv_2mortal(arg1);
+ }
+ if (!arg1) {
+ arg1 = val;
+ n--;
+ }
+ return magic_methcall(sv, mg, meth, flags, n, arg1, val);
}
STATIC int
S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
{
- dVAR; dSP;
-
- ENTER;
- SAVETMPS;
- PUSHSTACKi(PERLSI_MAGIC);
+ dVAR;
+ SV* ret;
- if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
- sv_setsv(sv, *PL_stack_sp--);
- }
+ PERL_ARGS_ASSERT_MAGIC_METHPACK;
- POPSTACK;
- FREETMPS;
- LEAVE;
+ ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
+ if (ret)
+ sv_setsv(sv, ret);
return 0;
}
int
Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
{
- if (mg->mg_ptr)
+ PERL_ARGS_ASSERT_MAGIC_GETPACK;
+
+ if (mg->mg_type == PERL_MAGIC_tiedelem)
mg->mg_flags |= MGf_GSKIP;
magic_methpack(sv,mg,"FETCH");
return 0;
int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR; dSP;
- ENTER;
- PUSHSTACKi(PERLSI_MAGIC);
- magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
- POPSTACK;
- LEAVE;
+ dVAR;
+ MAGIC *tmg;
+ SV *val;
+
+ PERL_ARGS_ASSERT_MAGIC_SETPACK;
+
+ /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to
+ * STORE() is not $val, but rather a PVLV (the sv in this call), whose
+ * public flags indicate its value based on copying from $val. Doing
+ * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us.
+ * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes
+ * wrong if $val happened to be tainted, as sv hasn't got magic
+ * enabled, even though taint magic is in the chain. In which case,
+ * fake up a temporary tainted value (this is easier than temporarily
+ * re-enabling magic on sv). */
+
+ if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint))
+ && (tmg->mg_len & 1))
+ {
+ val = sv_mortalcopy(sv);
+ SvTAINTED_on(val);
+ }
+ else
+ val = sv;
+
+ magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
return 0;
}
int
Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_CLEARPACK;
+
return magic_methpack(sv,mg,"DELETE");
}
U32
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR; dSP;
- U32 retval = 0;
+ dVAR;
+ I32 retval = 0;
+ SV* retsv;
- ENTER;
- SAVETMPS;
- PUSHSTACKi(PERLSI_MAGIC);
- if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
- sv = *PL_stack_sp--;
- retval = (U32) SvIV(sv)-1;
+ PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
+
+ retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
+ if (retsv) {
+ retval = SvIV(retsv)-1;
+ if (retval < -1)
+ Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
}
- POPSTACK;
- FREETMPS;
- LEAVE;
- return retval;
+ return (U32) retval;
}
int
Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
{
- dVAR; dSP;
+ dVAR;
- ENTER;
- PUSHSTACKi(PERLSI_MAGIC);
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj(sv, mg));
- PUTBACK;
- call_method("CLEAR", G_SCALAR|G_DISCARD);
- POPSTACK;
- LEAVE;
+ PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
+ magic_methcall(sv, mg, "CLEAR", G_DISCARD, 0, NULL, NULL);
return 0;
}
int
Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
{
- dVAR; dSP;
- const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
-
- ENTER;
- SAVETMPS;
- PUSHSTACKi(PERLSI_MAGIC);
- PUSHMARK(SP);
- EXTEND(SP, 2);
- PUSHs(SvTIED_obj(sv, mg));
- if (SvOK(key))
- PUSHs(key);
- PUTBACK;
+ dVAR;
+ SV* ret;
- if (call_method(meth, G_SCALAR))
- sv_setsv(key, *PL_stack_sp--);
+ PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
- POPSTACK;
- FREETMPS;
- LEAVE;
+ ret = magic_methcall(sv, mg,
+ (SvOK(key) ? "NEXTKEY" : "FIRSTKEY"),
+ 0,
+ (SvOK(key) ? 1 : 0), key, NULL);
+ if (ret)
+ sv_setsv(key,ret);
return 0;
}
int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_EXISTSPACK;
+
return magic_methpack(sv,mg,"EXISTS");
}
SV *
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
- dVAR; dSP;
- SV *retval = &PL_sv_undef;
- SV * const tied = SvTIED_obj((SV*)hv, mg);
- HV * const pkg = SvSTASH((SV*)SvRV(tied));
+ dVAR;
+ SV *retval;
+ SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
+ HV * const pkg = SvSTASH((const SV *)SvRV(tied));
+ PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
+
if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
SV *key;
if (HvEITER_get(hv))
return &PL_sv_yes;
/* no xhv_eiter so now use FIRSTKEY */
key = sv_newmortal();
- magic_nextpack((SV*)hv, mg, key);
+ magic_nextpack(MUTABLE_SV(hv), mg, key);
HvEITER_set(hv, NULL); /* need to reset iterator */
return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
}
/* there is a SCALAR method that we can call */
- ENTER;
- PUSHSTACKi(PERLSI_MAGIC);
- PUSHMARK(SP);
- EXTEND(SP, 1);
- PUSHs(tied);
- PUTBACK;
-
- if (call_method("SCALAR", G_SCALAR))
- retval = *PL_stack_sp--;
- POPSTACK;
- LEAVE;
+ retval = magic_methcall(MUTABLE_SV(hv), mg, "SCALAR", 0, 0, NULL, NULL);
+ if (!retval)
+ retval = &PL_sv_undef;
return retval;
}
const I32 i = SvTRUE(sv);
SV ** const svp = av_fetch(GvAV(gv),
atoi(MgPV_nolen_const(mg)), FALSE);
+
+ PERL_ARGS_ASSERT_MAGIC_SETDBLINE;
+
if (svp && SvIOKp(*svp)) {
OP * const o = INT2PTR(OP*,SvIVX(*svp));
if (o) {
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
dVAR;
- const AV * const obj = (AV*)mg->mg_obj;
+ AV * const obj = MUTABLE_AV(mg->mg_obj);
+
+ PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
+
if (obj) {
- sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
+ sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
} else {
SvOK_off(sv);
}
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- AV * const obj = (AV*)mg->mg_obj;
+ AV * const obj = MUTABLE_AV(mg->mg_obj);
+
+ PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
+
if (obj) {
- av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
+ av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop));
} else {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Attempt to set length of freed array");
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Attempt to set length of freed array");
}
return 0;
}
Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P;
PERL_UNUSED_ARG(sv);
+
/* during global destruction, mg_obj may already have been freed */
if (PL_in_clean_all)
return 0;
dVAR;
SV* const lsv = LvTARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_GETPOS;
+ PERL_UNUSED_ARG(mg);
+
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
- mg = mg_find(lsv, PERL_MAGIC_regex_global);
- if (mg && mg->mg_len >= 0) {
- I32 i = mg->mg_len;
+ MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
+ if (found && found->mg_len >= 0) {
+ I32 i = found->mg_len;
if (DO_UTF8(lsv))
sv_pos_b2u(lsv, &i);
- sv_setiv(sv, i + PL_curcop->cop_arybase);
+ sv_setiv(sv, i + CopARYBASE_get(PL_curcop));
return 0;
}
}
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
+ MAGIC* found;
- mg = 0;
+ PERL_ARGS_ASSERT_MAGIC_SETPOS;
+ PERL_UNUSED_ARG(mg);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
- mg = mg_find(lsv, PERL_MAGIC_regex_global);
- if (!mg) {
+ found = mg_find(lsv, PERL_MAGIC_regex_global);
+ else
+ found = NULL;
+ if (!found) {
if (!SvOK(sv))
return 0;
- sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
- mg = mg_find(lsv, PERL_MAGIC_regex_global);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(lsv))
+ sv_force_normal_flags(lsv, 0);
+#endif
+ found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
+ NULL, 0);
}
else if (!SvOK(sv)) {
- mg->mg_len = -1;
+ found->mg_len = -1;
return 0;
}
len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
- pos = SvIV(sv) - PL_curcop->cop_arybase;
+ pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
if (DO_UTF8(lsv)) {
ulen = sv_len_utf8(lsv);
pos = p;
}
- mg->mg_len = pos;
- mg->mg_flags &= ~MGf_MINMATCH;
-
- return 0;
-}
-
-int
-Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
-{
- PERL_UNUSED_ARG(mg);
- if (SvFAKE(sv)) { /* FAKE globs can get coerced */
- SvFAKE_off(sv);
- gv_efullname3(sv,((GV*)sv), "*");
- SvFAKE_on(sv);
- }
- else
- gv_efullname3(sv,((GV*)sv), "*"); /* a gv value, be nice */
- return 0;
-}
-
-int
-Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
-{
- GV* gv;
- PERL_UNUSED_ARG(mg);
+ found->mg_len = pos;
+ found->mg_flags &= ~MGf_MINMATCH;
- if (!SvOK(sv))
- return 0;
- gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
- if (sv == (SV*)gv)
- return 0;
- if (GvGP(sv))
- gp_free((GV*)sv);
- GvGP(sv) = gp_ref(GvGP(gv));
return 0;
}
STRLEN len;
SV * const lsv = LvTARG(sv);
const char * const tmps = SvPV_const(lsv,len);
- I32 offs = LvTARGOFF(sv);
- I32 rem = LvTARGLEN(sv);
+ STRLEN offs = LvTARGOFF(sv);
+ STRLEN rem = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
PERL_UNUSED_ARG(mg);
if (SvUTF8(lsv))
- sv_pos_u2b(lsv, &offs, &rem);
- if (offs > (I32)len)
+ offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
+ if (offs > len)
offs = len;
- if (rem + offs > (I32)len)
+ if (rem > len - offs)
rem = len - offs;
- sv_setpvn(sv, tmps + offs, (STRLEN)rem);
+ sv_setpvn(sv, tmps + offs, rem);
if (SvUTF8(lsv))
SvUTF8_on(sv);
return 0;
{
dVAR;
STRLEN len;
- const char *tmps = SvPV_const(sv, len);
+ const char * const tmps = SvPV_const(sv, len);
SV * const lsv = LvTARG(sv);
- I32 lvoff = LvTARGOFF(sv);
- I32 lvlen = LvTARGLEN(sv);
+ STRLEN lvoff = LvTARGOFF(sv);
+ STRLEN lvlen = LvTARGLEN(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
PERL_UNUSED_ARG(mg);
if (DO_UTF8(sv)) {
sv_utf8_upgrade(lsv);
- sv_pos_u2b(lsv, &lvoff, &lvlen);
+ lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
sv_insert(lsv, lvoff, lvlen, tmps, len);
LvTARGLEN(sv) = sv_len_utf8(sv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
- sv_pos_u2b(lsv, &lvoff, &lvlen);
+ const char *utf8;
+ lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
LvTARGLEN(sv) = len;
- tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
- sv_insert(lsv, lvoff, lvlen, tmps, len);
- Safefree(tmps);
+ utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
+ sv_insert(lsv, lvoff, lvlen, utf8, len);
+ Safefree(utf8);
}
else {
sv_insert(lsv, lvoff, lvlen, tmps, len);
LvTARGLEN(sv) = len;
}
-
return 0;
}
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_GETTAINT;
PERL_UNUSED_ARG(sv);
+
TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
}
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
+
+ PERL_ARGS_ASSERT_MAGIC_SETTAINT;
PERL_UNUSED_ARG(sv);
- /* update taint status unless we're restoring at scope exit */
- if (PL_localizing != 2) {
- if (PL_tainted)
- mg->mg_len |= 1;
- else
- mg->mg_len &= ~1;
- }
+
+ /* update taint status */
+ if (PL_tainted)
+ mg->mg_len |= 1;
+ else
+ mg->mg_len &= ~1;
return 0;
}
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
+
+ PERL_ARGS_ASSERT_MAGIC_GETVEC;
PERL_UNUSED_ARG(mg);
if (lsv)
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETVEC;
PERL_UNUSED_ARG(mg);
do_vecset(sv); /* XXX slurp this routine */
return 0;
Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- SV *targ = Nullsv;
+ SV *targ = NULL;
+
+ PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
+
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
- HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0);
if (he)
targ = HeVAL(he);
}
else {
- AV* const av = (AV*)LvTARG(sv);
+ AV *const av = MUTABLE_AV(LvTARG(sv));
if ((I32)LvTARGOFF(sv) <= AvFILL(av))
targ = AvARRAY(av)[LvTARGOFF(sv)];
}
- if (targ && targ != &PL_sv_undef) {
+ if (targ && (targ != &PL_sv_undef)) {
/* somebody else defined it for us */
SvREFCNT_dec(LvTARG(sv));
- LvTARG(sv) = SvREFCNT_inc(targ);
+ LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
LvTARGLEN(sv) = 0;
SvREFCNT_dec(mg->mg_obj);
- mg->mg_obj = Nullsv;
+ mg->mg_obj = NULL;
mg->mg_flags &= ~MGf_REFCOUNTED;
}
}
int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETDEFELEM;
PERL_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
vivify_defelem(sv);
{
dVAR;
MAGIC *mg;
- SV *value = Nullsv;
+ SV *value = NULL;
+
+ PERL_ARGS_ASSERT_VIVIFY_DEFELEM;
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
SV * const ahv = LvTARG(sv);
- HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0);
if (he)
value = HeVAL(he);
if (!value || value == &PL_sv_undef)
- Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
+ Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
}
else {
- AV* const av = (AV*)LvTARG(sv);
+ AV *const av = MUTABLE_AV(LvTARG(sv));
if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
- LvTARG(sv) = Nullsv; /* array can't be extended */
+ LvTARG(sv) = NULL; /* array can't be extended */
else {
- SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
+ SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE);
if (!svp || (value = *svp) == &PL_sv_undef)
Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv));
}
}
- (void)SvREFCNT_inc(value);
+ SvREFCNT_inc_simple_void(value);
SvREFCNT_dec(LvTARG(sv));
LvTARG(sv) = value;
LvTARGLEN(sv) = 0;
SvREFCNT_dec(mg->mg_obj);
- mg->mg_obj = Nullsv;
+ mg->mg_obj = NULL;
mg->mg_flags &= ~MGf_REFCOUNTED;
}
int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
- return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
+ PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
+ return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
}
int
Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETMGLOB;
+ PERL_UNUSED_CONTEXT;
mg->mg_len = -1;
- SvSCREAM_off(sv);
- return 0;
-}
-
-int
-Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
-{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_bm);
- SvVALID_off(sv);
- return 0;
-}
-
-int
-Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
-{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_fm);
- SvCOMPILED_off(sv);
+ if (!isGV_with_GP(sv))
+ SvSCREAM_off(sv);
return 0;
}
{
const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
+ PERL_ARGS_ASSERT_MAGIC_SETUVAR;
+
if (uf && uf->uf_set)
(*uf->uf_set)(aTHX_ uf->uf_index, sv);
return 0;
int
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
{
- PERL_UNUSED_ARG(mg);
- sv_unmagic(sv, PERL_MAGIC_qr);
- return 0;
-}
+ const char type = mg->mg_type;
-int
-Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- regexp * const re = (regexp *)mg->mg_obj;
- PERL_UNUSED_ARG(sv);
+ PERL_ARGS_ASSERT_MAGIC_SETREGEXP;
- ReREFCNT_dec(re);
- return 0;
+ if (type == PERL_MAGIC_qr) {
+ } else if (type == PERL_MAGIC_bm) {
+ SvTAIL_off(sv);
+ SvVALID_off(sv);
+ } else {
+ assert(type == PERL_MAGIC_fm);
+ SvCOMPILED_off(sv);
+ }
+ return sv_unmagic(sv, type);
}
#ifdef USE_LOCALE_COLLATE
int
Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM;
+
/*
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
*/
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
if (mg->mg_ptr) {
Safefree(mg->mg_ptr);
int
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_ARGS_ASSERT_MAGIC_SETUTF8;
+ PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
- mg->mg_ptr = 0;
+ mg->mg_ptr = NULL;
mg->mg_len = -1; /* The mg_len holds the len cache. */
return 0;
}
{
dVAR;
register const char *s;
+ register I32 paren;
+ register const REGEXP * rx;
+ const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;
+
+ PERL_ARGS_ASSERT_MAGIC_SET;
+
switch (*mg->mg_ptr) {
+ case '\015': /* $^MATCH */
+ if (strEQ(remaining, "ATCH"))
+ goto do_match;
+ case '`': /* ${^PREMATCH} caught below */
+ do_prematch:
+ paren = RX_BUFF_IDX_PREMATCH;
+ goto setparen;
+ case '\'': /* ${^POSTMATCH} caught below */
+ do_postmatch:
+ paren = RX_BUFF_IDX_POSTMATCH;
+ goto setparen;
+ case '&':
+ do_match:
+ paren = RX_BUFF_IDX_FULLMATCH;
+ goto setparen;
+ case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ paren = atoi(mg->mg_ptr);
+ setparen:
+ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+ CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
+ break;
+ } else {
+ /* Croak with a READONLY error when a numbered match var is
+ * set without a previous pattern match. Unless it's C<local $1>
+ */
+ if (!PL_localizing) {
+ Perl_croak(aTHX_ "%s", PL_no_modify);
+ }
+ }
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
break;
case '\003': /* ^C */
- PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ PL_minus_c = cBOOL(SvIV(sv));
break;
case '\004': /* ^D */
#ifdef DEBUGGING
s = SvPV_nolen_const(sv);
PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
- DEBUG_x(dump_all());
+ if (DEBUG_x_TEST || DEBUG_B_TEST)
+ dump_all_perl(!DEBUG_B_TEST);
#else
- PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
+ PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG;
#endif
break;
case '\005': /* ^E */
if (*(mg->mg_ptr+1) == '\0') {
-#ifdef MACOS_TRADITIONAL
- gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+#ifdef VMS
+ set_vaxc_errno(SvIV(sv));
#else
-# ifdef VMS
- set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
-# else
-# ifdef WIN32
+# ifdef WIN32
SetLastError( SvIV(sv) );
+# else
+# ifdef OS2
+ os2_setsyserrno(SvIV(sv));
# else
-# ifdef OS2
- os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
-# else
/* will anyone ever use this? */
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
-# endif
+ SETERRNO(SvIV(sv), 4);
# endif
# endif
#endif
}
else if (strEQ(mg->mg_ptr+1, "NCODING")) {
- if (PL_encoding)
- SvREFCNT_dec(PL_encoding);
+ SvREFCNT_dec(PL_encoding);
if (SvOK(sv) || SvGMAGICAL(sv)) {
PL_encoding = newSVsv(sv);
}
else {
- PL_encoding = Nullsv;
+ PL_encoding = NULL;
}
}
break;
case '\006': /* ^F */
- PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_maxsysfd = SvIV(sv);
break;
case '\010': /* ^H */
- PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_hints = SvIV(sv);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
Safefree(PL_inplace);
- PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
+ PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
break;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
Safefree(PL_osname);
- PL_osname = Nullch;
+ PL_osname = NULL;
if (SvOK(sv)) {
TAINT_PROPER("assigning to $^O");
PL_osname = savesvpv(sv);
}
}
else if (strEQ(mg->mg_ptr, "\017PEN")) {
- if (!PL_compiling.cop_io)
- PL_compiling.cop_io = newSVsv(sv);
- else
- sv_setsv(PL_compiling.cop_io,sv);
+ STRLEN len;
+ const char *const start = SvPV(sv, len);
+ const char *out = (const char*)memchr(start, '\0', len);
+ SV *tmp;
+
+
+ PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+ PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT;
+
+ /* Opening for input is more common than opening for output, so
+ ensure that hints for input are sooner on linked list. */
+ tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
+ SvUTF8(sv))
+ : newSVpvs_flags("", SvUTF8(sv));
+ (void)hv_stores(GvHV(PL_hintgv), "open>", tmp);
+ mg_set(tmp);
+
+ tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len,
+ SvUTF8(sv));
+ (void)hv_stores(GvHV(PL_hintgv), "open<", tmp);
+ mg_set(tmp);
}
break;
case '\020': /* ^P */
- PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if (PL_perldb && !PL_DBsingle)
- init_debugger();
- break;
+ if (*remaining == '\0') { /* ^P */
+ PL_perldb = SvIV(sv);
+ if (PL_perldb && !PL_DBsingle)
+ init_debugger();
+ break;
+ } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
+ goto do_prematch;
+ } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
+ goto do_postmatch;
+ }
case '\024': /* ^T */
#ifdef BIG_TIME
PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
#else
- PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ PL_basetime = (Time_t)SvIV(sv);
#endif
break;
+ case '\025': /* ^UTF8CACHE */
+ if (strEQ(mg->mg_ptr+1, "TF8CACHE")) {
+ PL_utf8cache = (signed char) sv_2iv(sv);
+ }
+ break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0') {
if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
- i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ i = SvIV(sv);
PL_dowarn = (PL_dowarn & ~G_WARN_ON)
| (i ? G_WARN_ON : G_WARN_OFF) ;
}
accumulate |= ptr[i] ;
any_fatals |= (ptr[i] & 0xAA) ;
}
- if (!accumulate)
- PL_compiling.cop_warnings = pWARN_NONE;
- else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+ if (!accumulate) {
+ 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))
+ PerlMemShared_free(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL;
PL_dowarn |= G_WARN_ONCE ;
}
else {
- if (specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = newSVsv(sv) ;
- else
- sv_setsv(PL_compiling.cop_warnings, sv);
+ STRLEN len;
+ const char *const p = SvPV_const(sv, len);
+
+ PL_compiling.cop_warnings
+ = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+ p, len);
+
if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
PL_dowarn |= G_WARN_ONCE ;
}
IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
break;
case '^':
- Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ if (isGV_with_GP(PL_defoutgv)) {
+ Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
+ s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '~':
- Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
- s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ if (isGV_with_GP(PL_defoutgv)) {
+ Safefree(IoFMT_NAME(GvIOp(PL_defoutgv)));
+ s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
+ IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO);
+ }
break;
case '=':
- IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ if (isGV_with_GP(PL_defoutgv))
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '-':
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
- if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ if (isGV_with_GP(PL_defoutgv)) {
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv));
+ if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
+ IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
+ }
break;
case '%':
- IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ if (isGV_with_GP(PL_defoutgv))
+ IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '|':
{
- IO * const io = GvIOp(PL_defoutgv);
+ IO * const io = GvIO(PL_defoutgv);
if(!io)
break;
- if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
+ if ((SvIV(sv)) == 0)
IoFLAGS(io) &= ~IOf_FLUSH;
else {
if (!(IoFLAGS(io) & IOf_FLUSH)) {
PL_rs = newSVsv(sv);
break;
case '\\':
- if (PL_ors_sv)
- SvREFCNT_dec(PL_ors_sv);
+ SvREFCNT_dec(PL_ors_sv);
if (SvOK(sv) || SvGMAGICAL(sv)) {
PL_ors_sv = newSVsv(sv);
}
else {
- PL_ors_sv = Nullsv;
- }
- break;
- case ',':
- if (PL_ofs_sv)
- SvREFCNT_dec(PL_ofs_sv);
- if (SvOK(sv) || SvGMAGICAL(sv)) {
- PL_ofs_sv = newSVsv(sv);
- }
- else {
- PL_ofs_sv = Nullsv;
+ PL_ors_sv = NULL;
}
break;
case '[':
- PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ CopARYBASE_set(&PL_compiling, SvIV(sv));
break;
case '?':
#ifdef COMPLEX_STATUS
if (PL_localizing == 2) {
+ SvUPGRADE(sv, SVt_PVLV);
PL_statusvalue = LvTARGOFF(sv);
PL_statusvalue_vms = LvTARGLEN(sv);
}
STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
else
#endif
- STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ STATUS_UNIX_EXIT_SET(SvIV(sv));
break;
case '!':
{
}
break;
case '<':
- PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_uid = SvIV(sv);
if (PL_delaymagic) {
PL_delaymagic |= DM_RUID;
break; /* don't do magic till later */
#endif
#endif
PL_uid = PerlProc_getuid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case '>':
- PL_euid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_euid = SvIV(sv);
if (PL_delaymagic) {
PL_delaymagic |= DM_EUID;
break; /* don't do magic till later */
#endif
#endif
PL_euid = PerlProc_geteuid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case '(':
- PL_gid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_gid = SvIV(sv);
if (PL_delaymagic) {
PL_delaymagic |= DM_RGID;
break; /* don't do magic till later */
#endif
#endif
PL_gid = PerlProc_getgid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case ')':
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(sv, len);
Groups_t *gary = NULL;
+#ifdef _SC_NGROUPS_MAX
+ int maxgrp = sysconf(_SC_NGROUPS_MAX);
+
+ if (maxgrp < 0)
+ maxgrp = NGROUPS;
+#else
+ int maxgrp = NGROUPS;
+#endif
while (isSPACE(*p))
++p;
PL_egid = Atol(p);
- for (i = 0; i < NGROUPS; ++i) {
+ for (i = 0; i < maxgrp; ++i) {
while (*p && !isSPACE(*p))
++p;
while (isSPACE(*p))
}
if (i)
(void)setgroups(i, gary);
- if (gary)
- Safefree(gary);
+ Safefree(gary);
}
#else /* HAS_SETGROUPS */
- PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_egid = SvIV(sv);
#endif /* HAS_SETGROUPS */
if (PL_delaymagic) {
PL_delaymagic |= DM_EGID;
#endif
#endif
PL_egid = PerlProc_getegid();
- PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
break;
case ':':
PL_chopset = SvPV_force(sv,len);
break;
-#ifndef MACOS_TRADITIONAL
case '0':
LOCK_DOLLARZERO_MUTEX;
#ifdef HAS_SETPROCTITLE
setproctitle("%s", s);
# endif
}
-#endif
-#if defined(__hpux) && defined(PSTAT_SETCMD)
+#elif defined(__hpux) && defined(PSTAT_SETCMD)
if (PL_origalen != 1) {
union pstun un;
s = SvPV_const(sv, len);
un.pst_command = (char *)s;
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
-#endif
+#else
if (PL_origalen > 1) {
/* PL_origalen is set in perl_parse(). */
s = SvPV_force(sv,len);
}
else {
/* Shorter than original, will be padded. */
+#ifdef PERL_DARWIN
+ /* Special case for Mac OS X: see [perl #38868] */
+ const int pad = 0;
+#else
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ const int pad = ' ';
+#endif
Copy(s, PL_origargv[0], len, char);
PL_origargv[0][len] = 0;
memset(PL_origargv[0] + len + 1,
- /* Is the space counterintuitive? Yes.
- * (You were expecting \0?)
- * Does it work? Seems to. (In Linux 2.4.20 at least.)
- * --jhi */
- (int)' ',
- PL_origalen - len - 1);
+ pad, PL_origalen - len - 1);
}
PL_origargv[0][PL_origalen-1] = 0;
for (i = 1; i < PL_origargc; i++)
PL_origargv[i] = 0;
+#ifdef HAS_PRCTL_SET_NAME
+ /* Set the legacy process name in addition to the POSIX name on Linux */
+ if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) {
+ /* diag_listed_as: SKIPME */
+ Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno));
+ }
+#endif
}
+#endif
UNLOCK_DOLLARZERO_MUTEX;
break;
-#endif
}
return 0;
}
{
register char* const* sigv;
+ PERL_ARGS_ASSERT_WHICHSIG;
+ PERL_UNUSED_CONTEXT;
+
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
if (strEQ(sig,*sigv))
return PL_sig_num[sigv - (char* const*)PL_sig_name];
Signal_t
#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
-Perl_sighandler(int sig, ...)
+Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL)
#else
Perl_sighandler(int sig)
#endif
dTHX;
#endif
dSP;
- GV *gv = Nullgv;
- SV *sv = Nullsv;
+ GV *gv = NULL;
+ SV *sv = NULL;
SV * const tSv = PL_Sv;
- CV *cv = Nullcv;
+ CV *cv = NULL;
OP *myop = PL_op;
U32 flags = 0;
XPV * const tXpv = PL_Xpv;
if (flags & 16)
PL_scopestack_ix += 1;
/* sv_2cv is too complicated, try a simpler variant first: */
- if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
+ if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig])))
|| SvTYPE(cv) != SVt_PVCV) {
HV *st;
cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
}
if (!cv || !CvROOT(cv)) {
- if (ckWARN(WARN_SIGNAL))
- Perl_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__")));
+ 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__")));
goto cleanup;
}
if(PL_psig_name[sig]) {
- sv = SvREFCNT_inc(PL_psig_name[sig]);
+ sv = SvREFCNT_inc_NN(PL_psig_name[sig]);
flags |= 64;
#if !defined(PERL_IMPLICIT_CONTEXT)
PL_sig_sv = sv;
struct sigaction oact;
if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
- siginfo_t *sip;
- va_list args;
-
- va_start(args, sig);
- sip = (siginfo_t*)va_arg(args, siginfo_t*);
if (sip) {
HV *sih = newHV();
- SV *rv = newRV_noinc((SV*)sih);
+ SV *rv = newRV_noinc(MUTABLE_SV(sih));
/* The siginfo fields signo, code, errno, pid, uid,
* addr, status, and band are defined by POSIX/SUSv3. */
- hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0);
- hv_store(sih, "code", 4, newSViv(sip->si_code), 0);
+ (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
+ (void)hv_stores(sih, "code", newSViv(sip->si_code));
#if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */
- hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0);
- hv_store(sih, "status", 6, newSViv(sip->si_status), 0);
- hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0);
- hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0);
- hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0);
- hv_store(sih, "band", 4, newSViv(sip->si_band), 0);
+ hv_stores(sih, "errno", newSViv(sip->si_errno));
+ hv_stores(sih, "status", newSViv(sip->si_status));
+ hv_stores(sih, "uid", newSViv(sip->si_uid));
+ hv_stores(sih, "pid", newSViv(sip->si_pid));
+ hv_stores(sih, "addr", newSVuv(PTR2UV(sip->si_addr)));
+ hv_stores(sih, "band", newSViv(sip->si_band));
#endif
EXTEND(SP, 2);
- PUSHs((SV*)rv);
- PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+ PUSHs(rv);
+ mPUSHp((char *)sip, sizeof(*sip));
}
- va_end(args);
}
}
#endif
PUTBACK;
- call_sv((SV*)cv, G_DISCARD|G_EVAL);
+ call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
POPSTACK;
if (SvTRUE(ERRSV)) {
(void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ Nullch);
+ Perl_die(aTHX_ NULL);
}
cleanup:
if (flags & 1)
sv_force_normal_flags(sv, 0);
#endif
- if (mgs->mgs_flags)
- SvFLAGS(sv) |= mgs->mgs_flags;
+ 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 */
- U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
- if (public) {
- SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
- SvFLAGS(sv) |= ( public << PRIVSHIFT );
+ 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 );
}
}
}
dVAR;
const U32 flags = *(const U32*)p;
+ PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK;
+
if (flags & 1)
PL_savestack_ix -= 5; /* Unprotect save in progress. */
#if !defined(PERL_IMPLICIT_CONTEXT)
}
/*
+=for apidoc magic_sethint
+
+Triggered by a store to %^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.
+
+=cut
+*/
+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);
+
+ PERL_ARGS_ASSERT_MAGIC_SETHINT;
+
+ /* mg->mg_obj isn't being used. If needed, it would be possible to store
+ an alternative leaf in there, with PL_compiling.cop_hints being used if
+ it's NULL. If needed for threads, the alternative could lock a mutex,
+ or take other more complex action. */
+
+ /* Something changed in %^H, so it will need to be restored on scope exit.
+ Doing this here saves a lot of doing it manually in perl code (and
+ forgetting to do it, and consequent subtle errors. */
+ PL_hints |= HINT_LOCALIZE_HH;
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv);
+ return 0;
+}
+
+/*
+=for apidoc magic_clearhint
+
+Triggered by a delete from %^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);
+
+ assert(mg->mg_len == HEf_SVKEY);
+
+ PERL_UNUSED_ARG(sv);
+
+ PL_hints |= HINT_LOCALIZE_HH;
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+ MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
+ return 0;
+}
+
+/*
+=for apidoc magic_clearhints
+
+Triggered by clearing %^H, resets C<PL_compiling.cop_hints_hash>.
+
+=cut
+*/
+int
+Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
+{
+ PERL_ARGS_ASSERT_MAGIC_CLEARHINTS;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
+ if (PL_compiling.cop_hints_hash) {
+ Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+ PL_compiling.cop_hints_hash = NULL;
+ }
+ return 0;
+}
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
projects / p5sagit/p5-mst-13.2.git / blobdiff