/* mg.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
"magical" properties. When any Perl code tries to read from, or assign to,
an SV marked as magical, it calls the 'get' or 'set' function associated
with that SV's magic. A get is called prior to reading an SV, in order to
-give it a chance to update its interval value (get on $. writes the line
+give it a chance to update its internal value (get on $. writes the line
number of the last read filehandle into to the SV's IV slot), while
set is called after an SV has been written to, in order to allow it to make
-use of it's changed value (set on $/ copies the SV's new value to the
+use of its changed value (set on $/ copies the SV's new value to the
PL_rs global variable).
Magic is implemented as a linked list of MAGIC structures attached to the
#include "perl.h"
#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
-# ifndef NGROUPS
-# define NGROUPS 32
-# endif
# ifdef I_GRP
# include <grp.h>
# endif
#endif
+#if defined(HAS_SETGROUPS)
+# ifndef NGROUPS
+# define NGROUPS 32
+# endif
+#endif
+
#ifdef __hpux
# include <sys/pstat.h>
#endif
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Signal_t Perl_csighandler(int sig, ...);
+#else
Signal_t Perl_csighandler(int sig);
-
-/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */
-#if !defined(HAS_SIGACTION) && defined(VMS)
-# define FAKE_PERSISTENT_SIGNAL_HANDLERS
#endif
-/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
-#if defined(KILL_BY_SIGPRC)
-# define FAKE_DEFAULT_SIGNAL_HANDLERS
-#endif
-
-static void restore_magic(pTHX_ void *p);
-static void unwind_handler_stack(pTHX_ void *p);
#ifdef __Lynx__
/* Missing protos on LynxOS */
STATIC void
S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
{
+ dVAR;
MGS* mgs;
assert(SvMAGICAL(sv));
-#ifdef PERL_COPY_ON_WRITE
- /* Turning READONLY off for a copy-on-write scalar is a bad idea. */
+ /* Turning READONLY off for a copy-on-write scalar (including shared
+ hash keys) is a bad idea. */
if (SvIsCOW(sv))
- sv_force_normal(sv);
-#endif
+ sv_force_normal_flags(sv, 0);
- SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix));
+ SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
mgs = SSPTR(mgs_ix, MGS*);
mgs->mgs_sv = sv;
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
/*
void
Perl_mg_magical(pTHX_ SV *sv)
{
- MAGIC* mg;
+ const MAGIC* mg;
+ PERL_UNUSED_CONTEXT;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl) {
if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
SvGMAGICAL_on(sv);
int
Perl_mg_get(pTHX_ SV *sv)
{
- int new = 0;
+ dVAR;
+ const I32 mgs_ix = SSNEW(sizeof(MGS));
+ const bool was_temp = (bool)SvTEMP(sv);
+ int have_new = 0;
MAGIC *newmg, *head, *cur, *mg;
- I32 mgs_ix = SSNEW(sizeof(MGS));
- int was_temp = SvTEMP(sv);
/* guard against sv having being freed midway by holding a private
reference. */
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) {
- MGVTBL *vtbl = mg->mg_virtual;
+ const MGVTBL * const vtbl = mg->mg_virtual;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg);
mg = mg->mg_moremagic;
- if (new) {
+ if (have_new) {
/* Have we finished with the new entries we saw? Start again
where we left off (unless there are more new entries). */
if (mg == head) {
- new = 0;
+ have_new = 0;
mg = cur;
head = newmg;
}
}
/* Were any new entries added? */
- if (!new && (newmg = SvMAGIC(sv)) != head) {
- new = 1;
+ if (!have_new && (newmg = SvMAGIC(sv)) != head) {
+ have_new = 1;
cur = mg;
mg = newmg;
}
}
- restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix));
+ restore_magic(INT2PTR(void *, (IV)mgs_ix));
if (SvREFCNT(sv) == 1) {
/* We hold the last reference to this SV, which implies that the
int
Perl_mg_set(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ dVAR;
+ const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC* nextmg;
- mgs_ix = SSNEW(sizeof(MGS));
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = nextmg) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* vtbl = mg->mg_virtual;
nextmg = mg->mg_moremagic; /* it may delete itself */
if (mg->mg_flags & MGf_GSKIP) {
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
}
- restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
+ restore_magic(INT2PTR(void*, (IV)mgs_ix));
return 0;
}
U32
Perl_mg_length(pTHX_ SV *sv)
{
+ dVAR;
MAGIC* mg;
STRLEN len;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL * const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
- I32 mgs_ix;
-
- mgs_ix = SSNEW(sizeof(MGS));
+ const I32 mgs_ix = SSNEW(sizeof(MGS));
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
- restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
+ restore_magic(INT2PTR(void*, (IV)mgs_ix));
return len;
}
}
- if (DO_UTF8(sv))
- {
- U8 *s = (U8*)SvPV(sv, len);
- len = Perl_utf8_length(aTHX_ s, s + len);
+ if (DO_UTF8(sv)) {
+ const U8 *s = (U8*)SvPV_const(sv, len);
+ len = utf8_length(s, s + len);
}
else
- (void)SvPV(sv, len);
+ (void)SvPV_const(sv, len);
return len;
}
Perl_mg_size(pTHX_ SV *sv)
{
MAGIC* mg;
- I32 len;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
- I32 mgs_ix;
-
- mgs_ix = SSNEW(sizeof(MGS));
+ const I32 mgs_ix = SSNEW(sizeof(MGS));
+ I32 len;
save_magic(mgs_ix, sv);
/* omit MGf_GSKIP -- not changed here */
len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
- restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
+ restore_magic(INT2PTR(void*, (IV)mgs_ix));
return len;
}
}
switch(SvTYPE(sv)) {
case SVt_PVAV:
- len = AvFILLp((AV *) sv); /* Fallback to non-tied array */
- return len;
+ return AvFILLp((AV *) sv); /* Fallback to non-tied array */
case SVt_PVHV:
/* FIXME */
default:
int
Perl_mg_clear(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
- mgs_ix = SSNEW(sizeof(MGS));
save_magic(mgs_ix, sv);
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
/* omit GSKIP -- never set here */
if (vtbl && vtbl->svt_clear)
CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
}
- restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix));
+ restore_magic(INT2PTR(void*, (IV)mgs_ix));
return 0;
}
*/
MAGIC*
-Perl_mg_find(pTHX_ SV *sv, int type)
-{
- MAGIC* mg;
- if (!sv)
- return 0;
- for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- if (mg->mg_type == type)
- return mg;
+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) {
+ if (mg->mg_type == type)
+ return mg;
+ }
}
- return 0;
+ return NULL;
}
/*
int count = 0;
MAGIC* mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
}
- else if (isUPPER(mg->mg_type)) {
- sv_magic(nsv,
- mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
- (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
- ? sv : mg->mg_obj,
- toLOWER(mg->mg_type), key, klen);
- count++;
+ else {
+ const char type = mg->mg_type;
+ if (isUPPER(type) && type != PERL_MAGIC_uvar) {
+ sv_magic(nsv,
+ (type == PERL_MAGIC_tied)
+ ? SvTIED_obj(sv, mg)
+ : (type == PERL_MAGIC_regdata && mg->mg_obj)
+ ? sv
+ : mg->mg_obj,
+ toLOWER(type), key, klen);
+ count++;
+ }
}
}
return count;
}
/*
+=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).
+
+=cut
+*/
+
+void
+Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
+{
+ dVAR;
+ MAGIC *mg;
+ 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:
+ continue;
+ }
+
+ if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
+ (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg);
+ else
+ sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
+ mg->mg_ptr, mg->mg_len);
+
+ /* container types should remain read-only across localization */
+ SvFLAGS(nsv) |= SvREADONLY(sv);
+ }
+
+ if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
+ SvFLAGS(nsv) |= SvMAGICAL(sv);
+ PL_localizing = 1;
+ SvSETMAGIC(nsv);
+ PL_localizing = 0;
+ }
+}
+
+/*
=for apidoc mg_free
Free any magic storage used by the SV. See C<sv_magic>.
MAGIC* mg;
MAGIC* moremagic;
for (mg = SvMAGIC(sv); mg; mg = moremagic) {
- MGVTBL* vtbl = mg->mg_virtual;
+ const MGVTBL* const vtbl = mg->mg_virtual;
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
}
- SvMAGIC(sv) = 0;
+ SvMAGIC_set(sv, NULL);
return 0;
}
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- register REGEXP *rx;
-
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (mg->mg_obj) /* @+ */
- return rx->nparens;
- else /* @- */
- return rx->lastparen;
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+
+ if (PL_curpm) {
+ register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ if (rx) {
+ if (mg->mg_obj) { /* @+ */
+ /* return the number possible */
+ return rx->nparens;
+ } else { /* @- */
+ I32 paren = rx->lastparen;
+
+ /* return the last filled */
+ while ( paren >= 0
+ && (rx->startp[paren] == -1 || rx->endp[paren] == -1) )
+ paren--;
+ return (U32)paren;
+ }
+ }
}
return (U32)-1;
int
Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
{
- register I32 paren;
- register I32 s;
- register I32 i;
- register REGEXP *rx;
- I32 t;
-
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- paren = mg->mg_len;
- if (paren < 0)
- return 0;
- if (paren <= (I32)rx->nparens &&
- (s = rx->startp[paren]) != -1 &&
- (t = rx->endp[paren]) != -1)
- {
- if (mg->mg_obj) /* @+ */
- i = t;
- else /* @- */
- i = s;
+ dVAR;
+ if (PL_curpm) {
+ register const REGEXP * const rx = PM_GETRE(PL_curpm);
+ if (rx) {
+ register const I32 paren = mg->mg_len;
+ register I32 s;
+ register I32 t;
+ if (paren < 0)
+ return 0;
+ if (paren <= (I32)rx->nparens &&
+ (s = rx->startp[paren]) != -1 &&
+ (t = rx->endp[paren]) != -1)
+ {
+ register I32 i;
+ if (mg->mg_obj) /* @+ */
+ i = t;
+ else /* @- */
+ i = s;
+
+ if (i > 0 && RX_MATCH_UTF8(rx)) {
+ const char * const b = rx->subbeg;
+ if (b)
+ i = utf8_length((U8*)b, (U8*)(b+i));
+ }
- if (i > 0 && RX_MATCH_UTF8(rx)) {
- char *b = rx->subbeg;
- if (b)
- i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+ sv_setiv(sv, i);
}
-
- sv_setiv(sv, i);
- }
+ }
}
return 0;
}
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_ PL_no_modify);
- /* NOT REACHED */
- return 0;
+ NORETURN_FUNCTION_END;
}
U32
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
register I32 paren;
register I32 i;
- register REGEXP *rx;
+ register const REGEXP *rx;
I32 s1, t1;
switch (*mg->mg_ptr) {
i = t1 - s1;
getlen:
if (i > 0 && RX_MATCH_UTF8(rx)) {
- char *s = rx->subbeg + s1;
- char *send = rx->subbeg + t1;
+ const char * const s = rx->subbeg + s1;
+ const U8 *ep;
+ STRLEN el;
i = t1 - s1;
- if (is_utf8_string((U8*)s, i))
- i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
+ if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
+ i = el;
}
if (i < 0)
Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
- STRLEN n_a;
- sv_2pv(sv, &n_a);
+ sv_2pv(sv, 0);
}
if (SvPOK(sv))
return SvCUR(sv);
return 0;
}
+#define SvRTRIM(sv) STMT_START { \
+ if (SvPOK(sv)) { \
+ STRLEN len = SvCUR(sv); \
+ char * const p = SvPVX(sv); \
+ while (len > 0 && isSPACE(p[len-1])) \
+ --len; \
+ SvCUR_set(sv, len); \
+ p[len] = '\0'; \
+ } \
+} STMT_END
+
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;
switch (*mg->mg_ptr) {
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
break;
- case '\003': /* ^C */
- sv_setiv(sv, (IV)PL_minus_c);
+ case '\003': /* ^C, ^CHILD_ERROR_NATIVE */
+ if (nextchar == '\0') {
+ sv_setiv(sv, (IV)PL_minus_c);
+ }
+ else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
+ sv_setiv(sv, (IV)STATUS_NATIVE);
+ }
break;
case '\004': /* ^D */
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
break;
case '\005': /* ^E */
- if (*(mg->mg_ptr+1) == '\0') {
-#ifdef MACOS_TRADITIONAL
+ if (nextchar == '\0') {
+#if defined(MACOS_TRADITIONAL)
{
char msg[256];
sv_setnv(sv,(double)gMacPerl_OSErr);
sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
}
-#else
-#ifdef VMS
+#elif 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_setpv(sv,"");
+ sv_setpvn(sv,"",0);
}
-#else
-#ifdef OS2
+#elif defined(OS2)
if (!(_emx_env & 0x200)) { /* Under DOS */
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
} else {
if (errno != errno_isOS2) {
- int tmp = _syserrno();
+ const int tmp = _syserrno();
if (tmp) /* 2nd call to _syserrno() makes it 0 */
Perl_rc = tmp;
}
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)
- {
+ if (dwErr) {
PerlProc_GetOSError(sv, dwErr);
}
else
- sv_setpv(sv, "");
+ sv_setpvn(sv, "", 0);
SetLastError(dwErr);
}
#else
{
- int saveerrno = errno;
+ const int saveerrno = errno;
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
errno = saveerrno;
}
#endif
-#endif
-#endif
-#endif
+ SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
}
- else if (strEQ(mg->mg_ptr+1, "NCODING"))
+ else if (strEQ(remaining, "NCODING"))
sv_setsv(sv, PL_encoding);
break;
case '\006': /* ^F */
sv_setsv(sv, &PL_sv_undef);
break;
case '\017': /* ^O & ^OPEN */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (nextchar == '\0') {
sv_setpv(sv, PL_osname);
SvTAINTED_off(sv);
}
- else if (strEQ(mg->mg_ptr, "\017PEN")) {
- if (!PL_compiling.cop_io)
+ else if (strEQ(remaining, "PEN")) {
+ if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
sv_setsv(sv, &PL_sv_undef);
else {
- sv_setsv(sv, PL_compiling.cop_io);
+ sv_setsv(sv,
+ Perl_refcounted_he_fetch(aTHX_
+ PL_compiling.cop_hints_hash,
+ 0, "open", 4, 0, 0));
}
}
break;
sv_setiv(sv, (IV)PL_perldb);
break;
case '\023': /* ^S */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (nextchar == '\0') {
if (PL_lex_state != LEX_NOTPARSING)
- (void)SvOK_off(sv);
+ SvOK_off(sv);
else if (PL_in_eval)
sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
else
}
break;
case '\024': /* ^T */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (nextchar == '\0') {
#ifdef BIG_TIME
sv_setnv(sv, PL_basetime);
#else
sv_setiv(sv, (IV)PL_basetime);
#endif
}
- else if (strEQ(mg->mg_ptr, "\024AINT"))
+ else if (strEQ(remaining, "AINT"))
sv_setiv(sv, PL_tainting
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
- case '\025': /* $^UNICODE */
- if (strEQ(mg->mg_ptr, "\025NICODE"))
+ 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 (*(mg->mg_ptr+1) == '\0')
+ if (nextchar == '\0')
sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE));
- else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
- if (PL_compiling.cop_warnings == pWARN_NONE ||
- PL_compiling.cop_warnings == pWARN_STD)
- {
+ else if (strEQ(remaining, "ARNING_BITS")) {
+ if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
- }
+ }
+ else if (PL_compiling.cop_warnings == pWARN_STD) {
+ sv_setpvn(
+ sv,
+ (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
+ WARNsize
+ );
+ }
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 *bits=get_hv("warnings::Bits", FALSE);
- if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
- sv_setsv(sv, *bits_all);
+ HV * const bits=get_hv("warnings::Bits", FALSE);
+ 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);
}
{
i = t1 - s1;
s = rx->subbeg + s1;
- if (!rx->subbeg)
- break;
+ assert(rx->subbeg);
+ assert(rx->sublen >= s1);
getrx:
if (i >= 0) {
+ const int oldtainted = PL_tainted;
+ TAINT_NOT;
sv_setpvn(sv, s, i);
- if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
+ PL_tainted = oldtainted;
+ if ( (rx->extflags & RXf_CANY_SEEN)
+ ? (RX_MATCH_UTF8(rx)
+ && (!i || is_utf8_string((U8*)s, i)))
+ : (RX_MATCH_UTF8(rx)) )
+ {
SvUTF8_on(sv);
+ }
else
SvUTF8_off(sv);
if (PL_tainting) {
if (RX_MATCH_TAINTED(rx)) {
- MAGIC* mg = SvMAGIC(sv);
+ MAGIC* const mg = SvMAGIC(sv);
MAGIC* mgt;
PL_tainted = 1;
- SvMAGIC(sv) = mg->mg_moremagic;
+ SvMAGIC_set(sv, mg->mg_moremagic);
SvTAINT(sv);
if ((mgt = SvMAGIC(sv))) {
mg->mg_moremagic = mgt;
- SvMAGIC(sv) = mg;
+ SvMAGIC_set(sv, mg);
}
} else
SvTAINTED_off(sv);
sv_setsv(sv,&PL_sv_undef);
break;
case '.':
-#ifndef lint
if (GvIO(PL_last_in_gv)) {
sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
}
-#endif
break;
case '?':
{
s = GvENAME(PL_defoutgv);
sv_setpv(sv,s);
break;
-#ifndef lint
case '=':
if (GvIOp(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv)));
if (GvIOp(PL_defoutgv))
sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv)));
break;
-#endif
case ':':
break;
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 (PL_ors_sv)
sv_copypv(sv, PL_ors_sv);
break;
- case '#':
- sv_setpv(sv,PL_ofmt);
- break;
case '!':
#ifdef VMS
sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
sv_setpv(sv, errno ? Strerror(errno) : "");
#else
{
- int saveerrno = errno;
+ const int saveerrno = errno;
sv_setnv(sv, (NV)errno);
#ifdef OS2
if (errno == errno_isOS2 || errno == errno_isOS2_set)
errno = saveerrno;
}
#endif
+ SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
break;
case '(':
sv_setiv(sv, (IV)PL_gid);
-#ifdef HAS_GETGROUPS
- Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
-#endif
goto add_groups;
case ')':
sv_setiv(sv, (IV)PL_egid);
-#ifdef HAS_GETGROUPS
- Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_egid);
-#endif
add_groups:
#ifdef HAS_GETGROUPS
{
- Groups_t gary[NGROUPS];
- i = getgroups(NGROUPS,gary);
- while (--i >= 0)
- Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]);
+ Groups_t *gary = NULL;
+ I32 i, num_groups = getgroups(0, gary);
+ Newx(gary, num_groups, Groups_t);
+ num_groups = getgroups(num_groups, gary);
+ for (i = 0; i < num_groups; i++)
+ Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+ Safefree(gary);
}
-#endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
+#endif
break;
#ifndef MACOS_TRADITIONAL
case '0':
int
Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
{
- struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+ struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
if (uf && uf->uf_val)
(*uf->uf_val)(aTHX_ uf->uf_index, sv);
int
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
- char *ptr;
- STRLEN len, klen;
-
- s = SvPV(sv,len);
- ptr = MgPV(mg,klen);
+ dVAR;
+ 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);
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
- SV **valp;
- if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
- s = SvPV(*valp, len);
+ SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
+ if (valp)
+ s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
#endif
MgTAINTEDDIR_off(mg);
#ifdef VMS
if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
- char pathbuf[256], eltbuf[256], *cp, *elt = s;
+ char pathbuf[256], eltbuf[256], *cp, *elt;
Stat_t sbuf;
int i = 0, j = 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 */
if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
return 0;
}
}
- if ((cp = strchr(elt, ':')) != Nullch)
+ if ((cp = strchr(elt, ':')) != NULL)
*cp = '\0';
if (my_trnlnm(elt, eltbuf, j++))
elt = eltbuf;
}
#endif /* VMS */
if (s && klen == 4 && strEQ(ptr,"PATH")) {
- char *strend = s + len;
+ const char * const strend = s + len;
while (s < strend) {
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)
{
- STRLEN n_a;
- my_setenv(MgPV(mg,n_a),Nullch);
+ PERL_UNUSED_ARG(sv);
+ my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
}
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
+ PERL_UNUSED_ARG(mg);
#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
if (PL_localizing) {
HE* entry;
- STRLEN n_a;
- magic_clear_all_env(sv,mg);
+ my_clearenv();
hv_iterinit((HV*)sv);
while ((entry = hv_iternext((HV*)sv))) {
I32 keylen;
my_setenv(hv_iterkey(entry, &keylen),
- SvPV(hv_iterval((HV*)sv, entry), n_a));
+ SvPV_nolen_const(hv_iterval((HV*)sv, entry)));
}
}
#endif
int
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
-#ifndef PERL_MICRO
-#if defined(VMS) || defined(EPOC)
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
+#if defined(VMS)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
-# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
- PerlEnv_clearenv();
-# else
-# ifdef USE_ENVIRON_ARRAY
-# if defined(USE_ITHREADS)
- /* only the parent thread can clobber the process environment */
- if (PL_curinterp == aTHX)
-# endif
- {
-# ifndef PERL_USE_SAFE_PUTENV
- I32 i;
-
- if (environ == PL_origenviron)
- environ = (char**)safesysmalloc(sizeof(char*));
- else
- for (i = 0; environ[i]; i++)
- safesysfree(environ[i]);
-# endif /* PERL_USE_SAFE_PUTENV */
-
- environ[0] = Nullch;
- }
-# endif /* USE_ENVIRON_ARRAY */
-# endif /* PERL_IMPLICIT_SYS || WIN32 */
-#endif /* VMS || EPOC */
-#endif /* !PERL_MICRO */
+ my_clearenv();
+#endif
return 0;
}
-#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
-static int sig_handlers_initted = 0;
-#endif
-#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
-static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */
-#endif
-#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
-static int sig_defaulting[SIG_SIZE];
-#endif
-
#ifndef PERL_MICRO
#ifdef HAS_SIGPROCMASK
static void
restore_sigmask(pTHX_ SV *save_sv)
{
- sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv );
- (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+ const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
+ (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
}
#endif
int
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
- I32 i;
- STRLEN n_a;
+ dVAR;
/* Are we fetching a signal entry? */
- i = whichsig(MgPV(mg,n_a));
+ const I32 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 (sig_handlers_initted && 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 (sig_handlers_initted && 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 == SIG_IGN)
+ if(sigstate == (Sighandler_t) SIG_IGN)
sv_setpv(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);
}
}
/* XXX Some of this code was copied from Perl_magic_setsig. A little
* refactoring might be in order.
*/
- register char *s;
- STRLEN n_a;
- SV* to_dec;
- s = MgPV(mg,n_a);
+ dVAR;
+ register const char * const s = MgPV_nolen_const(mg);
+ PERL_UNUSED_ARG(sv);
if (*s == '_') {
- SV** svp;
+ SV** svp = NULL;
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
- else if (strEQ(s,"__WARN__"))
+ else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
svp = &PL_warnhook;
- else
- Perl_croak(aTHX_ "No such hook: %s", s);
- if (*svp) {
- to_dec = *svp;
- *svp = 0;
- SvREFCNT_dec(to_dec);
+ if (svp && *svp) {
+ SV *const to_dec = *svp;
+ *svp = NULL;
+ SvREFCNT_dec(to_dec);
}
}
else {
- I32 i;
/* Are we clearing a signal entry? */
- i = whichsig(s);
+ const I32 i = whichsig(s);
if (i > 0) {
#ifdef HAS_SIGPROCMASK
sigset_t set, save;
#endif
PERL_ASYNC_CHECK();
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
- if (!sig_handlers_initted) Perl_csighandler_init();
+ if (!PL_sig_handlers_initted) Perl_csighandler_init();
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- sig_defaulting[i] = 1;
+ PL_sig_defaulting[i] = 1;
(void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, SIG_DFL);
+ (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]) {
- to_dec=PL_psig_ptr[i];
+ SV * const to_dec=PL_psig_ptr[i];
PL_psig_ptr[i]=0;
LEAVE;
SvREFCNT_dec(to_dec);
return 0;
}
-void
-Perl_raise_signal(pTHX_ int sig)
+#ifndef SIG_PENDING_DIE_COUNT
+# define SIG_PENDING_DIE_COUNT 120
+#endif
+
+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;
+ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT)
+ Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded",
+ (unsigned long)SIG_PENDING_DIE_COUNT);
}
Signal_t
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Perl_csighandler(int sig, ...)
+#else
Perl_csighandler(int sig)
+#endif
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
(void) rsignal(sig, PL_csighandlerp);
- if (sig_ignoring[sig]) return;
+ if (PL_sig_ignoring[sig]) return;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- if (sig_defaulting[sig])
+ if (PL_sig_defaulting[sig])
#ifdef KILL_BY_SIGPRC
exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
#else
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. */
(*PL_sighandlerp)(sig);
else
- Perl_raise_signal(aTHX_ sig);
+ S_raise_signal(aTHX_ sig);
}
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
Perl_csighandler_init(void)
{
int sig;
- if (sig_handlers_initted) return;
+ if (PL_sig_handlers_initted) return;
for (sig = 1; sig < SIG_SIZE; sig++) {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
dTHX;
- sig_defaulting[sig] = 1;
+ PL_sig_defaulting[sig] = 1;
(void) rsignal(sig, PL_csighandlerp);
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- sig_ignoring[sig] = 0;
+ PL_sig_ignoring[sig] = 0;
#endif
}
- sig_handlers_initted = 1;
+ PL_sig_handlers_initted = 1;
}
#endif
void
Perl_despatch_signals(pTHX)
{
+ dVAR;
int sig;
PL_sig_pending = 0;
for (sig = 1; sig < SIG_SIZE; sig++) {
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
+ dVAR;
I32 i;
- SV** svp = 0;
+ SV** svp = NULL;
/* Need to be careful with SvREFCNT_dec(), because that can have side
* effects (due to closures). We must make sure that the new disposition
* is in place before it is called.
*/
- SV* to_dec = 0;
+ SV* to_dec = NULL;
STRLEN len;
#ifdef HAS_SIGPROCMASK
sigset_t set, save;
SV* save_sv;
#endif
- s = MgPV(mg,len);
+ register const char *s = MgPV_const(mg,len);
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
Perl_croak(aTHX_ "No such hook: %s", s);
i = 0;
if (*svp) {
- to_dec = *svp;
- *svp = 0;
+ if (*svp != PERL_WARNHOOK_FATAL)
+ to_dec = *svp;
+ *svp = NULL;
}
}
else {
i = whichsig(s); /* ...no, a brick */
- if (i < 0) {
+ if (i <= 0) {
if (ckWARN(WARN_SIGNAL))
Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
return 0;
#endif
PERL_ASYNC_CHECK();
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
- if (!sig_handlers_initted) Perl_csighandler_init();
+ if (!PL_sig_handlers_initted) Perl_csighandler_init();
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- sig_ignoring[i] = 0;
+ PL_sig_ignoring[i] = 0;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
- sig_defaulting[i] = 0;
+ 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);
+ PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(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]);
#endif
}
else
- *svp = SvREFCNT_inc(sv);
+ *svp = SvREFCNT_inc_simple_NN(sv);
if(to_dec)
SvREFCNT_dec(to_dec);
return 0;
}
- s = SvPV_force(sv,len);
+ s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT";
if (strEQ(s,"IGNORE")) {
if (i) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
- sig_ignoring[i] = 1;
+ PL_sig_ignoring[i] = 1;
(void)rsignal(i, PL_csighandlerp);
#else
- (void)rsignal(i, SIG_IGN);
+ (void)rsignal(i, (Sighandler_t) SIG_IGN);
#endif
}
}
if (i)
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
{
- sig_defaulting[i] = 1;
+ PL_sig_defaulting[i] = 1;
(void)rsignal(i, PL_csighandlerp);
}
#else
- (void)rsignal(i, SIG_DFL);
+ (void)rsignal(i, (Sighandler_t) SIG_DFL);
#endif
}
else {
* tell whether HINT_STRICT_REFS is in force or not.
*/
if (!strchr(s,':') && !strchr(s,'\''))
- sv_insert(sv, 0, 0, "main::", 6);
+ Perl_sv_insert(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"));
if (i)
(void)rsignal(i, PL_csighandlerp);
else
- *svp = SvREFCNT_inc(sv);
+ *svp = SvREFCNT_inc_simple_NN(sv);
}
#ifdef HAS_SIGPROCMASK
if(i)
int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
PL_sub_generation++;
return 0;
}
int
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
/* HV_badAMAGIC_on(Sv_STASH(sv)); */
PL_amagic_generation++;
int
Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
{
- HV *hv = (HV*)LvTARG(sv);
+ HV * const hv = (HV*)LvTARG(sv);
I32 i = 0;
+ PERL_UNUSED_ARG(mg);
if (hv) {
(void) hv_iterinit(hv);
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_UNUSED_ARG(mg);
if (LvTARG(sv)) {
hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
}
/* caller is responsible for stack switching/cleanup */
STATIC int
-S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
+S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
{
+ dVAR;
dSP;
PUSHMARK(SP);
}
STATIC int
-S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth)
+S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
{
- dSP;
+ dVAR; dSP;
ENTER;
SAVETMPS;
int
Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
{
- dSP;
+ dVAR; dSP;
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv);
U32
Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
{
- dSP;
+ dVAR; dSP;
U32 retval = 0;
ENTER;
int
Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
{
- dSP;
+ dVAR; dSP;
ENTER;
PUSHSTACKi(PERLSI_MAGIC);
int
Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
{
- dSP;
- const char *meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
+ dVAR; dSP;
+ const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
ENTER;
SAVETMPS;
}
int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
return magic_methpack(sv,mg,"EXISTS");
}
SV *
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
- dSP;
- SV *retval = &PL_sv_undef;
- SV *tied = SvTIED_obj((SV*)hv, mg);
- HV *pkg = SvSTASH((SV*)SvRV(tied));
+ dVAR; dSP;
+ SV *retval;
+ SV * const tied = SvTIED_obj((SV*)hv, mg);
+ HV * const pkg = SvSTASH((SV*)SvRV(tied));
if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) {
SV *key;
- if (HvEITER(hv))
+ if (HvEITER_get(hv))
/* we are in an iteration so the hash cannot be empty */
return &PL_sv_yes;
/* no xhv_eiter so now use FIRSTKEY */
key = sv_newmortal();
magic_nextpack((SV*)hv, mg, key);
- HvEITER(hv) = NULL; /* need to reset iterator */
+ HvEITER_set(hv, NULL); /* need to reset iterator */
return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
}
if (call_method("SCALAR", G_SCALAR))
retval = *PL_stack_sp--;
+ else
+ retval = &PL_sv_undef;
POPSTACK;
LEAVE;
return retval;
int
Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
{
- OP *o;
- I32 i;
- GV* gv;
- SV** svp;
- STRLEN n_a;
-
- gv = PL_DBline;
- i = SvTRUE(sv);
- svp = av_fetch(GvAV(gv),
- atoi(MgPV(mg,n_a)), FALSE);
- if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
- /* set or clear breakpoint in the relevant control op */
- if (i)
- o->op_flags |= OPf_SPECIAL;
- else
- o->op_flags &= ~OPf_SPECIAL;
+ dVAR;
+ GV * const gv = PL_DBline;
+ const I32 i = SvTRUE(sv);
+ SV ** const svp = av_fetch(GvAV(gv),
+ atoi(MgPV_nolen_const(mg)), FALSE);
+ if (svp && SvIOKp(*svp)) {
+ OP * const o = INT2PTR(OP*,SvIVX(*svp));
+ if (o) {
+ /* set or clear breakpoint in the relevant control op */
+ if (i)
+ o->op_flags |= OPf_SPECIAL;
+ else
+ o->op_flags &= ~OPf_SPECIAL;
+ }
}
return 0;
}
int
-Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
- sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
+ dVAR;
+ const AV * const obj = (AV*)mg->mg_obj;
+ if (obj) {
+ sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
+ } else {
+ SvOK_off(sv);
+ }
return 0;
}
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
- av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase);
+ dVAR;
+ AV * const obj = (AV*)mg->mg_obj;
+ if (obj) {
+ 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");
+ }
+ return 0;
+}
+
+int
+Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+ /* during global destruction, mg_obj may already have been freed */
+ if (PL_in_clean_all)
+ return 0;
+
+ mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
+
+ if (mg) {
+ /* arylen scalar holds a pointer back to the array, but doesn't own a
+ reference. Hence the we (the array) are about to go away with it
+ still pointing at us. Clear its pointer, else it would be pointing
+ at free memory. See the comment in sv_magic about reference loops,
+ and why it can't own a reference to us. */
+ mg->mg_obj = 0;
+ }
return 0;
}
int
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
{
- SV* lsv = LvTARG(sv);
+ dVAR;
+ SV* const lsv = LvTARG(sv);
+ 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;
}
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
int
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
{
- SV* lsv = LvTARG(sv);
+ dVAR;
+ SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
+ MAGIC *found;
- mg = 0;
+ 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, (SV*)0, PERL_MAGIC_regex_global, Nullch, 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;
+ found->mg_len = pos;
+ found->mg_flags &= ~MGf_MINMATCH;
return 0;
}
int
-Perl_magic_getglob(pTHX_ SV *sv, MAGIC *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)
{
- register char *s;
GV* gv;
- STRLEN n_a;
+ PERL_UNUSED_ARG(mg);
if (!SvOK(sv))
return 0;
- s = SvPV(sv, n_a);
- if (*s == '*' && s[1])
- s++;
- gv = gv_fetchpv(s,TRUE, SVt_PVGV);
+ if (isGV_with_GP(sv)) {
+ /* We're actually already a typeglob, so don't need the stuff below.
+ */
+ return 0;
+ }
+ gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len;
- SV *lsv = LvTARG(sv);
- char *tmps = SvPV(lsv,len);
+ SV * const lsv = LvTARG(sv);
+ const char * const tmps = SvPV_const(lsv,len);
I32 offs = LvTARGOFF(sv);
I32 rem = LvTARGLEN(sv);
+ PERL_UNUSED_ARG(mg);
if (SvUTF8(lsv))
sv_pos_u2b(lsv, &offs, &rem);
int
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
STRLEN len;
- char *tmps = SvPV(sv, len);
- SV *lsv = LvTARG(sv);
+ const char * const tmps = SvPV_const(sv, len);
+ SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
+ PERL_UNUSED_ARG(mg);
if (DO_UTF8(sv)) {
sv_utf8_upgrade(lsv);
SvUTF8_on(lsv);
}
else if (lsv && SvUTF8(lsv)) {
+ const char *utf8;
sv_pos_u2b(lsv, &lvoff, &lvlen);
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);
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- TAINT_IF((mg->mg_len & 1) ||
- ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
+ dVAR;
+ PERL_UNUSED_ARG(sv);
+ TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1));
return 0;
}
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- if (PL_localizing) {
- if (PL_localizing == 1)
- mg->mg_len <<= 1;
+ dVAR;
+ 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;
+ mg->mg_len &= ~1;
}
- else if (PL_tainted)
- mg->mg_len |= 1;
- else
- mg->mg_len &= ~1;
return 0;
}
int
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
- SV *lsv = LvTARG(sv);
+ SV * const lsv = LvTARG(sv);
+ PERL_UNUSED_ARG(mg);
- if (!lsv) {
- (void)SvOK_off(sv);
- return 0;
- }
+ if (lsv)
+ sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+ else
+ SvOK_off(sv);
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_UNUSED_ARG(mg);
do_vecset(sv); /* XXX slurp this routine */
return 0;
}
int
Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
{
- SV *targ = Nullsv;
+ dVAR;
+ SV *targ = NULL;
if (LvTARGLEN(sv)) {
if (mg->mg_obj) {
- SV *ahv = LvTARG(sv);
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
+ SV * const ahv = LvTARG(sv);
+ HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0);
if (he)
targ = HeVAL(he);
}
else {
- AV* av = (AV*)LvTARG(sv);
+ AV* const av = (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_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
vivify_defelem(sv);
if (LvTARG(sv)) {
void
Perl_vivify_defelem(pTHX_ SV *sv)
{
+ dVAR;
MAGIC *mg;
- SV *value = Nullsv;
+ SV *value = NULL;
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
- SV *ahv = LvTARG(sv);
- STRLEN n_a;
- HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
+ SV * const ahv = LvTARG(sv);
+ HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0);
if (he)
value = HeVAL(he);
if (!value || value == &PL_sv_undef)
- Perl_croak(aTHX_ PL_no_helem, SvPV(mg->mg_obj, n_a));
+ Perl_croak(aTHX_ PL_no_helem_sv, mg->mg_obj);
}
else {
- AV* av = (AV*)LvTARG(sv);
+ AV* const av = (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** 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)
{
- AV *av = (AV*)mg->mg_obj;
- SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
- while (i >= 0) {
- if (svp[i]) {
- if (!SvWEAKREF(svp[i]))
- Perl_croak(aTHX_ "panic: magic_killbackrefs");
- /* XXX Should we check that it hasn't changed? */
- SvRV(svp[i]) = 0;
- (void)SvOK_off(svp[i]);
- SvWEAKREF_off(svp[i]);
- svp[i] = Nullsv;
- }
- i--;
- }
- SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
- return 0;
+ return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
}
int
Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
{
+ 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);
+ SvTAIL_off(sv);
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);
return 0;
int
Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
{
- struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
+ const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
if (uf && uf->uf_set)
(*uf->uf_set)(aTHX_ uf->uf_index, sv);
int
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
{
+ PERL_UNUSED_ARG(mg);
sv_unmagic(sv, PERL_MAGIC_qr);
return 0;
}
int
Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
{
- regexp *re = (regexp *)mg->mg_obj;
+ dVAR;
+ regexp * const re = (regexp *)mg->mg_obj;
+ PERL_UNUSED_ARG(sv);
+
ReREFCNT_dec(re);
return 0;
}
* 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);
mg->mg_ptr = NULL;
int
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
{
+ 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;
}
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
+ dVAR;
+ register const char *s;
I32 i;
STRLEN len;
switch (*mg->mg_ptr) {
sv_setsv(PL_bodytarget, sv);
break;
case '\003': /* ^C */
- PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ PL_minus_c = (bool)SvIV(sv);
break;
case '\004': /* ^D */
#ifdef DEBUGGING
- s = SvPV_nolen(sv);
- PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
+ s = SvPV_nolen_const(sv);
+ PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
#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);
+ gMacPerl_OSErr = SvIV(sv);
#else
# ifdef VMS
- set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ set_vaxc_errno(SvIV(sv));
# else
# ifdef WIN32
SetLastError( SvIV(sv) );
# else
# ifdef OS2
- os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ os2_setsyserrno(SvIV(sv));
# else
/* will anyone ever use this? */
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
+ SETERRNO(SvIV(sv), 4);
# endif
# endif
# endif
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 */
- if (PL_inplace)
- Safefree(PL_inplace);
- if (SvOK(sv))
- PL_inplace = savepv(SvPV(sv,len));
- else
- PL_inplace = Nullch;
+ Safefree(PL_inplace);
+ PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
break;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
- if (PL_osname) {
- Safefree(PL_osname);
- PL_osname = Nullch;
- }
+ Safefree(PL_osname);
+ PL_osname = NULL;
if (SvOK(sv)) {
TAINT_PROPER("assigning to $^O");
- PL_osname = savepv(SvPV(sv,len));
+ 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);
+ PL_compiling.cop_hints |= HINT_LEXICAL_IO;
+ PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
+ PL_compiling.cop_hints_hash
+ = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+ sv_2mortal(newSVpvs("open")), sv);
}
break;
case '\020': /* ^P */
- PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
- && !PL_DBsingle)
+ PL_perldb = SvIV(sv);
+ if (PL_perldb && !PL_DBsingle)
init_debugger();
break;
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) ;
}
STRLEN len, i;
int accumulate = 0 ;
int any_fatals = 0 ;
- char * ptr = (char*)SvPV(sv, len) ;
+ const char * const ptr = SvPV_const(sv, len) ;
for (i = 0 ; i < len ; ++i) {
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 ;
}
break;
case '^':
Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
- IoTOP_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+ 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)));
- IoFMT_NAME(GvIOp(PL_defoutgv)) = s = savepv(SvPV(sv,len));
- IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
+ 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));
+ IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '-':
- IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ 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));
+ IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv));
break;
case '|':
{
- IO *io = GvIOp(PL_defoutgv);
+ IO * const io = GvIOp(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_ors_sv = newSVsv(sv);
}
else {
- PL_ors_sv = Nullsv;
+ PL_ors_sv = NULL;
}
break;
case ',':
PL_ofs_sv = newSVsv(sv);
}
else {
- PL_ofs_sv = Nullsv;
+ PL_ofs_sv = NULL;
}
break;
- case '#':
- if (PL_ofmt)
- Safefree(PL_ofmt);
- PL_ofmt = savepv(SvPV(sv,len));
- break;
case '[':
- PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ CopARYBASE_set(&PL_compiling, SvIV(sv));
break;
case '?':
#ifdef COMPLEX_STATUS
#endif
#ifdef VMSISH_STATUS
if (VMSISH_STATUS)
- STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
+ STATUS_NATIVE_CHILD_SET((U32)SvIV(sv));
else
#endif
- STATUS_POSIX_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 */
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 */
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 */
case ')':
#ifdef HAS_SETGROUPS
{
- char *p = SvPV(sv, len);
- Groups_t gary[NGROUPS];
-
- while (isSPACE(*p))
- ++p;
- PL_egid = Atol(p);
- for (i = 0; i < NGROUPS; ++i) {
- while (*p && !isSPACE(*p))
- ++p;
- while (isSPACE(*p))
- ++p;
- if (!*p)
- break;
- gary[i] = Atol(p);
- }
- if (i)
- (void)setgroups(i, gary);
+ const char *p = SvPV_const(sv, len);
+ Groups_t *gary = NULL;
+
+ while (isSPACE(*p))
+ ++p;
+ PL_egid = Atol(p);
+ for (i = 0; i < NGROUPS; ++i) {
+ while (*p && !isSPACE(*p))
+ ++p;
+ while (isSPACE(*p))
+ ++p;
+ if (!*p)
+ break;
+ if(!gary)
+ Newx(gary, i + 1, Groups_t);
+ else
+ Renew(gary, i + 1, Groups_t);
+ gary[i] = Atol(p);
+ }
+ if (i)
+ (void)setgroups(i, 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;
/* The BSDs don't show the argv[] in ps(1) output, they
* show a string from the process struct and provide
* the setproctitle() routine to manipulate that. */
- {
- s = SvPV(sv, len);
+ if (PL_origalen != 1) {
+ s = SvPV_const(sv, len);
# if __FreeBSD_version > 410001
/* The leading "-" removes the "perl: " prefix,
* but not the "(perl) suffix from the ps(1)
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(sv, len);
- un.pst_command = s;
+ s = SvPV_const(sv, len);
+ un.pst_command = (char *)s;
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
-#endif
- /* PL_origalen is set in perl_parse(). */
- s = SvPV_force(sv,len);
- if (len >= (STRLEN)PL_origalen-1) {
- /* Longer than original, will be truncated. We assume that
- * PL_origalen bytes are available. */
- Copy(s, PL_origargv[0], PL_origalen-1, char);
+#else
+ if (PL_origalen > 1) {
+ /* PL_origalen is set in perl_parse(). */
+ s = SvPV_force(sv,len);
+ if (len >= (STRLEN)PL_origalen-1) {
+ /* Longer than original, will be truncated. We assume that
+ * PL_origalen bytes are available. */
+ Copy(s, PL_origargv[0], PL_origalen-1, char);
+ }
+ 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,
+ pad, PL_origalen - len - 1);
+ }
+ PL_origargv[0][PL_origalen-1] = 0;
+ for (i = 1; i < PL_origargc; i++)
+ PL_origargv[i] = 0;
}
- else {
- /* Shorter than original, will be padded. */
- 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);
- }
- PL_origargv[0][PL_origalen-1] = 0;
- for (i = 1; i < PL_origargc; i++)
- PL_origargv[i] = 0;
+#endif
UNLOCK_DOLLARZERO_MUTEX;
break;
#endif
}
I32
-Perl_whichsig(pTHX_ char *sig)
+Perl_whichsig(pTHX_ const char *sig)
{
- register char **sigv;
+ register char* const* sigv;
+ PERL_UNUSED_CONTEXT;
- for (sigv = PL_sig_name; *sigv; sigv++)
+ for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
if (strEQ(sig,*sigv))
- return PL_sig_num[sigv - PL_sig_name];
+ return PL_sig_num[sigv - (char* const*)PL_sig_name];
#ifdef SIGCLD
if (strEQ(sig,"CHLD"))
return SIGCLD;
return -1;
}
-#if !defined(PERL_IMPLICIT_CONTEXT)
-static SV* sig_sv;
-#endif
-
Signal_t
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+Perl_sighandler(int sig, ...)
+#else
Perl_sighandler(int sig)
+#endif
{
#ifdef PERL_GET_SIG_CONTEXT
dTHXa(PERL_GET_SIG_CONTEXT);
dTHX;
#endif
dSP;
- GV *gv = Nullgv;
- HV *st;
- SV *sv = Nullsv, *tSv = PL_Sv;
- CV *cv = Nullcv;
+ GV *gv = NULL;
+ SV *sv = NULL;
+ SV * const tSv = PL_Sv;
+ CV *cv = NULL;
OP *myop = PL_op;
U32 flags = 0;
- XPV *tXpv = PL_Xpv;
+ XPV * const tXpv = PL_Xpv;
if (PL_savestack_ix + 15 <= PL_savestack_max)
flags |= 1;
infinity, so we fix 4 (in fact 5): */
if (flags & 1) {
PL_savestack_ix += 5; /* Protect save in progress. */
- SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags);
+ SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags);
}
if (flags & 4)
PL_markstack_ptr++; /* Protect mark. */
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]))
- || SvTYPE(cv) != SVt_PVCV)
- cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
+ || 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))
}
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)
- sig_sv = sv;
+ PL_sig_sv = sv;
#endif
} else {
sv = sv_newmortal();
PUSHSTACKi(PERLSI_SIGNAL);
PUSHMARK(SP);
PUSHs(sv);
+#if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
+ {
+ 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);
+ /* 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);
+#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);
+#endif
+ EXTEND(SP, 2);
+ PUSHs((SV*)rv);
+ PUSHs(newSVpv((char *)sip, sizeof(*sip)));
+ }
+
+ va_end(args);
+ }
+ }
+#endif
PUTBACK;
call_sv((SV*)cv, G_DISCARD|G_EVAL);
(void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ Nullformat);
+ Perl_die(aTHX_ NULL);
}
cleanup:
if (flags & 1)
static void
-restore_magic(pTHX_ void *p)
+S_restore_magic(pTHX_ const void *p)
{
- MGS* mgs = SSPTR(PTR2IV(p), MGS*);
- SV* sv = mgs->mgs_sv;
+ dVAR;
+ MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
+ SV* const sv = mgs->mgs_sv;
if (!sv)
return;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
{
-#ifdef PERL_COPY_ON_WRITE
+#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(sv);
+ sv_force_normal_flags(sv, 0);
#endif
if (mgs->mgs_flags)
SvFLAGS(sv) |= mgs->mgs_flags;
else
mg_magical(sv);
- if (SvGMAGICAL(sv))
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
+ if (SvGMAGICAL(sv)) {
+ /* downgrade public flags to private,
+ and discard any other private flags */
+
+ const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
+ if (pubflags) {
+ SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
+ SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
+ }
+ }
}
mgs->mgs_sv = NULL; /* mark the MGS structure as restored */
}
static void
-unwind_handler_stack(pTHX_ void *p)
+S_unwind_handler_stack(pTHX_ const void *p)
{
- U32 flags = *(U32*)p;
+ dVAR;
+ const U32 flags = *(const U32*)p;
if (flags & 1)
PL_savestack_ix -= 5; /* Unprotect save in progress. */
- /* cxstack_ix-- Not needed, die already unwound it. */
#if !defined(PERL_IMPLICIT_CONTEXT)
if (flags & 64)
- SvREFCNT_dec(sig_sv);
+ SvREFCNT_dec(PL_sig_sv);
#endif
}
+/*
+=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;
+ assert(mg->mg_len == HEf_SVKEY);
+
+ /* 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,
+ (SV *)mg->mg_ptr, sv);
+ return 0;
+}
+
+/*
+=for apidoc magic_sethint
+
+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_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,
+ (SV *)mg->mg_ptr, &PL_sv_placeholder);
+ return 0;
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff