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 e410fa1675c1a801994ca621733c7a5056762f96
Author: Patrick Hochstenbach <patrick.hochstenb...@ugent.be>
Date: Sun May 11 20:45:09 2014 +0200
Maybe needs Just and Nothing and not undef (which is equal to eof)
---
lib/Catmandu/Fix/Bind/maybe.pm | 52 ++++++++++++++++++++++++++++++++++++++----
t/Catmandu-Fix-Bind-list.t | 11 +--------
t/Catmandu-Fix-Bind-maybe.t | 11 +--------
3 files changed, 50 insertions(+), 24 deletions(-)
diff --git a/lib/Catmandu/Fix/Bind/maybe.pm b/lib/Catmandu/Fix/Bind/maybe.pm
index 234261b..92173a7 100644
--- a/lib/Catmandu/Fix/Bind/maybe.pm
+++ b/lib/Catmandu/Fix/Bind/maybe.pm
@@ -2,19 +2,63 @@ package Catmandu::Fix::Bind::maybe;
use Moo;
use Data::Dumper;
+use Scalar::Util qw/reftype/;
with 'Catmandu::Fix::Bind';
+# Copied from hiratara's Data::Monad::Maybe
+sub just {
+ my ($self,@values) = @_;
+ bless [@values] , __PACKAGE__;
+}
+
+sub nothing {
+ my ($self) = @_;
+ bless \(my $d = undef), __PACKAGE__;
+}
+
+sub is_nothing { reftype $_[0] ne 'ARRAY' }
+
+sub value {
+ if (is_nothing($_[0])) {
+ {};
+ } else {
+ $_[0]->[0];
+ }
+}
+# ---
+
+sub unit {
+ my ($self,$data) = @_;
+ $self->just($data);
+}
+
sub bind {
my ($self,$mvar,$func) = @_;
- if (! defined $mvar) {
- return undef;
+ if (is_nothing($mvar)) {
+ return $self->nothing;
}
- my $res = $func->($mvar);
+ my $res;
+
+ eval {
+
+ $res = $func->(value($mvar))
+ };
+ if ($@ && ref $@ eq 'Catmandu::Fix::Reject') {
+ die $@;
+ }
+ else {
+ return $self->nothing;
+ }
- $res;
+ if (defined $res) {
+ return $self->just($res);
+ }
+ else {
+ return $self->nothing;
+ }
}
=head1 NAME
diff --git a/t/Catmandu-Fix-Bind-list.t b/t/Catmandu-Fix-Bind-list.t
index d5d45df..b092c92 100644
--- a/t/Catmandu-Fix-Bind-list.t
+++ b/t/Catmandu-Fix-Bind-list.t
@@ -14,15 +14,6 @@ BEGIN {
}
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)
@@ -115,4 +106,4 @@ is_deeply $fixer->fix(
), {foo => [ {bar => 1 , test => 'bar'} ,
{bar => 2 , test => 'bar'}]} , 'specific testing';
-done_testing 14;
\ No newline at end of file
+done_testing 11;
\ No newline at end of file
diff --git a/t/Catmandu-Fix-Bind-maybe.t b/t/Catmandu-Fix-Bind-maybe.t
index 776a391..63c6969 100644
--- a/t/Catmandu-Fix-Bind-maybe.t
+++ b/t/Catmandu-Fix-Bind-maybe.t
@@ -23,15 +23,6 @@ BEGIN {
}
require_ok $pkg;
-my $monad = Catmandu::Fix::Bind::maybe->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 maybe()
add_field(foo,bar)
@@ -122,4 +113,4 @@ $fixer = Catmandu::Fix->new(fixes => [$fixes]);
is_deeply $fixer->fix({foo => 'bar'}), {foo => 'bar'} , 'specific testing';
-done_testing 14;
\ No newline at end of file
+done_testing 11;
\ 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
