X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=80b762ce8e0647efa9f20df8baf9249c003cfd2e;hb=4634a855caf7cb9c97bd7d7c7bdb72d61fd2e9c0;hp=b126ec43e1893b5decab89e7185f2266cce45393;hpb=27cc343c4fb8030e5afb7c3824647d9e5e1d08d6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index b126ec4..80b762c 100644 --- a/mg.c +++ b/mg.c @@ -52,7 +52,11 @@ tie. # include #endif +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) +Signal_t Perl_csighandler(int sig, ...); +#else Signal_t Perl_csighandler(int sig); +#endif #ifdef __Lynx__ /* Missing protos on LynxOS */ @@ -81,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)); @@ -365,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; @@ -476,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; @@ -492,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; } @@ -637,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; @@ -655,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]; @@ -683,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; } @@ -695,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 @@ -717,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 */ @@ -733,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 { @@ -749,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) @@ -759,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); } @@ -826,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); @@ -1041,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,'<'))) ) { @@ -1100,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; @@ -1121,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; } @@ -1162,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 @@ -1184,7 +1182,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL; #endif /* cache state so we don't fetch it again */ - if(sigstate == SIG_IGN) + if(sigstate == (Sighandler_t) SIG_IGN) sv_setpv(sv,"IGNORE"); else sv_setsv(sv,&PL_sv_undef); @@ -1241,7 +1239,7 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) PL_sig_defaulting[i] = 1; (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, SIG_DFL); + (void)rsignal(i, (Sighandler_t) SIG_DFL); #endif if(PL_psig_name[i]) { SvREFCNT_dec(PL_psig_name[i]); @@ -1270,7 +1268,11 @@ S_raise_signal(pTHX_ int sig) } Signal_t +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) +Perl_csighandler(int sig, ...) +#else Perl_csighandler(int sig) +#endif { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); @@ -1419,7 +1421,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PL_sig_ignoring[i] = 1; (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, SIG_IGN); + (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif } } @@ -1431,7 +1433,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) (void)rsignal(i, PL_csighandlerp); } #else - (void)rsignal(i, SIG_DFL); + (void)rsignal(i, (Sighandler_t) SIG_DFL); #endif } else { @@ -2020,7 +2022,7 @@ Perl_vivify_defelem(pTHX_ SV *sv) if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) LvTARG(sv) = Nullsv; /* array can't be extended */ else { - SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE); + SV** const svp = av_fetch(av, LvTARGOFF(sv), TRUE); if (!svp || (value = *svp) == &PL_sv_undef) Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv)); } @@ -2041,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) { @@ -2061,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; @@ -2375,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 '!': { @@ -2613,7 +2617,11 @@ Perl_whichsig(pTHX_ const char *sig) } Signal_t +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) +Perl_sighandler(int sig, ...) +#else Perl_sighandler(int sig) +#endif { #ifdef PERL_GET_SIG_CONTEXT dTHXa(PERL_GET_SIG_CONTEXT); @@ -2683,6 +2691,40 @@ Perl_sighandler(int sig) PUSHSTACKi(PERLSI_SIGNAL); PUSHMARK(SP); PUSHs(sv); +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + { + struct sigaction oact; + + if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { + siginfo_t *sip; + va_list args; + + va_start(args, sig); + sip = (siginfo_t*)va_arg(args, siginfo_t*); + if (sip) { + HV *sih = newHV(); + SV *rv = newRV_noinc((SV*)sih); + /* The siginfo fields signo, code, errno, pid, uid, + * 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); +#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); + hv_store(sih, "addr", 4, newSVuv(PTR2UV(sip->si_addr)), 0); + hv_store(sih, "band", 4, newSViv(sip->si_band), 0); +#endif + EXTEND(SP, 2); + PUSHs((SV*)rv); + PUSHs(newSVpv((void*)sip, sizeof(*sip))); + } + + va_end(args); + } + } +#endif PUTBACK; call_sv((SV*)cv, G_DISCARD|G_EVAL); @@ -2705,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) @@ -2739,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 */