- --- mg.h 2022/02/20 14:56:46 1.1
- +++ mg.h 2022/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 2022/02/20 13:53:03 1.1
- +++ mg.c 2022/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 2022/02/20 14:40:33 1.1
- +++ t/op/tiearray.t 2022/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 2022/02/20 20:04:56 1.1
- +++ ext/DB_File/DB_File.xs 2022/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 2022/02/20 20:14:17 1.1
- +++ pod/perltie.pod 2022/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<Negative
- +Array Subscripts> 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<FETCH> and C<STORE>. The flags argument will indicate whether the
- +subscript was transformed from negative to positive. If desired, your
- +C<FETCH> and C<STORE> 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<defined $flags> may be necessary to avoid a
- +warning when warnings are enabled.
- =back
- --- lib/Tie/Array.pm 2022/02/20 20:19:47 1.1
- +++ lib/Tie/Array.pm 2022/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 2022/02/20 21:24:39 1.1
- +++ pod/perldelta.pod 2022/02/20 21:25:45
- @@ -504,6 +504,12 @@
- have been relaxed and simplified: now you can have an underscore
- simply B<between digits>.
- +=item *
- +
- +C<FETCH> and C<STORE> methods for tied arrays now get an additional
- +argument to allow them to determine whether the original subscript was
- +negative. See L<perltie/"Negative Array Subscripts> for details.
- +
- =back
- =head1 Modules and Pragmata