X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=408c7debf261bad9d0d5e60c30b6919586c2687f;hb=5ce10329cdf928fb6a8fbddb793336dc3ff530e6;hp=36026431d5742a456e77c91bf0b13e04068dc292;hpb=68795e9367de98482c4a5830e6e94b51bd60f4e3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 3602643..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. @@ -29,12 +29,16 @@ # endif #endif +#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 FAKE_PERSISTENT_SIGNAL_HANDLERS #endif /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */ -#if defined(KILL_BY_SIGPRC) +#if defined(KILL_BY_SIGPRC) # define FAKE_DEFAULT_SIGNAL_HANDLERS #endif @@ -57,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)); @@ -212,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); @@ -275,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); } @@ -354,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); @@ -400,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) { @@ -408,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) @@ -444,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) { @@ -454,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); } @@ -548,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 @@ -682,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) { @@ -693,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; } } @@ -802,7 +818,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\\': if (PL_ors_sv) - sv_setpv(sv,SvPVX(PL_ors_sv)); + sv_copypv(sv, PL_ors_sv); break; case '#': sv_setpv(sv,PL_ofmt); @@ -860,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; } @@ -908,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 */ @@ -936,7 +947,7 @@ 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); @@ -990,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) @@ -1002,11 +1018,11 @@ 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; @@ -1015,7 +1031,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS) static int sig_handlers_initted = 0; #endif -#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS +#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS static int sig_ignoring[SIG_SIZE]; /* which signals we are ignoring */ #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS @@ -1095,7 +1111,7 @@ Perl_csighandler(int sig) if (sig_ignoring[sig]) return; #endif #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - if (sig_defaulting[sig]) + 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 @@ -1171,7 +1187,7 @@ 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) @@ -1260,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)) @@ -1439,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; } @@ -1513,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) { @@ -1521,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; @@ -1573,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)) @@ -1662,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); @@ -1717,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)); } @@ -1840,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 */ @@ -1848,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; @@ -1945,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) ; @@ -1959,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) { @@ -2059,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); @@ -2197,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 @@ -2221,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); @@ -2239,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++) @@ -2254,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'; */ @@ -2266,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) { @@ -2347,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): */ @@ -2372,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)) @@ -2493,4 +2503,3 @@ unwind_handler_stack(pTHX_ void *p) } -