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

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

commit dadf3afe37e878ad6b4fa6dbb772a92549ee3785
Author: Patrick Hochstenbach <patrick.hochstenb...@ugent.be>
Date:   Sun May 11 09:25:09 2014 +0200

    Adding the list monad
---
 lib/Catmandu/Fix.pm            |  11 ++--
 lib/Catmandu/Fix/Bind.pm       |   6 +--
 lib/Catmandu/Fix/Bind/list.pm  |  86 ++++++++++++++++++++++++++++++
 lib/Catmandu/Fix/Bind/maybe.pm |   7 ++-
 t/Catmandu-Fix-Bind-list.t     | 118 +++++++++++++++++++++++++++++++++++++++++
 5 files changed, 220 insertions(+), 8 deletions(-)

diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm
index 0ea2bd9..cddb26e 100644
--- a/lib/Catmandu/Fix.pm
+++ b/lib/Catmandu/Fix.pm
@@ -1,3 +1,7 @@
+package Catmandu::Fix::Reject;
+
+use Moo;
+
 package Catmandu::Fix;
 
 use Catmandu::Sane;
@@ -25,7 +29,7 @@ has _num_vars   => (is => 'rw', lazy => 1, init_arg => undef, 
default => sub { 0
 has _captures   => (is => 'ro', lazy => 1, init_arg => undef, default => sub { 
+{}; });
 has var         => (is => 'ro', lazy => 1, init_arg => undef, builder => 
'generate_var');
 has fixes       => (is => 'ro', required => 1, trigger => 1);
-has _reject     => (is => 'ro', init_arg => undef, default => sub { +{} });
+has _reject     => (is => 'ro', init_arg => undef, default => sub { 
Catmandu::Fix::Reject->new; });
 has _reject_var => (is => 'ro', lazy => 1, init_arg => undef, builder => 
'_build_reject_var');
 
 sub _build_parser {
@@ -109,6 +113,7 @@ sub emit {
     my $var = $self->var;
     my $err = $self->generate_var;
     my $captures = $self->_captures;
+    my $reject_var = $self->_reject_var;
     my $perl = "";
 
     $perl .= "sub {";
@@ -122,7 +127,7 @@ sub emit {
     $perl .= "} or do {";
     $perl .= $self->emit_declare_vars($err, '$@');
     # TODO throw Catmandu::Error
-    $perl .= qq|die ${err}.Data::Dumper->Dump([${var}], [qw(data)]);|;
+    $perl .= qq|if (${err} == ${reject_var}) { ${err} } else { die 
${err}.Data::Dumper->Dump([${var}], [qw(data)]); }|;
     $perl .= "};";
     $perl .= "};";
 
@@ -174,7 +179,7 @@ sub emit_fixes {
 sub emit_reject {
     my ($self) = @_;
     my $reject_var = $self->_reject_var;
-    "return $reject_var;";
+    "die $reject_var;";
 }
 
 sub emit_fix {
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 54dbd66..1773c68 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -16,7 +16,7 @@ sub unit {
 
 sub bind {
     my ($self,$data,$code,$name,$perl) = @_;
-       return $code->($data);
+         return $code->($data);
 }
 
 sub emit {
@@ -37,6 +37,7 @@ sub emit_bind {
 
     my $bind_var = $fixer->capture($self);
     my $unit     = $fixer->generate_var;
+    my $reject   = $fixer->capture($fixer->_reject);
 
     $perl .= "my ${unit} = ${bind_var}->unit(${var});";
 
@@ -50,9 +51,6 @@ sub emit_bind {
         $perl .= "${var}";
         $perl .= "},'$name',${code_var});"
     }
-
-    my $reject = $fixer->capture($fixer->_reject);
-    $perl .= "return ${unit} if defined ${unit} && ${unit} == ${reject};";
     
     if ($self->return) {
         $perl .= "return ${unit};";
diff --git a/lib/Catmandu/Fix/Bind/list.pm b/lib/Catmandu/Fix/Bind/list.pm
new file mode 100644
index 0000000..93747d3
--- /dev/null
+++ b/lib/Catmandu/Fix/Bind/list.pm
@@ -0,0 +1,86 @@
+package Catmandu::Fix::Bind::list;
+
+use Moo;
+use Data::Dumper;
+use Catmandu::Util;
+
+with 'Catmandu::Fix::Bind';
+
+has path => (is => 'ro');
+
+sub zero {
+       my ($self) = @_;
+       [];
+}
+
+sub plus {
+       my ($self,$a,$b) = @_;
+       push @$a , @$b;
+}
+
+sub unit {
+       my ($self,$data) = @_;
+
+       if (defined $self->path) {
+               Catmandu::Util::data_at($self->path,$data);
+       }
+       elsif (Catmandu::Util::is_array_ref($data)) {
+               $data;
+       }
+       else {
+               [$data];
+       }       
+}
+
+sub bind {
+       my ($self,$mvar,$func,$name) = @_;
+
+       if (Catmandu::Util::is_array_ref($mvar)) {
+               map { $func->($_) } @$mvar;
+       }
+       else {
+               return $self->zero;
+       }
+}
+
+=head1 NAME
+
+Catmandu::Fix::Bind::maybe - a binder that computes Fix-es for every element 
in a list
+
+=head1 SYNOPSIS
+
+ add_field(demo.$append.test,1)
+ add_field(demo.$append.test,2)
+
+ do list(path => demo)
+       add_field(foo,bar)
+ end
+
+ # will produce
+   demo:
+        - test: 1
+          foo: bar
+        - test: 2
+          foo: bar
+
+=head1 DESCRIPTION
+
+The list binder will iterate over all the elements in a list and fixes the 
values in context of that list.
+
+=head1 CONFIGURATION
+
+=head2 path 
+
+The path to a list in the data.
+
+=head1 AUTHOR
+
+Patrick Hochstenbach <Patrick . Hochstenbach @ UGent . be >
+
+=head1 SEE ALSO
+
+L<Catmandu::Fix::Bind>
+
+=cut
+
+1;
\ No newline at end of file
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index c324c9b..c2867cc 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -14,7 +14,12 @@ sub bind {
                $res = $func->($mvar);
        };
        if ($@) {
-               return $mvar;
+               if (ref $@ eq 'Catmandu::Fix::Reject') {
+                       die $@;
+               }
+               else {
+                       return $mvar;
+               }
        }
        
        $res;
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
new file mode 100644
index 0000000..4504ee4
--- /dev/null
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -0,0 +1,118 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use Catmandu::Fix;
+use Catmandu::Importer::Mock;
+use Catmandu::Util qw(:is);
+
+my $pkg;
+BEGIN {
+    $pkg = 'Catmandu::Fix::Bind::list';
+    use_ok $pkg;
+}
+require_ok $pkg;
+
+my $monad = Catmandu::Fix::Bind::list->new();
+my $f     = sub { $_[0]->{demo}  = 1 ; $_[0] };
+my $g     = sub { $_[0]->{demo} += 1 ; $_[0] };
+
+is_deeply $monad->bind( $monad->unit({}), $f) , $f->({}) , "left unit monadic 
law";
+is_deeply $monad->bind( $monad->unit({}), sub { $monad->unit(shift) }) , 
$monad->unit({}) , "right unit monadic law";
+is_deeply $monad->bind( $monad->bind( $monad->unit({}), $f ) , $g )  ,
+          $monad->bind( $monad->unit({}) , sub { $monad->bind($f->($_[0]),$g) 
} ) , "associative monadic law";
+
+my $fixes =<<EOF;
+do list()
+  add_field(foo,bar)
+end
+EOF
+
+my $fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+ok $fixer , 'create fixer';
+
+is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing add_field';
+
+$fixes =<<EOF;
+do list()
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing zero fix 
functions';
+
+$fixes =<<EOF;
+do list()
+  unless exists(foo)
+       add_field(foo,bar)
+  end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({}), {foo => 'bar'} , 'testing unless';
+
+$fixes =<<EOF;
+do list()
+  if exists(foo)
+       add_field(foo2,bar)
+  end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar', foo2 => 'bar'} , 
'testing if';
+
+$fixes =<<EOF;
+do list()
+  reject exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+ok !defined $fixer->fix({foo => 'bar'}) , 'testing reject';
+
+$fixes =<<EOF;
+do list()
+  select exists(foo)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing select';
+
+$fixes =<<EOF;
+do list()
+ do list()
+  do list()
+   add_field(foo,bar)
+  end
+ end
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'testing nesting';
+
+$fixes =<<EOF;
+do list(path => foo)
+  add_field(test,bar)
+end
+EOF
+
+$fixer = Catmandu::Fix->new(fixes => [$fixes]);
+
+is_deeply $fixer->fix(
+             {foo => [ {bar => 1}, {bar => 2} ]}
+          ), {foo => [ {bar => 1 , test => 'bar'} , 
+             {bar => 2 , test => 'bar'}]} , 'specific testing';
+
+done_testing 14;
\ No newline at end of file

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

_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits

Reply via email to