--- mg.h 2002/02/20 14:56:46 1.1 +++ mg.h 2002/02/20 20:30:00 @@ -41,6 +41,9 @@ #define MGf_MINMATCH 1 +/* MGp: Flags set in mg_private 20020220 mjd-perl-patch+@plover.com */ +#define MGp_NEG_INDEX 1 /* must match Tie::Array::AR_NEGATIVE */ + #define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR) #define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR) #define MgTAINTEDDIR_off(mg) (mg->mg_flags &= ~MGf_TAINTEDDIR) --- mg.c 2002/02/20 13:53:03 1.1 +++ mg.c 2002/02/20 14:53:51 @@ -1307,6 +1307,9 @@ if (n > 2) { PUSHs(val); } + if (mg->mg_private) { + PUSHs(sv_2mortal(newSViv((IV)mg->mg_private))); + } PUTBACK; return call_method(meth, flags); --- av.c 2002/02/20 13:53:53 1.1 +++ av.c 2002/02/20 21:21:51 @@ -180,12 +180,18 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) { SV *sv; + unsigned char neg_index = 0; if (!av) return 0; if (key < 0) { - key += AvFILL(av) + 1; + if (SvRMAGICAL((SV *) av)) { + neg_index = MGp_NEG_INDEX; + key += mg_size((SV *) av) + 1; + } else { + key += AvFILL(av) + 1; /* subscript $a[-1] is like $a[$#array] */ + } if (key < 0) return 0; } @@ -196,6 +202,7 @@ { sv = sv_newmortal(); mg_copy((SV*)av, sv, 0, key); + SvMAGIC(sv)->mg_private |= neg_index; PL_av_fetch_sv = sv; return &PL_av_fetch_sv; } --- t/op/tiearray.t 2002/02/20 14:40:33 1.1 +++ t/op/tiearray.t 2002/02/20 21:33:45 @@ -99,9 +99,38 @@ return splice(@$ob,$off,$len,@_); } +package NegIndex; # 20020220 MJD +@ISA = 'Implement'; + +# simulate indices -2 .. 2 +my $offset = 2; + +sub FETCH { + $seen{'FETCH'}++; + my ($ob,$id,$flags) = @_; + print "# FETCH $id $flags\n"; + if (defined $flags && $flags & Tie::Array::AR_NEGATIVE()) { + $id -= $ob->FETCHSIZE; + } + $id += $offset; + $ob->[$id]; +} + +sub STORE { + $seen{'STORE'}++; + my ($ob,$id,$value,$flags) = @_; + print "# STORE $id $flags\n"; + if (defined $flags && $flags & Tie::Array::AR_NEGATIVE()) { + $id -= $ob->FETCHSIZE; + } + $id += $offset; + $ob->[$id] = $value; +} + + package main; -print "1..31\n"; +print "1..44\n"; my $test = 1; {my @ary; @@ -202,8 +231,58 @@ untie @ary; } + + +{ # 20020220 mjd-perl-patch@plover.com + my @n; + require Tie::Array; # For Tie::Array::AR_NEGATIVE + 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"; + $n[0] = 'zero'; + print "not " unless $n[0] eq 'zero'; + print "ok ", $test++,"\n"; + $n[1] = 'one'; + print "not " unless $n[1] eq 'one'; + print "ok ", $test++,"\n"; + $n[-1] = 'minus one'; + print "not " unless $n[-1] eq 'minus one'; + print "ok ", $test++,"\n"; + + # STORE + # How can these possibly work when I didn't put the change + # into av_store? I don't know, but it does. + $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"; + +} + + -print "not " unless $seen{'DESTROY'} == 2; +print "not " unless $seen{'DESTROY'} == 3; print "ok ", $test++,"\n"; --- ext/DB_File/DB_File.xs 2002/02/20 20:04:56 1.1 +++ ext/DB_File/DB_File.xs 2002/02/20 20:59:10 @@ -1504,7 +1504,7 @@ DBT_clear(value) ; CurrentDB = db ; /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */ - RETVAL = db_get(db, key, value, flags) ; + RETVAL = db_get(db, key, value, 0) ; ST(0) = sv_newmortal(); OutputValue(ST(0), value) } @@ -1519,6 +1519,7 @@ dMY_CXT; INIT: CurrentDB = db ; + flags=0; /* MJD */ void --- pod/perltie.pod 2002/02/20 20:14:17 1.1 +++ pod/perltie.pod 2002/02/20 21:36:09 @@ -247,7 +247,7 @@ =item FETCH this, index This method will be triggered every time an individual element the tied array -is accessed (read). It takes one argument beyond its self reference: the +is accessed (read). It usually takes one argument beyond its self reference: the index whose value we're trying to fetch. sub FETCH { @@ -258,7 +258,10 @@ 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. This means that tied array classes +do not need to do anything special to provide Perl's normal behavior +for negative subscripts. To provide special behavior, see L below. 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 @@ -460,6 +463,49 @@ As with the scalar tie class, this is almost never needed in a language that does its own garbage collection, so this time we'll just leave it out. + +=item Negative Array Subscripts + +=for credits +Mark Jason Dominus mjd@plover.com 20020220 + +(This is an advanced feature; beginners should ignore it.) + +In regular Perl arrays, negative array subscripts count backwards from +the end of the array, so that C<$a[-1]> and C<$a[$#a]> are always +identical. When a tied array is accessed with a negative subscript, +Perl adjusts the subscript to the equivalent positive number. Thus, +tied array classes do not need to do any extra work to emulate Perl's +normal behavior for negative subscripts. Hoever, this feature +prevented tied arrays from treating C<$a[-1]> differently from +C<$a[$#a]> if they wanted to. + +New in Perl 5.7.3, Perl may pass an extra 'flags' argument to +C and C. The flags argument will indicate whether the +subscript was transformed from negative to positive. If desired, your +C and C methods can use this flag to deduce the +original, untransformed subscript. To do this, use something like +this: + + use Tie::Array; + + sub FETCH { + my ($self, $n, $flags) = @_; + + if (defined $flags && $flags & Tie::Array::AR_NEGATIVE) { + # $n has been adjusted from its negative value + # This line will put it back the way it was: + $n -= $self->FETCHSIZE; + } + + # continue... + # $n is now original, unadjusted subscript + } + +Other data may be present in the C<$flags> argument, so don't use +C<$flags == Tie::Array::AR_NEGATIVE>. C<$flags> may be omitted if it +is zero, so the test for C may be necessary to avoid a +warning when warnings are enabled. =back --- lib/Tie/Array.pm 2002/02/20 20:19:47 1.1 +++ lib/Tie/Array.pm 2002/02/20 21:12:05 @@ -7,6 +7,9 @@ # Pod documentation after __END__ below. +# Must match MGp_NEG_INDEX in mg.c +sub AR_NEGATIVE () { 1 } + sub DESTROY { } sub EXTEND { } sub UNSHIFT { scalar shift->SPLICE(0,0,@_) } --- pod/perldelta.pod 2002/02/20 21:24:39 1.1 +++ pod/perldelta.pod 2002/02/20 21:25:45 @@ -504,6 +504,12 @@ have been relaxed and simplified: now you can have an underscore simply B. +=item * + +C and C methods for tied arrays now get an additional +argument to allow them to determine whether the original subscript was +negative. See L for details. + =back =head1 Modules and Pragmata