call by name

3 files changed, 95 insertions, 3 deletions

diff --git a/lib/Tree/Transform.pm b/lib/Tree/Transform.pm
index febd8e3..bf3d18b 100644
--- a/lib/Tree/Transform.pm
+++ b/lib/Tree/Transform.pm
@@ -5,6 +5,7 @@ use Sub::Exporter;
 use Params::Validate ':all';
 use Tree::Transform::Utils;
 use Tree::Transform::Transformer;
+use Carp::Clan qw(^Tree::Transform);
 
 our $VERSION='0.1';
 
@@ -36,12 +37,19 @@ sub tree_rule {
     });
 
     # TODO at least one of 'name' and 'match' must be specified
+    # TODO default priority mased on match
 
     my $store=Tree::Transform::Utils::_rules_store(scalar caller);
 
-    push @{$store->{by_match}},\%args;
+    if ($args{match}) {
+        push @{$store->{by_match}},\%args;
+    }
     if ($args{name}) {
-        push @{$store->{by_name}{$args{name}}},\%args;
+        if (exists $store->{by_name}{$args{name}}) {
+            carp "Duplicate rule named $args{name}, ignoring";
+            return;
+        }
+        $store->{by_name}{$args{name}}=\%args;
     }
 
     return;
diff --git a/lib/Tree/Transform/Transformer.pm b/lib/Tree/Transform/Transformer.pm
index 685e99e..c188b29 100644
--- a/lib/Tree/Transform/Transformer.pm
+++ b/lib/Tree/Transform/Transformer.pm
@@ -64,6 +64,23 @@ sub apply_rules {
     return @ret;
 }
 
+sub call_rule {
+    my ($self,$name)=@_;
+
+    unless ($name) {
+        carp 'call_rule called without a rule name!';
+        return;
+    }
+
+    unless ($self->has_context) {
+        carp 'call_rule called without context!';
+        return;
+    }
+
+    my $rule=$self->find_rule_by_name($name);
+    return $rule->{action}->($self);
+}
+
 sub find_rule {
     my ($self,$context)=@_;
 
@@ -76,6 +93,18 @@ sub find_rule {
     return $ret;
 }
 
+sub find_rule_by_name {
+    my ($self,$name,$context)=@_;
+
+    my $ret=$self->find_rule_by_name_in_package($self->rules_package,$name,$context);
+
+    if (!$ret) {
+        croak "No rule named $name";
+    }
+
+    return $ret;
+}
+
 sub find_rule_in_package {
     my ($self,$package,$context)=@_;
 
@@ -99,7 +128,27 @@ sub find_rule_in_package {
 
     my @inherited=Tree::Transform::Utils::_get_isa($package);
     for my $inh_pack (@inherited) {
-        my $ret=$self->find_rule_in_package($inh_pack);
+        my $ret=$self->find_rule_in_package($inh_pack,$context);
+        return $ret if $ret;
+    }
+}
+
+sub find_rule_by_name_in_package {
+    my ($self,$package,$name,$context)=@_;
+
+    $context||=$self->context;
+
+    my $store=Tree::Transform::Utils::_rules_store($package);
+
+    my $rules=$store->{by_name};
+
+    if (exists $rules->{$name}) {
+        return $rules->{$name};
+    }
+
+    my @inherited=Tree::Transform::Utils::_get_isa($package);
+    for my $inh_pack (@inherited) {
+        my $ret=$self->find_rule_by_name_in_package($inh_pack,$name,$context);
         return $ret if $ret;
     }
 }
diff --git a/t/03-byname.t b/t/03-byname.t
new file mode 100644
index 0000000..8b67b65
--- /dev/null
+++ b/t/03-byname.t
@@ -0,0 +1,35 @@
+#!perl
+package NameTransform;{
+ use Tree::Transform;
+ use strict;
+ use warnings;
+
+ default_rules;
+
+ tree_rule match => 'coso3', action => sub {
+     return $_[0]->call_rule('munge');
+ };
+
+ tree_rule name => 'munge', action => sub {
+     return 'munged-'.$_[0]->it->name;
+ };
+
+}
+
+package main;
+use Test::Most qw(no_plan die);
+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=NameTransform->new();
+my @results=$trans->transform($tree);
+is_deeply \@results,[qw(munged-coso3)];
+}