From: Vincent Pit <vince@profvince.com>
Date: Wed, 24 Jun 2009 16:50:42 +0000 (+0200)
Subject: Handle array and hash slices
X-Git-Tag: v0.04~13
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Fautovivification.git;a=commitdiff_plain;h=68e31f8ce73ddedf82977b4e05ec550c1cfe5688

Handle array and hash slices
---

diff --git a/autovivification.xs b/autovivification.xs
index 6886693..ae8db12 100644
--- a/autovivification.xs
+++ b/autovivification.xs
@@ -409,7 +409,7 @@ STATIC OP *a_pp_rv2av(pTHX) {
 
 /* ... pp_rv2hv ............................................................ */
 
-STATIC OP *a_pp_rv2hv(pTHX) {
+STATIC OP *a_pp_rv2hv_simple(pTHX) {
  a_op_info oi;
  UV flags;
  dSP;
@@ -427,6 +427,29 @@ STATIC OP *a_pp_rv2hv(pTHX) {
  return CALL_FPTR(oi.old_pp)(aTHX);
 }
 
+STATIC OP *a_pp_rv2hv(pTHX) {
+ a_op_info oi;
+ UV flags;
+ dSP;
+
+ a_map_fetch(PL_op, &oi);
+ flags = oi.flags;
+
+ if (flags & A_HINT_DEREF) {
+  if (!SvOK(TOPs)) {
+   SV *hv;
+   POPs;
+   hv = sv_2mortal((SV *) newHV());
+   PUSHs(hv);
+   RETURN;
+  }
+ } else {
+  PL_op->op_ppaddr = oi.old_pp;
+ }
+
+ return CALL_FPTR(oi.old_pp)(aTHX);
+}
+
 /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
 
 STATIC OP *a_pp_deref(pTHX) {
@@ -626,7 +649,7 @@ STATIC OP *a_ck_deref(pTHX_ OP *o) {
   case OP_HELEM:
    old_ck = a_old_ck_helem;
    if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT))
-    a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv);
+    a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple);
    break;
   case OP_RV2SV:
    old_ck = a_old_ck_rv2sv;
@@ -660,7 +683,7 @@ STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
 
  switch (o->op_type) {
   case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
-  case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv; break;
+  case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
  }
  o = CALL_FPTR(old_ck)(aTHX_ o);
 
@@ -677,6 +700,40 @@ STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
  return o;
 }
 
+/* ... ck_xslice (aslice,hslice) ........................................... */
+
+/* I think those are only found at the root, but there's nothing that really
+ * prevent them to be inside the expression too. We only need to update the
+ * root so that the rest of the expression will see the right context when
+ * resolving. That's why we don't replace the ppaddr. */
+
+STATIC OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0;
+STATIC OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0;
+
+STATIC OP *a_ck_xslice(pTHX_ OP *o) {
+ OP * (*old_ck)(pTHX_ OP *o) = 0;
+ UV hint = a_hint();
+
+ switch (o->op_type) {
+  case OP_ASLICE:
+   old_ck = a_old_ck_aslice;
+   break;
+  case OP_HSLICE:
+   old_ck = a_old_ck_hslice;
+   if (hint & A_HINT_DO)
+    a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
+   break;
+ }
+ o = CALL_FPTR(old_ck)(aTHX_ o);
+
+ if (hint & A_HINT_DO) {
+  a_map_store_root(o, 0, hint);
+ } else
+  a_map_delete(o);
+
+ return o;
+}
+
 /* ... ck_root (exists,delete,keys,values) ................................. */
 
 /* Those ops are only found at the root of a dereferencing expression. We can
@@ -768,6 +825,11 @@ BOOT:
   a_old_ck_rv2hv      = PL_check[OP_RV2HV];
   PL_check[OP_RV2HV]  = MEMBER_TO_FPTR(a_ck_rv2xv);
 
+  a_old_ck_aslice     = PL_check[OP_ASLICE];
+  PL_check[OP_ASLICE] = MEMBER_TO_FPTR(a_ck_xslice);
+  a_old_ck_hslice     = PL_check[OP_HSLICE];
+  PL_check[OP_HSLICE] = MEMBER_TO_FPTR(a_ck_xslice);
+
   a_old_ck_exists     = PL_check[OP_EXISTS];
   PL_check[OP_EXISTS] = MEMBER_TO_FPTR(a_ck_root);
   a_old_ck_delete     = PL_check[OP_DELETE];
diff --git a/samples/hash2array.pl b/samples/hash2array.pl
index 8b3419d..e70b69b 100644
--- a/samples/hash2array.pl
+++ b/samples/hash2array.pl
@@ -10,7 +10,10 @@ open my $hash_t,       '<', 't/20-hash.t';
 open my $array_t,      '>', 't/30-array.t';
 open my $array_fast_t, '>', 't/31-array-fast.t';
 
-sub num { ord($_[0]) - ord('a') }
+sub num {
+ my ($char) = $_[0] =~ /['"]?([a-z])['"]?/;
+ return ord($char) - ord('a')
+}
 
 sub hash2array {
  my ($h) = @_;
@@ -46,7 +49,12 @@ while (<$hash_t>) {
   for my $file ([ 1, $array_t ], [ 0, $array_fast_t ]) {
    local $_ = $_;
    s!(\ba\b)?(\s*)HASH\b!($1 ? 'an': '') . "$2ARRAY"!eg;
-   s!->{([a-z])}!my $n = num($1); '->[' . ($file->[0] ? "\$N[$n]" : $n) .']'!eg;
+   s{
+    {\s*(['"]?[a-z]['"]?(?:\s*,\s*['"]?[a-z]['"]?)*)\s*}
+   }{
+    '[' . join(', ', map { my $n = num($_); $file->[0] ? "\$N[$n]" : $n }
+                      split /\s*,\s*/, $1) . ']'
+   }gex;
    s!%(\{?)\$!\@$1\$!g;
    my $buf;
    my $suffix = $_;
diff --git a/t/20-hash.t b/t/20-hash.t
index fa16a37..6438056 100644
--- a/t/20-hash.t
+++ b/t/20-hash.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 * 3 * 274;
+use Test::More tests => 9 * 3 * 290;
 
 use lib 't/lib';
 use autovivification::TestCases;
@@ -130,6 +130,28 @@ $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +exists
 $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +delete
 $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +store
 
+--- slice ---
+
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { }
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef #
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef # +fetch
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { }   # +exists
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { }   # +delete
+$x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { }   # +store
+
+$x->{b} = 0 # my @a = @$x{'a', 'b'}; \@a # '', [ undef, 0 ], { b => 0 } # +fetch
+
+$x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 }
+$x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } #
+$x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +fetch
+$x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +exists
+$x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +delete
+$x # @$x{'a', 'b'} = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x->{a} = 0              # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store
+$x->{c} = 0              # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2, c => 0 } # +store
+$x->{a} = 0, $x->{b} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store
+
 --- exists ---
 
 $x # exists $x->{a} # '', '', { }
diff --git a/t/30-array.t b/t/30-array.t
index feea9eb..d8497f3 100644
--- a/t/30-array.t
+++ b/t/30-array.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 * 3 * 274;
+use Test::More tests => 9 * 3 * 290;
 
 use lib 't/lib';
 use autovivification::TestCases;
@@ -130,6 +130,28 @@ $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists
 $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete
 $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store
 
+--- slice ---
+
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ]
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef #
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef # +fetch
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +exists
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +delete
+$x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +store
+
+$x->[$N[1]] = 0 # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch
+
+$x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ]
+$x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] #
+$x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch
+$x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +exists
+$x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +delete
+$x # @$x[$N[0], $N[1]] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x->[$N[0]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store
+$x->[$N[2]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store
+$x->[$N[0]] = 0, $x->[$N[1]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store
+
 --- exists ---
 
 $x # exists $x->[$N[0]] # '', '', [ ]
diff --git a/t/31-array-fast.t b/t/31-array-fast.t
index 1adab77..6f62040 100644
--- a/t/31-array-fast.t
+++ b/t/31-array-fast.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 9 * 3 * 274;
+use Test::More tests => 9 * 3 * 290;
 
 use lib 't/lib';
 use autovivification::TestCases;
@@ -130,6 +130,28 @@ $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists
 $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete
 $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store
 
+--- slice ---
+
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ]
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef #
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef # +fetch
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +exists
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +delete
+$x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +store
+
+$x->[1] = 0 # my @a = @$x[0, 1]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch
+
+$x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ]
+$x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] #
+$x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch
+$x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +exists
+$x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +delete
+$x # @$x[0, 1] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x->[0] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store
+$x->[2] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store
+$x->[0] = 0, $x->[1] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store
+
 --- exists ---
 
 $x # exists $x->[0] # '', '', [ ]
diff --git a/t/lib/autovivification/TestCases.pm b/t/lib/autovivification/TestCases.pm
index 99d6672..13feb5a 100644
--- a/t/lib/autovivification/TestCases.pm
+++ b/t/lib/autovivification/TestCases.pm
@@ -41,9 +41,11 @@ TESTCASE
 sub testcase_ok {
  local $_  = shift;
  my $sigil = shift;
+
  my @chunks = split /#+/, "$_ ";
  s/^\s+//, s/\s+$// for @chunks;
  my ($init, $code, $exp, $opts) = @chunks;
+
  (my $var = $init) =~ s/[^\$@%\w].*//;
  $init = $var eq $init ? '' : "$init;";
  my $use;
@@ -60,15 +62,19 @@ sub testcase_ok {
   $opts = 'default';
   $use  = '';
  }
+
  my @base = ([ $var, $init, $code, $exp, $use ]);
  if ($var =~ /\$/) {
+  my ($name) = $var =~ /^\$(.*)/;
+
   my @oldderef = @{$base[0]};
   $oldderef[2] =~ s/\Q$var\E\->/\$$var/g;
   push @base, \@oldderef;
 
   my @nonref = @{$base[0]};
-  $nonref[0] =~ s/^\$/$sigil/;
+  $nonref[0] = $sigil . $name;
   for ($nonref[1], $nonref[2]) {
+   s/\@\Q$var\E([\[\{])/\@$name$1/g;
    s/\Q$sigil$var\E/$nonref[0]/g;
    s/\Q$var\E\->/$var/g;
   }
@@ -87,12 +93,14 @@ sub testcase_ok {
   $nonref[3] =~ s/,\s*undef\s*$/, $empty/;
   push @base, \@nonref;
  }
+
  my @testcases = map {
   my ($var, $init, $code, $exp, $use) = @$_;
   [ $var, $init,               $code, $exp, $use, $opts, 0 ],
   [ $var, "use strict; $init", $code, $exp, $use, $opts, 1 ],
   [ $var, "no strict;  $init", $code, $exp, $use, $opts, 1 ],
  } @base;
+
  for (@testcases) {
   my ($testcase, $desc) = generate(@$_);
   my @N = (0 .. 9);