the great renaming, part 1

1 files changed, 186 insertions, 0 deletions

diff --git a/lib/Tree/Transform/XSLTish/Transformer.pm b/lib/Tree/Transform/XSLTish/Transformer.pm
new file mode 100644
index 0000000..95448af
--- /dev/null
+++ b/lib/Tree/Transform/XSLTish/Transformer.pm
@@ -0,0 +1,186 @@
+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();
+    };
+
+    my $guard=Tree::Transform::ContextGuard->new
+        ($self,
+         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->{action}->($self);
+    }
+
+    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)=@_;
+
+    for my $pack (Tree::Transform::Utils::_get_inheritance
+          ($self->rules_package)) {
+        my $ret=$self->find_rule_in_package($pack,$context);
+        return $ret if $ret;
+    }
+
+    croak "No valid rule";
+}
+
+sub find_rule_by_name {
+    my ($self,$name,$context)=@_;
+
+    for my $pack (Tree::Transform::Utils::_get_inheritance
+          ($self->rules_package)) {
+        my $ret=$self->find_rule_by_name_in_package($pack,$name,$context);
+        return $ret if $ret;
+    }
+
+    croak "No rule named $name";
+}
+
+sub find_rule_in_package {
+    my ($self,$package,$context)=@_;
+
+    $context||=$self->context;
+
+    my $store=Tree::Transform::Utils::_rules_store($package);
+
+    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 >= 1) {
+        return $candidates[0];
+    }
+}
+
+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};
+    }
+}
+
+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;
+
+package Tree::Transform::ContextGuard;
+
+sub new {
+    my ($class,$trans,$context)=@_;
+    $trans->enter($context);
+    return bless {trans=>$trans},$class;
+}
+
+sub DESTROY {
+    $_[0]->{trans}->leave();
+}
+
+1;
+__END__