Merge branch 'master' of git@luxion:Tree-Transform-XSLTish

Conflicts:

	Makefile.PL

4 files changed, 309 insertions, 34 deletions

diff --git a/lib/Tree/Transform/XSLTish.pm b/lib/Tree/Transform/XSLTish.pm
index e754cd0..e489992 100644
--- a/lib/Tree/Transform/XSLTish.pm
+++ b/lib/Tree/Transform/XSLTish.pm
@@ -6,12 +6,14 @@ use Params::Validate ':all';
 use Tree::Transform::XSLTish::Utils;
 use Tree::Transform::XSLTish::Transformer;
 use Carp::Clan qw(^Tree::Transform::XSLTish);
+use 5.006;
 
-our $VERSION='0.1';
+our $VERSION='0.2';
 
 my @DEFAULT_EXPORTS=('tree_rule',
                      'default_rules',
-                     'new_transformer' => {-as => 'new'});
+                     'new_transformer' => {-as => 'new'},
+                 );
 
 Sub::Exporter::setup_exporter({
     exports => [qw(tree_rule default_rules new_transformer engine_class engine_factory)],
@@ -40,7 +42,7 @@ sub tree_rule {
     });
 
     # TODO at least one of 'name' and 'match' must be specified
-    # TODO default priority mased on match
+    # TODO default priority based on match
 
     my $store=Tree::Transform::XSLTish::Utils::_rules_store(scalar caller);
 
@@ -61,8 +63,10 @@ sub tree_rule {
 sub engine_class {
     my ($classname)=@_;
 
-    my $factory=Tree::Transform::XSLTish::Utils::_engine_factory(scalar caller);
-    $$factory=sub{$classname->new()};
+    Tree::Transform::XSLTish::Utils::_set_engine_factory(
+        scalar caller,
+        sub{$classname->new()},
+    );
 
     return;
 }
@@ -70,18 +74,18 @@ sub engine_class {
 sub engine_factory(&) {
     my ($new_factory)=@_;
 
-    my $factory=Tree::Transform::XSLTish::Utils::_engine_factory(scalar caller);
-    $$factory=$new_factory;
+    Tree::Transform::XSLTish::Utils::_set_engine_factory(
+        scalar caller,
+        $new_factory,
+    );
 
     return;
 }
 
-sub _transformer_class { 'Tree::Transform::XSLTish::Transformer' };
-
 sub new_transformer {
     my $rules_package=shift;
 
-    return _transformer_class->new(rules_package=>$rules_package,@_);
+    return Tree::Transform::XSLTish::Transformer->new(rules_package=>$rules_package,@_);
 }
 
 1;
@@ -117,6 +121,8 @@ Transforming an HTML document:
  use strict;
  use warnings;
 
+ engine_class 'XML::XPathEngine';
+
  default_rules;
 
  tree_rule match => 'img[@alt="pick"]', action => sub {
@@ -124,13 +130,12 @@ Transforming an HTML document:
  };
 
  package main;
- use XML::XPathEngine;
  use HTML::TreeBuilder::XPath;
 
  my $tree=HTML::TreeBuilder::XPath->new();
  $tree->parse_file('mypage.html');
 
- my $trans=HtmlTransform->new(engine=>XML::XPathEngine->new());
+ my $trans=HtmlTransform->new();
  my ($image_srce)=$trans->transform($tree);
 
 =head1 DESCRIPTION
@@ -153,6 +158,136 @@ that are compatible with the XPath engine; for example,
 L<Tree::DAG_Node::XPath> if you use L<Tree::XPathEngine>, or
 L<HTML::TreeBuilder::XPath> if you use L<XML::XPathEngine>.
 
+=head1 EXPORTS
+
+=head2 C<tree_rule>
+
+  tree_rule match => '//node_name',
+            priority => 1,
+            action => sub { ... };
+
+This is the basic fuction to declare a transformation rule; it's
+equivalent to the C<template> element is XSLT. It takes its parameters
+as a hash:
+
+=over 4
+
+=item C<match>
+
+this is equivalent to the C<match> attribute of C<template>: it
+specifies the pattern for the nodes to which this rule applies.
+
+From the L<XSLT spec|http://www.w3.org/TR/xslt.html#NT-Pattern>:
+
+I<A pattern is defined to match a node if and only if there is a
+possible context such that when the pattern is evaluated as an
+expression with that context, the node is a member of the resulting
+node-set. When a node is being matched, the possible contexts have a
+context node that is the node being matched or any ancestor of that
+node, and a context node list containing just the context node.>
+
+=item C<name>
+
+this is equivalent of the C<name> attribute of C<template>: it allows
+calling rules by name (see
+L<call_rule|Tree::Transform::XSLTish::Transformer/call_rule>)
+
+=item C<priority>
+
+this is equivalent of the C<priority> attribute of C<template>;
+currently the "default priority" as specified in the
+L<spec|http://www.w3.org/TR/xslt.html#conflict> is not implemented
+
+=item C<action>
+
+this code-ref will be called (in list context) when the rule is to be
+applied; it can return whatever you want:
+L<call_rule|Tree::Transform::XSLTish::Transformer/call_rule> will
+return the result unchanged,
+L<apply_rules|Tree::Transform::XSLTish::Transformer/apply_rules> will
+return the list of all results of all the applied rules
+
+=back
+
+The C<action> code-ref will be called (by
+L<apply_rules|Tree::Transform::XSLTish::Transformer/apply_rules> or
+L<call_rule|Tree::Transform::XSLTish::Transformer/call_rule>) with a
+L<Tree::Transform::XSLTish::Transformer> object as its only parameter.
+
+=head2 C<default_rules>
+
+This function will declare two rules that mimic the implicit rules of
+XSLT. It's equivalent to:
+
+ tree_rule match => '/', priority => 0, action => sub {$_[0]->apply_rules};
+ tree_rule match => '*', priority => 0, action => sub {$_[0]->apply_rules};
+
+=head2 C<engine_class>
+
+  engine_class 'XML::LibXML::XPathContext';
+
+This function declares that the
+L<Tree::Transform::XSLTish::Transformer> object returned by L</new>
+should use this class to build its XPath engine.
+
+This function is not exported by default: you have to use the module as:
+
+ use Tree::Transform::XSLTish ':engine';
+
+=head2 C<engine_factory>
+
+  engine_factory { My::XPath::Engine->new(params=>$whatever) };
+
+This function declares that the
+L<Tree::Transform::XSLTish::Transformer> object returned by L</new>
+should call the passed code-ref to get its engine.
+
+C<engine_class $classname> is equivalent to C<engine_factory {
+$classname->new }>.
+
+This function is not exported by default: you have to use the module as:
+
+ use Tree::Transform::XSLTish ':engine';
+
+=head2 C<new>
+
+Returns a L<Tree::Transform::XSLTish::Transformer> for the rules
+declared in this package.
+
+=head1 INHERITANCE
+
+L<Stylesheet import|http://www.w3.org/TR/xslt.html#import> is implented
+with the usual Perl inheritance scheme. It should even work with
+L<Class::C3>, since we use L<Class::MOP>'s C<class_precedence_list> to
+get the list of inherited packages.
+
+Engine factories are inherited, too, so you can extend a rules package
+without re-specifying the engine (you can, of course, override this
+and specify another one).
+
+=head1 IMPORTING
+
+This module uses L<Sub::Exporter>, see that module's documentation for
+things like renaming the imports.
+
+=head1 KNOWN BUGS & ISSUES
+
+=over 4
+
+=item *
+
+It's I<slow>. Right now each rule application is linear in the number
+of defined rules I<times> the depth of the node being
+transformed. There are several ways to optimize this for most common
+cases (patches welcome), but I prefer to "make it correct, before
+making it fast"
+
+=item *
+
+Some sugaring with L<Devel::Declare> could make everything look better
+
+=back
+
 =head1 AUTHOR
 
 Gianni Ceccarelli <dakkar@thenautilus.net>
diff --git a/lib/Tree/Transform/XSLTish/Context.pm b/lib/Tree/Transform/XSLTish/Context.pm
index 2e696a5..bb7c9de 100644
--- a/lib/Tree/Transform/XSLTish/Context.pm
+++ b/lib/Tree/Transform/XSLTish/Context.pm
@@ -2,8 +2,20 @@ package Tree::Transform::XSLTish::Context;
 use Moose;
 use Carp::Clan qw(^Tree::Transform::XSLTish);
 
+our $VERSION='0.2';
+
 has 'current_node' => ( is => 'rw', isa => 'Object' );
 has 'node_list' => ( is => 'rw', isa => 'ArrayRef[Object]' );
 
 __PACKAGE__->meta->make_immutable;no Moose;1;
 __END__
+
+=head1 NAME
+
+Tree::Transform::XSLTish::Context - helper class
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
diff --git a/lib/Tree/Transform/XSLTish/Transformer.pm b/lib/Tree/Transform/XSLTish/Transformer.pm
index fd61ea6..a36bd6a 100644
--- a/lib/Tree/Transform/XSLTish/Transformer.pm
+++ b/lib/Tree/Transform/XSLTish/Transformer.pm
@@ -8,14 +8,12 @@ use Tree::Transform::XSLTish::Context;
 use Tree::XPathEngine;
 use Carp::Clan qw(^Tree::Transform::XSLTish);
 
+our $VERSION='0.2';
+
 subtype 'Tree::Transform::XSLTish::Engine'
     => as 'Object'
     => where {
-        my $object=$_;
-        for my $meth (qw(findnodes)) {
-            return unless $object->can($meth);
-        }
-        return 1;
+        return $_->can('findnodes') ? 1 : ();
     };
 
 has 'rules_package' => (is => 'ro', isa => 'ClassName');
@@ -44,15 +42,15 @@ sub _build_engine {
     my ($self)=@_;
 
     if ($self->rules_package) {
-        my $factory=Tree::Transform::XSLTish::Utils::_engine_factory($self->rules_package);
-        if ($$factory) {
-            return $$factory->();
+        my $factory=$self->rules_package->can($Tree::Transform::XSLTish::Utils::ENGINE_FACTORY_NAME);
+        if ($factory) {
+            return $factory->();
         }
     }
     return Tree::XPathEngine->new();
 }
 
-sub it { $_[0]->context->current_node }
+sub it { return $_[0]->context->current_node }
 
 sub transform {
     my ($self,$tree)=@_;
@@ -115,7 +113,7 @@ sub find_rule {
         return $ret if $ret;
     }
 
-    croak "No valid rule";
+    croak 'No valid rule';
 }
 
 sub find_rule_by_name {
@@ -140,16 +138,18 @@ sub find_rule_in_package {
     my $rules=$store->{by_match};
 
     my @candidates=
-        sort { $b->{priority} <=> $a->{priority} }
-            grep { $self->rule_matches($_) } @$rules;
+        sort { $b->{priority} <=> $a->{priority} } ## no critic (ProhibitReverseSortBlock)
+            grep { $self->rule_matches($_) } @{$rules};
     if (@candidates > 1 and
             $candidates[0]->{priority} ==
                 $candidates[1]->{priority}) {
-        croak "Ambiguous rule application";
+        croak 'Ambiguous rule application';
     }
     elsif (@candidates >= 1) {
         return $candidates[0];
     }
+
+    return;
 }
 
 sub find_rule_by_name_in_package {
@@ -200,7 +200,7 @@ sub rule_matches {
 
 __PACKAGE__->meta->make_immutable;no Moose;
 
-package Tree::Transform::XSLTish::ContextGuard;
+package Tree::Transform::XSLTish::ContextGuard; ## no critic (ProhibitMultiplePackages)
 
 sub new {
     my ($class,$trans,$context)=@_;
@@ -210,7 +210,121 @@ sub new {
 
 sub DESTROY {
     $_[0]->{trans}->leave();
+    return;
 }
 
 1;
 __END__
+
+=head1 NAME
+
+Tree::Transform::XSLTish::Transformer - transformer class for L<Tree::Transform::XSLTish>
+
+=head1 METHODS
+
+=head2 C<new>
+
+  $trans=Tree::Transform::XSLTish::Transformer->new(
+    rules_package => 'Some::Package',
+    engine => $engine_instance,
+  );
+
+You usually don't call this constructor directly, but instead use L<<
+the C<new> function exported by
+Tree::Transform::XSLTish|Tree::Transform::XSLTish/new >>, which passes
+the correct C<rules_package> automatically.
+
+If you don't specify an C<engine>, it will be constructed using the
+class or factory declared in the rules package; if you didn't declare
+anything, it will be an instance of L<Tree::XPathEngine>.
+
+=head2 C<transform>
+
+  @results=$trans->transform($tree);
+
+When you call this function on a tree, the transformer will transform
+it according to your rules and to the L<XSLT processing
+model|http://www.w3.org/TR/xslt.html#section-Processing-Model>.
+
+C<< $trans->transform($node) >> is equivalent to C<<
+$trans->apply_rules($trans->engine->findnodes('/',$node)) >>.
+
+Always call this method in list context.
+
+=head2 C<apply_rules>
+
+   $trans->apply_rules(@nodes);
+
+Just like C<apply-rules> in XSLT, this function will apply the rules
+to the specified nodes, or to the children of the current node if none
+are passed, and return all the results in a single list.
+
+This will die if there are no matching rules, or if there are more
+than one matching rule with highest priority.
+
+Always call this method in list context.
+
+=head2 C<call_rule>
+
+  $trans->call_rule('rule-name');
+
+This fuction will apply the named rule to the current node, and return
+the result.
+
+This will die if there is no rule with the given name.
+
+Always call this method in list context.
+
+=head2 C<it>
+
+  $current_node = $trans->it;
+
+Inside a rule, this fuction will return the node to which the rule is
+being applied.
+
+=head1 INTERNAL FUNCTIONS
+
+These functions should not be called from outside this module.
+
+=head2 C<find_rule>
+
+For each package in the linearized inheritance chain of the rules
+package on which this transformer has been instantiated, calls
+L<find_rule_in_package> and returns the first defined result.
+
+=head2 C<find_rule_in_package>
+
+Gets all the rules having a C<match> attribute, filters those for
+which L<rule_matches> returns true, sorts them priority, and returns
+the one with the highest priority.
+
+Dies if there is more than one rule with the highest priority; returns
+undef if there are no matching rules.
+
+=head2 C<find_rule_by_name>
+
+For each package in the linearized inheritance chain of the rules
+package on which this transformer has been instantiated, calls
+L<find_rule_by_name_in_package> and returns the first defined result.
+
+=head2 C<find_rule_by_name_in_package>
+
+Returns the rule with the given name, if any; returns undef otherwise.
+
+=head2 C<rule_matches>
+
+Evaluates the C<match> XPath expression in a sequence of contexts, to
+see if the current node appears in the resulting node-set. If it does,
+returns true; if there is no such context, returns false.
+
+The first context is the current node; following contexts are each the
+parent node of the previous one.
+
+NOTE: to check whether a node appears in a node-set, we either use the
+C<isSameNode> method, or check the stringifications for equality.
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut
diff --git a/lib/Tree/Transform/XSLTish/Utils.pm b/lib/Tree/Transform/XSLTish/Utils.pm
index bed1167..c760585 100644
--- a/lib/Tree/Transform/XSLTish/Utils.pm
+++ b/lib/Tree/Transform/XSLTish/Utils.pm
@@ -3,26 +3,29 @@ use strict;
 use warnings;
 use Class::MOP;
 
+our $VERSION='0.2';
+
 my $RULES_NAME='%_tree_transform_rules';
 
 sub _rules_store {
     my $pack=Class::MOP::Class->initialize($_[0]);
 
-    if (! $pack->has_package_symbol($RULES_NAME) ) { 
+    if (! $pack->has_package_symbol($RULES_NAME) ) {
         $pack->add_package_symbol($RULES_NAME,{});
     }
     return $pack->get_package_symbol($RULES_NAME);
 }
 
-my $ENGINE_FACTORY_NAME='$_tree_transform_engine_factory';
+our $ENGINE_FACTORY_NAME='_tree_transform_engine_factory';
+my $ENGINE_FACTORY_NAME_WITH_SIGIL='&'.$ENGINE_FACTORY_NAME;
 
-sub _engine_factory {
-    my $pack=Class::MOP::Class->initialize($_[0]);
+sub _set_engine_factory {
+    my ($pack_name,$factory)=@_;
+    my $pack=Class::MOP::Class->initialize($pack_name);
 
-    if (! $pack->has_package_symbol($ENGINE_FACTORY_NAME) ) { 
-        $pack->add_package_symbol($ENGINE_FACTORY_NAME,undef);
-    }
-    return $pack->get_package_symbol($ENGINE_FACTORY_NAME);
+    $pack->add_package_symbol($ENGINE_FACTORY_NAME_WITH_SIGIL,$factory);
+
+    return;
 }
 
 
@@ -31,3 +34,14 @@ sub _get_inheritance {
 }
 
 1;
+__END__
+
+=head1 NAME
+
+Tree::Transform::XSLTish::Utils - utility functions
+
+=head1 AUTHOR
+
+Gianni Ceccarelli <dakkar@thenautilus.net>
+
+=cut