X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=4fc2ffc9f613610d5140b016dc23e565a1ed3f73;hb=a54396a03c51089dce3d7bc2dee3f48f90443e38;hp=99600a4fe7b5bd8dcf2bb5ed32479ff3889244b9;hpb=5acaa6ec689aa2e39b6ec028d286e5561be1d297;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 99600a4..4fc2ffc 100644 --- a/mg.c +++ b/mg.c @@ -20,10 +20,13 @@ # 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. @@ -42,7 +45,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) 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; @@ -51,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; } /* @@ -90,34 +93,48 @@ Do magic after a value is retrieved from the SV. See C. int Perl_mg_get(pTHX_ SV *sv) { - 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; + } + + 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; + } } - /* Advance to next magic (complicated by possible deletion) */ - if (mg == (mgp_valid ? *mgp : SvMAGIC(sv))) { - mgp = &mg->mg_moremagic; - mgp_valid = 1; + + /* 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; } @@ -150,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; } @@ -166,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) { @@ -178,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; } @@ -202,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; } } @@ -245,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; } @@ -286,8 +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_type == 'D' && mg->mg_obj) ? sv : 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++; } @@ -313,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); @@ -326,6 +350,7 @@ Perl_mg_free(pTHX_ SV *sv) return 0; } + #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX) #include #endif @@ -335,7 +360,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) { 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 /* @- */ @@ -354,7 +379,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) 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; @@ -367,11 +392,13 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) else /* @- */ i = s; - if (i > 0 && DO_UTF8(PL_reg_sv)) { + if (i > 0 && PL_reg_match_utf8) { char *b = rx->subbeg; - i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); + if (b) + i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); } - sv_setiv(sv,i); + + sv_setiv(sv, i); } } return 0; @@ -396,7 +423,7 @@ 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); /* $& is in [0] */ getparen: @@ -406,27 +433,36 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) { i = t1 - s1; getlen: - if (i > 0 && DO_UTF8(PL_reg_sv)) { + if (i > 0 && PL_reg_match_utf8) { char *s = rx->subbeg + s1; char *send = rx->subbeg + t1; - i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); + i = t1 - s1; + if (is_utf8_string((U8*)s, i)) + i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send); } if (i < 0) - Perl_croak(aTHX_ "panic: magic_len: %d", i); + 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) { @@ -438,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) { @@ -477,9 +513,9 @@ 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 */ @@ -571,6 +607,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) (void)SvOK_off(sv); else if (PL_in_eval) sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE)); + else + sv_setiv(sv, 0); } break; case '\024': /* ^T */ @@ -602,7 +640,7 @@ 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; /* @@ -622,13 +660,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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 (DO_UTF8(PL_reg_sv)) + if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i)) SvUTF8_on(sv); else SvUTF8_off(sv); @@ -641,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; @@ -658,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]; @@ -670,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; @@ -779,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; } @@ -794,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; } @@ -994,12 +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) { register char *s; I32 i; - SV** svp; + SV** svp = 0; STRLEN len; s = MgPV(mg,len); @@ -1032,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; @@ -1059,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); } @@ -1087,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); @@ -1131,7 +1208,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val) 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))); } } @@ -1294,7 +1371,7 @@ 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) { I32 i = mg->mg_len; if (DO_UTF8(lsv)) @@ -1318,12 +1395,12 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) 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; @@ -1402,12 +1479,14 @@ 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 (DO_UTF8(lsv)) + if (SvUTF8(lsv)) SvUTF8_on(sv); return 0; } @@ -1416,14 +1495,25 @@ int Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { STRLEN len; - char *tmps = SvPV(sv,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(LvTARG(sv)); - sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); - SvUTF8_on(LvTARG(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(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len); + sv_insert(lsv, lvoff, lvlen, tmps, len); return 0; } @@ -1530,7 +1620,7 @@ Perl_vivify_defelem(pTHX_ SV *sv) 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); @@ -1599,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; } @@ -1607,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; } @@ -1618,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; } @@ -1662,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 */ @@ -1675,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 @@ -1819,10 +1911,8 @@ 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_sv) @@ -2012,12 +2102,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) * the setproctitle() routine to manipulate that. */ { s = SvPV(sv, len); -# if __FreeBSD_version >= 410001 +# 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); + 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 @@ -2048,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++) @@ -2087,29 +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) { 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) @@ -2136,22 +2222,21 @@ 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) @@ -2171,7 +2256,6 @@ 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) @@ -2211,9 +2295,28 @@ 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. */ @@ -2233,12 +2336,8 @@ cleanup: } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - static void -restore_magic(pTHXo_ void *p) +restore_magic(pTHX_ void *p) { MGS* mgs = SSPTR(PTR2IV(p), MGS*); SV* sv = mgs->mgs_sv; @@ -2279,7 +2378,7 @@ restore_magic(pTHXo_ void *p) } static void -unwind_handler_stack(pTHXo_ void *p) +unwind_handler_stack(pTHX_ void *p) { U32 flags = *(U32*)p;