X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=4fc2ffc9f613610d5140b016dc23e565a1ed3f73;hb=a54396a03c51089dce3d7bc2dee3f48f90443e38;hp=0cf8228099b0d9bf67af9fd2b7fb1705aaf9768d;hpb=aaa362c4c9a4b61a85f6a240dc8826e53958f6da;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 0cf8228..4fc2ffc 100644 --- a/mg.c +++ b/mg.c @@ -25,8 +25,8 @@ # 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. @@ -40,12 +40,12 @@ struct magic_state { /* MGS is typedef'ed to struct magic_state in perl.h */ STATIC void -S_save_magic(pTHX_ IV mgs_ix, SV *sv) +S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { MGS* mgs; assert(SvMAGICAL(sv)); - SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*,mgs_ix)); + SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*, (IV)mgs_ix)); mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; @@ -93,34 +93,48 @@ Do magic after a value is retrieved from the SV. See C. int Perl_mg_get(pTHX_ SV *sv) { - IV 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_ INT2PTR(void*,mgs_ix)); + restore_magic(aTHX_ INT2PTR(void *, (IV)mgs_ix)); return 0; } @@ -135,7 +149,7 @@ Do magic after a value is assigned to the SV. See C. int Perl_mg_set(pTHX_ SV *sv) { - IV mgs_ix; + I32 mgs_ix; MAGIC* mg; MAGIC* nextmg; @@ -153,7 +167,7 @@ Perl_mg_set(pTHX_ SV *sv) CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); } - restore_magic(aTHXo_ INT2PTR(void*,mgs_ix)); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return 0; } @@ -169,28 +183,33 @@ U32 Perl_mg_length(pTHX_ SV *sv) { MAGIC* mg; - char *junk; STRLEN len; for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { - IV mgs_ix; + I32 mgs_ix; mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); - restore_magic(aTHXo_ INT2PTR(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; } -IV +I32 Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; @@ -199,13 +218,13 @@ Perl_mg_size(pTHX_ SV *sv) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { MGVTBL* vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { - IV mgs_ix; + I32 mgs_ix; mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); - restore_magic(aTHXo_ INT2PTR(void*,mgs_ix)); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return len; } } @@ -234,7 +253,7 @@ Clear something magical that the SV represents. See C. int Perl_mg_clear(pTHX_ SV *sv) { - IV mgs_ix; + I32 mgs_ix; MAGIC* mg; mgs_ix = SSNEW(sizeof(MGS)); @@ -248,7 +267,7 @@ Perl_mg_clear(pTHX_ SV *sv) CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); } - restore_magic(aTHXo_ INT2PTR(void*,mgs_ix)); + restore_magic(aTHX_ INT2PTR(void*, (IV)mgs_ix)); return 0; } @@ -373,7 +392,7 @@ 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; if (b) i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i)); @@ -414,7 +433,7 @@ 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; @@ -435,6 +454,13 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 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 = PM_GETRE(PL_curpm))) { if (rx->startp[0] != -1) { @@ -640,7 +666,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) PL_tainted = FALSE; } sv_setpvn(sv, s, i); - if (PL_reg_sv && DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i)) + if (PL_reg_match_utf8 && is_utf8_string((U8*)s, i)) SvUTF8_on(sv); else SvUTF8_off(sv); @@ -660,6 +686,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } 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 = PM_GETRE(PL_curpm))) { if ((s = rx->subbeg) && rx->startp[0] != -1) { @@ -791,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; } @@ -1133,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, PERL_MAGIC_tied)) - 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); @@ -1475,7 +1506,7 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) sv_insert(lsv, lvoff, lvlen, tmps, len); SvUTF8_on(lsv); } - else if (SvUTF8(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); @@ -1734,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 @@ -1878,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) @@ -2071,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 @@ -2107,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++) @@ -2146,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) @@ -2195,7 +2222,7 @@ 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 @@ -2206,11 +2233,10 @@ Perl_sighandler(int sig) 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) @@ -2230,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) @@ -2290,7 +2315,7 @@ Perl_sighandler(int sig) (void)rsignal(sig, &Perl_csighandler); #endif #endif /* !PERL_MICRO */ - Perl_die(aTHX_ Nullch); + Perl_die(aTHX_ Nullformat); } cleanup: if (flags & 1) @@ -2311,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; @@ -2357,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;