X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/48944bdf88abc95632c13b4206704af5887baf4e..97bc95472059d1dda25b407e80ce9946b88fc340:/mg.c diff --git a/mg.c b/mg.c index 4fe40a1..bec0a82 100644 --- a/mg.c +++ b/mg.c @@ -292,7 +292,8 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (isUPPER(mg->mg_type)) { sv_magic(nsv, - mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : mg->mg_obj, + mg->mg_type == 'P' ? SvTIED_obj(sv, mg) : + (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj, toLOWER(mg->mg_type), key, klen); count++; } @@ -339,10 +340,7 @@ U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { dTHR; - register char *s; - register I32 i; register REGEXP *rx; - char *t; if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (mg->mg_obj) /* @+ */ @@ -382,21 +380,28 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) return 0; } +int +Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) +{ + dTHR; + Perl_croak(aTHX_ PL_no_modify); + /* NOT REACHED */ + return 0; +} + U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { dTHR; register I32 paren; - register char *s; register I32 i; register REGEXP *rx; - char *t; + I32 s1, t1; switch (*mg->mg_ptr) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { - I32 s1, t1; paren = atoi(mg->mg_ptr); getparen: @@ -405,6 +410,16 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) (t1 = rx->endp[paren]) != -1) { i = t1 - s1; + getlen: + if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { + char *s = rx->subbeg + s1; + char *send = rx->subbeg + t1; + i = 0; + while (s < send) { + s += UTF8SKIP(s); + i++; + } + } if (i >= 0) return i; } @@ -421,8 +436,11 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (rx->startp[0] != -1) { i = rx->startp[0]; - if (i >= 0) - return i; + if (i > 0) { + s1 = 0; + t1 = i; + goto getlen; + } } } return 0; @@ -430,8 +448,11 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { if (rx->endp[0] != -1) { i = rx->sublen - rx->endp[0]; - if (i >= 0) - return i; + if (i > 0) { + s1 = rx->endp[0]; + t1 = rx->sublen; + goto getlen; + } } } return 0; @@ -458,7 +479,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) register char *s; register I32 i; register REGEXP *rx; - char *t; switch (*mg->mg_ptr) { case '\001': /* ^A */ @@ -479,8 +499,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { char msg[256]; - sv_setnv(sv,(double)gLastMacOSErr); - sv_setpv(sv, gLastMacOSErr ? GetSysErrText(gLastMacOSErr, msg) : ""); + sv_setnv(sv,(double)gMacPerl_OSErr); + sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } #else #ifdef VMS @@ -553,11 +573,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { dTHR; if (PL_lex_state != LEX_NOTPARSING) - SvOK_off(sv); + (void)SvOK_off(sv); else if (PL_in_eval) - sv_setiv(sv, 1); - else - sv_setiv(sv, 0); + sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); } break; case '\024': /* ^T */ @@ -571,17 +589,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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")) { - if (PL_compiling.cop_warnings == WARN_NONE || - PL_compiling.cop_warnings == WARN_STD) + if (PL_compiling.cop_warnings == pWARN_NONE || + PL_compiling.cop_warnings == pWARN_STD) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } - else if (PL_compiling.cop_warnings == WARN_ALL) { + else if (PL_compiling.cop_warnings == pWARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; } else { sv_setsv(sv, PL_compiling.cop_warnings); } + SvPOK_only(sv); } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) sv_setiv(sv, (IV)PL_widesyscalls); @@ -603,6 +622,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; s = rx->subbeg + s1; + if (!rx->subbeg) + break; + getrx: if (i >= 0) { bool was_tainted; @@ -756,7 +778,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) Perl_sv_catpvf(aTHX_ sv, " %"Gid_t_f, gary[i]); } #endif - SvIOK_on(sv); /* what a wonderful hack! */ + (void)SvIOK_on(sv); /* what a wonderful hack! */ break; case '*': break; @@ -879,7 +901,7 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) STRLEN n_a; magic_clear_all_env(sv,mg); hv_iterinit((HV*)sv); - while (entry = hv_iternext((HV*)sv)) { + while ((entry = hv_iternext((HV*)sv))) { I32 keylen; my_setenv(hv_iterkey(entry, &keylen), SvPV(hv_iterval((HV*)sv, entry), n_a)); @@ -892,7 +914,7 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { -#if defined(VMS) +#if defined(VMS) || defined(EPOC) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else # ifdef PERL_IMPLICIT_SYS @@ -939,6 +961,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) return 0; } +#ifndef PERL_MICRO int Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1055,6 +1078,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } return 0; } +#endif /* !PERL_MICRO */ int Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) @@ -1085,7 +1109,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) i = HvKEYS(hv); else { /*SUPPRESS 560*/ - while (entry = hv_iternext(hv)) { + while ((entry = hv_iternext(hv))) { i++; } } @@ -1261,8 +1285,6 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp)))) o->op_private = i; - else if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); return 0; } @@ -1403,6 +1425,8 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) if (rem + offs > len) rem = len - offs; sv_setpvn(sv, tmps + offs, (STRLEN)rem); + if (DO_UTF8(lsv)) + SvUTF8_on(sv); return 0; } @@ -1420,7 +1444,7 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { dTHR; TAINT_IF((mg->mg_len & 1) || - (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ + ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ return 0; } @@ -1447,7 +1471,7 @@ Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) SV *lsv = LvTARG(sv); if (!lsv) { - SvOK_off(sv); + (void)SvOK_off(sv); return 0; } @@ -1570,7 +1594,7 @@ Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "panic: magic_killbackrefs"); /* XXX Should we check that it hasn't changed? */ SvRV(svp[i]) = 0; - SvOK_off(svp[i]); + (void)SvOK_off(svp[i]); SvWEAKREF_off(svp[i]); svp[i] = &PL_sv_undef; } @@ -1659,7 +1683,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\005': /* ^E */ #ifdef MACOS_TRADITIONAL - gLastMacOSErr = 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)); @@ -1719,20 +1743,36 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } else if (strEQ(mg->mg_ptr, "\027ARNING_BITS")) { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) { - PL_compiling.cop_warnings = WARN_ALL; - PL_dowarn |= G_WARN_ONCE ; - } - else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) - PL_compiling.cop_warnings = WARN_NONE; - else { - if (specialWARN(PL_compiling.cop_warnings)) - PL_compiling.cop_warnings = newSVsv(sv) ; - else - sv_setsv(PL_compiling.cop_warnings, sv); - if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + if (!SvPOK(sv) && PL_localizing) { + sv_setpvn(sv, WARN_NONEstring, WARNsize); + PL_compiling.cop_warnings = pWARN_NONE; + break; + } + { + STRLEN len, i; + int accumulate = 0 ; + int any_fatals = 0 ; + char * ptr = (char*)SvPV(sv, len) ; + for (i = 0 ; i < len ; ++i) { + accumulate |= ptr[i] ; + any_fatals |= (ptr[i] & 0xAA) ; + } + if (!accumulate) + PL_compiling.cop_warnings = pWARN_NONE; + 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) ; + else + sv_setsv(PL_compiling.cop_warnings, sv); + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; + } + + } } } else if (strEQ(mg->mg_ptr, "\027IDE_SYSTEM_CALLS")) @@ -1971,6 +2011,30 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; #ifndef MACOS_TRADITIONAL case '0': +#ifdef HAS_SETPROCTITLE + /* The BSDs don't show the argv[] in ps(1) output, they + * show a string from the process struct and provide + * the setproctitle() routine to manipulate that. */ + { + s = SvPV(sv, len); +# if __FreeBSD_version >= 410001 + /* The leading "-" removes the "perl: " prefix, + * but not the "(perl) suffix from the ps(1) + * output, because that's what ps(1) shows if the + * argv[] is modified. */ + setproctitle("-%s", s, len + 1); +# else /* old FreeBSDs, NetBSD, OpenBSD, anyBSD */ + /* This doesn't really work if you assume that + * $0 = 'foobar'; will wipe out 'perl' from the $0 + * because in ps(1) output the result will be like + * sprintf("perl: %s (perl)", s) + * I guess this is a security feature: + * one (a user process) cannot get rid of the original name. + * --jhi */ + setproctitle("%s", s); +# endif + } +#endif if (!PL_origalen) { s = PL_origargv[0]; s += strlen(s); @@ -2077,7 +2141,11 @@ static SV* sig_sv; Signal_t Perl_sighandler(int sig) { +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ +#else dTHX; +#endif dSP; GV *gv = Nullgv; HV *st; @@ -2085,8 +2153,12 @@ Perl_sighandler(int sig) CV *cv = Nullcv; OP *myop = PL_op; U32 flags = 0; - I32 o_save_i = PL_savestack_ix, type; + I32 o_save_i = PL_savestack_ix; XPV *tXpv = PL_Xpv; + +#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) + PERL_SET_THX(aTHXo); /* fake TLS, see above */ +#endif if (PL_savestack_ix + 15 <= PL_savestack_max) flags |= 1;