dTHR;
sv = sv_newmortal();
mg_copy((SV*)av, sv, 0, key);
- Sv = sv;
- return &Sv;
+ av_fetch_sv = sv;
+ return &av_fetch_sv;
}
}
#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)
#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)
#define TSv Sv
#define TXpv Xpv
+#define Tav_fetch_sv av_fetch_sv
#define Tbodytarget bodytarget
#define Tchopset chopset
#define Tcurcop curcop
#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
#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
#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
#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)
#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)
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')) {
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')) {
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*
dTHR;
SSCHECK(3);
SSPUSHPTR(sptr);
- SSPUSHPTR(*sptr);
+ SSPUSHPTR(SvREFCNT_inc(*sptr));
SSPUSHINT(SAVEt_SVREF);
return save_scalar_at(sptr);
}
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;
}
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;
value = (SV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
ptr = &GvSV(gv);
+ SvREFCNT_dec(gv);
goto restore_sv;
case SAVEt_SVREF: /* scalar reference */
value = (SV*)SSPOPPTR;
localizing = 2;
SvSETMAGIC(value);
localizing = 0;
+ SvREFCNT_dec(value);
break;
case SAVEt_AV: /* array reference */
av = (AV*)SSPOPPTR;
hv = (HV*)ptr;
ptr = SSPOPPTR;
(void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
+ SvREFCNT_dec(hv);
Safefree(ptr);
break;
case SAVEt_DESTRUCTOR:
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;
# $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) = @_;
}
};
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";
+
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? */
projects / p5sagit/p5-mst-13.2.git / commitdiff