X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=4fc2ffc9f613610d5140b016dc23e565a1ed3f73;hb=a54396a03c51089dce3d7bc2dee3f48f90443e38;hp=aee279080fcfa8d34c03d82b45885aee66e4744d;hpb=c2e66d9e68806a7000ee1a4760c35703a0e0ae89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index aee2790..4fc2ffc 100644 --- a/mg.c +++ b/mg.c @@ -1,6 +1,6 @@ /* mg.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, 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. @@ -16,19 +16,17 @@ #define PERL_IN_MG_C #include "perl.h" -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include -#endif - #if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS) # ifndef NGROUPS # define NGROUPS 32 # endif +# ifdef I_GRP +# include +# endif #endif -static void restore_magic(pTHXo_ void *p); -static void unwind_handler_stack(pTHXo_ void *p); +static void restore_magic(pTHX_ void *p); +static void unwind_handler_stack(pTHX_ void *p); /* * Use the "DESTRUCTOR" scope cleanup to reinstate magic. @@ -44,11 +42,10 @@ struct magic_state { STATIC void S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { - dTHR; MGS* mgs; assert(SvMAGICAL(sv)); - SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix); + SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix)); mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; @@ -57,7 +54,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) SvMAGICAL_off(sv); SvREADONLY_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; } /* @@ -96,35 +93,48 @@ Do magic after a value is retrieved from the SV. See C. int Perl_mg_get(pTHX_ SV *sv) { - dTHR; - I32 mgs_ix; - MAGIC* mg; - MAGIC** mgp; - int mgp_valid = 0; + int new = 0; + MAGIC *newmg, *head, *cur, *mg; + I32 mgs_ix = SSNEW(sizeof(MGS)); - mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); - mgp = &SvMAGIC(sv); - while ((mg = *mgp) != 0) { - MGVTBL* vtbl = mg->mg_virtual; + /* We must call svt_get(sv, mg) for each valid entry in the linked + list of magic. svt_get() may delete the current entry, add new + magic to the head of the list, or upgrade the SV. AMS 20010810 */ + + newmg = cur = head = mg = SvMAGIC(sv); + while (mg) { + MGVTBL *vtbl = mg->mg_virtual; + if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); - /* Ignore this magic if it's been deleted */ - if ((mg == (mgp_valid ? *mgp : SvMAGIC(sv))) && - (mg->mg_flags & MGf_GSKIP)) - (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; + /* Don't restore the flags for this entry if it was deleted. */ + if (mg->mg_flags & MGf_GSKIP) + (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; } - /* Advance to next magic (complicated by possible deletion) */ - if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { - mgp = &mg->mg_moremagic; - mgp_valid = 1; + + mg = mg->mg_moremagic; + + if (new) { + /* Have we finished with the new entries we saw? Start again + where we left off (unless there are more new entries). */ + if (mg == head) { + new = 0; + mg = cur; + head = newmg; + } + } + + /* Were any new entries added? */ + if (!new && (newmg = SvMAGIC(sv)) != head) { + new = 1; + cur = mg; + mg = newmg; } - else - mgp = &SvMAGIC(sv); /* Re-establish pointer after sv_upgrade */ } - restore_magic(aTHXo_ (void*)mgs_ix); + restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix)); return 0; } @@ -139,7 +149,6 @@ Do magic after a value is assigned to the SV. See C. int Perl_mg_set(pTHX_ SV *sv) { - dTHR; I32 mgs_ix; MAGIC* mg; MAGIC* nextmg; @@ -158,7 +167,7 @@ Perl_mg_set(pTHX_ SV *sv) CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); } - restore_magic(aTHXo_ (void*)mgs_ix); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return 0; } @@ -174,7 +183,6 @@ U32 Perl_mg_length(pTHX_ SV *sv) { MAGIC* mg; - char *junk; STRLEN len; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { @@ -186,12 +194,18 @@ Perl_mg_length(pTHX_ SV *sv) save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); - restore_magic(aTHXo_ (void*)mgs_ix); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return len; } } - junk = SvPV(sv, len); + if (DO_UTF8(sv)) + { + U8 *s = (U8*)SvPV(sv, len); + len = Perl_utf8_length(aTHX_ s, s + len); + } + else + (void)SvPV(sv, len); return len; } @@ -200,7 +214,7 @@ Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; I32 len; - + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { @@ -210,7 +224,7 @@ Perl_mg_size(pTHX_ SV *sv) save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); - restore_magic(aTHXo_ (void*)mgs_ix); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return len; } } @@ -253,7 +267,7 @@ Perl_mg_clear(pTHX_ SV *sv) CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); } - restore_magic(aTHXo_ (void*)mgs_ix); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return 0; } @@ -269,6 +283,8 @@ MAGIC* Perl_mg_find(pTHX_ SV *sv, int type) { MAGIC* mg; + if (!sv) + return 0; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type) return mg; @@ -292,7 +308,9 @@ 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 == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) : + (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj) + ? sv : mg->mg_obj, toLOWER(mg->mg_type), key, klen); count++; } @@ -318,11 +336,12 @@ Perl_mg_free(pTHX_ SV *sv) moremagic = mg->mg_moremagic; if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != 'g') + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len >= 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); + } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); @@ -331,6 +350,7 @@ Perl_mg_free(pTHX_ SV *sv) return 0; } + #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif @@ -338,30 +358,28 @@ Perl_mg_free(pTHX_ SV *sv) U32 Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register REGEXP *rx; - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (mg->mg_obj) /* @+ */ return rx->nparens; else /* @- */ return rx->lastparen; } - + return (U32)-1; } int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 s; register I32 i; register REGEXP *rx; I32 t; - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = mg->mg_len; if (paren < 0) return 0; @@ -373,16 +391,30 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) i = t; else /* @- */ i = s; - sv_setiv(sv,i); + + if (i > 0 && PL_reg_match_utf8) { + char *b = rx->subbeg; + if (b) + i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); + } + + sv_setiv(sv, i); } } return 0; } +int +Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) +{ + Perl_croak(aTHX_ PL_no_modify); + /* NOT REACHED */ + return 0; +} + U32 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register I32 i; register REGEXP *rx; @@ -391,9 +423,9 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 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)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -401,29 +433,36 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; getlen: - if (i > 0 && (PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) { - char *s = rx->subbeg + s1; + if (i > 0 && PL_reg_match_utf8) { + char *s = rx->subbeg + s1; char *send = rx->subbeg + t1; - i = 0; - while (s < send) { - s += UTF8SKIP(s); - i++; - } + + i = t1 - s1; + if (is_utf8_string((U8*)s, i)) + i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); } - if (i >= 0) - return i; + if (i < 0) + Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); + return i; } } return 0; case '+': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = rx->lastparen; if (paren) goto getparen; } return 0; + case '\016': /* ^N */ + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = rx->lastcloseparen; + if (paren) + goto getparen; + } + return 0; case '`': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->startp[0] != -1) { i = rx->startp[0]; if (i > 0) { @@ -435,7 +474,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) } return 0; case '\'': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->endp[0] != -1) { i = rx->sublen - rx->endp[0]; if (i > 0) { @@ -446,10 +485,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) } } return 0; - case ',': - return (STRLEN)PL_ofslen; - case '\\': - return (STRLEN)PL_orslen; } magic_get(sv,mg); if (!SvPOK(sv) && SvNIOK(sv)) { @@ -464,7 +499,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register I32 paren; register char *s; register I32 i; @@ -479,16 +513,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\004': /* ^D */ - sv_setiv(sv, (IV)(PL_debug & 32767)); + sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK)); #if defined(YYDEBUG) && defined(DEBUGGING) - PL_yydebug = (PL_debug & 1); + PL_yydebug = DEBUG_p_TEST; #endif break; case '\005': /* ^E */ #ifdef MACOS_TRADITIONAL { char msg[256]; - + sv_setnv(sv,(double)gMacPerl_OSErr); sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); } @@ -553,19 +587,26 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else sv_setsv(sv, &PL_sv_undef); break; - case '\017': /* ^O */ - sv_setpv(sv, PL_osname); + case '\017': /* ^O & ^OPEN */ + if (*(mg->mg_ptr+1) == '\0') + sv_setpv(sv, PL_osname); + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + sv_setsv(sv, &PL_sv_undef); + else { + sv_setsv(sv, PL_compiling.cop_io); + } + } break; case '\020': /* ^P */ sv_setiv(sv, (IV)PL_perldb); break; case '\023': /* ^S */ { - dTHR; if (PL_lex_state != LEX_NOTPARSING) (void)SvOK_off(sv); else if (PL_in_eval) - sv_setiv(sv, 1); + sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); else sv_setiv(sv, 0); } @@ -588,10 +629,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } 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")) @@ -599,14 +640,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; 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)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { I32 s1, t1; /* * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); * XXX Does the new way break anything? */ - paren = atoi(mg->mg_ptr); + paren = atoi(mg->mg_ptr); /* $& is in [0] */ getparen: if (paren <= rx->nparens && (s1 = rx->startp[paren]) != -1 && @@ -614,18 +655,18 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; s = rx->subbeg + s1; - if (!rx->subbeg) + if (!rx->subbeg) break; getrx: if (i >= 0) { - bool was_tainted; + bool was_tainted = FALSE; if (PL_tainting) { was_tainted = PL_tainted; PL_tainted = FALSE; } sv_setpvn(sv, s, i); - if ((PL_curpm->op_pmdynflags & PMdf_UTF8) && !IN_BYTE) + if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i)) SvUTF8_on(sv); else SvUTF8_off(sv); @@ -638,15 +679,23 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv,&PL_sv_undef); break; case '+': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = rx->lastparen; if (paren) goto getparen; } sv_setsv(sv,&PL_sv_undef); break; + case '\016': /* ^N */ + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + paren = rx->lastcloseparen; + if (paren) + goto getparen; + } + sv_setsv(sv,&PL_sv_undef); + break; case '`': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if ((s = rx->subbeg) && rx->startp[0] != -1) { i = rx->startp[0]; goto getrx; @@ -655,7 +704,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv,&PL_sv_undef); break; case '\'': - if (PL_curpm && (rx = PL_curpm->op_pmregexp)) { + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->subbeg && rx->endp[0] != -1) { s = rx->subbeg + rx->endp[0]; i = rx->sublen - rx->endp[0]; @@ -667,7 +716,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '.': #ifndef lint if (GvIO(PL_last_in_gv)) { - sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv))); + sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); } #endif break; @@ -717,10 +766,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; case ',': - sv_setpvn(sv,PL_ofs,PL_ofslen); break; case '\\': - sv_setpvn(sv,PL_ors,PL_orslen); break; case '#': sv_setpv(sv,PL_ofmt); @@ -778,11 +825,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '0': break; #endif -#ifdef USE_THREADS +#ifdef USE_5005THREADS case '@': sv_setsv(sv, thr->errsv); break; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ } return 0; } @@ -793,7 +840,7 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; if (uf && uf->uf_val) - (*uf->uf_val)(uf->uf_index, sv); + (*uf->uf_val)(aTHX_ uf->uf_index, sv); return 0; } @@ -887,7 +934,6 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); #else - dTHR; if (PL_localizing) { HE* entry; STRLEN n_a; @@ -906,7 +952,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 @@ -928,12 +974,8 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) cur += len+1; } FreeEnvironmentStrings(envv); -# else -# ifdef __CYGWIN__ - I32 i; - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); # else +#ifdef USE_ENVIRON_ARRAY # ifndef PERL_USE_SAFE_PUTENV I32 i; @@ -943,10 +985,10 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) for (i = 0; environ[i]; i++) safesysfree(environ[i]); # endif /* PERL_USE_SAFE_PUTENV */ -# endif /* __CYGWIN__ */ environ[0] = Nullch; +#endif /* USE_ENVIRON_ARRAY */ # endif /* WIN32 */ # endif /* PERL_IMPLICIT_SYS */ #endif /* VMS */ @@ -998,13 +1040,46 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) return 0; } +void +Perl_raise_signal(pTHX_ int sig) +{ + /* Set a flag to say this signal is pending */ + PL_psig_pend[sig]++; + /* And one to say _a_ signal is pending */ + PL_sig_pending = 1; +} + +Signal_t +Perl_csighandler(int sig) +{ +#ifdef PERL_OLD_SIGNALS + /* Call the perl level handler now with risk we may be in malloc() etc. */ + (*PL_sighandlerp)(sig); +#else + dTHX; + Perl_raise_signal(aTHX_ sig); +#endif +} + +void +Perl_despatch_signals(pTHX) +{ + int sig; + PL_sig_pending = 0; + for (sig = 1; sig < SIG_SIZE; sig++) { + if (PL_psig_pend[sig]) { + PL_psig_pend[sig] = 0; + (*PL_sighandlerp)(sig); + } + } +} + int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; - SV** svp; + SV** svp = 0; STRLEN len; s = MgPV(mg,len); @@ -1037,7 +1112,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { if (i) - (void)rsignal(i, PL_sighandlerp); + (void)rsignal(i, &Perl_csighandler); else *svp = SvREFCNT_inc(sv); return 0; @@ -1064,7 +1139,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (!strchr(s,':') && !strchr(s,'\'')) sv_insert(sv, 0, 0, "main::", 6); if (i) - (void)rsignal(i, PL_sighandlerp); + (void)rsignal(i, &Perl_csighandler); else *svp = SvREFCNT_inc(sv); } @@ -1092,19 +1167,16 @@ int Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) { HV *hv = (HV*)LvTARG(sv); - HE *entry; I32 i = 0; - + if (hv) { - (void) hv_iterinit(hv); - if (! SvTIED_mg((SV*)hv, 'P')) - i = HvKEYS(hv); - else { - /*SUPPRESS 560*/ - while ((entry = hv_iternext(hv))) { - i++; - } - } + (void) hv_iterinit(hv); + if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) + i = HvKEYS(hv); + else { + while (hv_iternext(hv)) + i++; + } } sv_setiv(sv, (IV)i); @@ -1118,7 +1190,7 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); } return 0; -} +} /* caller is responsible for stack switching/cleanup */ STATIC int @@ -1129,14 +1201,14 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) PUSHMARK(SP); EXTEND(SP, n); PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { + if (n > 1) { if (mg->mg_ptr) { if (mg->mg_len >= 0) PUSHs(sv_2mortal(newSVpvn(mg->mg_ptr, mg->mg_len))); else if (mg->mg_len == HEf_SVKEY) PUSHs((SV*)mg->mg_ptr); } - else if (mg->mg_type == 'p') { + else if (mg->mg_type == PERL_MAGIC_tiedelem) { PUSHs(sv_2mortal(newSViv(mg->mg_len))); } } @@ -1197,7 +1269,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) -{ +{ dSP; U32 retval = 0; @@ -1259,12 +1331,11 @@ int Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg) { return magic_methpack(sv,mg,"EXISTS"); -} +} int Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) { - dTHR; OP *o; I32 i; GV* gv; @@ -1277,15 +1348,12 @@ 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; } int Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; sv_setiv(sv, AvFILL((AV*)mg->mg_obj) + PL_curcop->cop_arybase); return 0; } @@ -1293,7 +1361,6 @@ Perl_magic_getarylen(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { - dTHR; av_fill((AV*)mg->mg_obj, SvIV(sv) - PL_curcop->cop_arybase); return 0; } @@ -1302,11 +1369,10 @@ int Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { SV* lsv = LvTARG(sv); - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { - mg = mg_find(lsv, 'g'); + mg = mg_find(lsv, PERL_MAGIC_regex_global); if (mg && mg->mg_len >= 0) { - dTHR; I32 i = mg->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); @@ -1325,17 +1391,16 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SSize_t pos; STRLEN len; STRLEN ulen = 0; - dTHR; mg = 0; - + if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) - mg = mg_find(lsv, 'g'); + mg = mg_find(lsv, PERL_MAGIC_regex_global); if (!mg) { if (!SvOK(sv)) return 0; - sv_magic(lsv, (SV*)0, 'g', Nullch, 0); - mg = mg_find(lsv, 'g'); + sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(lsv, PERL_MAGIC_regex_global); } else if (!SvOK(sv)) { mg->mg_len = -1; @@ -1414,11 +1479,15 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) I32 offs = LvTARGOFF(sv); I32 rem = LvTARGLEN(sv); + if (SvUTF8(lsv)) + sv_pos_u2b(lsv, &offs, &rem); if (offs > len) offs = len; if (rem + offs > len) rem = len - offs; sv_setpvn(sv, tmps + offs, (STRLEN)rem); + if (SvUTF8(lsv)) + SvUTF8_on(sv); return 0; } @@ -1426,15 +1495,32 @@ int Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { STRLEN len; - char *tmps = SvPV(sv,len); - sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + char *tmps = SvPV(sv, len); + SV *lsv = LvTARG(sv); + I32 lvoff = LvTARGOFF(sv); + I32 lvlen = LvTARGLEN(sv); + + if (DO_UTF8(sv)) { + sv_utf8_upgrade(lsv); + sv_pos_u2b(lsv, &lvoff, &lvlen); + sv_insert(lsv, lvoff, lvlen, tmps, len); + SvUTF8_on(lsv); + } + else if (lsv && SvUTF8(lsv)) { + sv_pos_u2b(lsv, &lvoff, &lvlen); + tmps = (char*)bytes_to_utf8((U8*)tmps, &len); + sv_insert(lsv, lvoff, lvlen, tmps, len); + Safefree(tmps); + } + else + sv_insert(lsv, lvoff, lvlen, tmps, len); + return 0; } int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; TAINT_IF((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)); /* kludge */ return 0; @@ -1443,7 +1529,6 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) { - dTHR; if (PL_localizing) { if (PL_localizing == 1) mg->mg_len <<= 1; @@ -1502,7 +1587,6 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) targ = AvARRAY(av)[LvTARGOFF(sv)]; } if (targ && targ != &PL_sv_undef) { - dTHR; /* just for SvREFCNT_dec */ /* somebody else defined it for us */ SvREFCNT_dec(LvTARG(sv)); LvTARG(sv) = SvREFCNT_inc(targ); @@ -1533,11 +1617,10 @@ Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) void Perl_vivify_defelem(pTHX_ SV *sv) { - dTHR; /* just for SvREFCNT_inc and SvREFCNT_dec*/ MAGIC *mg; SV *value = Nullsv; - if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y'))) + if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) return; if (mg->mg_obj) { SV *ahv = LvTARG(sv); @@ -1606,7 +1689,7 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg) { - sv_unmagic(sv, 'B'); + sv_unmagic(sv, PERL_MAGIC_bm); SvVALID_off(sv); return 0; } @@ -1614,7 +1697,7 @@ Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg) { - sv_unmagic(sv, 'f'); + sv_unmagic(sv, PERL_MAGIC_fm); SvCOMPILED_off(sv); return 0; } @@ -1625,7 +1708,7 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr; if (uf && uf->uf_set) - (*uf->uf_set)(uf->uf_index, sv); + (*uf->uf_set)(aTHX_ uf->uf_index, sv); return 0; } @@ -1657,7 +1740,6 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { - dTHR; register char *s; I32 i; STRLEN len; @@ -1670,7 +1752,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\004': /* ^D */ - PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; + PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG; DEBUG_x(dump_all()); break; case '\005': /* ^E */ @@ -1683,7 +1765,9 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # ifdef WIN32 SetLastError( SvIV(sv) ); # else -# ifndef OS2 +# ifdef OS2 + os2_setsyserrno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); +# else /* will anyone ever use this? */ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4); # endif @@ -1706,12 +1790,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_inplace = Nullch; break; case '\017': /* ^O */ - if (PL_osname) - Safefree(PL_osname); - if (SvOK(sv)) - PL_osname = savepv(SvPV(sv,len)); - else - PL_osname = Nullch; + if (*(mg->mg_ptr+1) == '\0') { + if (PL_osname) + Safefree(PL_osname); + if (SvOK(sv)) + PL_osname = savepv(SvPV(sv,len)); + else + PL_osname = Nullch; + } + else if (strEQ(mg->mg_ptr, "\017PEN")) { + if (!PL_compiling.cop_io) + PL_compiling.cop_io = newSVsv(sv); + else + sv_setsv(PL_compiling.cop_io,sv); + } break; case '\020': /* ^P */ PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); @@ -1729,7 +1821,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (*(mg->mg_ptr+1) == '\0') { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (PL_dowarn & ~G_WARN_ON) + PL_dowarn = (PL_dowarn & ~G_WARN_ON) | (i ? G_WARN_ON : G_WARN_OFF) ; } } @@ -1740,18 +1832,21 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_compiling.cop_warnings = pWARN_NONE; break; } - if (isWARN_on(sv, WARN_ALL) && !isWARNf_on(sv, WARN_ALL)) { - PL_compiling.cop_warnings = pWARN_ALL; - PL_dowarn |= G_WARN_ONCE ; - } - else { + { 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] ; + 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) ; @@ -1760,6 +1855,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) PL_dowarn |= G_WARN_ONCE ; } + } } } @@ -1815,27 +1911,28 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_multiline = (i != 0); break; case '/': - SvREFCNT_dec(PL_nrs); - PL_nrs = newSVsv(sv); SvREFCNT_dec(PL_rs); - PL_rs = SvREFCNT_inc(PL_nrs); + PL_rs = newSVsv(sv); break; case '\\': - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { - s = SvPV(sv,PL_orslen); - PL_ors = savepvn(s,PL_orslen); + PL_ors_sv = newSVsv(sv); } else { - PL_ors = Nullch; - PL_orslen = 0; + PL_ors_sv = Nullsv; } break; case ',': - if (PL_ofs) - Safefree(PL_ofs); - PL_ofs = savepv(SvPV(sv, PL_ofslen)); + if (PL_ofs_sv) + SvREFCNT_dec(PL_ofs_sv); + if (SvOK(sv) || SvGMAGICAL(sv)) { + PL_ofs_sv = newSVsv(sv); + } + else { + PL_ofs_sv = Nullsv; + } break; case '#': if (PL_ofmt) @@ -1999,6 +2096,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); +# 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); @@ -2007,7 +2128,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) if (PL_origargv[i] == s + 1 #ifdef OS2 || PL_origargv[i] == s + 2 -#endif +#endif ) { ++s; @@ -2017,11 +2138,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; } /* can grab env area too? */ - if (PL_origenviron && (PL_origenviron[0] == s + 1 -#ifdef OS2 - || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif - )) { + if (PL_origenviron && (PL_origenviron[0] == s + 1)) { my_setenv("NoNe SuCh", Nullch); /* force copy of environment */ for (i = 0; PL_origenviron[i]; i++) @@ -2056,30 +2173,29 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; #endif -#ifdef USE_THREADS +#ifdef USE_5005THREADS case '@': sv_setsv(thr->errsv, sv); break; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ } return 0; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS int Perl_magic_mutexfree(pTHX_ SV *sv, MAGIC *mg) { - dTHR; DEBUG_S(PerlIO_printf(Perl_debug_log, "0x%"UVxf": magic_mutexfree 0x%"UVxf"\n", - PTR2UV(thr), PTR2UV(sv));) + 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_THREADS */ +#endif /* USE_5005THREADS */ I32 Perl_whichsig(pTHX_ char *sig) @@ -2106,24 +2222,23 @@ Signal_t Perl_sighandler(int sig) { #if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT) - dTHXoa(PL_curinterp); /* fake TLS, because signals don't do TLS */ + dTHXa(PL_curinterp); /* fake TLS, because signals don't do TLS */ #else dTHX; #endif dSP; GV *gv = Nullgv; HV *st; - SV *sv, *tSv = PL_Sv; + SV *sv = Nullsv, *tSv = PL_Sv; CV *cv = Nullcv; OP *myop = PL_op; U32 flags = 0; - 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 */ + 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) @@ -2141,10 +2256,9 @@ Perl_sighandler(int sig) infinity, so we fix 4 (in fact 5): */ if (flags & 1) { PL_savestack_ix += 5; /* Protect save in progress. */ - o_save_i = PL_savestack_ix; SAVEDESTRUCTOR_X(unwind_handler_stack, (void*)&flags); } - if (flags & 4) + if (flags & 4) PL_markstack_ptr++; /* Protect mark. */ if (flags & 8) { PL_retstack_ix++; @@ -2153,7 +2267,7 @@ Perl_sighandler(int sig) if (flags & 16) PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ - if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) + if (!SvROK(PL_psig_ptr[sig]) || !(cv = (CV*)SvRV(PL_psig_ptr[sig])) || SvTYPE(cv) != SVt_PVCV) cv = sv_2cv(PL_psig_ptr[sig],&st,&gv,TRUE); @@ -2181,36 +2295,50 @@ Perl_sighandler(int sig) PUSHs(sv); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)cv, G_DISCARD|G_EVAL); POPSTACK; + if (SvTRUE(ERRSV)) { +#ifndef PERL_MICRO +#ifdef HAS_SIGPROCMASK + /* Handler "died", for example to get out of a restart-able read(). + * Before we re-do that on its behalf re-enable the signal which was + * blocked by the system when we entered. + */ + sigset_t set; + sigemptyset(&set); + sigaddset(&set,sig); + sigprocmask(SIG_UNBLOCK, &set, NULL); +#else + /* Not clear if this will work */ + (void)rsignal(sig, SIG_IGN); + (void)rsignal(sig, &Perl_csighandler); +#endif +#endif /* !PERL_MICRO */ + Perl_die(aTHX_ Nullformat); + } cleanup: if (flags & 1) PL_savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 4) + if (flags & 4) PL_markstack_ptr--; - if (flags & 8) + if (flags & 8) PL_retstack_ix--; if (flags & 16) PL_scopestack_ix -= 1; if (flags & 64) SvREFCNT_dec(sv); PL_op = myop; /* Apparently not needed... */ - + PL_Sv = tSv; /* Restore global temporaries. */ PL_Xpv = tXpv; return; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - static void -restore_magic(pTHXo_ void *p) +restore_magic(pTHX_ void *p) { - dTHR; MGS* mgs = SSPTR(PTR2IV(p), MGS*); SV* sv = mgs->mgs_sv; @@ -2250,9 +2378,8 @@ restore_magic(pTHXo_ void *p) } static void -unwind_handler_stack(pTHXo_ void *p) +unwind_handler_stack(pTHX_ void *p) { - dTHR; U32 flags = *(U32*)p; if (flags & 1)