This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Negative subscripts optionally passed to tied array methods
[perl5.git] / av.c
diff --git a/av.c b/av.c
index 3146f25..a1d62fb 100644 (file)
--- 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])
     {