lib/TWiki/Query/Node.pm
author Colas Nahaboo <colas@nahaboo.net>
Sat, 26 Jan 2008 15:50:53 +0100
changeset 0 414e01d06fd5
child 1 e2915a7cbdfa
permissions -rw-r--r--
RELEASE 4.2.0 freetown
     1 # See bottom of file for copyright and license details
     2 
     3 =pod
     4 
     5 ---+ package TWiki::Query
     6 
     7 A Query object is a representation of a query over the TWiki database.
     8 
     9 Fields are given by name, and values by strings or numbers. Strings should always be surrounded by 'single-quotes'. Numbers can be signed integers or decimals. Single quotes in values may be escaped using backslash (\).
    10 
    11 See TWiki.QuerySearch for details of the query language. At the time of writing
    12 only a subset of the entire query language is supported, for use in searching.
    13 
    14 A query object implements the =evaluate= method as its general
    15 contract with the rest of the world. This method does a "hard work" evaluation
    16 of the parser tree. Of course, smarter Store implementations should be
    17 able to do it better....
    18 
    19 =cut
    20 
    21 package TWiki::Query::Node;
    22 use base 'TWiki::Infix::Node';
    23 
    24 use Assert;
    25 use Error qw( :try );
    26 
    27 # 1 for debug
    28 sub MONITOR_EVAL { 0 };
    29 
    30 =pod
    31 
    32 ---++ PUBLIC $aliases
    33 A hash mapping short aliases for META: entry names. For example, this hash
    34 maps 'form' to 'META:FORM'. Published so extensions can extend the range
    35 of supported types.
    36 
    37 ---++ PUBLIC %isArrayType
    38 Maps META: entry type names to true if the type is an array type (such as
    39 FIELD, ATTACHMENT or PREFERENCE). Published so extensions can extend the range
    40 or supported types. The type name should be given without the leading 'META:'
    41 
    42 =cut
    43 
    44 use vars qw ( %aliases %isArrayType );
    45 
    46 %aliases = (
    47     attachments => 'META:FILEATTACHMENT',
    48     fields      => 'META:FIELD',
    49     form        => 'META:FORM',
    50     info        => 'META:TOPICINFO',
    51     moved       => 'META:TOPICMOVED',
    52     parent      => 'META:TOPICPARENT',
    53     preferences => 'META:PREFERENCE',
    54    );
    55 
    56 %isArrayType =
    57   map { $_ => 1 } qw( FILEATTACHMENT FIELD PREFERENCE );
    58 
    59 sub lookupNames {
    60     return 1;
    61 }
    62 
    63 # $data is the indexed object
    64 # $field is the scalar being used to index the object
    65 sub _getField {
    66     my( $this, $data, $field ) = @_;
    67 
    68     my $result;
    69     if (UNIVERSAL::isa($data, 'TWiki::Meta')) {
    70         # The object being indexed is a TWiki::Meta object, so
    71         # we have to use a different approach to treating it
    72         # as an associative array. The first thing to do is to
    73         # apply our "alias" shortcuts.
    74         my $realField = $field;
    75         if( $aliases{$field} ) {
    76             $realField = $aliases{$field};
    77         }
    78         if ($realField =~ s/^META://) {
    79             if ($isArrayType{$realField}) {
    80                 # Array type, have to use find
    81                 my @e = $data->find( $realField );
    82                 $result = \@e;
    83             } else {
    84                 $result = $data->get( $realField );
    85             }
    86         } elsif ($realField eq 'name') {
    87             # Special accessor to compensate for lack of a topic
    88             # name anywhere in the saved fields of meta
    89             return $data->topic();
    90         } elsif ($realField eq 'text') {
    91             # Special accessor to compensate for lack of the topic text
    92             # name anywhere in the saved fields of meta
    93             return $data->text();
    94         } elsif ($realField eq 'web') {
    95             # Special accessor to compensate for lack of a web
    96             # name anywhere in the saved fields of meta
    97             return $data->web();
    98         } else {
    99             # The field name isn't an alias, check to see if it's
   100             # the form name
   101             my $form = $data->get( 'FORM' );
   102             if( $form && $field eq $form->{name}) {
   103                 # SHORTCUT;it's the form name, so give me the fields
   104                 # as if the 'field' keyword had been used.
   105                 # TODO: This is where multiple form support needs to reside.
   106                 # Return the array of FIELD for further indexing.
   107                 my @e = $data->find( 'FIELD' );
   108                 return \@e;
   109             } else {
   110                 # SHORTCUT; not a predefined name; assume it's a field
   111                 # 'name' instead.
   112                 # SMELL: Needs to error out if there are multiple forms -
   113                 # or perhaps have a heuristic that gives access to the
   114                 # uniquely named field.
   115                 $result = $data->get( 'FIELD', $field );
   116                 $result = $result->{value} if $result;
   117             }
   118         }
   119     } elsif( ref( $data ) eq 'ARRAY' ) {
   120         # Indexing an array object. The index will be one of:
   121         # 1. An integer, which is an implicit index='x' query
   122         # 2. A name, which is an implicit name='x' query
   123         if( $field =~ /^\d+$/ ) {
   124             # Integer index
   125             $result = $data->[$field];
   126         } else {
   127             # String index
   128             my @res;
   129             # Get all array entries that match the field
   130             foreach my $f ( @$data ) {
   131                 my $val = $this->_getField( $f, $field );
   132                 push( @res, $val ) if defined( $val );
   133             }
   134             if (scalar( @res )) {
   135                 $result = \@res;
   136             } else {
   137                 # The field name wasn't explicitly seen in any of the records.
   138                 # Try again, this time matching 'name' and returning 'value'
   139                 foreach my $f ( @$data ) {
   140                     next unless ref($f) eq 'HASH';
   141                     if ($f->{name} && $f->{name} eq $field
   142                           && defined $f->{value}) {
   143                         push( @res, $f->{value} );
   144                     }
   145                 }
   146                 if (scalar( @res )) {
   147                     $result = \@res;
   148                 }
   149             }
   150         }
   151     } elsif( ref( $data ) eq 'HASH' ) {
   152         $result = $data->{$this->{params}[0]};
   153     } else {
   154         $result = $this->{params}[0];
   155     }
   156     return $result;
   157 }
   158 
   159 # <DEBUG SUPPORT>
   160 sub toString {
   161     my ($a) = @_;
   162     return 'undef' unless defined($a);
   163     if (ref($a) eq 'ARRAY') {
   164         return '['.join(',', map { toString($_) } @$a).']'
   165     } elsif (UNIVERSAL::isa($a, 'TWiki::Meta')) {
   166         return $a->stringify();
   167     } elsif (ref($a) eq 'HASH') {
   168         return '{'.join(',', map { "$_=>".toString($a->{$_}) } keys %$a).'}'
   169     } else {
   170         return $a;
   171     }
   172 }
   173 
   174 my $ind = 0;
   175 # </DEBUG SUPPORT>
   176 
   177 # Evalute this node by invoking the operator function named in the 'exec'
   178 # field of the operator. The return result is either an array ref (for many
   179 # results) or a scalar (for a single result)
   180 sub evaluate {
   181     my $this = shift;
   182     ASSERT( scalar(@_) % 2 == 0);
   183     my $result;
   184 
   185     print STDERR ('-' x $ind).$this->stringify() if MONITOR_EVAL;
   186 
   187     if (!ref( $this->{op})) {
   188         my %domain = @_;
   189         if ($this->{op} == $TWiki::Infix::Node::NAME &&
   190             defined $domain{data}) {
   191             # a name; look it up in clientData
   192             $result = $this->_getField( $domain{data}, $this->{params}[0]);
   193         } else {
   194             $result = $this->{params}[0];
   195         }
   196     } else {
   197         print STDERR " {\n" if MONITOR_EVAL;
   198         $ind++ if MONITOR_EVAL;
   199         my $fn = $this->{op}->{exec};
   200         $result = $this->$fn( @_ );
   201         $ind-- if MONITOR_EVAL;
   202         print STDERR ('-' x $ind).'}' if MONITOR_EVAL;
   203     }
   204     print STDERR ' -> ',toString($result),"\n" if MONITOR_EVAL;
   205 
   206     return $result;
   207 }
   208 
   209 # Determine if a string represents a valid number
   210 sub _isNumber {
   211     return shift =~ m/^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/;
   212 }
   213 
   214 # Apply a comparison function to two data, tolerant of whether they are
   215 # numeric or not
   216 sub _cmp {
   217     my ($a, $b, $sub) = @_;
   218     if (_isNumber($a) && _isNumber($b)) {
   219         return &$sub($a <=> $b);
   220     } else {
   221         return &$sub($a cmp $b);
   222     }
   223 }
   224 
   225 # Evaluate a node using the comparison function passed in. Extra parameters
   226 # are passed on to the comparison function.
   227 sub _evalTest {
   228     my $this = shift;
   229     my $clientData = shift;
   230     my $sub = shift;
   231     my $a = $this->{params}[0];
   232     my $b = $this->{params}[1];
   233     my $ea = $a->evaluate( @{$clientData} ) || '';
   234     my $eb = $b->evaluate( @{$clientData} ) || '';
   235     if (ref($ea) eq 'ARRAY') {
   236         my @res;
   237         foreach my $lhs (@$ea) {
   238             push(@res, $lhs) if &$sub($lhs, $eb, @_);
   239         }
   240         if (scalar(@res) == 0) {
   241             return undef;
   242         } elsif (scalar(@res) == 1) {
   243             return $res[0];
   244         }
   245         return \@res;
   246     } else {
   247         return &$sub($ea, $eb, @_);
   248     }
   249 }
   250 
   251 sub _evalUnary {
   252     my $this = shift;
   253     my $sub = shift;
   254     my $a = $this->{params}[0];
   255     my $val = $a->evaluate( @_ ) || '';
   256     if (ref($val) eq 'ARRAY') {
   257         my @res = map { &$sub($_) } @$val;
   258         return \@res;
   259     } else {
   260         return &$sub( $val );
   261     }
   262 }
   263 
   264 sub OP_lc {
   265     my $this = shift;
   266     return $this->_evalUnary( sub { lc( shift ) }, @_ );
   267 }
   268 
   269 sub OP_uc {
   270     my $this = shift;
   271     return $this->_evalUnary( sub { uc( shift ) }, @_ );
   272 }
   273 
   274 sub OP_d2n {
   275     my $this = shift;
   276     return $this->_evalUnary(
   277         sub {
   278             my $date = shift;
   279             eval {
   280                 require TWiki::Time;
   281                 $date = TWiki::Time::parseTime( $date, 1);
   282             };
   283             # ignore $@
   284             return $date;
   285         },
   286         @_ );
   287 }
   288 
   289 sub OP_length {
   290     my $this = shift;
   291     my $a = $this->{params}[0];
   292     my $val = $a->evaluate( @_ ) || '';
   293     if (ref($val) eq 'ARRAY') {
   294         return scalar( @$val );
   295     }
   296     return 1;
   297 }
   298 
   299 sub OP_eq {
   300     my $this = shift;
   301     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] == 0 ? 1 : 0 });
   302 }
   303 
   304 sub OP_like {
   305     my $this = shift;
   306     return $this->_evalTest(
   307         \@_,
   308         sub {
   309             my $expr = quotemeta($_[1]);
   310             # quotemeta will have escapes * and ? wildcards
   311             $expr =~ s/\\\?/./g;
   312             $expr =~ s/\\\*/.*/g;
   313             defined($_[0]) && defined($_[1]) &&
   314               $_[0] =~ m/$expr/ ? 1 : 0;
   315         } );
   316 }
   317 
   318 sub OP_ne {
   319     my $this = shift;
   320     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] != 0 ? 1 : 0 });
   321 }
   322 
   323 sub OP_lte {
   324     my $this = shift;
   325     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] <= 0 ? 1 : 0 });
   326 }
   327 
   328 
   329 sub OP_gte {
   330     my $this = shift;
   331     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] >= 0 ? 1 : 0 });
   332 }
   333 
   334 sub OP_gt {
   335     my $this = shift;
   336     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] > 0 ? 1 : 0 });
   337 }
   338 
   339 sub OP_lt {
   340     my $this = shift;
   341     return $this->_evalTest( \@_, \&_cmp, sub { $_[0] < 0 ? 1 : 0 });
   342 }
   343 
   344 sub OP_and {
   345     my $this = shift;
   346     my $a = $this->{params}[0];
   347     return 0 unless $a->evaluate( @_ );
   348     my $b = $this->{params}[1];
   349     return $b->evaluate( @_ );
   350 }
   351 
   352 sub OP_or {
   353     my $this = shift;
   354     my $a = $this->{params}[0];
   355     return 1 if $a->evaluate( @_ );
   356     my $b = $this->{params}[1];
   357     return $b->evaluate( @_ );
   358 }
   359 
   360 sub OP_not {
   361     my $this = shift;
   362     my $a = $this->{params}[0];
   363     return $a->evaluate( @_ ) ? 0 : 1;
   364 }
   365 
   366 sub OP_ob {
   367     my $this = shift;
   368     my $a = $this->{params}[0];
   369     return $a->evaluate( @_ );
   370 }
   371 
   372 sub OP_dot {
   373     my $this = shift;
   374     my %domain = @_;
   375     my $a = $this->{params}[0];
   376     my $lval = $a->evaluate( @_ );
   377     my $b = $this->{params}[1];
   378     my $res = $b->evaluate( data=>$lval, tom=>$domain{tom} );
   379     if (ref($res) eq 'ARRAY' && scalar(@$res) == 1) {
   380         return $res->[0];
   381     }
   382     return $res;
   383 }
   384 
   385 sub OP_ref {
   386     my $this = shift;
   387     my %domain = @_;
   388 
   389     my $session = $domain{tom}->session;
   390     my $topic = $domain{tom}->topic;
   391 
   392     my $a = $this->{params}[0];
   393     my $node = $a->evaluate( @_ );
   394     return undef unless defined $node;
   395     if( ref($node) eq 'HASH') {
   396         return undef;
   397     }
   398     if( !( ref($node) eq 'ARRAY' )) {
   399         $node = [ $node ];
   400     }
   401     my @result;
   402     foreach my $v (@$node) {
   403         next if $v !~ /^($TWiki::regex{webNameRegex}\.)*$TWiki::regex{wikiWordRegex}$/;
   404 
   405         # Has to be relative to the web of the topic we are querying
   406         my( $w, $t ) = $session->normalizeWebTopicName(
   407             $session->{webName}, $v );
   408         my $result = undef;
   409         try {
   410             my $submeta = $domain{tom}->getMetaFor( $w, $t );
   411             my $b = $this->{params}[1];
   412             my $res = $b->evaluate( tom=>$submeta, data=>$submeta );
   413             if( ref($res) eq 'ARRAY') {
   414                 push(@result, @$res);
   415             } else {
   416                 push(@result, $res);
   417             }
   418         } catch Error::Simple with {
   419         };
   420     }
   421     return undef unless scalar( @result );
   422     return $result[0] if scalar(@result) == 1;
   423     return \@result;
   424 }
   425 
   426 sub OP_where {
   427     my $this = shift;
   428     my %domain = @_;
   429     my $a = $this->{params}[0];
   430     my $lval = $a->evaluate( @_ );
   431     my $b = $this->{params}[1];
   432     if (ref($lval) eq 'ARRAY') {
   433         my @res;
   434         foreach my $el (@$lval) {
   435             if ($b->evaluate( data=>$el, tom=>$domain{tom} )) {
   436                 push(@res, $el);
   437             }
   438         }
   439         return undef unless scalar( @res );
   440         return \@res;
   441     } else {
   442         return $b->evaluate( data=>$lval, tom=>$domain{tom} );
   443     }
   444 }
   445 
   446 1;
   447 __DATA__
   448 
   449 Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
   450 
   451 Copyright (C) 2005-2007 TWiki Contributors. All Rights Reserved.
   452 TWiki Contributors are listed in the AUTHORS file in the root of
   453 this distribution. NOTE: Please extend that file, not this notice.
   454 
   455 This program is free software; you can redistribute it and/or
   456 modify it under the terms of the GNU General Public License
   457 as published by the Free Software Foundation; either version 2
   458 of the License, or (at your option) any later version. For
   459 more details read LICENSE in the root of this distribution.
   460 
   461 This program is distributed in the hope that it will be useful,
   462 but WITHOUT ANY WARRANTY; without even the implied warranty of
   463 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
   464 
   465 As per the GPL, removal of this notice is prohibited.
   466 
   467 Author: Crawford Currie http://c-dot.co.uk