lib/Tree/Transform/Transformer.pm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
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__