/* 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
#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);
+ sv_force_normal_flags(sv, 0);
#endif
SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix));
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)) {
+ 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;
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;
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) {
+ return mg->mg_obj
+ ? rx->nparens /* @+ */
+ : rx->lastparen; /* @- */
+ }
}
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;
+ 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 = Perl_utf8_length(aTHX_ (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;
}
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, ^CHILD_ERROR_NATIVE */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (nextchar == '\0') {
sv_setiv(sv, (IV)PL_minus_c);
}
- else if (strEQ(mg->mg_ptr, "\003HILD_ERROR_NATIVE")) {
+ else if (strEQ(remaining, "HILD_ERROR_NATIVE")) {
sv_setiv(sv, (IV)STATUS_NATIVE);
}
break;
sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
break;
case '\005': /* ^E */
- if (*(mg->mg_ptr+1) == '\0') {
+ if (nextchar == '\0') {
#ifdef MACOS_TRADITIONAL
{
char msg[256];
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;
}
{
DWORD dwErr = GetLastError();
sv_setnv(sv, (NV)dwErr);
- if (dwErr)
- {
+ if (dwErr) {
PerlProc_GetOSError(sv, dwErr);
}
else
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")) {
+ else if (strEQ(remaining, "PEN")) {
if (!PL_compiling.cop_io)
sv_setsv(sv, &PL_sv_undef);
else {
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)
SvOK_off(sv);
else if (PL_in_eval)
}
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, $^UTF8LOCALE */
- if (strEQ(mg->mg_ptr, "\025NICODE"))
+ if (strEQ(remaining, "NICODE"))
sv_setuv(sv, (UV) PL_unicode);
- else if (strEQ(mg->mg_ptr, "\025TF8LOCALE"))
+ else if (strEQ(remaining, "TF8LOCALE"))
sv_setuv(sv, (UV) PL_utf8locale);
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")) {
+ else if (strEQ(remaining, "ARNING_BITS")) {
if (PL_compiling.cop_warnings == pWARN_NONE) {
sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
}
/* 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);
+ HV * const bits=get_hv("warnings::Bits", FALSE);
if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
sv_setsv(sv, *bits_all);
}
getrx:
if (i >= 0) {
+ const int oldtainted = PL_tainted;
+ TAINT_NOT;
sv_setpvn(sv, s, i);
+ PL_tainted = oldtainted;
if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i))
SvUTF8_on(sv);
else
SvUTF8_off(sv);
if (PL_tainting) {
if (RX_MATCH_TAINTED(rx)) {
- MAGIC* mg = SvMAGIC(sv);
+ MAGIC* const mg = SvMAGIC(sv);
MAGIC* mgt;
PL_tainted = 1;
SvMAGIC_set(sv, mg->mg_moremagic);
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 num_groups = getgroups(0, gary);
+ Newx(gary, num_groups, Groups_t);
+ num_groups = getgroups(num_groups, gary);
+ while (--num_groups >= 0)
+ Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f,
+ (long unsigned int)gary[num_groups]);
+ Safefree(gary);
}
#endif
(void)SvIOK_on(sv); /* what a wonderful hack! */
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);
+ const char *s = 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)))
+ SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
+ if (valp)
s = SvPV_const(*valp, len);
}
#endif
int
Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg)
{
-#if defined(VMS) || defined(EPOC)
+ 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 );
+ const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
(void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
}
#endif
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__"))
Perl_croak(aTHX_ "No such hook: %s", s);
if (svp && *svp) {
SV * const to_dec = *svp;
- *svp = 0;
+ *svp = NULL;
SvREFCNT_dec(to_dec);
}
}
{
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;
i = 0;
if (*svp) {
to_dec = *svp;
- *svp = 0;
+ *svp = NULL;
}
}
else {
if (!mg) {
if (!SvOK(sv))
return 0;
- sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+ sv_magic(lsv, NULL, PERL_MAGIC_regex_global, NULL, 0);
mg = mg_find(lsv, PERL_MAGIC_regex_global);
}
else if (!SvOK(sv)) {
if (!SvOK(sv))
return 0;
- gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
+ gv = gv_fetchsv(sv, GV_ADD, SVt_PVGV);
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
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
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));
#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_UNIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ STATUS_UNIX_EXIT_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '!':
{
#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);
+ if (gary)
+ Safefree(gary);
}
#else /* HAS_SETGROUPS */
PL_egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
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)) {
PUSHs((SV*)rv);
PUSHs(newSVpv((void*)sip, sizeof(*sip)));
}
+
+ va_end(args);
}
}
#endif
/* 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)
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);
https://perl5.git.perl.org / perl5.git / blobdiff