Introduce "delete local"

diff --git a/embed.fnc b/embed.fnc
index f1db823..3bd60bf 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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";