From: Mark-Jason Dominus Date: Sun, 14 Apr 2002 23:38:55 +0000 (-0400) Subject: Negative subscripts optionally passed to tied array methods X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f12eb6d2a1dfaf441504d869b27d2e40ef4966a;p=p5sagit%2Fp5-mst-13.2.git Negative subscripts optionally passed to tied array methods Message-id: <20020415033855.6343.qmail@plover.com> p4raw-id: //depot/perl@17727 --- diff --git a/av.c b/av.c index 3146f25..a1d62fb 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 beb7ea6..beed09d 100644 --- a/av.h +++ b/av.h @@ -83,3 +83,4 @@ Same as C. Deprecated, use C 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 adc557d..72288a0 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 337aff6..e7b547b 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";