diff options
| -rw-r--r-- | av.c | 181 | ||||
| -rw-r--r-- | av.h | 1 | ||||
| -rw-r--r-- | pod/perltie.pod | 4 | ||||
| -rwxr-xr-x | t/op/tiearray.t | 89 |
4 files changed, 221 insertions, 54 deletions
@@ -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]) { @@ -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"; |