Change 17727 by [EMAIL PROTECTED] on 2002/08/17 01:20:05
Subject: [PATCH 5.7.3] Negative subscripts optionally passed to tied array
methods
From: Mark-Jason Dominus <[EMAIL PROTECTED]>
Date: Sun, 14 Apr 2002 23:38:55 -0400 (Mon 04:38 BST)
Message-id: <[EMAIL PROTECTED]>
Affected files ...
.... //depot/perl/av.c#69 edit
.... //depot/perl/av.h#18 edit
.... //depot/perl/pod/perltie.pod#30 edit
.... //depot/perl/t/op/tiearray.t#9 edit
Differences ...
==== //depot/perl/av.c#69 (text) ====
Index: perl/av.c
--- perl/av.c#68~17725~ Fri Aug 16 17:51:19 2002
+++ perl/av.c Fri Aug 16 18:20:05 2002
@@ -184,23 +184,42 @@
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 @@
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 @@
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 @@
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 @@
{
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])
{
==== //depot/perl/av.h#18 (text) ====
Index: perl/av.h
--- perl/av.h#17~14391~ Wed Jan 23 10:48:45 2002
+++ perl/av.h Fri Aug 16 18:20:05 2002
@@ -83,3 +83,4 @@
#define AvFILL(av) ((SvRMAGICAL((SV *) (av))) \
? mg_size((SV *) av) : AvFILLp(av))
+#define NEGATIVE_INDICES_VAR "NEGATIVE_INDICES"
==== //depot/perl/pod/perltie.pod#30 (text) ====
Index: perl/pod/perltie.pod
--- perl/pod/perltie.pod#29~14684~ Thu Feb 14 06:09:10 2002
+++ perl/pod/perltie.pod Fri Aug 16 18:20:05 2002
@@ -258,7 +258,9 @@
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
==== //depot/perl/t/op/tiearray.t#9 (xtext) ====
Index: perl/t/op/tiearray.t
--- perl/t/op/tiearray.t#8~15711~ Wed Apr 3 09:04:22 2002
+++ perl/t/op/tiearray.t Fri Aug 16 18:20:05 2002
@@ -99,9 +99,44 @@
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];
+}
-print "1..36\n";
+sub EXISTS {
+ my ($ob,$id) = @_;
+# print "# EXISTS @_\n";
+ $id += $offset;
+ exists $ob->[$id];
+}
+
+package main;
+
+print "1..61\n";
my $test = 1;
{my @ary;
@@ -240,7 +275,55 @@
# If we survived this far.
print "ok ", $test++, "\n";
}
+
+
+{ # 20020220 [EMAIL PROTECTED]
+ 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";
End of Patch.
