From 3a65eeb9b614e7fa4b683db6a98ca0026b5a2404 Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Tue, 17 Mar 2009 17:46:40 +0100 Subject: passes the first test! --- Makefile.PL | 1 + lib/Tree/Transform.pm | 22 +++---- lib/Tree/Transform/Context.pm | 10 ++++ lib/Tree/Transform/Transformer.pm | 120 ++++++++++++++++++++++++++++++++++++++ lib/Tree/Transform/Utils.pm | 13 +++++ t/01-basic.t | 12 +++- 6 files changed, 164 insertions(+), 14 deletions(-) create mode 100644 lib/Tree/Transform/Context.pm create mode 100644 lib/Tree/Transform/Transformer.pm create mode 100644 lib/Tree/Transform/Utils.pm diff --git a/Makefile.PL b/Makefile.PL index c06ad85..bb78d3e 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -7,6 +7,7 @@ all_from 'lib/Tree/Transform.pm'; requires 'Tree::XPathEngine' => 0, 'Moose' => 0, 'Params::Validate' => 0, + 'Carp::Clan' => 0, ; test_requires 'Test::Most' => 0, diff --git a/lib/Tree/Transform.pm b/lib/Tree/Transform.pm index 7b9af2c..d130c3b 100644 --- a/lib/Tree/Transform.pm +++ b/lib/Tree/Transform.pm @@ -1,7 +1,10 @@ package Tree::Transform; -use Moose; +use strict; +use warnings; use Sub::Exporter; use Params::Validate ':all'; +use Tree::Transform::Utils; +use Tree::Transform::Transformer; our $VERSION='0.1'; @@ -13,14 +16,6 @@ Sub::Exporter::setup_exporter({ } }); -sub _rules_store { - no strict 'refs'; - if (!defined *{$_[0].'::_tree_transform_rules'}{HASH}) { - *{$_[0].'::_tree_transform_rules'}={}; - } - return *{$_[0].'::_tree_transform_rules'}{HASH}; -} - sub tree_rule { my (%args)=validate(@_, { match => { type => SCALAR, optional => 1 }, @@ -31,7 +26,7 @@ sub tree_rule { # TODO at least one of 'name' and 'match' must be specified - my $store=_rules_store(scalar caller); + my $store=Tree::Transform::Utils::_rules_store(scalar caller); push @{$store->{by_match}},\%args; if ($args{name}) { @@ -41,10 +36,15 @@ sub tree_rule { return; } +sub _transformer_class { 'Tree::Transform::Transformer' }; + sub new_transformer { + my ($rules_package)=@_; + + return _transformer_class->new(rules_package=>$rules_package); } -__PACKAGE__->meta->make_immutable;no Moose; +1; __END__ =head1 NAME diff --git a/lib/Tree/Transform/Context.pm b/lib/Tree/Transform/Context.pm new file mode 100644 index 0000000..5e70079 --- /dev/null +++ b/lib/Tree/Transform/Context.pm @@ -0,0 +1,10 @@ +package Tree::Transform::Context; +use Moose; +use Tree::Transform::Utils; +use Carp::Clan qw(^Tree::Transform); + +has 'current_node' => ( is => 'rw', isa => 'Object' ); +has 'node_list' => ( is => 'rw', isa => 'ArrayRef[Object]' ); + +__PACKAGE__->meta->make_immutable;no Moose;1; +__END__ diff --git a/lib/Tree/Transform/Transformer.pm b/lib/Tree/Transform/Transformer.pm new file mode 100644 index 0000000..24e5428 --- /dev/null +++ b/lib/Tree/Transform/Transformer.pm @@ -0,0 +1,120 @@ +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(); + }; + + $self->enter(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->($self); + } + + $self->leave; + + return @ret; +} + +sub find_rule { + my ($self,$context)=@_; + + $context||=$self->context; + + my $store=Tree::Transform::Utils::_rules_store($self->rules_package); + + # TODO inheritance + + 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 == 0) { + croak "No valid rule"; + } + + return $candidates[0]->{action}; +} + +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;1; +__END__ diff --git a/lib/Tree/Transform/Utils.pm b/lib/Tree/Transform/Utils.pm new file mode 100644 index 0000000..d8786dd --- /dev/null +++ b/lib/Tree/Transform/Utils.pm @@ -0,0 +1,13 @@ +package Tree::Transform::Utils; +use strict; +use warnings; + +sub _rules_store { + no strict 'refs'; + if (!defined *{$_[0].'::_tree_transform_rules'}{HASH}) { + *{$_[0].'::_tree_transform_rules'}={}; + } + return *{$_[0].'::_tree_transform_rules'}{HASH}; +} + +1; diff --git a/t/01-basic.t b/t/01-basic.t index e9b285b..a6eb0ba 100644 --- a/t/01-basic.t +++ b/t/01-basic.t @@ -9,7 +9,7 @@ package BasicTransform;{ }; tree_rule match => '*', action => sub { - return $_[0]->it->name; + return $_[0]->it->name, $_[0]->apply_rules; } } @@ -20,11 +20,17 @@ use strict; use warnings; use Tree::DAG_Node::XPath; +sub Tree::DAG_Node::XPath::Root::xpath_get_root_node { return $_[0] } + my $tree=Tree::DAG_Node::XPath->new(); +$tree->name('base'); $tree->new_daughter->name("coso$_") for 1..5; my $trans=BasicTransform->new(); -my @results=$trans->apply_rules($tree); +#explain 'root children:',$tree->xpath_get_root_node->xpath_get_child_nodes; +#explain 'root children:',$trans->engine->findnodes('*',$tree); + +my @results=$trans->transform($tree); -is_deeply \@results,[qw(root coso1 coso2 coso3 coso4 coso5)]; +is_deeply \@results,[qw(root base coso1 coso2 coso3 coso4 coso5)]; -- cgit v1.2.3