passes the first test!

6 files changed, 164 insertions, 14 deletions

diff --git a/Makefile.PL b/Makefile.PL
index c06ad85..bb78d3e 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -7,6 +7,7 @@ all_from 'lib/Tree/Transform.pm';
 requires 'Tree::XPathEngine' => 0,
          'Moose'             => 0,
          'Params::Validate'  => 0,
+         'Carp::Clan'        => 0,
 ;
 
 test_requires 'Test::Most'   => 0,
diff --git a/lib/Tree/Transform.pm b/lib/Tree/Transform.pm
index 7b9af2c..d130c3b 100644
--- a/lib/Tree/Transform.pm
+++ b/lib/Tree/Transform.pm
@@ -1,7 +1,10 @@
 package Tree::Transform;
-use Moose;
+use strict;
+use warnings;
 use Sub::Exporter;
 use Params::Validate ':all';
+use Tree::Transform::Utils;
+use Tree::Transform::Transformer;
 
 our $VERSION='0.1';
 
@@ -13,14 +16,6 @@ Sub::Exporter::setup_exporter({
     }
 });
 
-sub _rules_store {
-    no strict 'refs';
-    if (!defined *{$_[0].'::_tree_transform_rules'}{HASH}) {
-        *{$_[0].'::_tree_transform_rules'}={};
-    }
-    return *{$_[0].'::_tree_transform_rules'}{HASH};
-}
-
 sub tree_rule {
     my (%args)=validate(@_, {
         match => { type => SCALAR, optional => 1 },
@@ -31,7 +26,7 @@ sub tree_rule {
 
     # TODO at least one of 'name' and 'match' must be specified
 
-    my $store=_rules_store(scalar caller);
+    my $store=Tree::Transform::Utils::_rules_store(scalar caller);
 
     push @{$store->{by_match}},\%args;
     if ($args{name}) {
@@ -41,10 +36,15 @@ sub tree_rule {
     return;
 }
 
+sub _transformer_class { 'Tree::Transform::Transformer' };
+
 sub new_transformer {
+    my ($rules_package)=@_;
+
+    return _transformer_class->new(rules_package=>$rules_package);
 }
 
-__PACKAGE__->meta->make_immutable;no Moose;
+1;
 __END__
 
 =head1 NAME
diff --git a/lib/Tree/Transform/Context.pm b/lib/Tree/Transform/Context.pm
new file mode 100644
index 0000000..5e70079
--- /dev/null
+++ b/lib/Tree/Transform/Context.pm
@@ -0,0 +1,10 @@
+package Tree::Transform::Context;
+use Moose;
+use Tree::Transform::Utils;
+use Carp::Clan qw(^Tree::Transform);
+
+has 'current_node' => ( is => 'rw', isa => 'Object' );
+has 'node_list' => ( is => 'rw', isa => 'ArrayRef[Object]' );
+
+__PACKAGE__->meta->make_immutable;no Moose;1;
+__END__
diff --git a/lib/Tree/Transform/Transformer.pm b/lib/Tree/Transform/Transformer.pm
new file mode 100644
index 0000000..24e5428
--- /dev/null
+++ b/lib/Tree/Transform/Transformer.pm
@@ -0,0 +1,120 @@
+package Tree::Transform::Transformer;
+use Moose;
+use MooseX::AttributeHelpers;
+use Params::Validate ':all';
+use Tree::Transform::Utils;
+use Tree::Transform::Context;
+use Tree::XPathEngine;
+use Carp::Clan qw(^Tree::Transform);
+
+has 'rules_package' => (is => 'ro', isa => 'ClassName');
+
+has 'context_stack' => (
+    metaclass => 'Collection::Array',
+    is => 'rw',
+    isa => 'ArrayRef[Tree::Transform::Context]',
+    default => sub { [] },
+    provides => {
+        last => 'context',
+        push => 'enter',
+        pop => 'leave',
+        empty => 'has_context',
+    },
+);
+
+has 'engine' => (
+    is => 'ro',
+    isa => 'Tree::XPathEngine',
+    default => sub { Tree::XPathEngine->new() },
+);
+
+sub it { $_[0]->context->current_node }
+
+sub transform {
+    my ($self,$tree)=@_;
+
+    return $self->apply_rules($tree->xpath_get_root_node);
+}
+
+sub apply_rules {
+    my ($self,@nodes)=@_;
+
+    unless (@nodes) {
+        unless ($self->has_context) {
+            carp 'apply_rules called without nodes nor context!';
+            return;
+        }
+        @nodes=$self->it->xpath_get_child_nodes();
+    };
+
+    $self->enter(Tree::Transform::Context->new(node_list=>\@nodes));
+
+    my @ret;
+    for my $node (@nodes) {
+        $self->context->current_node($node);
+
+        #warn "# applying rules to @{[ $node ]}";
+
+        my $rule=$self->find_rule();
+        push @ret,$rule->($self);
+    }
+
+    $self->leave;
+
+    return @ret;
+}
+
+sub find_rule {
+    my ($self,$context)=@_;
+
+    $context||=$self->context;
+
+    my $store=Tree::Transform::Utils::_rules_store($self->rules_package);
+
+    # TODO inheritance
+
+    my $rules=$store->{by_match};
+
+    my @candidates=
+        sort { $b->{priority} <=> $a->{priority} }
+            grep { $self->rule_matches($_) } @$rules;
+    if (@candidates > 1 and
+            $candidates[0]->{priority} ==
+                $candidates[1]->{priority}) {
+        croak "Ambiguous rule application";
+    }
+    elsif (@candidates == 0) {
+        croak "No valid rule";
+    }
+
+    return $candidates[0]->{action};
+}
+
+sub rule_matches {
+    my ($self,$rule,$context)=@_;
+
+    $context||=$self->context;
+
+    my $node=$context->current_node;
+    my $path=$rule->{match};
+
+    # XXX check the semantic
+
+    my $base_node=$node;
+    while (1) {
+
+        #warn "# Testing <$path> against @{[ $node ]} based on @{[ $base_node ]}";
+
+        if ($self->engine->matches($node,$path,$base_node)) {
+            return 1;
+        }
+        if ($base_node->xpath_is_document_node) {
+            return;
+        }
+        $base_node=$base_node->xpath_get_parent_node;
+    }
+    return;
+}
+
+__PACKAGE__->meta->make_immutable;no Moose;1;
+__END__
diff --git a/lib/Tree/Transform/Utils.pm b/lib/Tree/Transform/Utils.pm
new file mode 100644
index 0000000..d8786dd
--- /dev/null
+++ b/lib/Tree/Transform/Utils.pm
@@ -0,0 +1,13 @@
+package Tree::Transform::Utils;
+use strict;
+use warnings;
+
+sub _rules_store {
+    no strict 'refs';
+    if (!defined *{$_[0].'::_tree_transform_rules'}{HASH}) {
+        *{$_[0].'::_tree_transform_rules'}={};
+    }
+    return *{$_[0].'::_tree_transform_rules'}{HASH};
+}
+
+1;
diff --git a/t/01-basic.t b/t/01-basic.t
index e9b285b..a6eb0ba 100644
--- a/t/01-basic.t
+++ b/t/01-basic.t
@@ -9,7 +9,7 @@ package BasicTransform;{
  };
 
  tree_rule match => '*', action => sub {
-     return $_[0]->it->name;
+     return $_[0]->it->name, $_[0]->apply_rules;
  }
 
 }
@@ -20,11 +20,17 @@ use strict;
 use warnings;
 use Tree::DAG_Node::XPath;
 
+sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
+
 my $tree=Tree::DAG_Node::XPath->new();
+$tree->name('base');
 $tree->new_daughter->name("coso$_") for 1..5;
 
 my $trans=BasicTransform->new();
 
-my @results=$trans->apply_rules($tree);
+#explain 'root children:',$tree->xpath_get_root_node->xpath_get_child_nodes;
+#explain 'root children:',$trans->engine->findnodes('*',$tree);
+
+my @results=$trans->transform($tree);
 
-is_deeply \@results,[qw(root coso1 coso2 coso3 coso4 coso5)];
+is_deeply \@results,[qw(root base coso1 coso2 coso3 coso4 coso5)];