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.hochstenb...@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 _______________________________________________ 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