[libcatmandu-perl] 11/85: Deleting the emit_bind code from the Fix and moving it to the Bind package
Jonas Smedegaard
dr at jones.dk
Tue May 20 09:56:15 UTC 2014
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 23b28c7f8d4b5c0e4c1c1314c3218f03598fee34
Author: Patrick Hochstenbach <patrick.hochstenbach at ugent.be>
Date: Fri May 9 06:58:16 2014 +0200
Deleting the emit_bind code from the Fix and moving it to the Bind package
---
lib/Catmandu/Fix.pm | 63 ++-----------------------------------------
lib/Catmandu/Fix/Bind.pm | 49 ++++++++++++++++++++++++++-------
lib/Catmandu/Fix/Bind/loop.pm | 31 ++++++++++++++++-----
3 files changed, 67 insertions(+), 76 deletions(-)
diff --git a/lib/Catmandu/Fix.pm b/lib/Catmandu/Fix.pm
index 411cd0f..0ea2bd9 100644
--- a/lib/Catmandu/Fix.pm
+++ b/lib/Catmandu/Fix.pm
@@ -25,7 +25,6 @@ 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 binder => (is => 'rw');
has _reject => (is => 'ro', init_arg => undef, default => sub { +{} });
has _reject_var => (is => 'ro', lazy => 1, init_arg => undef, builder => '_build_reject_var');
@@ -165,66 +164,8 @@ sub emit_fixes {
my ($self,$fixes) = @_;
my $perl = '';
- if ($self->binder) {
- # Loop over all 'Catmandu::Fix::Bind' an use the result
- # of a previous bind as input for a new bind. In this way
- # we are sure that every fix is executed once.
-
- my $code = [ map { [ref($_) , $self->emit_fix($_)] } @{$fixes} ];
-
- my $bind_perl = undef;
- my $prev_bind = undef;
- for my $bind (@{$self->binder}) {
- if (defined $bind_perl) {
- $bind_perl = $self->emit_bind($bind,[[$prev_bind , $bind_perl]]);
- }
- else {
- $bind_perl = $self->emit_bind($bind,$code);
- }
- $prev_bind = ref $bind;
- }
-
- $perl .= $bind_perl;
- }
- else {
- for my $fix (@{$fixes}) {
- $perl .= $self->emit_fix($fix);
- }
- }
-
- $perl;
-}
-
-# Wrap an array of fix names and code in bind a bind
-#
-# $bind : a Catmandu::Fix::Bind
-# $code : array of [ $name , $perl]
-#
-# where
-# $name : name of a fix
-# $perl : perl code of a fix
-sub emit_bind {
- my ($self,$bind,$code) = @_;
-
- my $var = $self->var;
-
- my $perl = "";
-
- if (is_instance($bind) && $bind->can('unit') && $bind->can('bind')) {
- my $bind_var = $self->capture($bind);
- my $unit = $self->generate_var;
- $perl .= "my ${unit} = ${bind_var}->unit(${var});";
-
- for my $pair (@$code) {
- my $name = $pair->[0];
- my $code = $pair->[1];
- my $code_var = $self->capture($code);
- $perl .= "${var} = ${bind_var}->bind(${unit}, sub {";
- $perl .= "${var} = shift;";
- $perl .= $code;
- $perl .= "${var}";
- $perl .= "},'$name',${code_var});"
- }
+ for my $fix (@{$fixes}) {
+ $perl .= $self->emit_fix($fix);
}
$perl;
diff --git a/lib/Catmandu/Fix/Bind.pm b/lib/Catmandu/Fix/Bind.pm
index 3c3e1c4..d089818 100644
--- a/lib/Catmandu/Fix/Bind.pm
+++ b/lib/Catmandu/Fix/Bind.pm
@@ -2,38 +2,66 @@ package Catmandu::Fix::Bind;
use Moo::Role;
use namespace::clean;
+use Data::Dumper;
requires 'unit';
requires 'bind';
has fixes => (is => 'rw', default => sub { [] });
+sub BUILD {
+ warn "creating " . $_[0];
+}
+
sub unit {
my ($self,$data) = @_;
return $data;
}
sub bind {
- my ($self,$data,$code,$name) = @_;
+ my ($self,$data,$code,$name) = @_;
return $code->($data);
}
+sub finally {
+ my ($self,$data) = @_;
+ $data;
+}
+
sub emit {
my ($self, $fixer, $label) = @_;
- my $perl = "";
- my $binder = $fixer->binder // [];
+ my $code = [ map { [ref($_) , $fixer->emit_fix($_)] } @{$self->fixes} ];
+ my $perl = $self->emit_bind($fixer,$code);
- push @$binder , $self;
- $fixer->binder($binder);
+ $perl;
+}
- $perl .= $fixer->emit_fixes($self->fixes);
+sub emit_bind {
+ my ($self,$fixer,$code) = @_;
- pop @$binder;
- $binder = undef if (@$binder == 0);
+ my $var = $fixer->var;
- $fixer->binder($binder);
+ my $perl = "";
+ my $bind_var = $fixer->capture($self);
+ my $unit = $fixer->generate_var;
+
+ $perl .= "my ${unit} = ${bind_var}->unit(${var});";
+
+ for my $pair (@$code) {
+ my $name = $pair->[0];
+ my $code = $pair->[1];
+ my $code_var = $fixer->capture($code);
+ $perl .= "${unit} = ${bind_var}->bind(${unit}, sub {";
+ $perl .= "${var} = shift;";
+ $perl .= $code;
+ $perl .= "${var}";
+ $perl .= "},'$name',${code_var});"
+ }
+
+ $perl .= "${unit} = ${bind_var}->finally(${unit});" if $self->can('finally');
+
$perl;
}
@@ -101,6 +129,9 @@ code to run it. It should return the fixed code. A trivial implementaion of 'bin
return $code->($data);
}
+=head2 finally($data)
+
+Optionally finally is executed on the data when all the fixes have run.
=head1 SEE ALSO
diff --git a/lib/Catmandu/Fix/Bind/loop.pm b/lib/Catmandu/Fix/Bind/loop.pm
index 8239de9..767db38 100644
--- a/lib/Catmandu/Fix/Bind/loop.pm
+++ b/lib/Catmandu/Fix/Bind/loop.pm
@@ -6,18 +6,37 @@ with 'Catmandu::Fix::Bind';
has count => (is => 'ro' , default => sub { 1 } );
has index => (is => 'ro');
+has promises => (is => 'rw', default => sub { [] });
sub bind {
my ($self,$data,$code,$name) = @_;
- for (my $i = 0 ; $i < $self->count ; $i++) {
- if (defined $self->index) {
- $data->{$self->index} = $i;
- }
- $data = $code->($data);
- }
+ push @{$self->promises} , [$code,$name];
$data;
}
+sub finally {
+ my ($self,$data) = @_;
+
+ for (my $i = 0 ; $i < $self->count ; $i++) {
+
+ for my $promise (@{$self->promises}) {
+ my ($code,$name) = @$promise;
+ if (defined $self->index) {
+ $data->{$self->index} = $i;
+ }
+ $data = $code->($data);
+ }
+ }
+
+ if (defined $self->index) {
+ delete $data->{$self->index};
+ }
+
+ $self->promises([]);
+
+ $data;
+}
+
1;
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git
More information about the Pkg-perl-cvs-commits
mailing list