TEXT   26

PATCH

Guest on 22nd April 2022 01:09:23 AM

  1. --- mg.h        2022/02/20 14:56:46     1.1
  2. +++ mg.h        2022/02/20 20:30:00
  3. @@ -41,6 +41,9 @@
  4.  
  5.  #define MGf_MINMATCH   1
  6.  
  7. +/* MGp: Flags set in mg_private   20020220 mjd-perl-patch+@plover.com */
  8. +#define MGp_NEG_INDEX  1     /* must match Tie::Array::AR_NEGATIVE */
  9. +
  10.  #define MgTAINTEDDIR(mg)       (mg->mg_flags & MGf_TAINTEDDIR)
  11.  #define MgTAINTEDDIR_on(mg)    (mg->mg_flags |= MGf_TAINTEDDIR)
  12.  #define MgTAINTEDDIR_off(mg)   (mg->mg_flags &= ~MGf_TAINTEDDIR)
  13. --- mg.c        2022/02/20 13:53:03     1.1
  14. +++ mg.c        2022/02/20 14:53:51
  15. @@ -1307,6 +1307,9 @@
  16.      if (n > 2) {
  17.         PUSHs(val);
  18.      }
  19. +    if (mg->mg_private) {
  20. +      PUSHs(sv_2mortal(newSViv((IV)mg->mg_private)));
  21. +    }
  22.      PUTBACK;
  23.  
  24.      return call_method(meth, flags);
  25. --- av.c        2002/02/20 13:53:53     1.1
  26. +++ av.c        2002/02/20 21:21:51
  27. @@ -180,12 +180,18 @@
  28.  Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval)
  29.  {
  30.      SV *sv;
  31. +    unsigned char neg_index = 0;
  32.  
  33.      if (!av)
  34.         return 0;
  35.  
  36.      if (key < 0) {
  37. -       key += AvFILL(av) + 1;
  38. +        if (SvRMAGICAL((SV *) av)) {
  39. +          neg_index = MGp_NEG_INDEX;
  40. +          key += mg_size((SV *) av) + 1;
  41. +        } else {
  42. +          key += AvFILL(av) + 1; /* subscript $a[-1] is like $a[$#array] */
  43. +        }
  44.         if (key < 0)
  45.             return 0;
  46.      }
  47. @@ -196,6 +202,7 @@
  48.         {
  49.             sv = sv_newmortal();
  50.             mg_copy((SV*)av, sv, 0, key);
  51. +            SvMAGIC(sv)->mg_private |= neg_index;
  52.             PL_av_fetch_sv = sv;
  53.             return &PL_av_fetch_sv;
  54.         }
  55. --- t/op/tiearray.t     2022/02/20 14:40:33     1.1
  56. +++ t/op/tiearray.t     2022/02/20 21:33:45
  57. @@ -99,9 +99,38 @@
  58.   return splice(@$ob,$off,$len,@_);
  59.  }
  60.  
  61. +package NegIndex;               # 20020220 MJD
  62. +@ISA = 'Implement';
  63. +
  64. +# simulate indices -2 .. 2
  65. +my $offset = 2;
  66. +
  67. +sub FETCH {
  68. +  $seen{'FETCH'}++;
  69. +  my ($ob,$id,$flags) = @_;
  70. +  print "# FETCH $id $flags\n";
  71. +  if (defined $flags && $flags & Tie::Array::AR_NEGATIVE()) {
  72. +    $id -= $ob->FETCHSIZE;
  73. +  }
  74. +  $id += $offset;
  75. +  $ob->[$id];
  76. +}
  77. +
  78. +sub STORE {
  79. +  $seen{'STORE'}++;
  80. +  my ($ob,$id,$value,$flags) = @_;
  81. +  print "# STORE $id $flags\n";
  82. +  if (defined $flags && $flags & Tie::Array::AR_NEGATIVE()) {
  83. +    $id -= $ob->FETCHSIZE;
  84. +  }
  85. +  $id += $offset;
  86. +  $ob->[$id] = $value;
  87. +}
  88. +
  89. +
  90.  package main;
  91.  
  92. -print "1..31\n";                  
  93. +print "1..44\n";                  
  94.  my $test = 1;
  95.  
  96.  {my @ary;
  97. @@ -202,8 +231,58 @@
  98.  untie @ary;  
  99.  
  100.  }
  101. +
  102. +
  103. +{ # 20020220 mjd-perl-patch@plover.com
  104. +  my @n;
  105. +  require Tie::Array; # For Tie::Array::AR_NEGATIVE
  106. +  tie @n => 'NegIndex', ('A' .. 'E');
  107. +
  108. +  # FETCH
  109. +  print "not " unless $n[0] eq 'C';
  110. +  print "ok ", $test++,"\n";
  111. +  print "not " unless $n[1] eq 'D';
  112. +  print "ok ", $test++,"\n";
  113. +  print "not " unless $n[2] eq 'E';
  114. +  print "ok ", $test++,"\n";
  115. +  print "not " unless $n[-1] eq 'B';
  116. +  print "ok ", $test++,"\n";
  117. +  print "not " unless $n[-2] eq 'A';
  118. +  print "ok ", $test++,"\n";
  119. +  $n[0] = 'zero';
  120. +  print "not " unless $n[0] eq 'zero';
  121. +  print "ok ", $test++,"\n";
  122. +  $n[1] = 'one';
  123. +  print "not " unless $n[1] eq 'one';
  124. +  print "ok ", $test++,"\n";
  125. +  $n[-1] = 'minus one';
  126. +  print "not " unless $n[-1] eq 'minus one';
  127. +  print "ok ", $test++,"\n";
  128. +
  129. +  # STORE
  130. +  # How can these possibly work when I didn't put the change
  131. +  # into av_store?  I don't know, but it does.
  132. +  $n[-2] = 'a';
  133. +  print "not " unless $n[-2] eq 'a';
  134. +  print "ok ", $test++,"\n";
  135. +  $n[-1] = 'b';
  136. +  print "not " unless $n[-1] eq 'b';
  137. +  print "ok ", $test++,"\n";
  138. +  $n[0] = 'c';
  139. +  print "not " unless $n[0] eq 'c';
  140. +  print "ok ", $test++,"\n";
  141. +  $n[1] = 'd';
  142. +  print "not " unless $n[1] eq 'd';
  143. +  print "ok ", $test++,"\n";
  144. +  $n[2] = 'e';
  145. +  print "not " unless $n[2] eq 'e';
  146. +  print "ok ", $test++,"\n";
  147. +
  148. +}
  149. +                          
  150. +
  151.                            
  152. -print "not " unless $seen{'DESTROY'} == 2;
  153. +print "not " unless $seen{'DESTROY'} == 3;
  154.  print "ok ", $test++,"\n";        
  155.  
  156.  
  157. --- ext/DB_File/DB_File.xs      2022/02/20 20:04:56     1.1
  158. +++ ext/DB_File/DB_File.xs      2022/02/20 20:59:10
  159. @@ -1504,7 +1504,7 @@
  160.             DBT_clear(value) ;
  161.             CurrentDB = db ;
  162.             /* RETVAL = ((db->dbp)->get)(db->dbp, TXN &key, &value, flags) ; */
  163. -           RETVAL = db_get(db, key, value, flags) ;
  164. +           RETVAL = db_get(db, key, value, 0) ;
  165.             ST(0) = sv_newmortal();
  166.             OutputValue(ST(0), value)
  167.         }
  168. @@ -1519,6 +1519,7 @@
  169.           dMY_CXT;
  170.         INIT:
  171.           CurrentDB = db ;
  172. +          flags=0;  /* MJD */
  173.  
  174.  
  175.  void
  176. --- pod/perltie.pod     2022/02/20 20:14:17     1.1
  177. +++ pod/perltie.pod     2022/02/20 21:36:09
  178. @@ -247,7 +247,7 @@
  179.  =item FETCH this, index
  180.  
  181.  This method will be triggered every time an individual element the tied array
  182. -is accessed (read).  It takes one argument beyond its self reference: the
  183. +is accessed (read).  It usually takes one argument beyond its self reference: the
  184.  index whose value we're trying to fetch.
  185.  
  186.      sub FETCH {
  187. @@ -258,7 +258,10 @@
  188.  
  189.  If a negative array index is used to read from an array, the index
  190.  will be translated to a positive one internally by calling FETCHSIZE
  191. -before being passed to FETCH.
  192. +before being passed to FETCH.  This means that tied array classes
  193. +do not need to do anything special to provide Perl's normal behavior
  194. +for negative subscripts.  To provide special behavior, see L<Negative
  195. +Array Subscripts> below.
  196.  
  197.  As you may have noticed, the name of the FETCH method (et al.) is the same
  198.  for all accesses, even though the constructors differ in names (TIESCALAR
  199. @@ -460,6 +463,49 @@
  200.  As with the scalar tie class, this is almost never needed in a
  201.  language that does its own garbage collection, so this time we'll
  202.  just leave it out.
  203. +
  204. +=item Negative Array Subscripts
  205. +
  206. +=for credits
  207. +Mark Jason Dominus mjd@plover.com 20020220
  208. +
  209. +(This is an advanced feature; beginners should ignore it.)
  210. +
  211. +In regular Perl arrays, negative array subscripts count backwards from
  212. +the end of the array, so that C<$a[-1]> and C<$a[$#a]> are always
  213. +identical.  When a tied array is accessed with a negative subscript,
  214. +Perl adjusts the subscript to the equivalent positive number.  Thus,
  215. +tied array classes do not need to do any extra work to emulate Perl's
  216. +normal behavior for negative subscripts.  Hoever, this feature
  217. +prevented tied arrays from treating C<$a[-1]> differently from
  218. +C<$a[$#a]> if they wanted to.
  219. +
  220. +New in Perl 5.7.3, Perl may pass an extra 'flags' argument to
  221. +C<FETCH> and C<STORE>.  The flags argument will indicate whether the
  222. +subscript was transformed from negative to positive.  If desired, your
  223. +C<FETCH> and C<STORE> methods can use this flag to deduce the
  224. +original, untransformed subscript.  To do this, use something like
  225. +this:
  226. +
  227. +        use Tie::Array;
  228. +
  229. +        sub FETCH {
  230. +          my ($self, $n, $flags) = @_;
  231. +
  232. +          if (defined $flags && $flags & Tie::Array::AR_NEGATIVE) {
  233. +            # $n has been adjusted from its negative value
  234. +            # This line will put it back the way it was:
  235. +            $n -= $self->FETCHSIZE;        
  236. +          }
  237. +
  238. +          # continue...  
  239. +          # $n is now original, unadjusted subscript
  240. +        }
  241. +
  242. +Other data may be present in the C<$flags> argument, so don't use
  243. +C<$flags == Tie::Array::AR_NEGATIVE>.  C<$flags> may be omitted if it
  244. +is zero, so the test for C<defined $flags> may be necessary to avoid a
  245. +warning when warnings are enabled.
  246.  
  247.  =back
  248.  
  249. --- lib/Tie/Array.pm    2022/02/20 20:19:47     1.1
  250. +++ lib/Tie/Array.pm    2022/02/20 21:12:05
  251. @@ -7,6 +7,9 @@
  252.  
  253.  # Pod documentation after __END__ below.
  254.  
  255. +# Must match MGp_NEG_INDEX in mg.c
  256. +sub AR_NEGATIVE () { 1 }
  257. +
  258.  sub DESTROY { }
  259.  sub EXTEND  { }
  260.  sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
  261. --- pod/perldelta.pod   2022/02/20 21:24:39     1.1
  262. +++ pod/perldelta.pod   2022/02/20 21:25:45
  263. @@ -504,6 +504,12 @@
  264.  have been relaxed and simplified: now you can have an underscore
  265.  simply B<between digits>.
  266.  
  267. +=item *
  268. +
  269. +C<FETCH> and C<STORE> methods for tied arrays now get an additional
  270. +argument to allow them to determine whether the original subscript was
  271. +negative.  See L<perltie/"Negative Array Subscripts> for details.
  272. +
  273.  =back
  274.  
  275.  =head1 Modules and Pragmata

Raw Paste


Login or Register to edit or fork this paste. It's free.