X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=408c7debf261bad9d0d5e60c30b6919586c2687f;hb=5ce10329cdf928fb6a8fbddb793336dc3ff530e6;hp=109d32171a4f676365d5d17a92e435db85f081e2;hpb=85b332e26be39e8deb56070cb1034370beeee539;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 109d321..408c7de 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,9 +29,17 @@ # endif #endif -/* if you only have signal() and it resets on each signal, SIGNAL_FIX fixes */ +#ifdef __hpux +# include +#endif + +/* if you only have signal() and it resets on each signal, FAKE_PERSISTENT_SIGNAL_HANDLERS fixes */ #if !defined(HAS_SIGACTION) && defined(VMS) -# define SIGNAL_FIX +# 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); @@ -49,6 +61,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)); @@ -204,7 +221,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); @@ -267,7 +284,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); } @@ -311,7 +328,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) @@ -342,7 +363,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); @@ -388,7 +409,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) { @@ -396,7 +417,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) @@ -432,7 +453,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) { @@ -442,7 +463,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); } @@ -450,6 +471,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 '+': @@ -528,11 +557,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef MACOS_TRADITIONAL { char msg[256]; - + sv_setnv(sv,(double)gMacPerl_OSErr); - sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } -#else +#else #ifdef VMS { # include @@ -662,7 +691,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) { @@ -673,18 +702,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 (PL_reg_match_utf8 && 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; } } @@ -781,6 +817,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case ',': break; case '\\': + if (PL_ors_sv) + sv_copypv(sv, PL_ors_sv); break; case '#': sv_setpv(sv,PL_ofmt); @@ -838,11 +876,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '0': break; #endif -#ifdef USE_5005THREADS - case '@': - sv_setsv(sv, thr->errsv); - break; -#endif /* USE_5005THREADS */ } return 0; } @@ -863,7 +896,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); @@ -887,7 +919,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 */ @@ -915,7 +947,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++; @@ -968,11 +1001,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 -# if defined(PERL_IMPLICIT_SYS) || defined(WIN32) +# if defined(PERL_IMPLICIT_SYS) || defined(WIN32) PerlEnv_clearenv(); -# 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) @@ -980,20 +1018,25 @@ 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 /* USE_ENVIRON_ARRAY */ # endif /* PERL_IMPLICIT_SYS || WIN32 */ #endif /* VMS || EPC */ return 0; } -#ifdef SIGNAL_FIX -static int sig_ignoring_initted = 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 @@ -1008,13 +1051,13 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv,PL_psig_ptr[i]); else { Sighandler_t sigstate; -#ifdef SIGNAL_FIX - if (sig_ignoring_initted && sig_ignoring[i]) - sigstate = SIG_IGN; - else -#endif 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"); @@ -1058,13 +1101,24 @@ Perl_raise_signal(pTHX_ int sig) Signal_t Perl_csighandler(int sig) { -#ifndef PERL_OLD_SIGNALS +#ifdef PERL_GET_SIG_CONTEXT + dTHXa(PERL_GET_SIG_CONTEXT); +#else dTHX; #endif -#ifdef SIGNAL_FIX +#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); @@ -1073,6 +1127,27 @@ Perl_csighandler(int 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) { @@ -1112,17 +1187,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; } -#ifdef SIGNAL_FIX - if (!sig_ignoring_initted) { - int j; - for (j = 0; j < SIG_SIZE; j++) sig_ignoring[j] = 0; - sig_ignoring_initted = 1; - } +#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); @@ -1140,7 +1216,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) s = SvPV_force(sv,len); if (strEQ(s,"IGNORE")) { if (i) { -#ifdef SIGNAL_FIX +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS sig_ignoring[i] = 1; (void)rsignal(i, &Perl_csighandler); #else @@ -1151,7 +1227,14 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } 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; } @@ -1193,7 +1276,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)) @@ -1372,7 +1455,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; } @@ -1446,7 +1529,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) { @@ -1454,7 +1537,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; @@ -1506,9 +1589,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)) @@ -1595,16 +1678,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); @@ -1650,16 +1726,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)); } @@ -1773,7 +1842,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 */ @@ -1781,32 +1850,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) DEBUG_x(dump_all()); break; case '\005': /* ^E */ - if (*(mg->mg_ptr+1) == '\0') { + 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) - sv_setsv(PL_encoding, sv); - else - PL_encoding = newSVsv(sv); - } + } + 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); break; @@ -1878,7 +1952,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) ; @@ -1892,7 +1966,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS")) - PL_widesyscalls = SvTRUE(sv); + PL_widesyscalls = (bool)SvTRUE(sv); break; case '.': if (PL_localizing) { @@ -1900,7 +1974,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))); @@ -1913,15 +1987,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 '|': { @@ -1992,8 +2066,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) STATUS_POSIX_SET(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '!': + { +#ifdef VMS +# define PERL_VMS_BANG vaxc$errno +#else +# define PERL_VMS_BANG 0 +#endif SETERRNO(SvIOK(sv) ? SvIVX(sv) : SvOK(sv) ? sv_2iv(sv) : 0, - (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno); + (SvIV(sv) == EVMSERR) ? 4 : PERL_VMS_BANG); + } break; case '<': PL_uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -2130,6 +2211,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 @@ -2154,6 +2236,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # endif } #endif +#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 if (!PL_origalen) { s = PL_origargv[0]; s += strlen(s); @@ -2172,7 +2262,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++) @@ -2187,7 +2282,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'; */ @@ -2199,38 +2294,18 @@ 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; } + 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) { @@ -2257,8 +2332,8 @@ static SV* sig_sv; 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 @@ -2271,10 +2346,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) @@ -2284,9 +2355,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): */ @@ -2309,7 +2382,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)) @@ -2428,3 +2501,5 @@ unwind_handler_stack(pTHX_ void *p) SvREFCNT_dec(sig_sv); #endif } + +