[libcatmandu-perl] 08/16: retain fix

[Jonas Smedegaard]

This is an automated email from the git hooks/post-receive script.

js pushed a commit to tag 0.9209
in repository libcatmandu-perl.

commit a2c3e56b9f6cbee7b45ac645d618834bcb253ebc
Author: Nicolas Steenlant <nicolas.steenlant at ugent.be>
Date:   Tue Dec 2 11:25:38 2014 +0100

    retain fix
---
 Build.PL                         | 10 +++----
 lib/Catmandu/Fix.pm              | 13 +++++++++
 lib/Catmandu/Fix/retain.pm       | 62 ++++++++++++++++++++++++++++++++++++++++
 lib/Catmandu/Fix/retain_field.pm |  4 +++
 t/Catmandu-Fix-retain.t          | 26 +++++++++++++++++
 5 files changed, 110 insertions(+), 5 deletions(-)

diff --git a/Build.PL b/Build.PL
index b3d3fe3..f8cc34d 100644
--- a/Build.PL
+++ b/Build.PL
@@ -1,17 +1,17 @@
 
-# This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v5.023.
+# This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v5.017.
 use strict;
 use warnings;
 
-use Module::Build 0.28;
+use Module::Build 0.3601;
 
 
 my %module_build_args = (
   "build_requires" => {
-    "Module::Build" => "0.28"
+    "Module::Build" => "0.3601"
   },
   "configure_requires" => {
-    "Module::Build" => "0.28"
+    "Module::Build" => "0.3601"
   },
   "dist_abstract" => "a data toolkit",
   "dist_author" => [
@@ -72,7 +72,7 @@ my %module_build_args = (
 my %fallback_build_requires = (
   "Log::Any::Adapter" => "0.11",
   "Log::Any::Test" => "0.15",
-  "Module::Build" => "0.28",
+  "Module::Build" => "0.3601",
   "Test::Deep" => "0.112",
   "Test::Exception" => "0.32",
   "Test::More" => "1.001003",
diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm
index 3ad45fc..7a4baf0 100644
--- a/lib/Catmandu/Fix.pm
+++ b/lib/Catmandu/Fix.pm
@@ -232,6 +232,11 @@ sub emit_block {
     $perl;
 }
 
+sub emit_clear_hash_ref {
+    my ($self, $var) = @_;
+    "undef %{${var}} if is_hash_ref(${var});";
+}
+
 sub emit_value {
     my ($self, $val) = @_;
     # Number should look like number and don't start with a 0 (no support for octals)
@@ -735,6 +740,8 @@ be understood by reading the code of existing fix packages.
 
 =item emit_clone
 
+=item emit_clear_hash_ref
+
 =item emit_create_path
 
 =item emit_declare_vars
@@ -745,12 +752,18 @@ be understood by reading the code of existing fix packages.
 
 =item emit_fixes
 
+=item emit_foreach
+
+=item emit_foreach_key
+
 =item emit_get_key
 
 =item emit_reject
 
 =item emit_retain_key
 
+this method is DEPRECATED.
+
 =item emit_set_key
 
 =item emit_string
diff --git a/lib/Catmandu/Fix/retain.pm b/lib/Catmandu/Fix/retain.pm
new file mode 100644
index 0000000..b74cdc7
--- /dev/null
+++ b/lib/Catmandu/Fix/retain.pm
@@ -0,0 +1,62 @@
+package Catmandu::Fix::retain;
+
+use Catmandu::Sane;
+use Moo;
+use Catmandu::Fix::Has;
+
+with 'Catmandu::Fix::Base';
+
+has paths => (fix_arg => 'collect', default => sub { [] });
+
+sub emit {
+    my ($self, $fixer) = @_;
+    my $paths = $self->paths;
+    my $var = $fixer->var;
+    my $tmp_var = $fixer->generate_var;
+    my $perl = $fixer->emit_declare_vars($tmp_var, '{}');
+    for (@$paths) {
+        my $path = $fixer->split_path($_);
+        my $key = pop @$path;
+        $perl .= $fixer->emit_walk_path($var, $path, sub {
+            my ($var) = @_;
+            $fixer->emit_get_key($var, $key, sub {
+                my ($var) = @_;
+                $fixer->emit_create_path($tmp_var, [@$path, $key], sub {
+                    my ($tmp_var) = @_;
+                    "${tmp_var} = ${var};";
+                });
+            });
+        });
+    }
+    # clear data
+    $perl .= $fixer->emit_clear_hash_ref($var);
+    # copy tmp data
+    $perl .= $fixer->emit_foreach_key($tmp_var, sub {
+        my ($key) = @_;
+        "${var}\->{${key}} = ${tmp_var}\->{${key}};";
+    });
+    # free tmp data
+    $perl .= "undef ${tmp_var};";
+    $perl;
+}
+
+=head1 NAME
+
+Catmandu::Fix::retain - delete everything except the paths given
+
+=head1 SYNOPSIS
+
+   # Delete everything except foo.bar and baz.bar
+   retain(foo.bar, baz.bar)
+
+   {bar => 3, foo => {bar => 1, baz => 2}}
+   # becomes
+   {foo => {bar => 1}}
+
+=head1 SEE ALSO
+
+L<Catmandu::Fix>
+
+=cut
+
+1;
diff --git a/lib/Catmandu/Fix/retain_field.pm b/lib/Catmandu/Fix/retain_field.pm
index 0963de8..5ca5646 100644
--- a/lib/Catmandu/Fix/retain_field.pm
+++ b/lib/Catmandu/Fix/retain_field.pm
@@ -23,6 +23,10 @@ sub emit {
 
 Catmandu::Fix::retain_field - delete everything from a field except 
 
+=head1 DEPRECIATION NOTICE
+
+This fix is deprecated, Please use L<Catmandu::Fix::retain> instead.
+
 =head1 SYNOPSIS
 
    # Delete every key from foo except bar
diff --git a/t/Catmandu-Fix-retain.t b/t/Catmandu-Fix-retain.t
new file mode 100644
index 0000000..6161a9b
--- /dev/null
+++ b/t/Catmandu-Fix-retain.t
@@ -0,0 +1,26 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+
+my $pkg;
+BEGIN {
+    $pkg = 'Catmandu::Fix::retain_field';
+    use_ok $pkg;
+}
+
+is_deeply
+    $pkg->new('keep')->fix({remove => 'me', also => 'me', keep => 'me'}),
+    {keep => 'me'};
+
+is_deeply
+    $pkg->new('unknown')->fix({remove => 'me', also => 'me'}),
+    {};
+is_deeply
+    $pkg->new('keep', 'maybe.keep')->fix({remove => 'me', keep => 'me', maybe => {keep => 'me', remove => 'me'}}),
+    {keep => 'me', maybe => {keep => 'me'}};
+
+done_testing 4;
+

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git