X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/36304a5b1f0a2c119c203d5ca7cc1ccae4267837..85dd75020c14313b276ae5a72e6d7227961a556b:/mg.c diff --git a/mg.c b/mg.c index 28acb57..245acd7 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,7 @@ /* mg.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 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. @@ -12,6 +13,10 @@ * come here, and I don't want to see no more magic,' he said, and fell silent." */ +/* +=head1 Magical Functions +*/ + #include "EXTERN.h" #define PERL_IN_MG_C #include "perl.h" @@ -25,9 +30,32 @@ # endif #endif +#ifdef __hpux +# include +#endif + +Signal_t Perl_csighandler(int sig); + +/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ +#if !defined(HAS_SIGACTION) && defined(VMS) +# define FAKE_PERSISTENT_SIGNAL_HANDLERS +#endif +/* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */ +#if defined(KILL_BY_SIGPRC) +# define FAKE_DEFAULT_SIGNAL_HANDLERS +#endif + static void restore_magic(pTHX_ void *p); static void unwind_handler_stack(pTHX_ void *p); +#ifdef __Lynx__ +/* Missing protos on LynxOS */ +void setruid(uid_t id); +void seteuid(uid_t id); +void setrgid(uid_t id); +void setegid(uid_t id); +#endif + /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ @@ -44,6 +72,11 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { MGS* mgs; assert(SvMAGICAL(sv)); +#ifdef PERL_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)); @@ -109,6 +142,16 @@ Perl_mg_get(pTHX_ SV *sv) if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); + + /* guard against sv having been freed */ + if (SvTYPE(sv) == SVTYPEMASK) { + Perl_croak(aTHX_ "Tied variable freed while still in use"); + } + /* guard against magic having been deleted - eg FETCH calling + * untie */ + if (!SvMAGIC(sv)) + break; + /* Don't restore the flags for this entry if it was deleted. */ if (mg->mg_flags & MGf_GSKIP) (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; @@ -199,7 +242,7 @@ Perl_mg_length(pTHX_ SV *sv) } } - if (DO_UTF8(sv)) + if (DO_UTF8(sv)) { U8 *s = (U8*)SvPV(sv, len); len = Perl_utf8_length(aTHX_ s, s + len); @@ -262,7 +305,7 @@ Perl_mg_clear(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ - + if (vtbl && vtbl->svt_clear) CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); } @@ -306,7 +349,11 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) int count = 0; MAGIC* mg; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - if (isUPPER(mg->mg_type)) { + MGVTBL* vtbl = mg->mg_virtual; + 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) @@ -337,7 +384,7 @@ Perl_mg_free(pTHX_ SV *sv) if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len >= 0) + if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); @@ -383,7 +430,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) paren = mg->mg_len; if (paren < 0) return 0; - if (paren <= rx->nparens && + if (paren <= (I32)rx->nparens && (s = rx->startp[paren]) != -1 && (t = rx->endp[paren]) != -1) { @@ -391,8 +438,8 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) i = t; else /* @- */ i = s; - - if (i > 0 && PL_reg_match_utf8) { + + if (i > 0 && RX_MATCH_UTF8(rx)) { char *b = rx->subbeg; if (b) i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); @@ -427,17 +474,17 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: - if (paren <= rx->nparens && + if (paren <= (I32)rx->nparens && (s1 = rx->startp[paren]) != -1 && (t1 = rx->endp[paren]) != -1) { i = t1 - s1; getlen: - if (i > 0 && PL_reg_match_utf8) { + if (i > 0 && RX_MATCH_UTF8(rx)) { char *s = rx->subbeg + s1; char *send = rx->subbeg + t1; - i = t1 - s1; + i = t1 - s1; if (is_utf8_string((U8*)s, i)) i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); } @@ -445,6 +492,14 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); return i; } + else { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); + } + } + else { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(); } return 0; case '+': @@ -500,7 +555,7 @@ int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { register I32 paren; - register char *s; + register char *s = NULL; register I32 i; register REGEXP *rx; @@ -519,62 +574,66 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif break; case '\005': /* ^E */ + if (*(mg->mg_ptr+1) == '\0') { #ifdef MACOS_TRADITIONAL - { - char msg[256]; - - sv_setnv(sv,(double)gMacPerl_OSErr); - sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); - } -#else + { + char msg[256]; + + sv_setnv(sv,(double)gMacPerl_OSErr); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); + } +#else #ifdef VMS - { -# include -# include - char msg[255]; - $DESCRIPTOR(msgdsc,msg); - sv_setnv(sv,(NV) vaxc$errno); - 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,""); - } + { +# include +# include + char msg[255]; + $DESCRIPTOR(msgdsc,msg); + sv_setnv(sv,(NV) vaxc$errno); + 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,""); + } #else #ifdef OS2 - if (!(_emx_env & 0x200)) { /* Under DOS */ - sv_setnv(sv, (NV)errno); - sv_setpv(sv, errno ? Strerror(errno) : ""); - } else { - if (errno != errno_isOS2) { - int tmp = _syserrno(); - if (tmp) /* 2nd call to _syserrno() makes it 0 */ - Perl_rc = tmp; - } - sv_setnv(sv, (NV)Perl_rc); - sv_setpv(sv, os2error(Perl_rc)); - } + if (!(_emx_env & 0x200)) { /* Under DOS */ + sv_setnv(sv, (NV)errno); + sv_setpv(sv, errno ? Strerror(errno) : ""); + } else { + if (errno != errno_isOS2) { + int tmp = _syserrno(); + if (tmp) /* 2nd call to _syserrno() makes it 0 */ + Perl_rc = tmp; + } + sv_setnv(sv, (NV)Perl_rc); + sv_setpv(sv, os2error(Perl_rc)); + } #else #ifdef WIN32 - { - DWORD dwErr = GetLastError(); - sv_setnv(sv, (NV)dwErr); - if (dwErr) - { - PerlProc_GetOSError(sv, dwErr); - } - else - sv_setpv(sv, ""); - SetLastError(dwErr); - } + { + DWORD dwErr = GetLastError(); + sv_setnv(sv, (NV)dwErr); + if (dwErr) + { + PerlProc_GetOSError(sv, dwErr); + } + else + sv_setpv(sv, ""); + SetLastError(dwErr); + } #else - sv_setnv(sv, (NV)errno); - sv_setpv(sv, errno ? Strerror(errno) : ""); + sv_setnv(sv, (NV)errno); + sv_setpv(sv, errno ? Strerror(errno) : ""); #endif #endif #endif #endif - SvNOK_on(sv); /* what a wonderful hack! */ - break; + SvNOK_on(sv); /* what a wonderful hack! */ + } + else if (strEQ(mg->mg_ptr+1, "NCODING")) + sv_setsv(sv, PL_encoding); + break; case '\006': /* ^F */ sv_setiv(sv, (IV)PL_maxsysfd); break; @@ -602,7 +661,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 (PL_lex_state != LEX_NOTPARSING) (void)SvOK_off(sv); else if (PL_in_eval) @@ -620,27 +679,40 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(mg->mg_ptr, "\024AINT")) - sv_setiv(sv, PL_tainting); + sv_setiv(sv, PL_tainting + ? (PL_taint_warn || PL_unsafe ? -1 : 1) + : 0); + break; + case '\025': /* $^UNICODE */ + if (strEQ(mg->mg_ptr, "\025NICODE")) + sv_setuv(sv, (UV) PL_unicode); break; - case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ + case '\027': /* ^W & $^WARNING_BITS */ if (*(mg->mg_ptr+1) == '\0') sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); - else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { + else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { if (PL_compiling.cop_warnings == pWARN_NONE || PL_compiling.cop_warnings == pWARN_STD) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_ALL) { - sv_setpvn(sv, WARN_ALLstring, 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); + if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + sv_setsv(sv, *bits_all); + } + else { + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + } } else { sv_setsv(sv, PL_compiling.cop_warnings); } SvPOK_only(sv); } - else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) - sv_setiv(sv, (IV)PL_widesyscalls); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': @@ -653,7 +725,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) */ paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: - if (paren <= rx->nparens && + if (paren <= (I32)rx->nparens && (s1 = rx->startp[paren]) != -1 && (t1 = rx->endp[paren]) != -1) { @@ -664,18 +736,25 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) getrx: if (i >= 0) { - bool was_tainted = FALSE; - if (PL_tainting) { - was_tainted = PL_tainted; - PL_tainted = FALSE; - } sv_setpvn(sv, s, i); - if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i)) + if (RX_MATCH_UTF8(rx) && is_utf8_string((U8*)s, i)) SvUTF8_on(sv); else SvUTF8_off(sv); - if (PL_tainting) - PL_tainted = (was_tainted || RX_MATCH_TAINTED(rx)); + if (PL_tainting) { + if (RX_MATCH_TAINTED(rx)) { + MAGIC* mg = SvMAGIC(sv); + MAGIC* mgt; + PL_tainted = 1; + SvMAGIC(sv) = mg->mg_moremagic; + SvTAINT(sv); + if ((mgt = SvMAGIC(sv))) { + mg->mg_moremagic = mgt; + SvMAGIC(sv) = mg; + } + } else + SvTAINTED_off(sv); + } break; } } @@ -734,7 +813,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '^': - s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); else { @@ -743,20 +823,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - s = IoFMT_NAME(GvIOp(PL_defoutgv)); + if (GvIOp(PL_defoutgv)) + s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); sv_setpv(sv,s); break; #ifndef lint case '=': - sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); break; case '-': - sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); break; case '%': - sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; #endif case ':': @@ -767,11 +851,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) WITH_THR(sv_setiv(sv, (IV)PL_curcop->cop_arybase)); break; case '|': - sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); + if (GvIOp(PL_defoutgv)) + sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': break; case '\\': + if (PL_ors_sv) + sv_copypv(sv, PL_ors_sv); break; case '#': sv_setpv(sv,PL_ofmt); @@ -823,17 +910,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif (void)SvIOK_on(sv); /* what a wonderful hack! */ break; - case '*': - break; #ifndef MACOS_TRADITIONAL case '0': break; #endif -#ifdef USE_5005THREADS - case '@': - sv_setsv(sv, thr->errsv); - break; -#endif /* USE_5005THREADS */ } return 0; } @@ -854,7 +934,6 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) register char *s; char *ptr; STRLEN len, klen; - I32 i; s = SvPV(sv,len); ptr = MgPV(mg,klen); @@ -878,7 +957,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) #ifdef VMS if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt = s; - struct stat sbuf; + Stat_t sbuf; int i = 0, j = 0; do { /* DCL$PATH may be a search list */ @@ -906,7 +985,8 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) while (s < strend) { char tmpbuf[256]; - struct stat st; + Stat_t st; + I32 i; s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, strend, ':', &i); s++; @@ -956,31 +1036,20 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { +#ifndef PERL_MICRO #if defined(VMS) || defined(EPOC) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else -# ifdef PERL_IMPLICIT_SYS +# if defined(PERL_IMPLICIT_SYS) || defined(WIN32) PerlEnv_clearenv(); -# else -# ifdef WIN32 - char *envv = GetEnvironmentStrings(); - char *cur = envv; - STRLEN len; - while (*cur) { - char *end = strchr(cur,'='); - if (end && end != cur) { - *end = '\0'; - my_setenv(cur,Nullch); - *end = '='; - cur = end + strlen(end+1)+2; - } - else if ((len = strlen(cur))) - cur += len+1; - } - FreeEnvironmentStrings(envv); -# else -#ifdef USE_ENVIRON_ARRAY -# ifndef PERL_USE_SAFE_PUTENV +# 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 I32 i; if (environ == PL_origenviron) @@ -988,18 +1057,36 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) else for (i = 0; environ[i]; i++) safesysfree(environ[i]); -# endif /* PERL_USE_SAFE_PUTENV */ +# endif /* PERL_USE_SAFE_PUTENV */ environ[0] = Nullch; - -#endif /* USE_ENVIRON_ARRAY */ -# endif /* WIN32 */ -# endif /* PERL_IMPLICIT_SYS */ -#endif /* VMS */ + } +# endif /* USE_ENVIRON_ARRAY */ +# endif /* PERL_IMPLICIT_SYS || WIN32 */ +#endif /* VMS || EPOC */ +#endif /* !PERL_MICRO */ return 0; } +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS) +static int sig_handlers_initted = 0; +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS +static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */ +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS +static int sig_defaulting[SIG_SIZE]; +#endif + #ifndef PERL_MICRO +#ifdef HAS_SIGPROCMASK +static void +restore_sigmask(pTHX_ SV *save_sv) +{ + sigset_t *ossetp = (sigset_t *) SvPV_nolen( save_sv ); + (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); +} +#endif int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1007,12 +1094,18 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) STRLEN n_a; /* Are we fetching a signal entry? */ i = whichsig(MgPV(mg,n_a)); - if (i) { + if (i > 0) { if(PL_psig_ptr[i]) sv_setsv(sv,PL_psig_ptr[i]); else { - Sighandler_t sigstate = rsignal_state(i); - + Sighandler_t sigstate; + sigstate = rsignal_state(i); +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + if (sig_handlers_initted && sig_ignoring[i]) sigstate = SIG_IGN; +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + if (sig_handlers_initted && sig_defaulting[i]) sigstate = SIG_DFL; +#endif /* cache state so we don't fetch it again */ if(sigstate == SIG_IGN) sv_setpv(sv,"IGNORE"); @@ -1027,19 +1120,67 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { - I32 i; + /* XXX Some of this code was copied from Perl_magic_setsig. A little + * refactoring might be in order. + */ + register char *s; STRLEN n_a; - /* Are we clearing a signal entry? */ - i = whichsig(MgPV(mg,n_a)); - if (i) { - if(PL_psig_ptr[i]) { - SvREFCNT_dec(PL_psig_ptr[i]); - PL_psig_ptr[i]=0; - } - if(PL_psig_name[i]) { - SvREFCNT_dec(PL_psig_name[i]); - PL_psig_name[i]=0; - } + SV* to_dec; + s = MgPV(mg,n_a); + if (*s == '_') { + SV** svp; + if (strEQ(s,"__DIE__")) + svp = &PL_diehook; + else if (strEQ(s,"__WARN__")) + svp = &PL_warnhook; + else + Perl_croak(aTHX_ "No such hook: %s", s); + if (*svp) { + to_dec = *svp; + *svp = 0; + SvREFCNT_dec(to_dec); + } + } + else { + I32 i; + /* Are we clearing a signal entry? */ + i = whichsig(s); + if (i > 0) { +#ifdef HAS_SIGPROCMASK + sigset_t set, save; + SV* save_sv; + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) + if (!sig_handlers_initted) Perl_csighandler_init(); +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); +#else + (void)rsignal(i, SIG_DFL); +#endif + if(PL_psig_name[i]) { + SvREFCNT_dec(PL_psig_name[i]); + PL_psig_name[i]=0; + } + if(PL_psig_ptr[i]) { + to_dec=PL_psig_ptr[i]; + PL_psig_ptr[i]=0; + LEAVE; + SvREFCNT_dec(to_dec); + } + else + LEAVE; + } } return 0; } @@ -1056,14 +1197,51 @@ Perl_raise_signal(pTHX_ int sig) Signal_t Perl_csighandler(int sig) { -#ifdef PERL_OLD_SIGNALS - /* Call the perl level handler now with risk we may be in malloc() etc. */ - (*PL_sighandlerp)(sig); +#ifdef PERL_GET_SIG_CONTEXT + dTHXa(PERL_GET_SIG_CONTEXT); #else dTHX; - Perl_raise_signal(aTHX_ sig); #endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + (void) rsignal(sig, PL_csighandlerp); + if (sig_ignoring[sig]) return; +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + if (sig_defaulting[sig]) +#ifdef KILL_BY_SIGPRC + exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG); +#else + exit(1); +#endif +#endif + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) + /* Call the perl level handler now-- + * with risk we may be in malloc() etc. */ + (*PL_sighandlerp)(sig); + else + Perl_raise_signal(aTHX_ sig); +} + +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) +void +Perl_csighandler_init(void) +{ + int sig; + if (sig_handlers_initted) return; + + for (sig = 1; sig < SIG_SIZE; sig++) { +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + dTHX; + sig_defaulting[sig] = 1; + (void) rsignal(sig, PL_csighandlerp); +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + sig_ignoring[sig] = 0; +#endif + } + sig_handlers_initted = 1; } +#endif void Perl_despatch_signals(pTHX) @@ -1072,8 +1250,11 @@ Perl_despatch_signals(pTHX) PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { - PL_psig_pend[sig] = 0; + PERL_BLOCKSIG_ADD(set, sig); + PL_psig_pend[sig] = 0; + PERL_BLOCKSIG_BLOCK(set); (*PL_sighandlerp)(sig); + PERL_BLOCKSIG_UNBLOCK(set); } } } @@ -1084,7 +1265,16 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) register char *s; I32 i; SV** svp = 0; + /* 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; STRLEN len; +#ifdef HAS_SIGPROCMASK + sigset_t set, save; + SV* save_sv; +#endif s = MgPV(mg,len); if (*s == '_') { @@ -1096,43 +1286,78 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "No such hook: %s", s); i = 0; if (*svp) { - SvREFCNT_dec(*svp); + to_dec = *svp; *svp = 0; } } else { i = whichsig(s); /* ...no, a brick */ - if (!i) { + if (i < 0) { if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s); + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } +#ifdef HAS_SIGPROCMASK + /* Avoid having the signal arrive at a bad time, if possible. */ + sigemptyset(&set); + sigaddset(&set,i); + sigprocmask(SIG_BLOCK, &set, &save); + ENTER; + save_sv = newSVpv((char *)(&save), sizeof(sigset_t)); + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(restore_sigmask, save_sv); +#endif + PERL_ASYNC_CHECK(); +#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) + if (!sig_handlers_initted) Perl_csighandler_init(); +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + sig_ignoring[i] = 0; +#endif +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + sig_defaulting[i] = 0; +#endif SvREFCNT_dec(PL_psig_name[i]); - SvREFCNT_dec(PL_psig_ptr[i]); + to_dec = PL_psig_ptr[i]; PL_psig_ptr[i] = SvREFCNT_inc(sv); SvTEMP_off(sv); /* Make sure it doesn't go away on us */ PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { - if (i) - (void)rsignal(i, &Perl_csighandler); + if (i) { + (void)rsignal(i, PL_csighandlerp); +#ifdef HAS_SIGPROCMASK + LEAVE; +#endif + } else *svp = SvREFCNT_inc(sv); + if(to_dec) + SvREFCNT_dec(to_dec); return 0; } s = SvPV_force(sv,len); if (strEQ(s,"IGNORE")) { - if (i) + if (i) { +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + sig_ignoring[i] = 1; + (void)rsignal(i, PL_csighandlerp); +#else (void)rsignal(i, SIG_IGN); - else - *svp = 0; +#endif + } } else if (strEQ(s,"DEFAULT") || !*s) { if (i) +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + { + sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); + } +#else (void)rsignal(i, SIG_DFL); - else - *svp = 0; +#endif } else { /* @@ -1143,10 +1368,16 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (!strchr(s,':') && !strchr(s,'\'')) sv_insert(sv, 0, 0, "main::", 6); if (i) - (void)rsignal(i, &Perl_csighandler); + (void)rsignal(i, PL_csighandlerp); else *svp = SvREFCNT_inc(sv); } +#ifdef HAS_SIGPROCMASK + if(i) + LEAVE; +#endif + if(to_dec) + SvREFCNT_dec(to_dec); return 0; } #endif /* !PERL_MICRO */ @@ -1172,7 +1403,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) { HV *hv = (HV*)LvTARG(sv); I32 i = 0; - + if (hv) { (void) hv_iterinit(hv); if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) @@ -1246,9 +1477,9 @@ S_magic_methpack(pTHX_ SV *sv, MAGIC *mg, char *meth) int Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) { - magic_methpack(sv,mg,"FETCH"); if (mg->mg_ptr) mg->mg_flags |= MGf_GSKIP; + magic_methpack(sv,mg,"FETCH"); return 0; } @@ -1350,8 +1581,13 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) i = SvTRUE(sv); svp = av_fetch(GvAV(gv), atoi(MgPV(mg,n_a)), FALSE); - if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) - o->op_private = i; + 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; + } return 0; } @@ -1425,7 +1661,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) if (pos < 0) pos = 0; } - else if (pos > len) + else if (pos > (SSize_t)len) pos = len; if (ulen) { @@ -1433,7 +1669,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) sv_pos_u2b(lsv, &p, 0); pos = p; } - + mg->mg_len = pos; mg->mg_flags &= ~MGf_MINMATCH; @@ -1485,9 +1721,9 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) if (SvUTF8(lsv)) sv_pos_u2b(lsv, &offs, &rem); - if (offs > len) + if (offs > (I32)len) offs = len; - if (rem + offs > len) + if (rem + offs > (I32)len) rem = len - offs; sv_setpvn(sv, tmps + offs, (STRLEN)rem); if (SvUTF8(lsv)) @@ -1574,16 +1810,9 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) if (LvTARGLEN(sv)) { if (mg->mg_obj) { SV *ahv = LvTARG(sv); - if (SvTYPE(ahv) == SVt_PVHV) { - HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); - if (he) - targ = HeVAL(he); - } - else { - SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, FALSE, 0); - if (svp) - targ = *svp; - } + HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); + if (he) + targ = HeVAL(he); } else { AV* av = (AV*)LvTARG(sv); @@ -1629,16 +1858,9 @@ Perl_vivify_defelem(pTHX_ SV *sv) if (mg->mg_obj) { SV *ahv = LvTARG(sv); STRLEN n_a; - if (SvTYPE(ahv) == SVt_PVHV) { - HE *he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); - if (he) - value = HeVAL(he); - } - else { - SV **svp = avhv_fetch_ent((AV*)ahv, mg->mg_obj, TRUE, 0); - if (svp) - value = *svp; - } + HE *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, SvPV(mg->mg_obj, n_a)); } @@ -1679,6 +1901,7 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) } i--; } + SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ return 0; } @@ -1717,6 +1940,13 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) } int +Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) +{ + sv_unmagic(sv, PERL_MAGIC_qr); + return 0; +} + +int Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg) { regexp *re = (regexp *)mg->mg_obj; @@ -1741,6 +1971,16 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) } #endif /* USE_LOCALE_COLLATE */ +/* Just clear the UTF-8 cache data. */ +int +Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) +{ + 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. */ + return 0; +} + int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { @@ -1752,32 +1992,49 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) sv_setsv(PL_bodytarget, sv); break; case '\003': /* ^C */ - PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '\004': /* ^D */ - PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; +#ifdef DEBUGGING + s = SvPV_nolen(sv); + PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG; DEBUG_x(dump_all()); +#else + PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; +#endif break; case '\005': /* ^E */ + if (*(mg->mg_ptr+1) == '\0') { #ifdef MACOS_TRADITIONAL - gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); + gMacPerl_OSErr = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); #else # ifdef VMS - set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); # else # ifdef WIN32 - SetLastError( SvIV(sv) ); + SetLastError( SvIV(sv) ); # else # ifdef OS2 - os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); # else - /* will anyone ever use this? */ - SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); + /* will anyone ever use this? */ + SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); # endif # endif # endif #endif + } + else if (strEQ(mg->mg_ptr+1, "NCODING")) { + if (PL_encoding) + SvREFCNT_dec(PL_encoding); + if (SvOK(sv) || SvGMAGICAL(sv)) { + PL_encoding = newSVsv(sv); + } + else { + PL_encoding = Nullsv; + } + } break; case '\006': /* ^F */ PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1821,7 +2078,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); #endif break; - case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ + case '\027': /* ^W & $^WARNING_BITS */ if (*(mg->mg_ptr+1) == '\0') { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1829,7 +2086,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) | (i ? G_WARN_ON : G_WARN_OFF) ; } } - else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { + else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { if (!SvPOK(sv) && PL_localizing) { sv_setpvn(sv, WARN_NONEstring, WARNsize); @@ -1850,7 +2107,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) else if (isWARN_on(sv, WARN_ALL) && !any_fatals) { PL_compiling.cop_warnings = pWARN_ALL; PL_dowarn |= G_WARN_ONCE ; - } + } else { if (specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = newSVsv(sv) ; @@ -1863,8 +2120,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } - else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) - PL_widesyscalls = SvTRUE(sv); break; case '.': if (PL_localizing) { @@ -1872,7 +2127,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) SAVESPTR(PL_last_in_gv); } else if (SvOK(sv) && GvIO(PL_last_in_gv)) - IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv); + IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); break; case '^': Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); @@ -1885,15 +2140,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO); break; case '=': - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '-': - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; break; case '%': - IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); + IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '|': { @@ -1912,10 +2167,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } break; - case '*': - i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_multiline = (i != 0); - break; case '/': SvREFCNT_dec(PL_rs); PL_rs = newSVsv(sv); @@ -1964,13 +2215,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '!': - SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, + { #ifdef VMS - (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno +# define PERL_VMS_BANG vaxc$errno #else - 0 +# define PERL_VMS_BANG 0 #endif - ); + SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + } break; case '<': PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1987,9 +2240,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #ifdef HAS_SETRESUID (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); #else - if (PL_uid == PL_euid) /* special case $< = $> */ + if (PL_uid == PL_euid) { /* special case $< = $> */ +#ifdef PERL_DARWIN + /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ + if (PL_uid != 0 && PerlProc_getuid() == 0) + (void)PerlProc_setuid(0); +#endif (void)PerlProc_setuid(PL_uid); - else { + } else { PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } @@ -2107,6 +2365,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; #ifndef MACOS_TRADITIONAL case '0': + LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE /* The BSDs don't show the argv[] in ps(1) output, they * show a string from the process struct and provide @@ -2131,89 +2390,49 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # endif } #endif - if (!PL_origalen) { - s = PL_origargv[0]; - s += strlen(s); - /* See if all the arguments are contiguous in memory */ - for (i = 1; i < PL_origargc; i++) { - if (PL_origargv[i] == s + 1 -#ifdef OS2 - || PL_origargv[i] == s + 2 -#endif - ) - { - ++s; - s += strlen(s); /* this one is ok too */ - } - else - break; - } - /* can grab env area too? */ - if (PL_origenviron && (PL_origenviron[0] == s + 1)) { - my_setenv("NoNe SuCh", Nullch); - /* force copy of environment */ - for (i = 0; PL_origenviron[i]; i++) - if (PL_origenviron[i] == s + 1) { - ++s; - s += strlen(s); - } - else - break; - } - PL_origalen = s - PL_origargv[0]; +#if defined(__hpux) && defined(PSTAT_SETCMD) + { + union pstun un; + s = SvPV(sv, len); + un.pst_command = s; + pstat(PSTAT_SETCMD, un, len, 0, 0); } +#endif + /* PL_origalen is set in perl_parse(). */ s = SvPV_force(sv,len); - i = len; - if (i >= PL_origalen) { - i = PL_origalen; - /* don't allow system to limit $0 seen by script */ - /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */ - Copy(s, PL_origargv[0], i, char); - s = PL_origargv[0]+i; - *s = '\0'; + if (len >= (STRLEN)PL_origalen-1) { + /* Longer than original, will be truncated. We assume that + * PL_origalen bytes are available. */ + Copy(s, PL_origargv[0], PL_origalen-1, char); + PL_origargv[0][PL_origalen-1] = 0; } else { - Copy(s, PL_origargv[0], i, char); - s = PL_origargv[0]+i; - *s++ = '\0'; - while (++i < PL_origalen) - *s++ = ' '; - s = PL_origargv[0]+i; + /* Shorter than original, will be padded. */ + Copy(s, PL_origargv[0], len, char); + PL_origargv[0][len] = 0; + memset(PL_origargv[0] + len + 1, + /* Is the space counterintuitive? Yes. + * (You were expecting \0?) + * Does it work? Seems to. (In Linux 2.4.20 at least.) + * --jhi */ + (int)' ', + PL_origalen - len - 1); for (i = 1; i < PL_origargc; i++) - PL_origargv[i] = Nullch; + PL_origargv[i] = 0; } + UNLOCK_DOLLARZERO_MUTEX; break; #endif -#ifdef USE_5005THREADS - case '@': - sv_setsv(thr->errsv, sv); - break; -#endif /* USE_5005THREADS */ } return 0; } -#ifdef USE_5005THREADS -int -Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) -{ - DEBUG_S(PerlIO_printf(Perl_debug_log, - "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv))); - if (MgOWNER(mg)) - Perl_croak(aTHX_ "panic: magic_mutexfree"); - MUTEX_DESTROY(MgMUTEXP(mg)); - COND_DESTROY(MgCONDP(mg)); - return 0; -} -#endif /* USE_5005THREADS */ - I32 Perl_whichsig(pTHX_ char *sig) { register char **sigv; - for (sigv = PL_sig_name+1; *sigv; sigv++) + for (sigv = PL_sig_name; *sigv; sigv++) if (strEQ(sig,*sigv)) return PL_sig_num[sigv - PL_sig_name]; #ifdef SIGCLD @@ -2224,16 +2443,18 @@ Perl_whichsig(pTHX_ char *sig) if (strEQ(sig,"CLD")) return SIGCHLD; #endif - return 0; + return -1; } +#if !defined(PERL_IMPLICIT_CONTEXT) static SV* sig_sv; +#endif Signal_t Perl_sighandler(int sig) { -#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) - dTHXa(PL_curinterp); /* fake TLS, because signals don't do TLS */ +#ifdef PERL_GET_SIG_CONTEXT + dTHXa(PERL_GET_SIG_CONTEXT); #else dTHX; #endif @@ -2246,10 +2467,6 @@ Perl_sighandler(int sig) U32 flags = 0; XPV *tXpv = PL_Xpv; -#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) - PERL_SET_THX(aTHX); /* fake TLS, see above */ -#endif - if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1; if (PL_markstack_ptr < PL_markstack_max - 2) @@ -2259,9 +2476,11 @@ Perl_sighandler(int sig) if (PL_scopestack_ix < PL_scopestack_max - 3) flags |= 16; - if (!PL_psig_ptr[sig]) - Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n", - PL_sig_name[sig]); + if (!PL_psig_ptr[sig]) { + PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", + PL_sig_name[sig]); + exit(sig); + } /* Max number of items pushed there is 3*n or 4. We cannot fix infinity, so we fix 4 (in fact 5): */ @@ -2284,7 +2503,7 @@ Perl_sighandler(int sig) if (!cv || !CvROOT(cv)) { if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n", + Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", PL_sig_name[sig], (gv ? GvENAME(gv) : ((cv && CvGV(cv)) ? GvENAME(CvGV(cv)) @@ -2295,7 +2514,9 @@ Perl_sighandler(int sig) if(PL_psig_name[sig]) { sv = SvREFCNT_inc(PL_psig_name[sig]); flags |= 64; +#if !defined(PERL_IMPLICIT_CONTEXT) sig_sv = sv; +#endif } else { sv = sv_newmortal(); sv_setpv(sv,PL_sig_name[sig]); @@ -2323,7 +2544,7 @@ Perl_sighandler(int sig) #else /* Not clear if this will work */ (void)rsignal(sig, SIG_IGN); - (void)rsignal(sig, &Perl_csighandler); + (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ Perl_die(aTHX_ Nullformat); @@ -2396,6 +2617,10 @@ unwind_handler_stack(pTHX_ void *p) 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(sig_sv); +#endif } + +