From cac85e265a2f78adf3094f043c100861b8674bc9 Mon Sep 17 00:00:00 2001 From: Gianni Ceccarelli Date: Thu, 19 Mar 2009 14:37:55 +0100 Subject: the great renaming --- Makefile.PL | 4 +- lib/Tree/Transform/XSLTish.pm | 77 +++++++++++++ lib/Tree/Transform/XSLTish/Context.pm | 9 ++ lib/Tree/Transform/XSLTish/Transformer.pm | 186 ++++++++++++++++++++++++++++++ lib/Tree/Transform/XSLTish/Utils.pm | 21 ++++ t/01-basic.t | 4 +- t/02-inherit.t | 4 +- t/03-byname.t | 2 +- t/04-errors.t | 2 +- 9 files changed, 301 insertions(+), 8 deletions(-) create mode 100644 lib/Tree/Transform/XSLTish.pm create mode 100644 lib/Tree/Transform/XSLTish/Context.pm create mode 100644 lib/Tree/Transform/XSLTish/Transformer.pm create mode 100644 lib/Tree/Transform/XSLTish/Utils.pm diff --git a/Makefile.PL b/Makefile.PL index bb78d3e..11e7649 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,8 +1,8 @@ use inc::Module::Install; -name 'Tree-Transform'; +name 'Tree-Transform-XSLTish'; license 'perl'; -all_from 'lib/Tree/Transform.pm'; +all_from 'lib/Tree/Transform/XSLTish.pm'; requires 'Tree::XPathEngine' => 0, 'Moose' => 0, diff --git a/lib/Tree/Transform/XSLTish.pm b/lib/Tree/Transform/XSLTish.pm new file mode 100644 index 0000000..390616f --- /dev/null +++ b/lib/Tree/Transform/XSLTish.pm @@ -0,0 +1,77 @@ +package Tree::Transform::XSLTish; +use strict; +use warnings; +use Sub::Exporter; +use Params::Validate ':all'; +use Tree::Transform::XSLTish::Utils; +use Tree::Transform::XSLTish::Transformer; +use Carp::Clan qw(^Tree::Transform::XSLTish); + +our $VERSION='0.1'; + +Sub::Exporter::setup_exporter({ + exports => [qw(tree_rule default_rules new_transformer)], + groups => { + default => [ 'tree_rule', + 'default_rules', + 'new_transformer' => {-as => 'new'} ], + } +}); + +sub default_rules { + my $store=Tree::Transform::XSLTish::Utils::_rules_store(scalar caller); + + push @{$store->{by_match}}, + {match=> '/',priority=>0,action=>sub { $_[0]->apply_rules } }, + {match=> '*',priority=>0,action=>sub { $_[0]->apply_rules } }, + ; + return; +} + +sub tree_rule { + my (%args)=validate(@_, { + match => { type => SCALAR, optional => 1 }, + action => { type => CODEREF }, + name => { type => SCALAR, optional => 1}, + priority => { type => SCALAR, default => 1 }, + }); + + # TODO at least one of 'name' and 'match' must be specified + # TODO default priority mased on match + + my $store=Tree::Transform::XSLTish::Utils::_rules_store(scalar caller); + + if ($args{match}) { + push @{$store->{by_match}},\%args; + } + if ($args{name}) { + if (exists $store->{by_name}{$args{name}}) { + carp "Duplicate rule named $args{name}, ignoring"; + return; + } + $store->{by_name}{$args{name}}=\%args; + } + + return; +} + +sub _transformer_class { 'Tree::Transform::XSLTish::Transformer' }; + +sub new_transformer { + my ($rules_package)=@_; + + return _transformer_class->new(rules_package=>$rules_package); +} + +1; +__END__ + +=head1 NAME + +Tree::Transform::XSLTish - transform tree data, like XSLT but in Perl + +=head1 AUTHOR + +Gianni Ceccarelli + +=cut diff --git a/lib/Tree/Transform/XSLTish/Context.pm b/lib/Tree/Transform/XSLTish/Context.pm new file mode 100644 index 0000000..2e696a5 --- /dev/null +++ b/lib/Tree/Transform/XSLTish/Context.pm @@ -0,0 +1,9 @@ +package Tree::Transform::XSLTish::Context; +use Moose; +use Carp::Clan qw(^Tree::Transform::XSLTish); + +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/XSLTish/Transformer.pm b/lib/Tree/Transform/XSLTish/Transformer.pm new file mode 100644 index 0000000..2f8fc52 --- /dev/null +++ b/lib/Tree/Transform/XSLTish/Transformer.pm @@ -0,0 +1,186 @@ +package Tree::Transform::XSLTish::Transformer; +use Moose; +use MooseX::AttributeHelpers; +use Params::Validate ':all'; +use Tree::Transform::XSLTish::Utils; +use Tree::Transform::XSLTish::Context; +use Tree::XPathEngine; +use Carp::Clan qw(^Tree::Transform::XSLTish); + +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::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::XSLTish::ContextGuard->new + ($self, + Tree::Transform::XSLTish::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::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]; + } +} + +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}; + + # 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::XSLTish::ContextGuard; + +sub new { + my ($class,$trans,$context)=@_; + $trans->enter($context); + return bless {trans=>$trans},$class; +} + +sub DESTROY { + $_[0]->{trans}->leave(); +} + +1; +__END__ diff --git a/lib/Tree/Transform/XSLTish/Utils.pm b/lib/Tree/Transform/XSLTish/Utils.pm new file mode 100644 index 0000000..11a25cb --- /dev/null +++ b/lib/Tree/Transform/XSLTish/Utils.pm @@ -0,0 +1,21 @@ +package Tree::Transform::XSLTish::Utils; +use strict; +use warnings; +use Class::MOP; + +my $RULES_NAME='%_tree_transform_rules'; + +sub _rules_store { + my $pack=Class::MOP::Class->initialize($_[0]); + + if (! $pack->has_package_symbol($RULES_NAME) ) { + $pack->add_package_symbol($RULES_NAME,{}); + } + return $pack->get_package_symbol($RULES_NAME); +} + +sub _get_inheritance { + return Class::MOP::Class->initialize($_[0])->class_precedence_list; +} + +1; diff --git a/t/01-basic.t b/t/01-basic.t index 305b67b..7c622e8 100644 --- a/t/01-basic.t +++ b/t/01-basic.t @@ -1,6 +1,6 @@ #!perl package BasicTransform;{ - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; @@ -15,7 +15,7 @@ package BasicTransform;{ } package OtherTransform;{ - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; diff --git a/t/02-inherit.t b/t/02-inherit.t index 3b0f65a..1b1b90a 100644 --- a/t/02-inherit.t +++ b/t/02-inherit.t @@ -1,6 +1,6 @@ #!perl package TransformA;{ - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; @@ -14,7 +14,7 @@ package TransformA;{ package TransformB;{ use base 'TransformA'; - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; diff --git a/t/03-byname.t b/t/03-byname.t index 8b67b65..3c801fa 100644 --- a/t/03-byname.t +++ b/t/03-byname.t @@ -1,6 +1,6 @@ #!perl package NameTransform;{ - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; diff --git a/t/04-errors.t b/t/04-errors.t index 5333303..9e2903a 100644 --- a/t/04-errors.t +++ b/t/04-errors.t @@ -13,7 +13,7 @@ $tree->new_daughter->name("coso$_") for 1..5; warning_like { eval <<'PACK' } [qr/duplicate rule name/i],'Name collision'; package BadTransform;{ - use Tree::Transform; + use Tree::Transform::XSLTish; use strict; use warnings; -- cgit v1.2.3