From d219a89d8d6ecc553851687967473665a78c77c8 Mon Sep 17 00:00:00 2001 From: dakkar Date: Sun, 13 Feb 2011 18:47:12 +0000 Subject: some more notes on an optimizer --- lib/Tree/Transform/XSLTish/Optimizer.pm | 93 ++++++++++++++++++++++ lib/Tree/Transform/XSLTish/Optimizer.pod | 58 +++++++++++++- .../Transform/XSLTish/Optimizer/StructMatcher.pm | 15 ++++ t/08-optimize.t | 31 ++++++++ 4 files changed, 196 insertions(+), 1 deletion(-) create mode 100644 lib/Tree/Transform/XSLTish/Optimizer.pm create mode 100644 lib/Tree/Transform/XSLTish/Optimizer/StructMatcher.pm create mode 100644 t/08-optimize.t diff --git a/lib/Tree/Transform/XSLTish/Optimizer.pm b/lib/Tree/Transform/XSLTish/Optimizer.pm new file mode 100644 index 0000000..d6449ed --- /dev/null +++ b/lib/Tree/Transform/XSLTish/Optimizer.pm @@ -0,0 +1,93 @@ +package Tree::Transform::XSLTish::Optimizer; +use strict; +use warnings; +use Tree::XPathEngine; +use Scalar::Util qw(blessed looks_like_number reftype); + +my $NCName = qr{(?: [A-Za-z_] [\w\\.\\-]* )}x; +my $QName = qr{(?: $NCName : )? $NCName}x; + +sub optimize_single_step { + my ($path) = @_; + + my $s=$path->as_string; + +warn "single: $s\n"; + + if ($s =~ m{\A \( child:: ($QName) \) \z}x) { + return "self::$1",0,0,'any'; + } + + if ($s =~ m{\A \( /descendant:: ($QName) (?: /self::node\(\) )? \) \z}x) { + return "self::$1",0,0,'any'; + } + + return; +} + +sub optimize_simple_path { + my ($path) = @_; + + my $s=$path->as_string; + $s =~ s{/self::node\(\)/}{/}g; + +warn "simple: $s\n"; + + return unless $s =~ m{\A \( + (?: (?:child|/descendant) :: $QName ) + (?: / (?:child|descendant) :: $QName )+ + \) \z}x; + + $s =~ s{/self::node\(\)/}{/}g; + my @steps= reverse grep {$_} split '/',substr($s,1,-1); + + my @new=(); + + while (my $step = shift @steps) { + if ($step =~ m{^child::($QName)$}) { + if (@new) { + push @new,"parent::$1"; + } + else { + push @new,"self::$1"; + } + } + elsif ($step =~ m{^descendant::($QName)$}) { + if (@steps) { + push @new,"ancestor::$1"; + } + else { + push @new,"parent::$1"; + } + } + } + + return unless @new; + + return join('/',@new),0,0,'any'; +} + +my @rules = ( + \&optimize_single_step, + \&optimize_simple_path, +); + +my @flds=qw(opt_pattern min_depth max_depth expected_result); +sub optimize { + my ($class,$rule) = @_; + + return unless $rule->{match}; + + my $path = Tree::XPathEngine->new(NAME=>$QName)->_parse($rule->{match}); + + for my $opt (@rules) { + if (my @ret=$opt->($path)) { + @{$rule}{@flds}=@ret; + return; + } + } + + return; +} + +1; diff --git a/lib/Tree/Transform/XSLTish/Optimizer.pod b/lib/Tree/Transform/XSLTish/Optimizer.pod index ce855d5..e721e72 100644 --- a/lib/Tree/Transform/XSLTish/Optimizer.pod +++ b/lib/Tree/Transform/XSLTish/Optimizer.pod @@ -1,4 +1,6 @@ -C is in fact C (so C does not count) +=head1 random notes + +C is in fact C (so C does not count) C can also be C (check that option) C<..> can also be C @@ -11,3 +13,57 @@ path contains C but no C, apply only at C upwar path contains C but no C<..>, start at C upwards (ok, C counts as 1 C) and go up to root what about C ?? + + +-------- + +an optimizer takes a match rule and adds three slots: + +=over 4 + +=item C + +a pattern to use instead of the C one + +=item C + +enum, specifying what the pattern (either C or C) +should return for this rule to be considered matching: + +=over 8 + +=item C + +the node we are applying the rule to + +=item C + +any node + +=back + +=item C + +the minimum depth (on the C axis) to test; 0 (or +C) means start at the current node, 1 means start at its +parent, and so on + +=item C + +the maximum depth (on the C axis) to test; +C means "unlimited", i.e. stop only at the document root + +=back + +So: + +C<< match => 'foo' >> or C<< match => '//foo' >> would produce C<< +opt_pattern => 'self::foo', min_depth => 0, max_depth => 0 >> + +C<< match => 'foo/bar' >> or C<< match => '//foo/bar' >> would produce +C<< opt_pattern => 'self::bar/parent::foo', min_depth => 0, max_depth +=> 0 >> + +--------- + +we need a proper structure matcher! diff --git a/lib/Tree/Transform/XSLTish/Optimizer/StructMatcher.pm b/lib/Tree/Transform/XSLTish/Optimizer/StructMatcher.pm new file mode 100644 index 0000000..56b19c1 --- /dev/null +++ b/lib/Tree/Transform/XSLTish/Optimizer/StructMatcher.pm @@ -0,0 +1,15 @@ +package Tree::Transform::XSLTish::Optimizer::StructMatcher; +use struct; +use warnings; +use Scalar::Util qw(blessed looks_like_number reftype); + +sub match { + my ($datum,$struct) = @_; + + my $dc=blessed($datum);my $sc=blessed($struct); + my $dr=reftype($datum);my $sr=reftype($struct); + + +} + +1; diff --git a/t/08-optimize.t b/t/08-optimize.t new file mode 100644 index 0000000..bd1b891 --- /dev/null +++ b/t/08-optimize.t @@ -0,0 +1,31 @@ +#!perl +use Test::Most; +use strict; +use warnings; +use Tree::Transform::XSLTish::Optimizer; + +my $o=\&Tree::Transform::XSLTish::Optimizer::optimize; + +my @flds=qw(opt_pattern min_depth max_depth expected_result); +my %cases=( + 'foo' => [ 'self::foo',0,0,'any' ], + '//foo' => [ 'self::foo',0,0,'any' ], + 'foo/bar' => [ 'self::bar/parent::foo',0,0,'any' ], + '//foo/bar' => [ 'self::bar/parent::foo',0,0,'any' ], +); + +while (my ($path,$res) = each %cases) { + + note "testing $path"; + + my $rule = { match => $path }; + $o->('',$rule); + + my $i=0; + for my $field (@flds) { + is($rule->{$field},$res->[$i],"$field ok") if defined $res->[$i]; + ++$i; + } +} + +done_testing; -- cgit v1.2.3