From: Vincent Pit <vince@profvince.com>
Date: Wed, 1 Apr 2015 12:36:50 +0000 (-0300)
Subject: Implement temp/set_temp on container variables
X-Git-Tag: v0.02~6
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=ff85c569554967a354f1b6d113312fb2899af564;p=perl%2Fmodules%2FVariable-Temp.git

Implement temp/set_temp on container variables

Variable::Magic 0.51 is required.
---

diff --git a/Makefile.PL b/Makefile.PL
index 93f9b63..3391e24 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -12,10 +12,11 @@ my $dist = 'Variable-Temp';
 $file = "lib/$file.pm";
 
 my %PREREQ_PM = (
- 'Exporter'     => 0,
- 'Scope::Upper' => 0,
- 'Test::More'   => 0,
- 'base'         => 0,
+ 'Exporter'        => 0,
+ 'Scope::Upper'    => 0,
+ 'Test::More'      => 0,
+ 'Variable::Magic' => '0.51',
+ 'base'            => 0,
 );
 
 my %BUILD_REQUIRES = (
diff --git a/lib/Variable/Temp.pm b/lib/Variable/Temp.pm
index be72888..5be8073 100644
--- a/lib/Variable/Temp.pm
+++ b/lib/Variable/Temp.pm
@@ -34,11 +34,13 @@ BEGIN {
 
 =head1 DESCRIPTION
 
-This module provides an utility routine that can be used to temporarily change the value of a variable, until the end of the current scope is reached where the original value of the variable is restored.
+This module provides an utility routine that can be used to temporarily change the value of a scalar, array or hash variable, until the end of the current scope is reached where the original value of the variable is restored.
 It is similar to C<local>, except that it can be applied onto lexicals as well as globals, and that it replaces values by copying the new value into the container variable instead of by aliasing.
 
 =cut
 
+use Variable::Magic 0.51;
+
 use Scope::Upper;
 
 =head1 FUNCTIONS
@@ -48,23 +50,72 @@ use Scope::Upper;
     temp $var;
     temp $var = $value;
 
-Temporarily replace the value of the lexical or global variable C<$var> by C<$value>, or by C<undef> if C<$value> is omitted, until the end of the current scope.
-Any subsequent assignments to C<$var> in the current (or any inferior) scope will not affect the original value which will be restored into the variable at scope end.
+    temp @var;
+    temp @var = \@value;
+
+    temp %var;
+    temp %var = \%value;
+
+Temporarily replaces the value of the lexical or global variable C<$var> by C<$value> (respectively C<@var> by C<@value>, C<%var> by C<%value>), or by C<undef> if C<$value> is omitted (respectively empties C<@var> and C<%var> if the second argument is omitted), until the end of the current scope.
+Any subsequent assignments to this variable in the current (or any inferior) scope will not affect the original value which will be restored into the variable at scope end.
 Several C<temp> calls can be made onto the same variable, and the restore are processed in reverse order.
 
-Note that destructors associated with C<$var> will B<not> be called when C<temp> sets the temporary value, but only at the natural end of life of the variable (i.e. at the end of the scope).
-They will trigger after any destructor associated with the replacement C<$value>.
+Note that destructors associated with the variable will B<not> be called when C<temp> sets the temporary value, but only at the natural end of life of the variable.
+They will trigger after any destructor associated with the replacement value.
 
 Due to a shortcoming in the handling of the C<\$> prototype, which was addressed in C<perl> 5.14, the pseudo-statement C<temp $var = $value> will cause compilation errors on C<perl> 5.12.x and below.
 If you want your code to run on these versions of C<perl>, you are encouraged to use L</set_temp> instead.
 
 =cut
 
-sub temp (\$) :lvalue {
- my $var  = $_[0];
- my $save = $$var;
- &Scope::Upper::reap(sub { $$var = $save } => Scope::Upper::UP);
- $$var;
+my $wiz;
+$wiz = Variable::Magic::wizard(
+ data => sub { $_[1] },
+ set  => sub {
+  my ($token, $var) = @_;
+  &Variable::Magic::dispell($token, $wiz);
+  if (ref $var eq 'ARRAY') {
+   @$var = @$$token;
+  } else {
+   %$var = %$$token;
+  }
+  return;
+ },
+ free => sub {
+  my ($token, $var) = @_;
+  # We need Variable::Magic 0.51 so that dispell in free does not crash.
+  &Variable::Magic::dispell($token, $wiz);
+  if (ref $var eq 'ARRAY') {
+   @$var = ();
+  } else {
+   %$var = ();
+  }
+ },
+);
+
+sub temp (\[$@%]) :lvalue {
+ my $var    = $_[0];
+ my $target = Scope::Upper::UP;
+ my $ret;
+ my $type   = ref $var;
+ if ($type eq 'ARRAY') {
+  my @save = @$var;
+  &Scope::Upper::reap(sub { @$var = @save } => $target);
+  my $token;
+  Variable::Magic::cast($token, $wiz, $var);
+  $ret = \$token;
+ } elsif ($type eq 'HASH') {
+  my %save = %$var;
+  &Scope::Upper::reap(sub { %$var = %save } => $target);
+  my $token;
+  Variable::Magic::cast($token, $wiz, $var);
+  $ret = \$token;
+ } else { # $type eq 'SCALAR' || $type eq 'REF'
+  my $save = $$var;
+  &Scope::Upper::reap(sub { $$var = $save } => $target);
+  $ret = $var;
+ }
+ $$ret;
 }
 
 =head2 C<set_temp>
@@ -72,15 +123,33 @@ sub temp (\$) :lvalue {
     set_temp $var;
     set_temp $var => $value;
 
+    set_temp @var;
+    set_temp @var => \@value;
+
+    set_temp %var;
+    set_temp %var => \%value;
+
 A non-lvalue variant of L</temp> that can be used with any version of C<perl>.
 
 =cut
 
-sub set_temp (\$;$) {
- my $var  = $_[0];
- my $save = $$var;
- &Scope::Upper::reap(sub { $$var = $save } => Scope::Upper::UP);
- $$var = $_[1] if @_ >= 2;
+sub set_temp (\[$@%];$) {
+ my $var    = $_[0];
+ my $target = Scope::Upper::UP;
+ my $type   = ref $var;
+ if ($type eq 'ARRAY') {
+  my @save = @$var;
+  &Scope::Upper::reap(sub { @$var = @save } => $target);
+  @$var = @_ >= 2 ? @{$_[1]} : ();
+ } elsif ($type eq 'HASH') {
+  my %save = %$var;
+  &Scope::Upper::reap(sub { %$var = %save } => $target);
+  %$var = @_ >= 2 ? %{$_[1]} : ();
+ } else { # $type eq 'SCALAR' || $type eq 'REF'
+  my $save = $$var;
+  &Scope::Upper::reap(sub { $$var = $save } => $target);
+  $$var = $_[1];
+ }
  return;
 }
 
@@ -96,17 +165,15 @@ our @EXPORT      = ();
 our %EXPORT_TAGS = ();
 our @EXPORT_OK   = qw<temp set_temp>;
 
-=head1 CAVEATS
-
-Currently only applies to scalar variables.
-
 =head1 DEPENDENCIES
 
 L<perl> 5.6.
 
+L<Exporter> (core since perl 5).
+
 L<Scope::Upper>.
 
-L<Exporter> (core since perl 5).
+L<Variable::Magic> 0.51.
 
 =head1 SEE ALSO
 
diff --git a/t/01-import.t b/t/01-import.t
index 2870901..9ece740 100644
--- a/t/01-import.t
+++ b/t/01-import.t
@@ -8,8 +8,8 @@ use Test::More tests => 2 * 2;
 require Variable::Temp;
 
 my %syms = (
- temp     => '\$',
- set_temp => '\$;$',
+ temp     => '\[$@%]',
+ set_temp => '\[$@%];$',
 );
 
 for (sort keys %syms) {
diff --git a/t/10-base.t b/t/10-base.t
index d203f22..f5fb397 100644
--- a/t/10-base.t
+++ b/t/10-base.t
@@ -5,7 +5,14 @@ use warnings;
 
 use Variable::Temp 'set_temp';
 
-use Test::More tests => 7 + 13;
+use Test::More tests => (7 + 2 * 19) * 2 + 6 * 3;
+
+sub describe {
+ my $h = $_[0];
+ return join ', ', map "$_:$h->{$_}", sort keys %$h;
+}
+
+# Lexicals
 
 my $x = 1;
 is $x, 1;
@@ -24,6 +31,104 @@ is $x, 1;
 }
 is $x, 1;
 
+{
+ my @y = (1, 2);
+ is "@y", "1 2";
+ {
+  set_temp @y => [ 3 ];
+  is "@y", '3';
+  @y = (4, 5, 6);
+  is "@y", '4 5 6';
+  $y[3] = 7;
+  is "@y", '4 5 6 7';
+ }
+ is "@y", "1 2";
+ {
+  set_temp @y => [ 8, 9, 10 ];
+  is "@y", '8 9 10';
+  $y[1] = 11;
+  is "@y", '8 11 10';
+ }
+ is "@y", "1 2";
+ {
+  set_temp @y => [ 12, 13, 14 ];
+  is "@y", '12 13 14';
+  set_temp @y => [ 15, 16];
+  is "@y", '15 16';
+ }
+ is "@y", '1 2';
+ {
+  set_temp @y;
+  is "@y", '';
+ }
+ is "@y", '1 2';
+ {
+  set_temp @y => [ qw<a b c> ];
+  is "@y", 'a b c';
+  {
+   local $y[1] = 'd';
+   is "@y", 'a d c';
+   {
+    local @y[2, 3] = qw<e f>;
+    is "@y", 'a d e f';
+   }
+   is "@y", 'a d c';
+  }
+  is "@y", 'a b c';
+ }
+ is "@y", '1 2';
+}
+
+{
+ my %z = (a => 1);
+ is describe(\%z), 'a:1';
+ {
+  set_temp %z => { b => 2 };
+  is describe(\%z), 'b:2';
+  %z = (c => 3);
+  is describe(\%z), 'c:3';
+  $z{d} = 4;
+  is describe(\%z), 'c:3, d:4';
+ }
+ is describe(\%z), 'a:1';
+ {
+  set_temp %z => { a => 5 };
+  is describe(\%z), 'a:5';
+  $z{a} = 6;
+  is describe(\%z), 'a:6';
+ }
+ is describe(\%z), 'a:1';
+ {
+  set_temp %z => { a => 7, d => 8 };
+  is describe(\%z), 'a:7, d:8';
+  set_temp %z => { d => 9, e => 10 };
+  is describe(\%z), 'd:9, e:10';
+ }
+ is describe(\%z), 'a:1';
+ {
+  set_temp %z;
+  is describe(\%z), '';
+ }
+ is describe(\%z), 'a:1';
+ {
+  set_temp %z => { a => 11, f => 12 };
+  is describe(\%z), 'a:11, f:12';
+  {
+   local $z{a} = 13;
+   is describe(\%z), 'a:13, f:12';
+   {
+    local @z{qw<f g>} = (14, 15);
+    is describe(\%z), 'a:13, f:14, g:15';
+   }
+   is describe(\%z), 'a:13, f:12';
+  }
+  is describe(\%z), 'a:11, f:12';
+ }
+ is describe(\%z), 'a:1';
+}
+
+# Globals
+
 our $X = 1;
 is $X, 1;
 {
@@ -57,3 +162,133 @@ is $X, 1;
  is $X, 3;
 }
 is $X, 1;
+
+{
+ our @Y = (1, 2);
+ is "@Y", "1 2";
+ {
+  set_temp @Y => [ 3 ];
+  is "@Y", '3';
+  @Y = (4, 5, 6);
+  is "@Y", '4 5 6';
+  $Y[3] = 7;
+  is "@Y", '4 5 6 7';
+ }
+ is "@Y", "1 2";
+ {
+  set_temp @Y => [ 8, 9, 10 ];
+  is "@Y", '8 9 10';
+  $Y[1] = 11;
+  is "@Y", '8 11 10';
+ }
+ is "@Y", "1 2";
+ {
+  set_temp @Y => [ 12, 13, 14 ];
+  is "@Y", '12 13 14';
+  set_temp @Y => [ 15, 16];
+  is "@Y", '15 16';
+ }
+ is "@Y", '1 2';
+ {
+  set_temp @Y;
+  is "@Y", '';
+ }
+ is "@Y", '1 2';
+ {
+  set_temp @Y => [ qw<a b c> ];
+  is "@Y", 'a b c';
+  {
+   local $Y[1] = 'd';
+   is "@Y", 'a d c';
+   {
+    local @Y[2, 3] = qw<e f>;
+    is "@Y", 'a d e f';
+   }
+   is "@Y", 'a d c';
+  }
+  is "@Y", 'a b c';
+ }
+ is "@Y", '1 2';
+ {
+  local @Y = qw<A B>;
+  is "@Y", 'A B';
+ }
+ is "@Y", '1 2';
+ {
+  local @Y = qw<C D E>;
+  set_temp @Y => [ qw<F> ];
+  is "@Y", 'F';
+ }
+ is "@Y", '1 2';
+ {
+  set_temp @Y => [ qw<G H I> ];
+  local @Y = qw<J>;
+  is "@Y", 'J';
+ }
+ is "@Y", '1 2';
+}
+
+{
+ our %Z = (a => 1);
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z => { b => 2 };
+  is describe(\%Z), 'b:2';
+  %Z = (c => 3);
+  is describe(\%Z), 'c:3';
+  $Z{d} = 4;
+  is describe(\%Z), 'c:3, d:4';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z => { a => 5 };
+  is describe(\%Z), 'a:5';
+  $Z{a} = 6;
+  is describe(\%Z), 'a:6';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z => { a => 7, d => 8 };
+  is describe(\%Z), 'a:7, d:8';
+  set_temp %Z => { d => 9, e => 10 };
+  is describe(\%Z), 'd:9, e:10';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z;
+  is describe(\%Z), '';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z => { a => 11, f => 12 };
+  is describe(\%Z), 'a:11, f:12';
+  {
+   local $Z{a} = 13;
+   is describe(\%Z), 'a:13, f:12';
+   {
+    local @Z{qw<f g>} = (14, 15);
+    is describe(\%Z), 'a:13, f:14, g:15';
+   }
+   is describe(\%Z), 'a:13, f:12';
+  }
+  is describe(\%Z), 'a:11, f:12';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  local %Z = (A => 1, B => 2);
+  is describe(\%Z), 'A:1, B:2';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  local %Z = (A => 3, C => 4);
+  set_temp %Z => { A => 5, D => 6 };
+  is describe(\%Z), 'A:5, D:6';
+ }
+ is describe(\%Z), 'a:1';
+ {
+  set_temp %Z => { A => 7, E => 8 };
+  local %Z = (A => 9, F => 10);
+  is describe(\%Z), 'A:9, F:10';
+ }
+ is describe(\%Z), 'a:1';
+}