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)) {
return unless $object->can($meth);
}
return 1;
};
has 'rules_package' => (is => 'ro', isa => 'ClassName');
has 'context_stack' => (
metaclass => 'Collection::Array',
is => 'rw',
isa => 'ArrayRef[Tree::Transform::XSLTish::Context]',
default => sub { [] },
provides => {
last => 'context',
push => 'enter',
pop => 'leave',
empty => 'has_context',
},
);
has 'engine' => (
is => 'ro',
isa => 'Tree::Transform::XSLTish::Engine',
lazy => 1,
builder => '_build_engine',
);
sub _build_engine {
my ($self)=@_;
if ($self->rules_package) {
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 transform {
my ($self,$tree)=@_;
return $self->apply_rules($self->engine->findnodes('/',$tree));
}
sub apply_rules {
my ($self,@nodes)=@_;
unless (@nodes) {
unless ($self->has_context) {
carp 'apply_rules called without nodes nor context!';
return;
}
@nodes=$self->engine->findnodes('*',$self->it);
};
my $guard=Tree::Transform::XSLTish::ContextGuard->new
($self,
Tree::Transform::XSLTish::Context->new(node_list=>\@nodes)
);
my @ret;
for my $node (@nodes) {
$self->context->current_node($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::XSLTish::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::XSLTish::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::XSLTish::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];
}
return;
}
sub find_rule_by_name_in_package {
my ($self,$package,$name,$context)=@_;
$context||=$self->context;
my $store=Tree::Transform::XSLTish::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};
my $base_node=$node;
my $test_sub= ($node->can('isSameNode'))?
sub { grep { $node->isSameNode($_) } @_ }
:
sub { grep { "$node" eq "$_" } @_ };
while ($base_node) {
my @selected_nodes=$self->engine->findnodes($path,$base_node);
if ($test_sub->(@selected_nodes)) {
return 1;
}
($base_node)=$self->engine->findnodes('..',$base_node);
}
return;
}
__PACKAGE__->meta->make_immutable;no Moose;
package Tree::Transform::XSLTish::ContextGuard;
sub new {
my ($class,$trans,$context)=@_;
$trans->enter($context);
return bless {trans=>$trans},$class;
}
sub DESTROY {
$_[0]->{trans}->leave();
}
1;
__END__