Negative subscripts optionally passed to tied array methods

Message-id: <20020415033855.6343.qmail@plover.com>

p4raw-id: //depot/perl@17727

4 files changed, 221 insertions, 54 deletions

diff --git a/av.c b/av.c
index 3146f25635..a1d62fbdcb 100644
--- a/av.c
+++ b/av.c
@@ -184,23 +184,42 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
     if (!av)
 	return 0;
 
+    if (SvRMAGICAL(av)) {
+        MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
+        if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
+            U32 adjust_index = 1;
+
+            if (tied_magic && key < 0) {
+                /* Handle negative array indices 20020222 MJD */
+                SV **negative_indices_glob = 
+                    hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
+                                                     tied_magic))), 
+                             NEGATIVE_INDICES_VAR, 16, 0);
+
+                if (negative_indices_glob
+                    && SvTRUE(GvSV(*negative_indices_glob)))
+                    adjust_index = 0;
+            }
+
+            if (key < 0 && adjust_index) {
+                key += AvFILL(av) + 1;
+                if (key < 0)
+                    return 0;
+            }
+
+            sv = sv_newmortal();
+            mg_copy((SV*)av, sv, 0, key);
+            PL_av_fetch_sv = sv;
+            return &PL_av_fetch_sv;
+        }
+    }
+
     if (key < 0) {
 	key += AvFILL(av) + 1;
 	if (key < 0)
 	    return 0;
     }
 
-    if (SvRMAGICAL(av)) {
-	if (mg_find((SV*)av, PERL_MAGIC_tied) ||
-		mg_find((SV*)av, PERL_MAGIC_regdata))
-	{
-	    sv = sv_newmortal();
-	    mg_copy((SV*)av, sv, 0, key);
-	    PL_av_fetch_sv = sv;
-	    return &PL_av_fetch_sv;
-	}
-    }
-
     if (key > AvFILLp(av)) {
 	if (!lval)
 	    return 0;
@@ -251,6 +270,33 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     if (!val)
 	val = &PL_sv_undef;
 
+    if (SvRMAGICAL(av)) {
+        MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
+        if (tied_magic) {
+            /* Handle negative array indices 20020222 MJD */
+            if (key < 0) {
+                unsigned adjust_index = 1;
+                SV **negative_indices_glob = 
+                    hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
+                                                     tied_magic))), 
+                             NEGATIVE_INDICES_VAR, 16, 0);
+                if (negative_indices_glob
+                    && SvTRUE(GvSV(*negative_indices_glob)))
+                    adjust_index = 0;
+                if (adjust_index) {
+                    key += AvFILL(av) + 1;
+                    if (key < 0)
+                        return 0;
+                }
+            }
+	    if (val != &PL_sv_undef) {
+		mg_copy((SV*)av, val, 0, key);
+	    }
+	    return 0;
+        }
+    }
+
+
     if (key < 0) {
 	key += AvFILL(av) + 1;
 	if (key < 0)
@@ -260,15 +306,6 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     if (SvREADONLY(av) && key >= AvFILL(av))
 	Perl_croak(aTHX_ PL_no_modify);
 
-    if (SvRMAGICAL(av)) {
-	if (mg_find((SV*)av, PERL_MAGIC_tied)) {
-	    if (val != &PL_sv_undef) {
-		mg_copy((SV*)av, val, 0, key);
-	    }
-	    return 0;
-	}
-    }
-
     if (!AvREAL(av) && AvREIFY(av))
 	av_reify(av);
     if (key > AvMAX(av))
@@ -750,26 +787,48 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
 	return Nullsv;
     if (SvREADONLY(av))
 	Perl_croak(aTHX_ PL_no_modify);
+
+    if (SvRMAGICAL(av)) {
+        MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
+        SV **svp;
+        if ((tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata))) {
+            /* Handle negative array indices 20020222 MJD */
+            if (key < 0) {
+                unsigned adjust_index = 1;
+                if (tied_magic) {
+                    SV **negative_indices_glob = 
+                        hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
+                                                         tied_magic))), 
+                                 NEGATIVE_INDICES_VAR, 16, 0);
+                    if (negative_indices_glob
+                        && SvTRUE(GvSV(*negative_indices_glob)))
+                        adjust_index = 0;
+                }
+                if (adjust_index) {
+                    key += AvFILL(av) + 1;
+                    if (key < 0)
+                        return Nullsv;
+                }
+            }
+            svp = av_fetch(av, key, TRUE);
+            if (svp) {
+                sv = *svp;
+                mg_clear(sv);
+                if (mg_find(sv, PERL_MAGIC_tiedelem)) {
+                    sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */
+                    return sv;
+                }
+                return Nullsv;     
+            }
+        }
+    }
+
     if (key < 0) {
 	key += AvFILL(av) + 1;
 	if (key < 0)
 	    return Nullsv;
     }
-    if (SvRMAGICAL(av)) {
-	SV **svp;
-	if ((mg_find((SV*)av, PERL_MAGIC_tied) ||
-		mg_find((SV*)av, PERL_MAGIC_regdata))
-	    && (svp = av_fetch(av, key, TRUE)))
-	{
-	    sv = *svp;
-	    mg_clear(sv);
-	    if (mg_find(sv, PERL_MAGIC_tiedelem)) {
-		sv_unmagic(sv, PERL_MAGIC_tiedelem);	/* No longer an element */
-		return sv;
-	    }
-	    return Nullsv;			/* element cannot be deleted */
-	}
-    }
+
     if (key > AvFILLp(av))
 	return Nullsv;
     else {
@@ -807,26 +866,48 @@ Perl_av_exists(pTHX_ AV *av, I32 key)
 {
     if (!av)
 	return FALSE;
+
+
+    if (SvRMAGICAL(av)) {
+        MAGIC *tied_magic = mg_find((SV*)av, PERL_MAGIC_tied);
+        if (tied_magic || mg_find((SV*)av, PERL_MAGIC_regdata)) {
+            SV *sv = sv_newmortal();
+            MAGIC *mg;
+            /* Handle negative array indices 20020222 MJD */
+            if (key < 0) {
+                unsigned adjust_index = 1;
+                if (tied_magic) {
+                    SV **negative_indices_glob = 
+                        hv_fetch(SvSTASH(SvRV(SvTIED_obj((SV *)av, 
+                                                         tied_magic))), 
+                                 NEGATIVE_INDICES_VAR, 16, 0);
+                    if (negative_indices_glob
+                        && SvTRUE(GvSV(*negative_indices_glob)))
+                        adjust_index = 0;
+                }
+                if (adjust_index) {
+                    key += AvFILL(av) + 1;
+                    if (key < 0)
+                        return FALSE;
+                }
+            }
+
+            mg_copy((SV*)av, sv, 0, key);
+            mg = mg_find(sv, PERL_MAGIC_tiedelem);
+            if (mg) {
+                magic_existspack(sv, mg);
+                return (bool)SvTRUE(sv);
+            }
+
+        }
+    }
+
     if (key < 0) {
 	key += AvFILL(av) + 1;
 	if (key < 0)
 	    return FALSE;
     }
-    if (SvRMAGICAL(av)) {
-	if (mg_find((SV*)av, PERL_MAGIC_tied) ||
-		mg_find((SV*)av, PERL_MAGIC_regdata))
-	{
-	    SV *sv = sv_newmortal();
-	    MAGIC *mg;
-
-	    mg_copy((SV*)av, sv, 0, key);
-	    mg = mg_find(sv, PERL_MAGIC_tiedelem);
-	    if (mg) {
-		magic_existspack(sv, mg);
-		return (bool)SvTRUE(sv);
-	    }
-	}
-    }
+
     if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef
 	&& AvARRAY(av)[key])
     {
diff --git a/av.h b/av.h
index beb7ea6eb7..beed09d26d 100644
--- a/av.h
+++ b/av.h
@@ -83,3 +83,4 @@ Same as C<av_len()>.  Deprecated, use C<av_len()> instead.
 #define AvFILL(av)	((SvRMAGICAL((SV *) (av))) \
 			  ? mg_size((SV *) av) : AvFILLp(av))
 
+#define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
diff --git a/pod/perltie.pod b/pod/perltie.pod
index adc557d71c..72288a08a2 100644
--- a/pod/perltie.pod
+++ b/pod/perltie.pod
@@ -258,7 +258,9 @@ index whose value we're trying to fetch.
 
 If a negative array index is used to read from an array, the index
 will be translated to a positive one internally by calling FETCHSIZE
-before being passed to FETCH.
+before being passed to FETCH.  You may disable this feature by
+assigning a true value to the variable C<$NEGATIVE_INDICES> in the
+tied array class.
 
 As you may have noticed, the name of the FETCH method (et al.) is the same
 for all accesses, even though the constructors differ in names (TIESCALAR
diff --git a/t/op/tiearray.t b/t/op/tiearray.t
index 337aff689a..e7b547bcd9 100755
--- a/t/op/tiearray.t
+++ b/t/op/tiearray.t
@@ -99,9 +99,44 @@ sub SPLICE
  return splice(@$ob,$off,$len,@_);
 }
 
-package main;
+package NegIndex;               # 20020220 MJD
+@ISA = 'Implement';
+
+# simulate indices -2 .. 2
+my $offset = 2;
+$NegIndex::NEGATIVE_INDICES = 1;
+
+sub FETCH {
+  my ($ob,$id) = @_;
+#  print "# FETCH @_\n";
+  $id += $offset;
+  $ob->[$id];
+}
+
+sub STORE {
+  my ($ob,$id,$value) = @_;
+#  print "# STORE @_\n";
+  $id += $offset;
+  $ob->[$id] = $value;
+}
+
+sub DELETE {
+  my ($ob,$id) = @_;
+#  print "# DELETE @_\n";
+  $id += $offset;
+  delete $ob->[$id];
+}
+
+sub EXISTS {
+  my ($ob,$id) = @_;
+#  print "# EXISTS @_\n";
+  $id += $offset;
+  exists $ob->[$id];
+}
 
-print "1..36\n";                   
+package main;
+  
+print "1..61\n";                   
 my $test = 1;
 
 {my @ary;
@@ -240,7 +275,55 @@ untie @ary;
   # If we survived this far.
   print "ok ", $test++, "\n";
 }
+
+
+{ # 20020220 mjd-perl-patch+@plover.com
+  my @n;
+  tie @n => 'NegIndex', ('A' .. 'E');
+
+  # FETCH
+  print "not " unless $n[0] eq 'C';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[1] eq 'D';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[2] eq 'E';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[-1] eq 'B';
+  print "ok ", $test++,"\n";
+  print "not " unless $n[-2] eq 'A';
+  print "ok ", $test++,"\n";
+
+  # STORE
+  $n[-2] = 'a';
+  print "not " unless $n[-2] eq 'a';
+  print "ok ", $test++,"\n";
+  $n[-1] = 'b';
+  print "not " unless $n[-1] eq 'b';
+  print "ok ", $test++,"\n";
+  $n[0] = 'c';
+  print "not " unless $n[0] eq 'c';
+  print "ok ", $test++,"\n";
+  $n[1] = 'd';
+  print "not " unless $n[1] eq 'd';
+  print "ok ", $test++,"\n";
+  $n[2] = 'e';
+  print "not " unless $n[2] eq 'e';
+  print "ok ", $test++,"\n";
+
+  # DELETE and EXISTS
+  for (-2 .. 2) {
+    print exists($n[$_]) ? "ok $test\n" : "not ok $test\n";
+    $test++;
+    delete $n[$_];
+    print defined($n[$_]) ? "not ok $test\n" : "ok $test\n";
+    $test++;
+    print exists($n[$_]) ? "not ok $test\n" : "ok $test\n";
+    $test++;
+  }
+}
+                           
+
                            
-print "not " unless $seen{'DESTROY'} == 2;
+print "not " unless $seen{'DESTROY'} == 3;
 print "ok ", $test++,"\n";