From: Gurusamy Sarathy Date: Mon, 9 Mar 1998 03:51:01 +0000 (+0000) Subject: [win32] merge C patch, also moved statics in X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4e4c362ec2e3f4b5f5c23aa83a26a13b85d0c2c1;p=p5sagit%2Fp5-mst-13.2.git [win32] merge C patch, also moved statics in [ah]v.c to thrdvar.h p4raw-id: //depot/win32/perl@802 --- diff --git a/av.c b/av.c index fad0b2e..f4a9883 100644 --- a/av.c +++ b/av.c @@ -157,8 +157,8 @@ av_fetch(register AV *av, I32 key, I32 lval) dTHR; sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); - Sv = sv; - return &Sv; + av_fetch_sv = sv; + return &av_fetch_sv; } } diff --git a/embedvar.h b/embedvar.h index bfc39d5..1b93609 100644 --- a/embedvar.h +++ b/embedvar.h @@ -22,6 +22,7 @@ #define Sv (curinterp->TSv) #define Xpv (curinterp->TXpv) +#define av_fetch_sv (curinterp->Tav_fetch_sv) #define bodytarget (curinterp->Tbodytarget) #define chopset (curinterp->Tchopset) #define curcop (curinterp->Tcurcop) @@ -37,6 +38,8 @@ #define delaymagic (curinterp->Tdelaymagic) #define dirty (curinterp->Tdirty) #define formtarget (curinterp->Tformtarget) +#define hv_fetch_ent_mh (curinterp->Thv_fetch_ent_mh) +#define hv_fetch_sv (curinterp->Thv_fetch_sv) #define in_eval (curinterp->Tin_eval) #define last_in_gv (curinterp->Tlast_in_gv) #define localizing (curinterp->Tlocalizing) @@ -316,6 +319,7 @@ #define TSv Sv #define TXpv Xpv +#define Tav_fetch_sv av_fetch_sv #define Tbodytarget bodytarget #define Tchopset chopset #define Tcurcop curcop @@ -331,6 +335,8 @@ #define Tdelaymagic delaymagic #define Tdirty dirty #define Tformtarget formtarget +#define Thv_fetch_ent_mh hv_fetch_ent_mh +#define Thv_fetch_sv hv_fetch_sv #define Tin_eval in_eval #define Tlast_in_gv last_in_gv #define Tlocalizing localizing @@ -494,6 +500,7 @@ #define Sv Perl_Sv #define Xpv Perl_Xpv +#define av_fetch_sv Perl_av_fetch_sv #define bodytarget Perl_bodytarget #define chopset Perl_chopset #define curcop Perl_curcop @@ -509,6 +516,8 @@ #define delaymagic Perl_delaymagic #define dirty Perl_dirty #define formtarget Perl_formtarget +#define hv_fetch_ent_mh Perl_hv_fetch_ent_mh +#define hv_fetch_sv Perl_hv_fetch_sv #define in_eval Perl_in_eval #define last_in_gv Perl_last_in_gv #define localizing Perl_localizing @@ -556,6 +565,7 @@ #define Sv (thr->TSv) #define Xpv (thr->TXpv) +#define av_fetch_sv (thr->Tav_fetch_sv) #define bodytarget (thr->Tbodytarget) #define chopset (thr->Tchopset) #define curcop (thr->Tcurcop) @@ -571,6 +581,8 @@ #define delaymagic (thr->Tdelaymagic) #define dirty (thr->Tdirty) #define formtarget (thr->Tformtarget) +#define hv_fetch_ent_mh (thr->Thv_fetch_ent_mh) +#define hv_fetch_sv (thr->Thv_fetch_sv) #define in_eval (thr->Tin_eval) #define last_in_gv (thr->Tlast_in_gv) #define localizing (thr->Tlocalizing) diff --git a/hv.c b/hv.c index b1e095a..822c002 100644 --- a/hv.c +++ b/hv.c @@ -94,8 +94,8 @@ hv_fetch(HV *hv, char *key, U32 klen, I32 lval) dTHR; sv = sv_newmortal(); mg_copy((SV*)hv, sv, key, klen); - Sv = sv; - return &Sv; + hv_fetch_sv = sv; + return &hv_fetch_sv; } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv,'E')) { @@ -170,19 +170,17 @@ hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash) if (SvRMAGICAL(hv)) { if (mg_find((SV*)hv,'P')) { - static HE mh; - sv = sv_newmortal(); keysv = sv_2mortal(newSVsv(keysv)); mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); - if (!HeKEY_hek(&mh)) { + if (!HeKEY_hek(&hv_fetch_ent_mh)) { char *k; New(54, k, HEK_BASESIZE + sizeof(SV*), char); - HeKEY_hek(&mh) = (HEK*)k; + HeKEY_hek(&hv_fetch_ent_mh) = (HEK*)k; } - HeSVKEY_set(&mh, keysv); - HeVAL(&mh) = sv; - return &mh; + HeSVKEY_set(&hv_fetch_ent_mh, keysv); + HeVAL(&hv_fetch_ent_mh) = sv; + return &hv_fetch_ent_mh; } #ifdef ENV_IS_CASELESS else if (mg_find((SV*)hv,'E')) { diff --git a/scope.c b/scope.c index 73aadff..1dfb25a 100644 --- a/scope.c +++ b/scope.c @@ -155,11 +155,12 @@ SV * save_scalar(GV *gv) { dTHR; + SV **sptr = &GvSV(gv); SSCHECK(3); - SSPUSHPTR(gv); - SSPUSHPTR(GvSV(gv)); + SSPUSHPTR(SvREFCNT_inc(gv)); + SSPUSHPTR(SvREFCNT_inc(*sptr)); SSPUSHINT(SAVEt_SV); - return save_scalar_at(&GvSV(gv)); + return save_scalar_at(sptr); } SV* @@ -168,7 +169,7 @@ save_svref(SV **sptr) dTHR; SSCHECK(3); SSPUSHPTR(sptr); - SSPUSHPTR(*sptr); + SSPUSHPTR(SvREFCNT_inc(*sptr)); SSPUSHINT(SAVEt_SVREF); return save_scalar_at(sptr); } @@ -428,35 +429,11 @@ save_delete(HV *hv, char *key, I32 klen) SSCHECK(4); SSPUSHINT(klen); SSPUSHPTR(key); - SSPUSHPTR(hv); + SSPUSHPTR(SvREFCNT_inc(hv)); SSPUSHINT(SAVEt_DELETE); } void -save_aelem(AV *av, I32 idx, SV **sptr) -{ - dTHR; - SSCHECK(4); - SSPUSHPTR(av); - SSPUSHINT(idx); - SSPUSHPTR(*sptr); - SSPUSHINT(SAVEt_AELEM); - save_scalar_at(sptr); -} - -void -save_helem(HV *hv, SV *key, SV **sptr) -{ - dTHR; - SSCHECK(4); - SSPUSHPTR(hv); - SSPUSHPTR(key); - SSPUSHPTR(*sptr); - SSPUSHINT(SAVEt_HELEM); - save_scalar_at(sptr); -} - -void save_list(register SV **sarg, I32 maxsarg) { dTHR; @@ -484,6 +461,30 @@ save_destructor(void (*f) (void *), void *p) } void +save_aelem(AV *av, I32 idx, SV **sptr) +{ + dTHR; + SSCHECK(4); + SSPUSHPTR(SvREFCNT_inc(av)); + SSPUSHINT(idx); + SSPUSHPTR(SvREFCNT_inc(*sptr)); + SSPUSHINT(SAVEt_AELEM); + save_scalar_at(sptr); +} + +void +save_helem(HV *hv, SV *key, SV **sptr) +{ + dTHR; + SSCHECK(4); + SSPUSHPTR(SvREFCNT_inc(hv)); + SSPUSHPTR(SvREFCNT_inc(key)); + SSPUSHPTR(SvREFCNT_inc(*sptr)); + SSPUSHINT(SAVEt_HELEM); + save_scalar_at(sptr); +} + +void save_op(void) { dTHR; @@ -520,6 +521,7 @@ leave_scope(I32 base) value = (SV*)SSPOPPTR; gv = (GV*)SSPOPPTR; ptr = &GvSV(gv); + SvREFCNT_dec(gv); goto restore_sv; case SAVEt_SVREF: /* scalar reference */ value = (SV*)SSPOPPTR; @@ -551,6 +553,7 @@ leave_scope(I32 base) localizing = 2; SvSETMAGIC(value); localizing = 0; + SvREFCNT_dec(value); break; case SAVEt_AV: /* array reference */ av = (AV*)SSPOPPTR; @@ -707,6 +710,7 @@ leave_scope(I32 base) hv = (HV*)ptr; ptr = SSPOPPTR; (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD); + SvREFCNT_dec(hv); Safefree(ptr); break; case SAVEt_DESTRUCTOR: @@ -726,14 +730,38 @@ leave_scope(I32 base) i = SSPOPINT; av = (AV*)SSPOPPTR; ptr = av_fetch(av,i,1); - goto restore_sv; + if (ptr) { + sv = *(SV**)ptr; + if (sv && sv != &sv_undef) { + if (SvRMAGICAL(av) && mg_find((SV*)av, 'P')) + (void)SvREFCNT_inc(sv); + SvREFCNT_dec(av); + goto restore_sv; + } + } + SvREFCNT_dec(av); + SvREFCNT_dec(value); + break; case SAVEt_HELEM: /* hash element */ value = (SV*)SSPOPPTR; sv = (SV*)SSPOPPTR; hv = (HV*)SSPOPPTR; ptr = hv_fetch_ent(hv, sv, 1, 0); - ptr = &HeVAL((HE*)ptr); - goto restore_sv; + if (ptr) { + SV *oval = HeVAL((HE*)ptr); + if (oval && oval != &sv_undef) { + ptr = &HeVAL((HE*)ptr); + if (SvRMAGICAL(hv) && mg_find((SV*)hv, 'P')) + (void)SvREFCNT_inc(*(SV**)ptr); + SvREFCNT_dec(hv); + SvREFCNT_dec(sv); + goto restore_sv; + } + } + SvREFCNT_dec(hv); + SvREFCNT_dec(sv); + SvREFCNT_dec(value); + break; case SAVEt_OP: op = (OP*)SSPOPPTR; break; diff --git a/t/op/local.t b/t/op/local.t index 0df1b6d..513e063 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -2,7 +2,7 @@ # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ -print "1..36\n"; +print "1..47\n"; sub foo { local($a, $b) = @_; @@ -101,3 +101,61 @@ eval { } }; print $m == 5 ? "" : "not ", "ok 36\n"; + +# see if localization works on tied arrays +{ + package TA; + sub TIEARRAY { bless [], $_[0] } + sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } + sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } + sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } + sub FETCHSIZE { scalar(@{$_[0]}) } + sub SHIFT { shift (@{$_[0]}) } + sub EXTEND {} +} + +tie @a, 'TA'; +@a = ('a', 'b', 'c'); +{ + local($a[1]) = 'foo'; + local($a[2]) = $a[1]; # XXX LHS == RHS doesn't work yet + print +($a[1] eq 'foo') ? "" : "not ", "ok 37\n"; + print +($a[2] eq 'foo') ? "" : "not ", "ok 38\n"; + @a = (); +} +print +($a[1] eq 'b') ? "" : "not ", "ok 39\n"; +print +($a[2] eq 'c') ? "" : "not ", "ok 40\n"; +print +(!defined $a[0]) ? "" : "not ", "ok 41\n"; + +{ + package TH; + sub TIEHASH { bless {}, $_[0] } + sub STORE { print "# STORE [@_]\n"; $_[0]->{$_[1]} = $_[2] } + sub FETCH { my $v = $_[0]->{$_[1]}; print "# FETCH [@_=$v]\n"; $v } + sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->{$_[1]}; } + sub CLEAR { print "# CLEAR [@_]\n"; %{$_[0]} = (); } +} + +# see if localization works on tied hashes +tie %h, 'TH'; +%h = ('a' => 1, 'b' => 2, 'c' => 3); + +{ + local($h{'a'}) = 'foo'; + local($h{'b'}) = $h{'a'}; # XXX LHS == RHS doesn't work yet + print +($h{'a'} eq 'foo') ? "" : "not ", "ok 42\n"; + print +($h{'b'} eq 'foo') ? "" : "not ", "ok 43\n"; + local($h{'c'}); + delete $h{'c'}; +} +print +($h{'a'} == 1) ? "" : "not ", "ok 44\n"; +print +($h{'b'} == 2) ? "" : "not ", "ok 45\n"; +print +($h{'c'} == 3) ? "" : "not ", "ok 46\n"; + +@a = ('a', 'b', 'c'); +{ + local($a[1]) = "X"; + shift @a; +} +print +($a[0].$a[1] eq "Xb") ? "" : "not ", "ok 47\n"; + diff --git a/thrdvar.h b/thrdvar.h index 9719420..ba867c1 100644 --- a/thrdvar.h +++ b/thrdvar.h @@ -77,6 +77,11 @@ PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */ PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */ PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */ +/* statics "owned" by various functions */ +PERLVAR(Tav_fetch_sv, SV *) +PERLVAR(Thv_fetch_sv, SV *) +PERLVAR(Thv_fetch_ent_mh, HE) + /* XXX Sort stuff, firstgv secongv and so on? */ /* XXX What about regexp stuff? */