From 92f310bf8712f12dbc3717b2529df4694a073310 Mon Sep 17 00:00:00 2001
From: Gianni Ceccarelli <dakkar@dechirico.(none)>
Date: Fri, 20 Mar 2009 15:13:59 +0100
Subject: it's now possible to change the XPath engine for each transformer
 added a test that uses XML::XPathEngine and HTML::TreeBuilder::XPath

---
 Makefile.PL                               |  2 ++
 lib/Tree/Transform/XSLTish.pm             | 32 ++++++++++++++++++++++++--
 lib/Tree/Transform/XSLTish/Transformer.pm | 25 +++++++++++++-------
 t/01-basic.t                              |  1 +
 t/02-inherit.t                            |  1 +
 t/03-byname.t                             |  1 +
 t/04-errors.t                             |  1 +
 t/05-html-tree.t                          | 38 +++++++++++++++++++++++++++++++
 8 files changed, 91 insertions(+), 10 deletions(-)
 create mode 100644 t/05-html-tree.t

diff --git a/Makefile.PL b/Makefile.PL
index 11e7649..bd808dd 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -12,6 +12,8 @@ requires 'Tree::XPathEngine' => 0,
 
 test_requires 'Test::Most'   => 0,
               'Tree::DAG_Node::XPath' => 0,
+              'HTML::TreeBuilder::XPath' => 0,
+              'XML::XPathEngine' => 0,
 ;
 
 WriteAll;
diff --git a/lib/Tree/Transform/XSLTish.pm b/lib/Tree/Transform/XSLTish.pm
index 390616f..8be326d 100644
--- a/lib/Tree/Transform/XSLTish.pm
+++ b/lib/Tree/Transform/XSLTish.pm
@@ -58,9 +58,9 @@ sub tree_rule {
 sub _transformer_class { 'Tree::Transform::XSLTish::Transformer' };
 
 sub new_transformer {
-    my ($rules_package)=@_;
+    my $rules_package=shift;
 
-    return _transformer_class->new(rules_package=>$rules_package);
+    return _transformer_class->new(rules_package=>$rules_package,@_);
 }
 
 1;
@@ -70,6 +70,34 @@ __END__
 
 Tree::Transform::XSLTish - transform tree data, like XSLT but in Perl
 
+=head1 SYNOPSIS
+
+  package MyTransform;
+  use Tree::Transform::XSLTish;
+
+  default_rules;
+
+  tree_rule match => 'node[@id=5]', action => sub {
+    return $_[0]->it->data();
+  };
+
+  package main;
+  use My::Tree;
+
+  my $tree= My::Tree->new();
+  # build something inside the tree
+
+  my ($node5_data)=MyTransform->new->transform($tree);
+
+=head1 DESCRIPTION
+
+This module allows you to transform tree with Perl subroutines, just
+like XSLT does for XML documents.
+
+It tries to model as closely as reasonable the semantic of XSLT.
+
+=head1 REQUIREMENTS
+
 =head1 AUTHOR
 
 Gianni Ceccarelli <dakkar@thenautilus.net>
diff --git a/lib/Tree/Transform/XSLTish/Transformer.pm b/lib/Tree/Transform/XSLTish/Transformer.pm
index 2f8fc52..8b06422 100644
--- a/lib/Tree/Transform/XSLTish/Transformer.pm
+++ b/lib/Tree/Transform/XSLTish/Transformer.pm
@@ -1,12 +1,23 @@
 package Tree::Transform::XSLTish::Transformer;
 use Moose;
 use MooseX::AttributeHelpers;
+use Moose::Util::TypeConstraints;
 use Params::Validate ':all';
 use Tree::Transform::XSLTish::Utils;
 use Tree::Transform::XSLTish::Context;
 use Tree::XPathEngine;
 use Carp::Clan qw(^Tree::Transform::XSLTish);
 
+subtype 'Tree::Transform::XSLTish::Engine'
+    => as 'Object'
+    => where {
+        my $object=$_;
+        for my $meth (qw(findnodes matches exists)) {
+            return unless $object->can($meth);
+        }
+        return 1;
+    };
+
 has 'rules_package' => (is => 'ro', isa => 'ClassName');
 
 has 'context_stack' => (
@@ -24,7 +35,7 @@ has 'context_stack' => (
 
 has 'engine' => (
     is => 'ro',
-    isa => 'Tree::XPathEngine',
+    isa => 'Tree::Transform::XSLTish::Engine',
     default => sub { Tree::XPathEngine->new() },
 );
 
@@ -33,7 +44,7 @@ sub it { $_[0]->context->current_node }
 sub transform {
     my ($self,$tree)=@_;
 
-    return $self->apply_rules($tree->xpath_get_root_node);
+    return $self->apply_rules($self->engine->findnodes('/',$tree));
 }
 
 sub apply_rules {
@@ -44,7 +55,7 @@ sub apply_rules {
             carp 'apply_rules called without nodes nor context!';
             return;
         }
-        @nodes=$self->it->xpath_get_child_nodes();
+        @nodes=$self->engine->findnodes('*',$self->it);
     };
 
     my $guard=Tree::Transform::XSLTish::ContextGuard->new
@@ -153,17 +164,15 @@ sub rule_matches {
     # XXX check the semantic
 
     my $base_node=$node;
-    while (1) {
+    while ($base_node) {
 
         #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;
+
+        ($base_node)=$self->engine->findnodes('..',$base_node);
     }
     return;
 }
diff --git a/t/01-basic.t b/t/01-basic.t
index 7c622e8..a6670a5 100644
--- a/t/01-basic.t
+++ b/t/01-basic.t
@@ -38,6 +38,7 @@ use warnings;
 use Tree::DAG_Node::XPath;
 
 sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
+sub Tree::DAG_Node::XPath::Root::xpath_get_parent_node { return }
 
 my $tree=Tree::DAG_Node::XPath->new();
 $tree->name('base');
diff --git a/t/02-inherit.t b/t/02-inherit.t
index 1b1b90a..fb8e238 100644
--- a/t/02-inherit.t
+++ b/t/02-inherit.t
@@ -35,6 +35,7 @@ use warnings;
 use Tree::DAG_Node::XPath;
 
 sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
+sub Tree::DAG_Node::XPath::Root::xpath_get_parent_node { return }
 
 my $tree=Tree::DAG_Node::XPath->new();
 $tree->name('base');
diff --git a/t/03-byname.t b/t/03-byname.t
index 3c801fa..784138b 100644
--- a/t/03-byname.t
+++ b/t/03-byname.t
@@ -23,6 +23,7 @@ use warnings;
 use Tree::DAG_Node::XPath;
 
 sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
+sub Tree::DAG_Node::XPath::Root::xpath_get_parent_node { return }
 
 my $tree=Tree::DAG_Node::XPath->new();
 $tree->name('base');
diff --git a/t/04-errors.t b/t/04-errors.t
index 9e2903a..107c1bd 100644
--- a/t/04-errors.t
+++ b/t/04-errors.t
@@ -6,6 +6,7 @@ use warnings;
 use Tree::DAG_Node::XPath;
 
 sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] }
+sub Tree::DAG_Node::XPath::Root::xpath_get_parent_node { return }
 
 my $tree=Tree::DAG_Node::XPath->new();
 $tree->name('base');
diff --git a/t/05-html-tree.t b/t/05-html-tree.t
new file mode 100644
index 0000000..a562aba
--- /dev/null
+++ b/t/05-html-tree.t
@@ -0,0 +1,38 @@
+#!perl
+package HtmlTransform;{
+ use Tree::Transform::XSLTish;
+ use strict;
+ use warnings;
+
+ default_rules;
+
+ tree_rule match => 'img[@alt="pick"]', action => sub {
+     return $_[0]->it->findvalue('@src');
+ };
+
+}
+
+package main;
+use Test::Most qw(no_plan die);
+use strict;
+use warnings;
+use HTML::TreeBuilder::XPath;
+
+sub HTML::TreeBuilder::XPath::Root::getRootNode { return $_[0] }
+
+my $tree=HTML::TreeBuilder::XPath->new();
+$tree->parse(<<'HTML');$tree->eof;
+<html>
+ <body>
+  <p>test</p>
+  <img src="nothing" />
+  <img src="this one" alt="pick" />
+ </body>
+</html>
+HTML
+
+{
+my $trans=HtmlTransform->new(engine=>XML::XPathEngine->new());
+my @results=$trans->transform($tree);
+is_deeply \@results,['this one'],'HTML example';
+}
-- 
cgit v1.2.3