Introduce "delete local"

7 files changed, 376 insertions, 3 deletions

diff --git a/embed.fnc b/embed.fnc
index f1db82301f..3bd60bf31d 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 dd7f269eee..473b9decd6 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 d7ef32c3cd..d1ed0807d8 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 f06dbdc120..e8ba8ef07a 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 107a396681..930bc53b73 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 61805f6131..92ce73899f 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 24acbff167..211213b84b 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";