From edbd275c4046e3e5c69a05fbca0e5df11f9bf34a Mon Sep 17 00:00:00 2001
From: Gianni Ceccarelli <dakkar@dechirico.(none)>
Date: Thu, 26 Mar 2009 17:33:38 +0100
Subject: custom builder works, it's just ugly

---
 lib/Tree/Template/Declare.pm          | 106 ++++++++++++++++------------------
 lib/Tree/Template/Declare/DAG_Node.pm |  40 +++++++++++++
 t/01-basic.t                          |   2 +-
 t/02-xslt.t                           |   5 +-
 4 files changed, 94 insertions(+), 59 deletions(-)
 create mode 100644 lib/Tree/Template/Declare/DAG_Node.pm

diff --git a/lib/Tree/Template/Declare.pm b/lib/Tree/Template/Declare.pm
index 4e060d4..0cff864 100644
--- a/lib/Tree/Template/Declare.pm
+++ b/lib/Tree/Template/Declare.pm
@@ -9,77 +9,71 @@ use Data::Dumper;
 our $VERSION='0.1';
 
 Sub::Exporter::setup_exporter({
-    exports => [qw(tree node name attribs)],
     groups => {
-        default => [qw(tree node name attribs)],
-        builder => \&_set_builder_for_package,
+        default => \&_build_group,
     },
+    collectors => [ INIT => \&_init_args, 'options' ],
 });
 
-{
-my %builder_for;
-sub _set_builder_for_package {
-    my ($class,$name,$args)=@_;
+sub _init_args {
+    my (undef,$args)=@_;
 
-    my $builder_pkg=$args->{import_args}->[0]->[0];
-
-    if (!ref($builder_pkg)) {
-        if ($builder_pkg=~m{\A \+(\w+) \z}smx) {
-            $builder_pkg="Tree::Template::Declare::$1";
-        }
-        eval "require $builder_pkg";
-        croak "Can't load $builder_pkg: $@" if $@;
-    }
-    $builder_for{$args->{into}}=$builder_pkg;
+    @{$args->{import_args}}=( [ -default => undef] )
+        unless @{$args->{import_args}};
 
     return 1;
 }
 
-sub builder_for {
-    my ($pkg)=@_;
-
-    if (exists $builder_for{$pkg}) {
-        return $builder_for{$pkg};
-    }
-    else {
-        return $pkg;
-    }
-}
-}
+sub _build_group {
+    my ($class,$name,$args,$coll)=@_;
 
-our $current_node;
+    my $builder=$args->{builder} || $coll->{options}{builder};
 
-sub tree(&) {
-    local $current_node=undef;
-    my ($ret)=$_[0]->(caller_args(1));
-    #warn "returning @{[ $ret->name ]}\n";
-    return $ret;
-}
+    if (!ref($builder)) {
+        my $builder_pkg=$builder;
+        if ($builder_pkg=~m{\A \+(\w+) \z}smx) {
+            $builder_pkg="Tree::Template::Declare::$1";
+        }
+        eval "require $builder_pkg";
+        croak "Can't load $builder_pkg: $@" if $@;
 
-sub node(&) {
-    my $node=builder_for(caller)->new_node();
-    #warn "new node\n";
-    {
-        local $current_node=$node;
-        $_[0]->(caller_args(1));
-    }
-    if ($current_node) {
-        #warn "adding to parent (@{[ $current_node->name ]})\n";
-        builder_for(caller)->add_child_node($current_node,$node);
+        if ($builder_pkg->can('new')) {
+            $builder=$builder_pkg->new();
+        }
+        else {
+            $builder=$builder_pkg;
+        }
     }
-    return $node;
-}
 
-sub name($) {
-    #warn "setting name ($_[0])\n";
-    builder_for(caller)->set_node_name($current_node,$_[0]);
-}
+    my @current_node=(undef);
 
-sub attribs {
-    my %attrs=@_;
-    #warn "setting attributes\n";
-    builder_for(caller)->set_node_attributes($current_node,\%attrs);
-    return;
+    return {
+        tree => sub(&) {
+            local $current_node[0]=undef;
+            my ($ret)=$_[0]->(caller_args(1));
+            return $ret;
+        },
+        node => sub (&) {
+            my $node=$builder->new_node();
+            {
+                local $current_node[0]=$node;
+                $_[0]->(caller_args(1));
+            }
+            if ($current_node[0]) {
+                $builder->add_child_node($current_node[0],$node);
+            }
+            return $node;
+        },
+        name => sub ($) {
+            $builder->set_node_name($current_node[0],$_[0]);
+            return;
+        },
+        attribs => sub {
+            my %attrs=@_;
+            $builder->set_node_attributes($current_node[0],\%attrs);
+            return;
+        },
+    };
 }
 
 1;
diff --git a/lib/Tree/Template/Declare/DAG_Node.pm b/lib/Tree/Template/Declare/DAG_Node.pm
new file mode 100644
index 0000000..c005752
--- /dev/null
+++ b/lib/Tree/Template/Declare/DAG_Node.pm
@@ -0,0 +1,40 @@
+package Tree::Template::Declare::DAG_Node;
+use strict;
+use warnings;
+use Carp;
+
+sub new {
+    my ($class,$node_class)=@_;
+    $node_class||='Tree::DAG_Node';
+
+    eval "require $node_class";
+    croak "Can't load $node_class: $@" if $@;
+
+    return bless {nc=>$node_class},$class;
+}
+
+sub new_node {
+    my ($self)=@_;
+
+    return $self->{nc}->new();
+}
+
+sub add_child_node {
+    my ($self,$parent,$child)=@_;
+
+    return $parent->add_daughter($child);
+}
+
+sub set_node_name {
+    my ($self,$node,$name)=@_;
+
+    return $node->name($name);
+}
+
+sub set_node_attributes {
+    my ($self,$node,$attrs)=@_;
+
+    return $node->attributes($attrs);
+}
+
+1;
diff --git a/t/01-basic.t b/t/01-basic.t
index 006fa6a..fe205e1 100644
--- a/t/01-basic.t
+++ b/t/01-basic.t
@@ -2,7 +2,7 @@
 use Test::Most 'no_plan','die';
 use strict;
 use warnings;
-use Tree::Template::Declare '+DAG_Node';
+use Tree::Template::Declare options => {builder => '+DAG_Node'};
 use Data::Dumper;
 
 my $tree=tree {
diff --git a/t/02-xslt.t b/t/02-xslt.t
index 2778586..e47572b 100644
--- a/t/02-xslt.t
+++ b/t/02-xslt.t
@@ -2,7 +2,8 @@
 
 package Copy;{
 use Tree::Transform::XSLTish;
-use Tree::Template::Declare;
+use Tree::Template::Declare::DAG_Node;
+use Tree::Template::Declare options => {builder => Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath') };
 use strict;
 use warnings;
 
@@ -26,7 +27,7 @@ package main;
 use Test::Most 'no_plan','die';
 use strict;
 use warnings;
-use Tree::Template::Declare;
+use Tree::Template::Declare options => {builder => Tree::Template::Declare::DAG_Node->new('Tree::DAG_Node::XPath') };
 use Data::Dumper;
 
 sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
-- 
cgit v1.2.3