X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/93189314521460c01625b05f7cfa81ac855affa9..cbee2ce6415703614b5d2d3cc8308adf35811c9f:/mg.c diff --git a/mg.c b/mg.c index 25f4585..fae5cda 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 @@ -654,9 +658,15 @@ 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 */ + case '\025': /* $^UTF8_LOCALE */ + if (strEQ(mg->mg_ptr, "\025TF8_LOCALE")) + sv_setiv(sv, (IV) (PL_wantutf8 && PL_utf8locale)); + break; + 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+1, "ARNING_BITS")) { @@ -673,8 +683,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } SvPOK_only(sv); } - 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': case '5': case '6': case '7': case '8': case '9': case '&': @@ -814,7 +822,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); @@ -872,11 +880,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; } @@ -1455,8 +1458,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 = (U8)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; } @@ -1832,6 +1840,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) { @@ -1851,32 +1869,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; @@ -1919,7 +1942,13 @@ 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 '\025': /* $^UTF8_LOCALE */ + if (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) + PL_wantutf8 = PL_utf8locale; + else + PL_wantutf8 = FALSE; + break; + 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); @@ -1961,8 +1990,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } } - else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS")) - PL_widesyscalls = (bool)SvTRUE(sv); break; case '.': if (PL_localizing) { @@ -2207,6 +2234,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 @@ -2231,6 +2259,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); @@ -2286,32 +2322,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) {