diff options
author | Gianni Ceccarelli <dakkar@dechirico.(none)> | 2009-03-19 14:45:23 +0100 |
---|---|---|
committer | Gianni Ceccarelli <dakkar@dechirico.(none)> | 2009-03-19 14:45:23 +0100 |
commit | 8abf3c4080812b0295bbd9b3f658f77d60d76f22 (patch) | |
tree | 9e694bfe52d38cbc7d63edfbaf1c9fafe6fe9341 /lib | |
parent | the great renaming (diff) | |
parent | the great renaming, part 2 (diff) | |
download | Tree-Transform-XSLTish-8abf3c4080812b0295bbd9b3f658f77d60d76f22.tar.gz Tree-Transform-XSLTish-8abf3c4080812b0295bbd9b3f658f77d60d76f22.tar.bz2 Tree-Transform-XSLTish-8abf3c4080812b0295bbd9b3f658f77d60d76f22.zip |
renaming merge
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Tree/Transform.pm | 77 | ||||
-rw-r--r-- | lib/Tree/Transform/Context.pm | 10 | ||||
-rw-r--r-- | lib/Tree/Transform/Transformer.pm | 186 | ||||
-rw-r--r-- | lib/Tree/Transform/Utils.pm | 21 |
4 files changed, 0 insertions, 294 deletions
diff --git a/lib/Tree/Transform.pm b/lib/Tree/Transform.pm deleted file mode 100644 index bf3d18b..0000000 --- a/lib/Tree/Transform.pm +++ /dev/null @@ -1,77 +0,0 @@ -package Tree::Transform; -use strict; -use warnings; -use Sub::Exporter; -use Params::Validate ':all'; -use Tree::Transform::Utils; -use Tree::Transform::Transformer; -use Carp::Clan qw(^Tree::Transform); - -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::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::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::Transformer' }; - -sub new_transformer { - my ($rules_package)=@_; - - return _transformer_class->new(rules_package=>$rules_package); -} - -1; -__END__ - -=head1 NAME - -Tree::Transform - transform tree data, like XSLT but in Perl - -=head1 AUTHOR - -Gianni Ceccarelli <dakkar@thenautilus.net> - -=cut diff --git a/lib/Tree/Transform/Context.pm b/lib/Tree/Transform/Context.pm deleted file mode 100644 index 5e70079..0000000 --- a/lib/Tree/Transform/Context.pm +++ /dev/null @@ -1,10 +0,0 @@ -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 deleted file mode 100644 index 95448af..0000000 --- a/lib/Tree/Transform/Transformer.pm +++ /dev/null @@ -1,186 +0,0 @@ -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__ diff --git a/lib/Tree/Transform/Utils.pm b/lib/Tree/Transform/Utils.pm deleted file mode 100644 index cdc58f7..0000000 --- a/lib/Tree/Transform/Utils.pm +++ /dev/null @@ -1,21 +0,0 @@ -package Tree::Transform::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; |