/* mg.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005 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.
#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
STATIC void
S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
{
+ dVAR;
MGS* mgs;
assert(SvMAGICAL(sv));
-#ifdef PERL_OLD_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_flags(sv, 0);
-#endif
SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
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;
}
/*
Perl_mg_magical(pTHX_ SV *sv)
{
const MAGIC* mg;
+ PERL_UNUSED_CONTEXT;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
if (vtbl) {
int
Perl_mg_get(pTHX_ SV *sv)
{
+ dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
const bool was_temp = (bool)SvTEMP(sv);
int have_new = 0;
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);
}
int
Perl_mg_set(pTHX_ SV *sv)
{
+ dVAR;
const I32 mgs_ix = SSNEW(sizeof(MGS));
MAGIC* mg;
MAGIC* nextmg;
U32
Perl_mg_length(pTHX_ SV *sv)
{
+ dVAR;
MAGIC* mg;
STRLEN len;
if (DO_UTF8(sv)) {
const U8 *s = (U8*)SvPV_const(sv, len);
- len = Perl_utf8_length(aTHX_ s, s + len);
+ len = utf8_length(s, s + len);
}
else
(void)SvPV_const(sv, len);
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;
}
/*
}
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)
void
Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
{
+ dVAR;
MAGIC *mg;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
- const MGVTBL* const vtbl = mg->mg_virtual;
+ MGVTBL* const vtbl = mg->mg_virtual;
switch (mg->mg_type) {
/* value magic types: don't copy */
case PERL_MAGIC_bm:
continue;
}
- if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
- /* XXX calling the copy method is probably not correct. DAPM */
- (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
- mg->mg_ptr, mg->mg_len);
- }
- else {
+ 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);
}
U32
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
- register const REGEXP *rx;
+ dVAR;
PERL_UNUSED_ARG(sv);
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- if (mg->mg_obj) /* @+ */
- return rx->nparens;
- else /* @- */
- return rx->lastparen;
+ 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 REGEXP *rx;
-
- if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
- 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;
+ 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)) {
- const char * const 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_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_ PL_no_modify);
NORETURN_FUNCTION_END;
}
U32
Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
register I32 paren;
register I32 i;
register const REGEXP *rx;
}
#define SvRTRIM(sv) STMT_START { \
- STRLEN len = SvCUR(sv); \
- while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
- --len; \
- SvCUR_set(sv, len); \
+ 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
break;
case '\005': /* ^E */
if (nextchar == '\0') {
-#ifdef MACOS_TRADITIONAL
+#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>
else
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) : "");
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);
errno = saveerrno;
}
#endif
-#endif
-#endif
-#endif
SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
}
SvTAINTED_off(sv);
}
else if (strEQ(remaining, "PEN")) {
- if (!PL_compiling.cop_io)
+ 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;
? (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_fetch(bits, "all", 3, FALSE))) {
- sv_setsv(sv, *bits_all);
+ 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) {
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))
break;
case '(':
sv_setiv(sv, (IV)PL_gid);
-#ifdef HAS_GETGROUPS
- 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, (long unsigned int)PL_egid);
-#endif
add_groups:
#ifdef HAS_GETGROUPS
{
- Groups_t gary[NGROUPS];
- I32 j = getgroups(NGROUPS,gary);
- while (--j >= 0)
- Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, (long unsigned int)gary[j]);
+ 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':
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- const char *s;
- const char *ptr;
- STRLEN len, klen;
-
- s = SvPV_const(sv,len);
- ptr = MgPV_const(mg,klen);
+ 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_const(*valp, len);
+ SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
+ if (valp)
+ 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;
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
PERL_UNUSED_ARG(sv);
- my_setenv(MgPV_nolen_const(mg),Nullch);
+ my_setenv(MgPV_nolen_const(mg),NULL);
return 0;
}
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
-#if defined(VMS) || defined(EPOC)
+ 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;
- magic_clear_all_env(sv,mg);
+ my_clearenv();
hv_iterinit((HV*)sv);
while ((entry = hv_iternext((HV*)sv))) {
I32 keylen;
Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
-#ifndef PERL_MICRO
-#if defined(VMS) || defined(EPOC)
- 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
- if (!PL_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 */
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
+ my_clearenv();
+#endif
return 0;
}
static void
restore_sigmask(pTHX_ SV *save_sv)
{
- const sigset_t *ossetp = (const sigset_t *) SvPV_nolen_const( 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)
{
+ dVAR;
/* Are we fetching a signal entry? */
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 (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");
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);
}
}
register const char * const s = MgPV_nolen_const(mg);
PERL_UNUSED_ARG(sv);
if (*s == '_') {
- SV** svp = 0;
+ 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 && *svp) {
- SV * const to_dec = *svp;
- *svp = 0;
- SvREFCNT_dec(to_dec);
+ SV *const to_dec = *svp;
+ *svp = NULL;
+ SvREFCNT_dec(to_dec);
}
}
else {
PL_psig_name[i]=0;
}
if(PL_psig_ptr[i]) {
- SV *to_dec=PL_psig_ptr[i];
+ SV * const to_dec=PL_psig_ptr[i];
PL_psig_ptr[i]=0;
LEAVE;
SvREFCNT_dec(to_dec);
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 */
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);
void
Perl_despatch_signals(pTHX)
{
+ dVAR;
int sig;
PL_sig_pending = 0;
for (sig = 1; sig < SIG_SIZE; sig++) {
{
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;
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 {
#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
* 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++;
int
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(mg);
/* HV_badAMAGIC_on(Sv_STASH(sv)); */
STATIC int
S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
{
+ dVAR;
dSP;
PUSHMARK(SP);
}
int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
{
return magic_methpack(sv,mg,"EXISTS");
}
Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
{
dVAR; dSP;
- SV *retval = &PL_sv_undef;
+ SV *retval;
SV * const tied = SvTIED_obj((SV*)hv, mg);
HV * const pkg = SvSTASH((SV*)SvRV(tied));
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)
{
+ dVAR;
GV * const gv = PL_DBline;
const I32 i = SvTRUE(sv);
SV ** const svp = av_fetch(GvAV(gv),
int
Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
{
+ dVAR;
const AV * const obj = (AV*)mg->mg_obj;
if (obj) {
- sv_setiv(sv, AvFILL(obj) + PL_curcop->cop_arybase);
+ sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop));
} else {
SvOK_off(sv);
}
int
Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
AV * const obj = (AV*)mg->mg_obj;
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),
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)
int
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
{
+ 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;
}
}
int
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
{
+ 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;
-
- return 0;
-}
+ found->mg_len = pos;
+ found->mg_flags &= ~MGf_MINMATCH;
-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;
}
if (!SvOK(sv))
return 0;
- gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
+ if (SvFLAGS(sv) & SVp_SCREAM
+ && (SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVGV)) {
+ /* 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))
int
Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
{
+ 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);
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)
{
+ 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)
{
+ dVAR;
PERL_UNUSED_ARG(sv);
/* update taint status unless we're restoring at scope exit */
if (PL_localizing != 2) {
SV * const lsv = LvTARG(sv);
PERL_UNUSED_ARG(mg);
- if (!lsv) {
+ if (lsv)
+ sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
+ else
SvOK_off(sv);
- return 0;
- }
- sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
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 * const ahv = 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;
}
}
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;
else {
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** 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)
{
- AV *const av = (AV*)mg->mg_obj;
- SV **svp = AvARRAY(av);
- PERL_UNUSED_ARG(sv);
-
- if (svp) {
- SV *const *const last = svp + AvFILLp(av);
-
- while (svp <= last) {
- if (*svp) {
- SV *const referrer = *svp;
- if (SvWEAKREF(referrer)) {
- /* XXX Should we check that it hasn't changed? */
- SvRV_set(referrer, 0);
- SvOK_off(referrer);
- SvWEAKREF_off(referrer);
- } else if (SvTYPE(referrer) == SVt_PVGV ||
- SvTYPE(referrer) == SVt_PVLV) {
- /* You lookin' at me? */
- assert(GvSTASH(referrer));
- assert(GvSTASH(referrer) == (HV*)sv);
- GvSTASH(referrer) = 0;
- } else {
- Perl_croak(aTHX_
- "panic: magic_killbackrefs (flags=%"UVxf")",
- (UV)SvFLAGS(referrer));
- }
-
- *svp = Nullsv;
- }
- svp++;
- }
- }
- 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_freeregexp(pTHX_ SV *sv, MAGIC *mg)
{
+ dVAR;
regexp * const re = (regexp *)mg->mg_obj;
PERL_UNUSED_ARG(sv);
* 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_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)
{
+ dVAR;
register const char *s;
I32 i;
STRLEN len;
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 */
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 */
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);
+ 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);
+ PL_perldb = SvIV(sv);
if (PL_perldb && !PL_DBsingle)
init_debugger();
break;
#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 ;
}
case '^':
Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv);
- IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv,TRUE, SVt_PVIO);
+ 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,TRUE, SVt_PVIO);
+ 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 * 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 '[':
- PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ CopARYBASE_set(&PL_compiling, SvIV(sv));
break;
case '?':
#ifdef COMPLEX_STATUS
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 */
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 */
#ifdef HAS_SETGROUPS
{
const char *p = SvPV_const(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);
+ 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. */
- {
+ if (PL_origalen != 1) {
s = SvPV_const(sv, len);
# if __FreeBSD_version > 410001
/* The leading "-" removes the "perl: " prefix,
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);
}
+#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. */
+ Copy(s, PL_origargv[0], len, char);
+ PL_origargv[0][len] = 0;
+ memset(PL_origargv[0] + len + 1,
+#ifdef PERL_DARWIN
+ /* Special case for darwin: see [perl #38868] */
+ (int)'\0',
+#else
+ /* Is the space counterintuitive? Yes.
+ * (You were expecting \0?)
+ * Does it work? Seems to. (In Linux 2.4.20 at least.)
+ * --jhi */
+ (int)' ',
#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);
+ 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
Perl_whichsig(pTHX_ const char *sig)
{
register char* const* sigv;
+ PERL_UNUSED_CONTEXT;
for (sigv = (char* const*)PL_sig_name; *sigv; sigv++)
if (strEQ(sig,*sigv))
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 (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig]))
|| SvTYPE(cv) != SVt_PVCV) {
HV *st;
- cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
+ cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD);
}
if (!cv || !CvROOT(cv)) {
}
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;
#endif
EXTEND(SP, 2);
PUSHs((SV*)rv);
- PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+ PUSHs(newSVpv((char *)sip, sizeof(*sip)));
}
+
+ va_end(args);
}
}
#endif
(void)rsignal(sig, PL_csighandlerp);
#endif
#endif /* !PERL_MICRO */
- Perl_die(aTHX_ Nullch);
+ Perl_die(aTHX_ NULL);
}
cleanup:
if (flags & 1)
static void
S_restore_magic(pTHX_ const void *p)
{
+ dVAR;
MGS* const mgs = SSPTR(PTR2IV(p), MGS*);
SV* const sv = mgs->mgs_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 );
}
}
}
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(PL_sig_sv);
}
/*
+=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
https://perl5.git.perl.org / perl5.git / blobdiff