X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7e4f04509c6d4e8d2ed0e31eaf59004e5c930b39..99a4af00dc49ad5653f019eb044606a31d6a6e34:/mg.c diff --git a/mg.c b/mg.c index 14e9705..14965da 100644 --- a/mg.c +++ b/mg.c @@ -789,6 +789,11 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) } } +#ifdef VMS +#include +#include +#endif + int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { @@ -823,8 +828,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (nextchar == '\0') { #if defined(VMS) { -# include -# include char msg[255]; $DESCRIPTOR(msgdsc,msg); sv_setnv(sv,(NV) vaxc$errno); @@ -1079,9 +1082,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '$': /* $$ */ { IV const pid = (IV)PerlProc_getpid(); - if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { /* never set manually, or at least not since last fork */ sv_setiv(sv, pid); + /* never unsafe, even if reading in a tainted expression */ + SvTAINTED_off(sv); + } /* else a value has been assigned manually, so do nothing */ } break; @@ -1109,16 +1115,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvNOK_on(sv); /* what a wonderful hack! */ break; case '<': - sv_setiv(sv, (IV)PL_uid); + sv_setiv(sv, (IV)PerlProc_getuid()); break; case '>': - sv_setiv(sv, (IV)PL_euid); + sv_setiv(sv, (IV)PerlProc_geteuid()); break; case '(': - sv_setiv(sv, (IV)PL_gid); + sv_setiv(sv, (IV)PerlProc_getgid()); goto add_groups; case ')': - sv_setiv(sv, (IV)PL_egid); + sv_setiv(sv, (IV)PerlProc_getegid()); add_groups: #ifdef HAS_GETGROUPS { @@ -1688,18 +1694,6 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) } int -Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) -{ - dVAR; - PERL_ARGS_ASSERT_MAGIC_SETAMAGIC; - PERL_UNUSED_ARG(sv); - PERL_UNUSED_ARG(mg); - PL_amagic_generation++; - - return 0; -} - -int Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) { HV * const hv = MUTABLE_HV(LvTARG(sv)); @@ -2049,6 +2043,25 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) } int +Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) +{ + dVAR; + + PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; + PERL_UNUSED_ARG(sv); + + /* Reset the iterator when the array is cleared */ +#if IVSIZE == I32SIZE + *((IV *) &(mg->mg_len)) = 0; +#else + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; +#endif + + return 0; +} + +int Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) { dVAR; @@ -2438,9 +2451,6 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) } else if (type == PERL_MAGIC_bm) { SvTAIL_off(sv); SvVALID_off(sv); - } else if (type == PERL_MAGIC_study) { - if (!isGV_with_GP(sv)) - SvSCREAM_off(sv); } else { assert(type == PERL_MAGIC_fm); } @@ -2516,11 +2526,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) paren = atoi(mg->mg_ptr); setparen: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + setparen_got_rx: CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); } else { /* Croak with a READONLY error when a numbered match var is * set without a previous pattern match. Unless it's C */ + croakparen: if (!PL_localizing) { Perl_croak_no_modify(aTHX); } @@ -2595,6 +2607,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Safefree(PL_inplace); PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; break; + case '\016': /* ^N */ + if (PL_curpm && (rx = PM_GETRE(PL_curpm)) + && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; + goto croakparen; case '\017': /* ^O */ if (*(mg->mg_ptr+1) == '\0') { Safefree(PL_osname); @@ -2795,89 +2811,94 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '<': - PL_uid = SvIV(sv); + { + const IV new_uid = SvIV(sv); + PL_delaymagic_uid = new_uid; if (PL_delaymagic) { PL_delaymagic |= DM_RUID; break; /* don't do magic till later */ } #ifdef HAS_SETRUID - (void)setruid((Uid_t)PL_uid); + (void)setruid((Uid_t)new_uid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)PL_uid, (Uid_t)-1); + (void)setreuid((Uid_t)new_uid, (Uid_t)-1); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); + (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1); #else - if (PL_uid == PL_euid) { /* special case $< = $> */ + if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ #ifdef PERL_DARWIN /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ - if (PL_uid != 0 && PerlProc_getuid() == 0) + if (new_uid != 0 && PerlProc_getuid() == 0) (void)PerlProc_setuid(0); #endif - (void)PerlProc_setuid(PL_uid); + (void)PerlProc_setuid(new_uid); } else { - PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } #endif #endif #endif - PL_uid = PerlProc_getuid(); break; + } case '>': - PL_euid = SvIV(sv); + { + const UV new_euid = SvIV(sv); + PL_delaymagic_euid = new_euid; if (PL_delaymagic) { PL_delaymagic |= DM_EUID; break; /* don't do magic till later */ } #ifdef HAS_SETEUID - (void)seteuid((Uid_t)PL_euid); + (void)seteuid((Uid_t)new_euid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, (Uid_t)PL_euid); + (void)setreuid((Uid_t)-1, (Uid_t)new_euid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1); + (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1); #else - if (PL_euid == PL_uid) /* special case $> = $< */ - PerlProc_setuid(PL_euid); + if (new_euid == PerlProc_getuid()) /* special case $> = $< */ + PerlProc_setuid(new_euid); else { - PL_euid = PerlProc_geteuid(); Perl_croak(aTHX_ "seteuid() not implemented"); } #endif #endif #endif - PL_euid = PerlProc_geteuid(); break; + } case '(': - PL_gid = SvIV(sv); + { + const UV new_gid = SvIV(sv); + PL_delaymagic_gid = new_gid; if (PL_delaymagic) { PL_delaymagic |= DM_RGID; break; /* don't do magic till later */ } #ifdef HAS_SETRGID - (void)setrgid((Gid_t)PL_gid); + (void)setrgid((Gid_t)new_gid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)PL_gid, (Gid_t)-1); + (void)setregid((Gid_t)new_gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1); + (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1); #else - if (PL_gid == PL_egid) /* special case $( = $) */ - (void)PerlProc_setgid(PL_gid); + if (new_gid == PerlProc_getegid()) /* special case $( = $) */ + (void)PerlProc_setgid(new_gid); else { - PL_gid = PerlProc_getgid(); Perl_croak(aTHX_ "setrgid() not implemented"); } #endif #endif #endif - PL_gid = PerlProc_getgid(); break; + } case ')': + { + UV new_egid; #ifdef HAS_SETGROUPS { const char *p = SvPV_const(sv, len); @@ -2893,7 +2914,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - PL_egid = Atol(p); + new_egid = Atol(p); for (i = 0; i < maxgrp; ++i) { while (*p && !isSPACE(*p)) ++p; @@ -2912,32 +2933,32 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Safefree(gary); } #else /* HAS_SETGROUPS */ - PL_egid = SvIV(sv); + new_egid = SvIV(sv); #endif /* HAS_SETGROUPS */ + PL_delaymagic_egid = new_egid; if (PL_delaymagic) { PL_delaymagic |= DM_EGID; break; /* don't do magic till later */ } #ifdef HAS_SETEGID - (void)setegid((Gid_t)PL_egid); + (void)setegid((Gid_t)new_egid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)-1, (Gid_t)PL_egid); + (void)setregid((Gid_t)-1, (Gid_t)new_egid); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1); + (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1); #else - if (PL_egid == PL_gid) /* special case $) = $( */ - (void)PerlProc_setgid(PL_egid); + if (new_egid == PerlProc_getgid()) /* special case $) = $( */ + (void)PerlProc_setgid(new_egid); else { - PL_egid = PerlProc_getegid(); Perl_croak(aTHX_ "setegid() not implemented"); } #endif #endif #endif - PL_egid = PerlProc_getegid(); break; + } case ':': PL_chopset = SvPV_force(sv,len); break; @@ -3090,6 +3111,7 @@ Perl_sighandler(int sig) U32 flags = 0; XPV * const tXpv = PL_Xpv; I32 old_ss_ix = PL_savestack_ix; + SV *errsv_save = NULL; if (!PL_psig_ptr[sig]) { @@ -3168,10 +3190,13 @@ Perl_sighandler(int sig) #endif PUTBACK; + errsv_save = newSVsv(ERRSV); + call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); POPSTACK; if (SvTRUE(ERRSV)) { + SvREFCNT_dec(errsv_save); #ifndef PERL_MICRO /* Handler "died", for example to get out of a restart-able read(). * Before we re-do that on its behalf re-enable the signal which was @@ -3195,6 +3220,11 @@ Perl_sighandler(int sig) #endif /* !PERL_MICRO */ die_sv(ERRSV); } + else { + sv_setsv(ERRSV, errsv_save); + SvREFCNT_dec(errsv_save); + } + cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; @@ -3347,14 +3377,13 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARHINT; PERL_UNUSED_ARG(sv); - assert(mg->mg_len == HEf_SVKEY); - - PERL_UNUSED_ARG(sv); - PL_hints |= HINT_LOCALIZE_HH; CopHINTHASH_set(&PL_compiling, - cophh_delete_sv(CopHINTHASH_get(&PL_compiling), - MUTABLE_SV(mg->mg_ptr), 0, 0)); + mg->mg_len == HEf_SVKEY + ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0) + : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), + mg->mg_ptr, mg->mg_len, 0, 0)); return 0; } @@ -3376,12 +3405,31 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) return 0; } +int +Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, + const char *name, I32 namlen) +{ + MAGIC *nmg; + + PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; + PERL_UNUSED_ARG(name); + PERL_UNUSED_ARG(namlen); + + sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); + nmg = mg_find(nsv, mg->mg_type); + if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); + nmg->mg_ptr = mg->mg_ptr; + nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); + nmg->mg_flags |= MGf_REFCOUNTED; + return 1; +} + /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */