X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=bdf204bd8f3d6e69c8ae33a9d6b863f547ac2fa2;hb=0678cb22c235366e6443f8ba36afc299093d457c;hp=1c7d239eaeda0b0b2d4a0fec93094688c15bc8b9;hpb=e9814ee1ed9f0b1debd0da67ac6d70cbfec03e3d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 1c7d239..bdf204b 100644 --- a/mg.c +++ b/mg.c @@ -29,6 +29,10 @@ # 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 @@ -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)); @@ -649,7 +658,9 @@ 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 '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ if (*(mg->mg_ptr+1) == '\0') @@ -809,7 +820,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); @@ -867,11 +878,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; } @@ -1674,16 +1680,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); @@ -1729,16 +1728,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)); } @@ -1860,32 +1852,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; @@ -2071,8 +2068,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); @@ -2209,6 +2213,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 @@ -2233,6 +2238,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); @@ -2288,32 +2301,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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) {