Signal_t Perl_csighandler(int sig);
-static void restore_magic(pTHX_ const void *p);
-static void unwind_handler_stack(pTHX_ const void *p);
-
#ifdef __Lynx__
/* Missing protos on LynxOS */
void setruid(uid_t id);
{
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);
#endif
- 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;
}
}
- 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
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;
}
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);
+ 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;
}
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;
}
}
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;
}
}
/*
+=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)
+{
+ MAGIC *mg;
+ for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+ const 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_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 {
+ 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>.
Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
{
register const REGEXP *rx;
- (void)sv;
+ PERL_UNUSED_ARG(sv);
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (mg->mg_obj) /* @+ */
i = s;
if (i > 0 && RX_MATCH_UTF8(rx)) {
- char *b = rx->subbeg;
+ const char * const b = rx->subbeg;
if (b)
i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
}
int
Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
{
- (void)sv; (void)mg;
+ PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg);
Perl_croak(aTHX_ PL_no_modify);
- /* NOT REACHED */
-#ifndef HASATTRIBUTE
- /* No __attribute__, so the compiler doesn't know that croak never returns
- */
- return 0;
-#endif
+ NORETURN_FUNCTION_END;
}
U32
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)
{
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
{
- int saveerrno = errno;
+ const int saveerrno = errno;
sv_setnv(sv, (NV)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
errno = saveerrno;
#endif
#endif
#endif
+ SvRTRIM(sv);
SvNOK_on(sv); /* what a wonderful hack! */
}
else if (strEQ(mg->mg_ptr+1, "NCODING"))
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));
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 '<':
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_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);
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
- register char *s;
- char *ptr;
+ 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 * const strend = s + len;
while (s < strend) {
char tmpbuf[256];
int
Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg)
{
- STRLEN n_a;
- (void)sv;
- my_setenv(MgPV(mg,n_a),Nullch);
+ PERL_UNUSED_ARG(sv);
+ my_setenv(MgPV_nolen_const(mg),Nullch);
return 0;
}
#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
# endif /* PERL_IMPLICIT_SYS || WIN32 */
#endif /* VMS || EPOC */
#endif /* !PERL_MICRO */
- (void)sv;
- (void)mg;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
return 0;
}
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
int
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));
+ const I32 i = whichsig(MgPV_nolen_const(mg));
if (i > 0) {
if(PL_psig_ptr[i])
sv_setsv(sv,PL_psig_ptr[i]);
* refactoring might be in order.
*/
dVAR;
- STRLEN n_a;
- register const char *s = MgPV(mg,n_a);
- (void)sv;
+ register const char * const s = MgPV_nolen_const(mg);
+ PERL_UNUSED_ARG(sv);
if (*s == '_') {
SV** svp = 0;
if (strEQ(s,"__DIE__"))
else
Perl_croak(aTHX_ "No such hook: %s", s);
if (svp && *svp) {
- SV *to_dec = *svp;
+ SV * const to_dec = *svp;
*svp = 0;
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;
SV* save_sv;
#endif
- register const char *s = MgPV(mg,len);
+ register const char *s = MgPV_const(mg,len);
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &PL_diehook;
int
Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
{
- (void)sv;
- (void)mg;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
PL_sub_generation++;
return 0;
}
int
Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
{
- (void)sv;
- (void)mg;
+ PERL_UNUSED_ARG(sv);
+ PERL_UNUSED_ARG(mg);
/* HV_badAMAGIC_on(Sv_STASH(sv)); */
PL_amagic_generation++;
{
HV * const hv = (HV*)LvTARG(sv);
I32 i = 0;
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (hv) {
(void) hv_iterinit(hv);
int
Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (LvTARG(sv)) {
hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
}
{
dVAR; dSP;
SV *retval = &PL_sv_undef;
- SV *tied = SvTIED_obj((SV*)hv, mg);
- HV *pkg = SvSTASH((SV*)SvRV(tied));
+ 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;
}
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;
+ 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);
+ const AV * const 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 * const 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;
}
int
Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
{
- SV* lsv = LvTARG(sv);
+ SV* const lsv = LvTARG(sv);
if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
mg = mg_find(lsv, PERL_MAGIC_regex_global);
int
Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
{
- SV* lsv = LvTARG(sv);
+ SV* const lsv = LvTARG(sv);
SSize_t pos;
STRLEN len;
STRLEN ulen = 0;
int
Perl_magic_getglob(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (SvFAKE(sv)) { /* FAKE globs can get coerced */
SvFAKE_off(sv);
gv_efullname3(sv,((GV*)sv), "*");
Perl_magic_setglob(pTHX_ SV *sv, MAGIC *mg)
{
GV* gv;
- (void)mg;
-
+ PERL_UNUSED_ARG(mg);
+
if (!SvOK(sv))
return 0;
gv = gv_fetchsv(sv,TRUE, SVt_PVGV);
{
STRLEN len;
SV * const lsv = LvTARG(sv);
- const char * const tmps = SvPV(lsv,len);
+ const char * const tmps = SvPV_const(lsv,len);
I32 offs = LvTARGOFF(sv);
I32 rem = LvTARGLEN(sv);
- (void)mg;
+ PERL_UNUSED_ARG(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);
+ const char *tmps = SvPV_const(sv, len);
SV * const lsv = LvTARG(sv);
I32 lvoff = LvTARGOFF(sv);
I32 lvlen = LvTARGLEN(sv);
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (DO_UTF8(sv)) {
sv_utf8_upgrade(lsv);
int
Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg)
{
- TAINT_IF((mg->mg_len & 1) ||
- ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */
+ PERL_UNUSED_ARG(sv);
+ TAINT_IF(mg->mg_len & 1);
return 0;
}
int
Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg)
{
- (void)sv;
- if (PL_localizing) {
- if (PL_localizing == 1)
- mg->mg_len <<= 1;
+ 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;
}
Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg)
{
SV * const lsv = LvTARG(sv);
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (!lsv) {
SvOK_off(sv);
int
Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
do_vecset(sv); /* XXX slurp this routine */
return 0;
}
SV *targ = Nullsv;
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)];
}
int
Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
if (LvTARGLEN(sv))
vivify_defelem(sv);
if (LvTARG(sv)) {
if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
return;
if (mg->mg_obj) {
- SV *ahv = LvTARG(sv);
- 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_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 */
else {
int
Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
{
- AV *av = (AV*)mg->mg_obj;
+ AV *const av = (AV*)mg->mg_obj;
SV **svp = AvARRAY(av);
- I32 i = AvFILLp(av);
- (void)sv;
+ 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")",
+ SvFLAGS(referrer));
+ }
- 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_set(svp[i], 0);
- SvOK_off(svp[i]);
- SvWEAKREF_off(svp[i]);
- svp[i] = Nullsv;
+ *svp = Nullsv;
+ }
+ svp++;
}
- i--;
}
SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */
return 0;
int
Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
sv_unmagic(sv, PERL_MAGIC_bm);
SvVALID_off(sv);
return 0;
int
Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
{
- (void)mg;
+ PERL_UNUSED_ARG(mg);
sv_unmagic(sv, PERL_MAGIC_fm);
SvCOMPILED_off(sv);
return 0;
int
Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
{
- (void)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;
+ regexp * const re = (regexp *)mg->mg_obj;
+ PERL_UNUSED_ARG(sv);
+
ReREFCNT_dec(re);
- (void)sv;
return 0;
}
* RenE<eacute> Descartes said "I think not."
* and vanished with a faint plop.
*/
- (void)sv;
+ 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)
{
- (void)sv;
+ PERL_UNUSED_ARG(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. */
case '\004': /* ^D */
#ifdef DEBUGGING
- s = SvPV_nolen(sv);
+ s = SvPV_nolen_const(sv);
PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG;
DEBUG_x(dump_all());
#else
PL_hints = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
case '\011': /* ^I */ /* NOT \t in EBCDIC */
- if (PL_inplace)
- Safefree(PL_inplace);
- if (SvOK(sv))
- PL_inplace = savesvpv(sv);
- else
- PL_inplace = Nullch;
+ Safefree(PL_inplace);
+ PL_inplace = SvOK(sv) ? savesvpv(sv) : Nullch;
break;
case '\017': /* ^O */
if (*(mg->mg_ptr+1) == '\0') {
- if (PL_osname) {
- Safefree(PL_osname);
- PL_osname = Nullch;
- }
+ Safefree(PL_osname);
+ PL_osname = Nullch;
if (SvOK(sv)) {
TAINT_PROPER("assigning to $^O");
PL_osname = savesvpv(sv);
STRLEN len, i;
int accumulate = 0 ;
int any_fatals = 0 ;
- const char * const 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 '|':
{
- IO *io = GvIOp(PL_defoutgv);
+ IO * const io = GvIOp(PL_defoutgv);
if(!io)
break;
if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
PL_ofs_sv = Nullsv;
}
break;
- case '#':
- if (PL_ofmt)
- Safefree(PL_ofmt);
- PL_ofmt = savesvpv(sv);
- 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
{
- const 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);
+ s = SvPV_const(sv, len);
un.pst_command = (char *)s;
pstat(PSTAT_SETCMD, un, len, 0, 0);
}
#endif
dSP;
GV *gv = Nullgv;
- HV *st;
- SV *sv = Nullsv, *tSv = PL_Sv;
+ SV *sv = Nullsv;
+ SV * const tSv = PL_Sv;
CV *cv = Nullcv;
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)
+ || SvTYPE(cv) != SVt_PVCV) {
+ HV *st;
cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE);
+ }
if (!cv || !CvROOT(cv)) {
if (ckWARN(WARN_SIGNAL))
static void
-restore_magic(pTHX_ const void *p)
+S_restore_magic(pTHX_ const void *p)
{
- MGS* mgs = SSPTR(PTR2IV(p), MGS*);
- SV* sv = mgs->mgs_sv;
+ 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))
}
static void
-unwind_handler_stack(pTHX_ const void *p)
+S_unwind_handler_stack(pTHX_ const void *p)
{
dVAR;
const U32 flags = *(const U32*)p;
#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:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff