X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=80b762ce8e0647efa9f20df8baf9249c003cfd2e;hb=4634a855caf7cb9c97bd7d7c7bdb72d61fd2e9c0;hp=f3e67204b32e075f3d33981828d765115398ff7e;hpb=79dec0f47660bf63141eb6171dd4c2d4053422af;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index f3e6720..80b762c 100644 --- a/mg.c +++ b/mg.c @@ -85,7 +85,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) #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)); @@ -369,13 +369,18 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) 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; @@ -480,14 +485,15 @@ Perl_mg_free(pTHX_ SV *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; @@ -496,32 +502,33 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) 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; } @@ -641,16 +648,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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; @@ -659,7 +668,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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]; @@ -687,7 +696,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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; } @@ -699,8 +708,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { DWORD dwErr = GetLastError(); sv_setnv(sv, (NV)dwErr); - if (dwErr) - { + if (dwErr) { PerlProc_GetOSError(sv, dwErr); } else @@ -721,7 +729,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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 */ @@ -737,11 +745,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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 { @@ -753,7 +761,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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) @@ -763,38 +771,43 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } 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")) { - if (PL_compiling.cop_warnings == pWARN_NONE || - PL_compiling.cop_warnings == pWARN_STD) - { + else if (strEQ(remaining, "ARNING_BITS")) { + if (PL_compiling.cop_warnings == pWARN_NONE) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - } + } + else if (PL_compiling.cop_warnings == pWARN_STD) { + sv_setpvn( + sv, + (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring, + WARNsize + ); + } 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 *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); } @@ -830,14 +843,17 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) getrx: if (i >= 0) { + 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); @@ -1045,10 +1061,13 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) MgTAINTEDDIR_off(mg); #ifdef VMS if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { - char pathbuf[256], eltbuf[256], *cp, *elt = s; + char pathbuf[256], eltbuf[256], *cp, *elt; Stat_t sbuf; int i = 0, j = 0; + strncpy(eltbuf, s, 255); + eltbuf[255] = 0; + elt = eltbuf; do { /* DCL$PATH may be a search list */ while (1) { /* as may dev portion of any element */ if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) { @@ -1104,12 +1123,13 @@ Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) { -#if defined(VMS) || defined(EPOC) || defined(SYMBIAN) + 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; @@ -1125,39 +1145,13 @@ int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { dVAR; -#ifndef PERL_MICRO -#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) - 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; } @@ -1166,7 +1160,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) 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 @@ -2049,7 +2043,9 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) SV **svp = AvARRAY(av); PERL_UNUSED_ARG(sv); - if (svp) { + /* Not sure why the av can get freed ahead of its sv, but somehow it does + in ext/B/t/bytecode.t test 15 (involving print ) */ + if (svp && !SvIS_FREED(av)) { SV *const *const last = svp + AvFILLp(av); while (svp <= last) { @@ -2069,7 +2065,7 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) } else { Perl_croak(aTHX_ "panic: magic_killbackrefs (flags=%"UVxf")", - SvFLAGS(referrer)); + (UV)SvFLAGS(referrer)); } *svp = Nullsv; @@ -2383,10 +2379,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #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 '!': { @@ -2712,8 +2708,8 @@ Perl_sighandler(int sig) * addr, status, and band are defined by POSIX/SUSv3. */ hv_store(sih, "signo", 5, newSViv(sip->si_signo), 0); hv_store(sih, "code", 4, newSViv(sip->si_code), 0); - hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0); #if 0 /* XXX TODO: Configure scan for the existence of these, but even that does not help if the SA_SIGINFO is not implemented according to the spec. */ + hv_store(sih, "errno", 5, newSViv(sip->si_errno), 0); hv_store(sih, "status", 6, newSViv(sip->si_status), 0); hv_store(sih, "uid", 3, newSViv(sip->si_uid), 0); hv_store(sih, "pid", 3, newSViv(sip->si_pid), 0); @@ -2724,6 +2720,8 @@ Perl_sighandler(int sig) PUSHs((SV*)rv); PUSHs(newSVpv((void*)sip, sizeof(*sip))); } + + va_end(args); } } #endif @@ -2749,7 +2747,7 @@ Perl_sighandler(int sig) (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ - DieNull; + Perl_die(aTHX_ Nullch); } cleanup: if (flags & 1) @@ -2783,15 +2781,23 @@ S_restore_magic(pTHX_ const void *p) /* 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) SvFLAGS(sv) |= mgs->mgs_flags; else mg_magical(sv); - if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + if (SvGMAGICAL(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 ); + } + } } mgs->mgs_sv = NULL; /* mark the MGS structure as restored */