From: Vincent Pit <perl@profvince.com>
Date: Fri, 2 Jan 2009 09:26:57 +0000 (+0100)
Subject: Introduce "delete local"
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7332a6c406299d5e73836d2410689bd7c3ae4782;p=p5sagit%2Fp5-mst-13.2.git
Introduce "delete local"
---
diff --git a/embed.fnc b/embed.fnc
index f1db823..3bd60bf 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1501,6 +1501,7 @@ s |SV * |incpush_if_exists|NN AV *const av|NN SV *dir|NN SV *const stem
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
+s |OP* |do_delete_local
sR |SV* |refto |NN SV* sv
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index dd7f269..473b9de 100644
--- a/embed.h
+++ b/embed.h
@@ -1315,6 +1315,7 @@
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
+#define do_delete_local S_do_delete_local
#define refto S_refto
#endif
#endif
@@ -3661,6 +3662,7 @@
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
+#define do_delete_local() S_do_delete_local(aTHX)
#define refto(a) S_refto(aTHX_ a)
#endif
#endif
diff --git a/op.c b/op.c
index d7ef32c..d1ed080 100644
--- a/op.c
+++ b/op.c
@@ -6463,6 +6463,8 @@ Perl_ck_delete(pTHX_ OP *o)
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
OP_DESC(o));
}
+ if (kid->op_private & OPpLVAL_INTRO)
+ o->op_private |= OPpLVAL_INTRO;
op_null(kid);
}
return o;
diff --git a/op.h b/op.h
index f06dbdc..e8ba8ef 100644
--- a/op.h
+++ b/op.h
@@ -244,6 +244,7 @@ Deprecated. Use C<GIMME_V> instead.
/* Private for OP_DELETE */
#define OPpSLICE 64 /* Operating on a list of keys */
+/* Also OPpLVAL_INTRO (128) */
/* Private for OP_EXISTS */
#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */
diff --git a/pp.c b/pp.c
index 107a396..930bc53 100644
--- a/pp.c
+++ b/pp.c
@@ -4066,12 +4066,195 @@ PP(pp_each)
RETURN;
}
-PP(pp_delete)
+STATIC OP *
+S_do_delete_local(pTHX)
{
dVAR;
dSP;
const I32 gimme = GIMME_V;
- const I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
+ const MAGIC *mg;
+ HV *stash;
+
+ if (PL_op->op_private & OPpSLICE) {
+ dMARK; dORIGMARK;
+ SV * const osv = POPs;
+ const bool tied = SvRMAGICAL(osv)
+ && mg_find((const SV *)osv, PERL_MAGIC_tied);
+ const bool can_preserve = SvCANEXISTDELETE(osv)
+ || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const U32 type = SvTYPE(osv);
+ if (type == SVt_PVHV) { /* hash element */
+ HV * const hv = MUTABLE_HV(osv);
+ while (++MARK <= SP) {
+ SV * const keysv = *MARK;
+ SV *sv = NULL;
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ if (tied) {
+ HE *he = hv_fetch_ent(hv, keysv, 1, 0);
+ if (he)
+ sv = HeVAL(he);
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = hv_delete_ent(hv, keysv, 0, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ *MARK = sv_mortalcopy(sv);
+ mg_clear(sv);
+ } else
+ *MARK = sv;
+ }
+ else {
+ SAVEHDELETE(hv, keysv);
+ *MARK = &PL_sv_undef;
+ }
+ }
+ }
+ else if (type == SVt_PVAV) { /* array element */
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ AV * const av = MUTABLE_AV(osv);
+ while (++MARK <= SP) {
+ I32 idx = SvIV(*MARK);
+ SV *sv = NULL;
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = av_exists(av, idx);
+ if (tied) {
+ SV **svp = av_fetch(av, idx, 1);
+ if (svp)
+ sv = *svp;
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = av_delete(av, idx, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ *MARK = sv_mortalcopy(sv);
+ mg_clear(sv);
+ } else
+ *MARK = sv;
+ }
+ else {
+ SAVEADELETE(av, idx);
+ *MARK = &PL_sv_undef;
+ }
+ }
+ }
+ }
+ else
+ DIE(aTHX_ "Not a HASH reference");
+ if (gimme == G_VOID)
+ SP = ORIGMARK;
+ else if (gimme == G_SCALAR) {
+ MARK = ORIGMARK;
+ if (SP > MARK)
+ *++MARK = *SP;
+ else
+ *++MARK = &PL_sv_undef;
+ SP = MARK;
+ }
+ }
+ else {
+ SV * const keysv = POPs;
+ SV * const osv = POPs;
+ const bool tied = SvRMAGICAL(osv)
+ && mg_find((const SV *)osv, PERL_MAGIC_tied);
+ const bool can_preserve = SvCANEXISTDELETE(osv)
+ || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const U32 type = SvTYPE(osv);
+ SV *sv = NULL;
+ if (type == SVt_PVHV) {
+ HV * const hv = MUTABLE_HV(osv);
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ if (tied) {
+ HE *he = hv_fetch_ent(hv, keysv, 1, 0);
+ if (he)
+ sv = HeVAL(he);
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = hv_delete_ent(hv, keysv, 0, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_helem_flags(hv, keysv, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ SV *nsv = sv_mortalcopy(sv);
+ mg_clear(sv);
+ sv = nsv;
+ }
+ }
+ else
+ SAVEHDELETE(hv, keysv);
+ }
+ else if (type == SVt_PVAV) {
+ if (PL_op->op_flags & OPf_SPECIAL) {
+ AV * const av = MUTABLE_AV(osv);
+ I32 idx = SvIV(keysv);
+ bool preeminent = TRUE;
+ if (can_preserve)
+ preeminent = av_exists(av, idx);
+ if (tied) {
+ SV **svp = av_fetch(av, idx, 1);
+ if (svp)
+ sv = *svp;
+ else
+ preeminent = FALSE;
+ }
+ else {
+ sv = av_delete(av, idx, 0);
+ SvREFCNT_inc_simple_void(sv); /* De-mortalize */
+ }
+ if (preeminent) {
+ save_aelem_flags(av, idx, &sv, SAVEf_KEEPOLDELEM);
+ if (tied) {
+ SV *nsv = sv_mortalcopy(sv);
+ mg_clear(sv);
+ sv = nsv;
+ }
+ }
+ else
+ SAVEADELETE(av, idx);
+ }
+ else
+ DIE(aTHX_ "panic: avhv_delete no longer supported");
+ }
+ else
+ DIE(aTHX_ "Not a HASH reference");
+ if (!sv)
+ sv = &PL_sv_undef;
+ if (gimme != G_VOID)
+ PUSHs(sv);
+ }
+
+ RETURN;
+}
+
+PP(pp_delete)
+{
+ dVAR;
+ dSP;
+ I32 gimme;
+ I32 discard;
+
+ if (PL_op->op_private & OPpLVAL_INTRO)
+ return do_delete_local();
+
+ gimme = GIMME_V;
+ discard = (gimme == G_VOID) ? G_DISCARD : 0;
if (PL_op->op_private & OPpSLICE) {
dMARK; dORIGMARK;
diff --git a/proto.h b/proto.h
index 61805f6..92ce738 100644
--- a/proto.h
+++ b/proto.h
@@ -4833,6 +4833,7 @@ STATIC SV * S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem)
#endif
#if defined(PERL_IN_PP_C) || defined(PERL_DECL_PROT)
+STATIC OP* S_do_delete_local(pTHX);
STATIC SV* S_refto(pTHX_ SV* sv)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
diff --git a/t/op/local.t b/t/op/local.t
index 24acbff..211213b 100644
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -5,7 +5,7 @@ BEGIN {
@INC = qw(. ../lib);
require './test.pl';
}
-plan tests => 183;
+plan tests => 296;
my $list_assignment_supported = 1;
@@ -158,6 +158,109 @@ is($a[0].$a[1], "Xb");
is("@a", $d);
}
+@a = ('a', 'b', 'c');
+$a[4] = 'd';
+{
+ delete local $a[1];
+ is(scalar(@a), 5);
+ is($a[0], 'a');
+ ok(!exists($a[1]));
+ is($a[2], 'c');
+ ok(!exists($a[3]));
+ is($a[4], 'd');
+
+ ok(!exists($a[888]));
+ delete local $a[888];
+ is(scalar(@a), 5);
+ ok(!exists($a[888]));
+
+ ok(!exists($a[999]));
+ my ($d, $zzz) = delete local @a[4, 999];
+ is(scalar(@a), 3);
+ ok(!exists($a[4]));
+ ok(!exists($a[999]));
+ is($d, 'd');
+ is($zzz, undef);
+
+ my $c = delete local $a[2];
+ is(scalar(@a), 1);
+ ok(!exists($a[2]));
+ is($c, 'c');
+
+ $a[888] = 'yyy';
+ $a[999] = 'zzz';
+}
+is(scalar(@a), 5);
+is($a[0], 'a');
+is($a[1], 'b');
+is($a[2], 'c');
+ok(!defined($a[3]));
+is($a[4], 'd');
+ok(!exists($a[5]));
+ok(!exists($a[888]));
+ok(!exists($a[999]));
+
+%h = (a => 1, b => 2, c => 3, d => 4);
+{
+ delete local $h{b};
+ is(scalar(keys(%h)), 3);
+ is($h{a}, 1);
+ ok(!exists($h{b}));
+ is($h{c}, 3);
+ is($h{d}, 4);
+
+ ok(!exists($h{yyy}));
+ delete local $h{yyy};
+ is(scalar(keys(%h)), 3);
+ ok(!exists($h{yyy}));
+
+ ok(!exists($h{zzz}));
+ my ($d, $zzz) = delete local @h{qw/d zzz/};
+ is(scalar(keys(%h)), 2);
+ ok(!exists($h{d}));
+ ok(!exists($h{zzz}));
+ is($d, 4);
+ is($zzz, undef);
+
+ my $c = delete local $h{c};
+ is(scalar(keys(%h)), 1);
+ ok(!exists($h{c}));
+ is($c, 3);
+
+ $h{yyy} = 888;
+ $h{zzz} = 999;
+}
+is(scalar(keys(%h)), 4);
+is($h{a}, 1);
+is($h{b}, 2);
+is($h{c}, 3);
+ok($h{d}, 4);
+ok(!exists($h{yyy}));
+ok(!exists($h{zzz}));
+
+%h = ('a' => { 'b' => 1 }, 'c' => 2);
+{
+ my $a = delete local $h{a};
+ is(scalar(keys(%h)), 1);
+ ok(!exists($h{a}));
+ is($h{c}, 2);
+ is(scalar(keys(%$a)), 1);
+
+ my $b = delete local $a->{b};
+ is(scalar(keys(%$a)), 0);
+ is($b, 1);
+
+ $a->{d} = 3;
+}
+is(scalar(keys(%h)), 2);
+{
+ my $a = $h{a};
+ is(scalar(keys(%$a)), 2);
+ is($a->{b}, 1);
+ is($a->{d}, 3);
+}
+is($h{c}, 2);
+
%h = ('a' => 1, 'b' => 2, 'c' => 3);
{
local($h{'a'}) = 'foo';
@@ -276,6 +379,48 @@ ok(!defined $a[4]);
is($a[5], 'y');
ok(!exists $a[6]);
+@a = ('a', 'b', 'c');
+$a[4] = 'd';
+{
+ delete local $a[1];
+ is(scalar(@a), 5);
+ is($a[0], 'a');
+ ok(!exists($a[1]));
+ is($a[2], 'c');
+ ok(!exists($a[3]));
+ is($a[4], 'd');
+
+ ok(!exists($a[888]));
+ delete local $a[888];
+ is(scalar(@a), 5);
+ ok(!exists($a[888]));
+
+ ok(!exists($a[999]));
+ my ($d, $zzz) = delete local @a[4, 999];
+ is(scalar(@a), 3);
+ ok(!exists($a[4]));
+ ok(!exists($a[999]));
+ is($d, 'd');
+ is($zzz, undef);
+
+ my $c = delete local $a[2];
+ is(scalar(@a), 1);
+ ok(!exists($a[2]));
+ is($c, 'c');
+
+ $a[888] = 'yyy';
+ $a[999] = 'zzz';
+}
+is(scalar(@a), 5);
+is($a[0], 'a');
+is($a[1], 'b');
+is($a[2], 'c');
+ok(!defined($a[3]));
+is($a[4], 'd');
+ok(!exists($a[5]));
+ok(!exists($a[888]));
+ok(!exists($a[999]));
+
# see if localization works on tied hashes
{
package TH;
@@ -315,6 +460,44 @@ TODO: {
is(join("\n", map { "$_=>$h{$_}" } sort keys %h), $d);
}
+%h = (a => 1, b => 2, c => 3, d => 4);
+{
+ delete local $h{b};
+ is(scalar(keys(%h)), 3);
+ is($h{a}, 1);
+ ok(!exists($h{b}));
+ is($h{c}, 3);
+ is($h{d}, 4);
+
+ ok(!exists($h{yyy}));
+ delete local $h{yyy};
+ is(scalar(keys(%h)), 3);
+ ok(!exists($h{yyy}));
+
+ ok(!exists($h{zzz}));
+ my ($d, $zzz) = delete local @h{qw/d zzz/};
+ is(scalar(keys(%h)), 2);
+ ok(!exists($h{d}));
+ ok(!exists($h{zzz}));
+ is($d, 4);
+ is($zzz, undef);
+
+ my $c = delete local $h{c};
+ is(scalar(keys(%h)), 1);
+ ok(!exists($h{c}));
+ is($c, 3);
+
+ $h{yyy} = 888;
+ $h{zzz} = 999;
+}
+is(scalar(keys(%h)), 4);
+is($h{a}, 1);
+is($h{b}, 2);
+is($h{c}, 3);
+ok($h{d}, 4);
+ok(!exists($h{yyy}));
+ok(!exists($h{zzz}));
+
@a = ('a', 'b', 'c');
{
local($a[1]) = "X";