X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=63de61249fe0e9438a48bd51e0b6d448c1a0c27a;hb=abc0a0153433fe6596e1ca3a6b5572dc424d0f11;hp=ef6963d9d395dae7c8133f129b663483cb5e8b41;hpb=53c4c00cd908b83921217c52fa633bcfdd89f0fb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index ef6963d..63de612 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,6 @@ /* mg.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * 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 +12,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,6 +29,15 @@ # endif #endif +/* 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); @@ -199,7 +212,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 +275,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 +319,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 +354,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 +400,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,7 +408,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) i = t; else /* @- */ i = s; - + if (i > 0 && PL_reg_match_utf8) { char *b = rx->subbeg; if (b) @@ -427,7 +444,7 @@ 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) { @@ -437,7 +454,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 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 +462,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 '+': @@ -519,62 +544,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; @@ -612,16 +641,20 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '\024': /* ^T */ + if (*(mg->mg_ptr+1) == '\0') { #ifdef BIG_TIME - sv_setnv(sv, PL_basetime); + sv_setnv(sv, PL_basetime); #else - sv_setiv(sv, (IV)PL_basetime); + sv_setiv(sv, (IV)PL_basetime); #endif - break; + } + else if (strEQ(mg->mg_ptr, "\024AINT")) + sv_setiv(sv, PL_tainting); + break; case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ 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) { @@ -635,7 +668,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } SvPOK_only(sv); } - else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) + else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS")) sv_setiv(sv, (IV)PL_widesyscalls); break; case '1': case '2': case '3': case '4': @@ -649,7 +682,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) { @@ -768,6 +801,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case ',': break; case '\\': + if (PL_ors_sv) + sv_setpv(sv,SvPVX(PL_ors_sv)); break; case '#': sv_setpv(sv,PL_ofmt); @@ -850,7 +885,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); @@ -874,7 +908,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 */ @@ -902,7 +936,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++; @@ -955,28 +990,16 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) #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) @@ -984,17 +1007,26 @@ 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 || EPC */ 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 int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) @@ -1007,8 +1039,14 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) 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"); @@ -1052,15 +1090,53 @@ Perl_raise_signal(pTHX_ int sig) Signal_t Perl_csighandler(int sig) { +#ifdef PERL_GET_SIG_CONTEXT + dTHXa(PERL_GET_SIG_CONTEXT); +#else + dTHX; +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + (void) rsignal(sig, &Perl_csighandler); + 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 + #ifdef PERL_OLD_SIGNALS /* Call the perl level handler now with risk we may be in malloc() etc. */ (*PL_sighandlerp)(sig); #else - dTHX; Perl_raise_signal(aTHX_ sig); #endif } +#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, &Perl_csighandler); +#endif +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS + sig_ignoring[sig] = 0; +#endif + } + sig_handlers_initted = 1; +} +#endif + void Perl_despatch_signals(pTHX) { @@ -1100,9 +1176,18 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) i = whichsig(s); /* ...no, a brick */ if (!i) { 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; } +#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]); PL_psig_ptr[i] = SvREFCNT_inc(sv); @@ -1119,14 +1204,26 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } 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, &Perl_csighandler); +#else (void)rsignal(i, SIG_IGN); - else +#endif + } else *svp = 0; } else if (strEQ(s,"DEFAULT") || !*s) { if (i) +#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS + { + sig_defaulting[i] = 1; + (void)rsignal(i, &Perl_csighandler); + } +#else (void)rsignal(i, SIG_DFL); +#endif else *svp = 0; } @@ -1168,7 +1265,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)) @@ -1347,7 +1444,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) svp = av_fetch(GvAV(gv), atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) - o->op_private = i; + o->op_private = (U8)i; return 0; } @@ -1421,7 +1518,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) { @@ -1429,7 +1526,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; @@ -1481,9 +1578,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)) @@ -1506,7 +1603,7 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) sv_insert(lsv, lvoff, lvlen, tmps, len); SvUTF8_on(lsv); } - else if (SvUTF8(lsv)) { + else if (lsv && SvUTF8(lsv)) { sv_pos_u2b(lsv, &lvoff, &lvlen); tmps = (char*)bytes_to_utf8((U8*)tmps, &len); sv_insert(lsv, lvoff, lvlen, tmps, len); @@ -1748,7 +1845,7 @@ 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 */ @@ -1756,25 +1853,32 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) DEBUG_x(dump_all()); 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 - break; + } + else if (strEQ(mg->mg_ptr+1, "NCODING")) { + if (PL_encoding) + sv_setsv(PL_encoding, sv); + else + PL_encoding = newSVsv(sv); + } case '\006': /* ^F */ PL_maxsysfd = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); break; @@ -1825,7 +1929,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); @@ -1846,7 +1950,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) ; @@ -1859,8 +1963,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } - else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) - PL_widesyscalls = SvTRUE(sv); + else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS")) + PL_widesyscalls = (bool)SvTRUE(sv); break; case '.': if (PL_localizing) { @@ -1868,7 +1972,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))); @@ -1881,19 +1985,21 @@ 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 '|': { IO *io = GvIOp(PL_defoutgv); + if(!io) + break; if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0) IoFLAGS(io) &= ~IOf_FLUSH; else { @@ -1911,10 +2017,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_multiline = (i != 0); break; case '/': - SvREFCNT_dec(PL_nrs); - PL_nrs = newSVsv(sv); SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = newSVsv(sv); break; case '\\': if (PL_ors_sv) @@ -2140,7 +2244,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; } /* can grab env area too? */ - if (PL_origenviron && (PL_origenviron[0] == s + 1)) { + if (PL_origenviron +#ifdef USE_ITHREADS + && PL_curinterp == aTHX +#endif + && (PL_origenviron[0] == s + 1)) + { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ for (i = 0; PL_origenviron[i]; i++) @@ -2155,7 +2264,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } s = SvPV_force(sv,len); i = len; - if (i >= PL_origalen) { + if (i >= (I32)PL_origalen) { i = PL_origalen; /* don't allow system to limit $0 seen by script */ /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */ @@ -2167,9 +2276,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Copy(s, PL_origargv[0], i, char); s = PL_origargv[0]+i; *s++ = '\0'; - while (++i < PL_origalen) - *s++ = ' '; - s = PL_origargv[0]+i; + while (++i < (I32)PL_origalen) + *s++ = '\0'; for (i = 1; i < PL_origargc; i++) PL_origargv[i] = Nullch; } @@ -2218,13 +2326,15 @@ Perl_whichsig(pTHX_ char *sig) return 0; } +#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 @@ -2237,10 +2347,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) @@ -2250,9 +2356,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): */ @@ -2275,7 +2383,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)) @@ -2286,7 +2394,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]); @@ -2317,7 +2427,7 @@ Perl_sighandler(int sig) (void)rsignal(sig, &Perl_csighandler); #endif #endif /* !PERL_MICRO */ - Perl_die(aTHX_ Nullch); + Perl_die(aTHX_ Nullformat); } cleanup: if (flags & 1) @@ -2387,6 +2497,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 } + +