/* 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 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
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);
+static void restore_magic(pTHX_ const void *p);
+static void unwind_handler_stack(pTHX_ const void *p);
#ifdef __Lynx__
/* Missing protos on LynxOS */
{
MGS* mgs;
assert(SvMAGICAL(sv));
-#ifdef PERL_COPY_ON_WRITE
+#ifdef PERL_OLD_COPY_ON_WRITE
/* Turning READONLY off for a copy-on-write scalar is a bad idea. */
if (SvIsCOW(sv))
sv_force_normal(sv);
void
Perl_mg_magical(pTHX_ SV *sv)
{
- MAGIC* mg;
+ const MAGIC* mg;
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;
+ 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. */
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;
}
if (SvREFCNT(sv) == 1) {
/* We hold the last reference to this SV, which implies that the
SV was deleted as a side effect of the routines we called. */
- (void)SvOK_off(sv);
+ SvOK_off(sv);
}
return 0;
}
int
Perl_mg_set(pTHX_ SV *sv)
{
- I32 mgs_ix;
+ 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 */
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);
}
}
- if (DO_UTF8(sv))
- {
- U8 *s = (U8*)SvPV(sv, len);
+ if (DO_UTF8(sv)) {
+ const U8 *s = (U8*)SvPV_const(sv, len);
len = Perl_utf8_length(aTHX_ 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);
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)
*/
MAGIC*
-Perl_mg_find(pTHX_ SV *sv, int type)
+Perl_mg_find(pTHX_ const 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;
+ if (sv) {
+ MAGIC *mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ if (mg->mg_type == type)
+ return mg;
+ }
}
return 0;
}
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);
}
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;
+ register const REGEXP *rx;
+ (void)sv;
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (mg->mg_obj) /* @+ */
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;
+ 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 /* @- */
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)sv; (void)mg;
Perl_croak(aTHX_ PL_no_modify);
- /* NOT REACHED */
- return 0;
+ NORETURN_FUNCTION_END;
}
U32
{
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 { \
+ STRLEN len = SvCUR(sv); \
+ while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
+ --len; \
+ SvCUR_set(sv, len); \
+} STMT_END
+
int
Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
register I32 paren;
register char *s = NULL;
register I32 i;
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 (*(mg->mg_ptr+1) == '\0') {
+ sv_setiv(sv, (IV)PL_minus_c);
+ }
+ else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
+ sv_setiv(sv, (IV)STATUS_NATIVE);
+ }
break;
case '\004': /* ^D */
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
PerlProc_GetOSError(sv, dwErr);
}
else
- sv_setpv(sv, "");
+ sv_setpvn(sv, "", 0);
SetLastError(dwErr);
}
#else
#endif
#endif
#endif
+ SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
}
else if (strEQ(mg->mg_ptr+1, "NCODING"))
case '\023': /* ^S */
if (*(mg->mg_ptr+1) == '\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
? (PL_taint_warn || PL_unsafe ? -1 : 1)
: 0);
break;
- case '\025': /* $^UNICODE */
+ case '\025': /* $^UNICODE, $^UTF8LOCALE */
if (strEQ(mg->mg_ptr, "\025NICODE"))
sv_setuv(sv, (UV) PL_unicode);
+ else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
+ sv_setuv(sv, (UV) PL_utf8locale);
break;
case '\027': /* ^W & $^WARNING_BITS */
if (*(mg->mg_ptr+1) == '\0')
MAGIC* 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 '/':
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));
errno = saveerrno;
}
#endif
+ SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
case '(':
sv_setiv(sv, (IV)PL_gid);
#ifdef HAS_GETGROUPS
- Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, PL_gid);
+ Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)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);
+ Perl_sv_setpvf(aTHX_ sv, "%"Gid_t_f, (long unsigned int)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]);
+ I32 j = getgroups(NGROUPS,gary);
+ while (--j >= 0)
+ Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
}
#endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
int
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
- char *ptr;
+ dVAR;
+ const char *s;
+ const char *ptr;
STRLEN len, klen;
- s = SvPV(sv,len);
- ptr = MgPV(mg,klen);
+ s = SvPV_const(sv,len);
+ ptr = MgPV_const(mg,klen);
my_setenv(ptr, s);
#ifdef DYNAMIC_ENV_FETCH
if (!len) {
SV **valp;
if ((valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE)))
- s = SvPV(*valp, len);
+ s = SvPV_const(*valp, len);
}
#endif
}
#endif /* VMS */
if (s && klen == 4 && strEQ(ptr,"PATH")) {
- char *strend = s + len;
+ const char *strend = s + len;
while (s < strend) {
char tmpbuf[256];
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
- STRLEN n_a;
- my_setenv(MgPV(mg,n_a),Nullch);
+ (void)sv;
+ my_setenv(MgPV_nolen_const(mg),Nullch);
return 0;
}
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
-#if defined(VMS)
+#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
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);
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)
{
+ dVAR;
#ifndef PERL_MICRO
-#if defined(VMS) || defined(EPOC)
+#if defined(VMS) || defined(EPOC) || defined(SYMBIAN)
Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
#else
# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
# endif
{
# ifndef PERL_USE_SAFE_PUTENV
+ if (!PL_use_safe_putenv) {
I32 i;
if (environ == PL_origenviron)
else
for (i = 0; environ[i]; i++)
safesysfree(environ[i]);
+ }
# endif /* PERL_USE_SAFE_PUTENV */
environ[0] = Nullch;
# endif /* PERL_IMPLICIT_SYS || WIN32 */
#endif /* VMS || EPOC */
#endif /* !PERL_MICRO */
+ (void)sv;
+ (void)mg;
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 );
+ const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
#endif
Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
{
I32 i;
- STRLEN n_a;
/* Are we fetching a signal entry? */
- i = whichsig(MgPV(mg,n_a));
+ i = whichsig(MgPV_nolen_const(mg));
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
Sighandler_t sigstate;
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)
/* 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 *s = MgPV_nolen_const(mg);
+ (void)sv;
if (*s == '_') {
- SV** svp;
+ SV** svp = 0;
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) {
- to_dec = *svp;
+ if (svp && *svp) {
+ SV *to_dec = *svp;
*svp = 0;
SvREFCNT_dec(to_dec);
}
#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);
PL_psig_name[i]=0;
}
if(PL_psig_ptr[i]) {
- to_dec=PL_psig_ptr[i];
+ SV *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)
+static void
+S_raise_signal(pTHX_ int sig)
{
/* Set a flag to say this signal is pending */
PL_psig_pend[sig]++;
#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
* 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
int
Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
+ dVAR;
I32 i;
SV** svp = 0;
/* Need to be careful with SvREFCNT_dec(), because that can have side
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;
}
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];
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);
if (i)
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
{
- sig_defaulting[i] = 1;
+ PL_sig_defaulting[i] = 1;
(void)rsignal(i, PL_csighandlerp);
}
#else
int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)sv;
+ (void)mg;
PL_sub_generation++;
return 0;
}
int
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)sv;
+ (void)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;
+ (void)mg;
if (hv) {
(void) hv_iterinit(hv);
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)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)
{
dSP;
}
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;
SV *
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
- dSP;
+ dVAR; dSP;
SV *retval = &PL_sv_undef;
SV *tied = SvTIED_obj((SV*)hv, mg);
HV *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;
}
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);
+ atoi(MgPV_nolen_const(mg)), FALSE);
if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) {
/* set or clear breakpoint in the relevant control op */
if (i)
int
Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg)
{
- sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase);
+ AV *obj = (AV*)mg->mg_obj;
+ if (obj) {
+ sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
+ } 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);
+ AV *obj = (AV*)mg->mg_obj;
+ if (obj) {
+ av_fill(obj, SvIV(sv) - PL_curcop->cop_arybase);
+ } 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)
+{
+ 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;
}
return 0;
}
}
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
int
Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)mg;
if (SvFAKE(sv)) { /* FAKE globs can get coerced */
SvFAKE_off(sv);
gv_efullname3(sv,((GV*)sv), "*");
int
Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
GV* gv;
- STRLEN n_a;
-
+ (void)mg;
+
if (!SvOK(sv))
return 0;
- s = SvPV(sv, n_a);
- if (*s == '*' && s[1])
- s++;
- gv = gv_fetchpv(s,TRUE, SVt_PVGV);
+ gv = gv_fetchsv(sv,TRUE, 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);
+ (void)mg;
if (SvUTF8(lsv))
sv_pos_u2b(lsv, &offs, &rem);
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
STRLEN len;
- char *tmps = SvPV(sv, len);
- SV *lsv = LvTARG(sv);
+ const char *tmps = SvPV_const(sv, len);
+ SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
+ (void)mg;
if (DO_UTF8(sv)) {
sv_utf8_upgrade(lsv);
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)sv;
if (PL_localizing) {
if (PL_localizing == 1)
mg->mg_len <<= 1;
int
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
- SV *lsv = LvTARG(sv);
+ SV * const lsv = LvTARG(sv);
+ (void)mg;
if (!lsv) {
- (void)SvOK_off(sv);
+ SvOK_off(sv);
return 0;
}
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)mg;
do_vecset(sv); /* XXX slurp this routine */
return 0;
}
int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)mg;
if (LvTARGLEN(sv))
vivify_defelem(sv);
if (LvTARG(sv)) {
return;
if (mg->mg_obj) {
SV *ahv = LvTARG(sv);
- STRLEN n_a;
HE *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 *av = (AV*)mg->mg_obj;
SV **svp = AvARRAY(av);
I32 i = AvFILLp(av);
+ (void)sv;
+
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]);
+ SvRV_set(svp[i], 0);
+ SvOK_off(svp[i]);
SvWEAKREF_off(svp[i]);
svp[i] = Nullsv;
}
int
Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)mg;
sv_unmagic(sv, PERL_MAGIC_bm);
SvVALID_off(sv);
return 0;
int
Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)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)
{
+ (void)mg;
sv_unmagic(sv, PERL_MAGIC_qr);
return 0;
}
{
regexp *re = (regexp *)mg->mg_obj;
ReREFCNT_dec(re);
+ (void)sv;
return 0;
}
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
*/
+ (void)sv;
if (mg->mg_ptr) {
Safefree(mg->mg_ptr);
mg->mg_ptr = NULL;
int
Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg)
{
+ (void)sv;
Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */
mg->mg_ptr = 0;
mg->mg_len = -1; /* The mg_len holds the len cache. */
int
Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
- register char *s;
+ register const char *s;
I32 i;
STRLEN len;
switch (*mg->mg_ptr) {
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;
if (PL_inplace)
Safefree(PL_inplace);
if (SvOK(sv))
- PL_inplace = savepv(SvPV(sv,len));
+ PL_inplace = savesvpv(sv);
else
PL_inplace = Nullch;
break;
}
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")) {
break;
case '\020': /* ^P */
PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
- && !PL_DBsingle)
+ if (PL_perldb && !PL_DBsingle)
init_debugger();
break;
case '\024': /* ^T */
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) ;
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,TRUE, 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,TRUE, SVt_PVIO);
break;
case '=':
IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
PL_ofs_sv = Nullsv;
}
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);
break;
STATUS_NATIVE_SET((U32)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)));
else
#endif
- STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ STATUS_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
{
case ')':
#ifdef HAS_SETGROUPS
{
- char *p = SvPV(sv, len);
+ const char *p = SvPV_const(sv, len);
Groups_t gary[NGROUPS];
while (isSPACE(*p))
* show a string from the process struct and provide
* the setproctitle() routine to manipulate that. */
{
- s = SvPV(sv, len);
+ s = SvPV_const(sv, len);
# if __FreeBSD_version > 410001
/* The leading "-" removes the "perl: " prefix,
* but not the "(perl) suffix from the ps(1)
#if defined(__hpux) && defined(PSTAT_SETCMD)
{
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
}
I32
-Perl_whichsig(pTHX_ char *sig)
+Perl_whichsig(pTHX_ const char *sig)
{
- register char **sigv;
+ register char* const* sigv;
- 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
Perl_sighandler(int sig)
{
sv = SvREFCNT_inc(PL_psig_name[sig]);
flags |= 64;
#if !defined(PERL_IMPLICIT_CONTEXT)
- sig_sv = sv;
+ PL_sig_sv = sv;
#endif
} else {
sv = sv_newmortal();
(void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ Nullformat);
+ DieNull;
}
cleanup:
if (flags & 1)
static void
-restore_magic(pTHX_ void *p)
+restore_magic(pTHX_ const void *p)
{
MGS* mgs = SSPTR(PTR2IV(p), MGS*);
SV* sv = mgs->mgs_sv;
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))
}
static void
-unwind_handler_stack(pTHX_ void *p)
+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
}
-
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */