# 
# The contents of this file are subject to the Mozilla Public
# License Version 1.1 (the "License"); you may not use this file
# except in compliance with the License. You may obtain a copy of
# the License at http://www.mozilla.org/MPL/
# 
# Software distributed under the License is distributed on an "AS
# IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
# implied. See the License for the specific language governing
# rights and limitations under the License.
# 
# The Original Code is the RDF::Core module
# 
# The Initial Developer of the Original Code is Ginger Alliance Ltd.
# Portions created by Ginger Alliance are 
# Copyright (C) 2001 Ginger Alliance Ltd.
# All Rights Reserved.
# 
# Contributor(s):
# 
# Alternatively, the contents of this file may be used under the
# terms of the GNU General Public License Version 2 or later (the
# "GPL"), in which case the provisions of the GPL are applicable 
# instead of those above.  If you wish to allow use of your 
# version of this file only under the terms of the GPL and not to
# allow others to use your version of this file under the MPL,
# indicate your decision by deleting the provisions above and
# replace them with the notice and other provisions required by
# the GPL.  If you do not delete the provisions above, a recipient
# may use your version of this file under either the MPL or the
# GPL.
# 

package RDF::Core::Query;

use strict;
require Exporter;


use Carp;

# token types
use constant TOK_NONE     => 'TOK_NONE';
use constant TOK_END      => 'TOK_END';

use constant TOK_LITERAL  => 'TOK_LITERAL';
use constant TOK_VAR      => 'TOK_VAR';
use constant TOK_URI      => 'TOK_URI';
use constant TOK_NAME     => 'TOK_NAME';

use constant TOK_CLASS    => 'TOK_CLASS';
use constant TOK_MATCH    => 'TOK_MATCH';

use constant TOK_LPAREN   => 'TOK_LPAREN';
use constant TOK_RPAREN   => 'TOK_RPAREN';
use constant TOK_LCUR     => 'TOK_LCUR';
use constant TOK_RCUR     => 'TOK_RCUR';
use constant TOK_PERIOD   => 'TOK_PERIOD';
use constant TOK_COMMA    => 'TOK_COMMA';
use constant TOK_COLON    => 'TOK_COLON';
use constant TOK_PIPE     => 'TOK_PIPE';
use constant TOK_EQ       => 'TOK_EQ';
use constant TOK_LE       => 'TOK_LE';
use constant TOK_LT       => 'TOK_LT';
use constant TOK_GE       => 'TOK_GE';
use constant TOK_GT       => 'TOK_GT';

use constant TOK_SELECT   => 'TOK_SELECT';
use constant TOK_WHERE    => 'TOK_WHERE';
use constant TOK_FROM     => 'TOK_FROM';
use constant TOK_AND      => 'TOK_AND';
use constant TOK_OR       => 'TOK_OR';

#query syntax elements

use constant Q_QUERY        => 'QUERY';
use constant Q_RESULTSET    => 'RESULTSET';
use constant Q_SOURCE       => 'SOURCE';
use constant Q_SOURCEPATH   => 'SOURCEPATH';
use constant Q_HASTARGET    => 'HASTARGET';
use constant Q_TARGET       => 'TARGET';
use constant Q_CONDITION    => 'CONDITION';
use constant Q_MATCH        => 'MATCH';
use constant Q_PATH         => 'PATH';
use constant Q_CLASSPATH    => 'CLASSPATH';
use constant Q_ELEMENTS     => 'ELEMENTS';
use constant Q_ELEMENTPATH  => 'ELEMENTPATH';
use constant Q_ELEMENT      => 'ELEMENT';
use constant Q_FUNCTION     => 'FUNCTION';
use constant Q_NODE         => 'NODE';
use constant Q_VARIABLE     => 'VARIABLE';
use constant Q_URIDEF       => 'URIDEF';
use constant Q_NAME         => 'NAME';
use constant Q_EXPRESSION   => 'EXPRESSION';
use constant Q_CONNECTION   => 'CONNECTION';
use constant Q_RELATION     => 'RELATION';
use constant Q_OPERATION    => 'OPERATION';
use constant Q_LITERAL      => 'LITERAL';
use constant Q_URI          => 'URI';

sub new {
    my ($pkg,%options) = @_;
    $pkg = ref $pkg || $pkg;
    my $self = {};
    $self->{_options} = \%options;
    bless $self, $pkg;
}

sub getOptions {
    my $self = shift;
    return $self->{_options};
}

sub query {
    my ($self, $queryString) = @_;
    my @tokens = $self->_tokenize($queryString);
    $self->_parse (\@tokens);
    my $rs = $self->getOptions->{Evaluator}->evaluate($self->{QUERY}[0]);
    return $rs;

}

sub _tokenize {
    #Translate query string into an array of tokens
    #token's properties: type, value

    my ($self, $queryString) = @_;
    print "Tokenizing $queryString"
      if $self->getOptions->{Debug};
    my @tokens;
    my $pos = 0;
    my $lastToken = -1;
    until ($lastToken eq TOK_END || $lastToken eq TOK_NONE) {
	my $token = $self->_nextToken(\$queryString,\$pos);
	push @tokens, $token;
	$lastToken = $token->{type};
    }
    return @tokens;
}
sub _nextToken {
    my ($self, $str, $pos) = @_;
    my $retVal;
    $retVal->{type} = TOK_NONE;
    
    #skip blank spaces
    while (substr($$str, $$pos, 1) =~ /\s/) {
	$$pos++;
    }
    
    my $firstChar = substr($$str, $$pos, 1);
    my $secondChar = substr($$str, $$pos + 1, 1);
    
    print "\tgetting next token at pos $$pos, from ",substr ($$str, $$pos, 20)
      if $self->getOptions->{Debug};
    
    if ($firstChar eq '') {
	$retVal->{type} = TOK_END;
    } elsif ($firstChar eq '(') {
	$retVal->{type} = TOK_LPAREN;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq ')') {
	$retVal->{type} = TOK_RPAREN;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq '{') {
	$retVal->{type} = TOK_LCUR;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq '}') {
	$retVal->{type} = TOK_RCUR;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq '.') {
	$retVal->{type} = TOK_PERIOD;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq ',') {
	$retVal->{type} = TOK_COMMA;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq '|') {
	$retVal->{type} = TOK_PIPE;
	$retVal->{value} = $firstChar;
	$$pos++;
    } elsif ($firstChar eq '=') {
	if ($secondChar eq '>') {
	    $retVal->{type} = TOK_MATCH;
	    $retVal->{value} = $firstChar.$secondChar;
	    $$pos += 2;
	} else {
	    $retVal->{type} = TOK_EQ;
	    $retVal->{value} = $firstChar;
	    $$pos++;
	}
    } elsif ($firstChar eq '<') {
	if ($secondChar eq '=') {
	    $retVal->{type} = TOK_LE;
	    $retVal->{value} = $firstChar.$secondChar;
	    $$pos += 2;
	} else {
	    $retVal->{type} = TOK_LT;
	    $retVal->{value} = $firstChar;
	    $$pos++;
	}
    } elsif ($firstChar eq '>') {
	if ($secondChar eq '=') {
	    $retVal->{type} = TOK_GE;
	    $retVal->{value} = $firstChar.$secondChar;
	    $$pos += 2;
	} else {
	    $retVal->{type} = TOK_GT;
	    $retVal->{value} = $firstChar;
	    $$pos++;
	}
    } elsif ($firstChar eq ':') {
	if ($secondChar eq ':') {
	    $retVal->{type} = TOK_CLASS;
	    $retVal->{value} = $firstChar.$secondChar;
	    $$pos += 2;
	} else {
	    $retVal->{type} = TOK_COLON;
	    $retVal->{value} = $firstChar;
	    $$pos++;
	}
    } elsif (substr ($$str, $$pos, 6) =~ /select/i) {
	$retVal->{type} = TOK_SELECT;
	$retVal->{value} = substr ($$str, $$pos, 6);
	$$pos += 6;
    } elsif (substr ($$str, $$pos, 5) =~ /where/i) {
	$retVal->{type} = TOK_WHERE;
	$retVal->{value} = substr ($$str, $$pos, 5);
	$$pos += 5;
    } elsif (substr ($$str, $$pos, 4) =~ /from/i) {
	$retVal->{type} = TOK_FROM;
	$retVal->{value} = substr ($$str, $$pos, 4);
	$$pos += 4;
    } elsif (substr ($$str, $$pos, 3) =~ /and/i) {
	$retVal->{type} = TOK_AND;
	$retVal->{value} = substr ($$str, $$pos, 3);
	$$pos += 3;
    } elsif (substr ($$str, $$pos, 2) =~ /or/i) {
	$retVal->{type} = TOK_OR;
	$retVal->{value} = substr ($$str, $$pos, 2);
	$$pos += 2;
    } elsif ($firstChar eq '"' || $firstChar eq '\'') {
	$retVal->{type} = TOK_LITERAL;
	$retVal->{value} = $self->_str2Token($str, $pos, $retVal->{type});
    } elsif ($firstChar eq '?' || $firstChar eq '$') {
	$retVal->{type} = TOK_VAR;
	$retVal->{value} = $self->_str2Token($str, $pos, $retVal->{type});
    } elsif ($firstChar eq '[') {
	$retVal->{type} = TOK_URI;
	$retVal->{value} = $self->_str2Token($str, $pos, $retVal->{type});
    } elsif ($firstChar =~ /\w/) {
	$retVal->{type} = TOK_NAME;
	$retVal->{value} = $self->_str2Token($str, $pos, $retVal->{type});
    } else {
	$retVal->{type} = TOK_NONE;
	$retVal->{value} = $firstChar;
	$$pos++;
	
    } 
    
    return $retVal;
}
sub _str2Token {
    my ($self, $str, $pos, $tokenType) = @_;
    my $retVal;
    if ($tokenType eq TOK_LITERAL) {
	my $quote = substr ($$str, $$pos, 1);
	my $subpos = $$pos ;
	my $escaped = '';
	my $found = 0;
	while (defined(my $char = substr ($$str, ++$subpos, 1))) {
	    if ($char eq $quote && !$escaped) {
		$found = $subpos;
		last;
	    } else {
		if (!($char eq "\\") || $escaped) {
		    $retVal .= $char;
		}
	    }
	    if ($char eq "\\") {
		$escaped = !$escaped;
	    } else {
		$escaped = '';
	    }
	}
	unless ($found) {
	    croak "Syntax error: Infinite literal at position ".$$pos
	      ."\n".substr ($$str, $$pos,30);
	}
	$$pos = ++$subpos;
    } elsif ($tokenType eq TOK_URI) {
	my $delim = "]";
	my $subpos = $$pos ;
	my $found = 0;
	while (defined (my $char = substr ($$str, ++$subpos, 1))) {
	    if ($char eq $delim) {
		$found = $subpos;
		last;
	    } else {
		$retVal .= $char;
	    }
	}
	unless ($found) {
	    croak "Syntax error: Infinite URI at position ".$$pos
	      ."\n".substr ($$str, $$pos,30);
	}
	$$pos = ++$subpos;
    } elsif ($tokenType eq TOK_VAR) {
	$retVal = substr ($$str, $$pos++,1);
	$retVal .= $self->_str2Token($str, $pos, TOK_NAME);
    } elsif ($tokenType eq TOK_NAME) {
	my $subpos = $$pos ;
	if (substr ($$str, $subpos ,1) =~ /[a-zA-Z]/ ) {
	    $retVal = substr ($$str, $subpos,1);
	} else {
	    croak "Syntax error: Invalid name at position ".$$pos
	      ."\n".substr ($$str, $$pos,30);
	}
	while (defined (my $char = substr ($$str, ++$subpos, 1))) {
	    if ($char =~ /\W/) {
		last;
	    } else {
		$retVal .= $char;
	    }
	}
	$$pos = $subpos;
    }
    return $retVal;
}
sub _parse {
    my ($self, $tokens) = @_;
    
    #init query tree
    delete $self->{+Q_QUERY};
    my @context = ([Q_QUERY, 0]);
    my @rndParens; #keep track of which parenthesis you are in
    $self->_treeNode(\@context);
    
    for (my $i = 0; $i < @$tokens; $i++) {
	my $token = $tokens->[$i];
	#debug############################################################
	if ($self->getOptions->{Debug}) {
	    use Data::Dumper;
	    print Dumper @context;
	    print "TOKEN: ",$token->{value}, "\n";
	}
	##################################################################
	if ($token->{type} eq TOK_NONE) {
	    _errSyntax ($tokens, $i, \@context, "Token not recognized");
	} elsif ($token->{type} eq TOK_END) {
	} elsif ($token->{type} eq TOK_LITERAL) {
	    until ( @context == 0 || 
		    @context[@context - 1]->[0] eq Q_TARGET ||
		    @context[@context - 1]->[0] eq Q_ELEMENTPATH ||
		    @context[@context - 1]->[0] eq Q_PATH ||
		    @context[@context - 1]->[0] eq Q_EXPRESSION) {
		pop @context;
	    }
	    if (@context > 0) {
		#we might have expected Q_ELEMENT, let's remove it now 
		my $node = $self->_treeNode(\@context);
		#TODO: $node should point to an empty structure, raise error 
		# if there is a token value in it
		# $node->{classpath}[0]{elements}[0]{element} = [] is ok
		# $node->{classpath}[0]{elements}[0]{element} = [{node}...] is not ok
		# $node->{classpath}[1]{elements}[0]{element} = [] is not ok either
		undef %$node;
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	    
	    if (@context[@context - 1]->[0] eq Q_TARGET || 
		@context[@context - 1]->[0] eq Q_PATH || 
		@context[@context - 1]->[0] eq Q_ELEMENTPATH) {
		
		my $node = $self->_treeNodeAppend(\@context, Q_EXPRESSION);
		$node = $self->_treeNodeAppend(\@context, Q_EXPRESSION);
		$node->{+Q_LITERAL}->[0] = $token->{value};
		pop @context;	#Q_EXPRESSION (inner)
	    } elsif (@context[@context - 1]->[0] eq Q_EXPRESSION) {
		#just add literal
		my $node = $self->_treeNode(\@context);
		$node->{+Q_LITERAL}->[0] = $token->{value};
		pop @context	#Q_EXPRESSION
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_VAR) {
	    
	    if (@context[@context - 1]->[0] eq Q_SOURCEPATH) {
		my $node = $self->_treeNode(\@context);
		my $index = @{$node->{+Q_ELEMENT}} -1;
		push @context, [Q_VARIABLE, $index];
		$node = $self->_treeNode(\@context);
		$node->{+Q_NAME}->[0] = $token->{value};
		pop @context;	#Q_VARIABLE
	    } elsif (@context[@context - 1]->[0] eq Q_ELEMENT) {
		my $node = $self->_treeNodeAppend(\@context, Q_VARIABLE);
		$node->{+Q_NAME}->[0] = $token->{value};
		pop @context;	#Q_VARIABLE
		pop @context;	#Q_ELEMENT
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_URI) {
	    
	    if (@context[@context - 1]->[0] eq Q_ELEMENT) {
		my $node = $self->_treeNodeAppend(\@context, Q_NODE);
		$node->{+Q_URI}->[0] = $token->{value};
		pop @context;  #Q_NODE
		pop @context;  #Q_ELEMENT
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_NAME) {
	    if (@context[@context - 1]->[0] eq Q_ELEMENT) {
		if ($tokens->[$i+1]->{type} eq TOK_LPAREN) {
		    my $node = $self->_treeNodeAppend(\@context, Q_FUNCTION);
		    $node->{+Q_NAME}->[0] = $token->{value};
		} else {
		    my $node = $self->_treeNodeAppend(\@context, Q_NODE);
		    $node->{+Q_NAME}->[0] = $token->{value};
		    unless ($tokens->[$i+1]->{type} eq TOK_COLON) {
			pop @context; #Q_NODE
			pop @context; #Q_ELEMENT
		    }
		}
	    } elsif (@context[@context - 1]->[0] eq Q_NODE) {
		my $node = $self->_treeNode(\@context);
		my $index = @{$node->{+Q_NAME}};
		_errSyntax ($tokens, $i, \@context, "Invalid node")
		  if $index > 1;
		$node->{+Q_NAME}->[$index] = $token->{value};
		unless ($tokens->[$i+1]->{type} eq TOK_COLON) {
		    pop @context; #Q_NODE
		    pop @context; #Q_ELEMENT
		}
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_CLASS) {
	    if (@context[@context - 1]->[0] eq Q_ELEMENTS) {
		pop @context;	#Q_ELEMENTS

		_errSyntax ($tokens, $i, \@context, "Unexpected token")
		  unless @context[@context - 1]->[0] eq Q_CLASSPATH;
		my $node = $self->_treeNode(\@context);

		$self->_treeNodeAppend(\@context, Q_ELEMENTS);
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");
	    }
	} elsif ($token->{type} eq TOK_MATCH) {
	    until (@context == 0 || @context[@context - 1]->[0] eq Q_SOURCEPATH) {
		pop @context
	    }
	    if (@context > 0) {
		my $node = $self->_treeNode(\@context);
		$node->{+Q_HASTARGET}->[0] = 1;
		$self->_treeNodeAppend(\@context, Q_TARGET);
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_LPAREN) {
	    if (@context[@context - 1]->[0] eq Q_CONDITION) {
		# look ahead to specify context
		my $pos = $i;
		my $depth = 1;
		my %significant;
		while (1) {
		    $pos++;
		    my $tok = $tokens->[$pos];
		    if ($tok->{type} eq TOK_END) {
			_errSyntax ($tokens, $i, \@context, "Unclosed parenthesis");
			last;
		    }
		    if ($depth == 1 &&
			$tok->{type} eq TOK_COMMA ||
			$tok->{type} eq TOK_AND ||
			$tok->{type} eq TOK_OR ||
			$tok->{type} eq TOK_LITERAL ||
			$tok->{type} eq TOK_PIPE ||
			$tok->{type} eq TOK_PERIOD
		       ) {
			$significant{$tok->{type}} = 1;
		    }
		    $depth++ if $tok->{type} eq TOK_LPAREN;
		    $depth-- if $tok->{type} eq TOK_RPAREN;
		    last unless $depth;
		}
		if (exists $significant{+TOK_COMMA}) {
		    #elements
		    push @rndParens, Q_ELEMENTS;
		    $self->_treeNodeAppend(\@context,Q_MATCH);
		    $self->_treeNodeAppend(\@context,Q_PATH);
		    $self->_treeNodeAppend(\@context,Q_CLASSPATH);
		    $self->_treeNodeAppend(\@context,Q_ELEMENTS);
		    $self->_treeNodeAppend(\@context,Q_ELEMENT);
		} elsif (exists $significant{+TOK_AND} ||
			 exists $significant{+TOK_OR}) {
		    #condition 
		    push @rndParens, Q_CONDITION;
		    $self->_treeNodeAppend(\@context, Q_CONDITION);
		    unless ($tokens->[$i+1]->{type} eq TOK_LPAREN) {
			$self->_treeNodeAppend(\@context,Q_MATCH);
			$self->_treeNodeAppend(\@context,Q_PATH);
			$self->_treeNodeAppend(\@context,Q_CLASSPATH);
			$self->_treeNodeAppend(\@context,Q_ELEMENTS);
			$self->_treeNodeAppend(\@context,Q_ELEMENT);
		    }
		} elsif (#exists $significant{+TOK_LITERAL} ||
			 exists $significant{+TOK_PIPE}) {
		    #expression
		    push @rndParens, Q_EXPRESSION;
		    $self->_treeNodeAppend(\@context, Q_EXPRESSION);
		} else {
		    #condition again
		    push @rndParens, Q_CONDITION;
		    $self->_treeNodeAppend(\@context, Q_CONDITION);
		    unless ($tokens->[$i+1]->{type} eq TOK_LPAREN) {
			$self->_treeNodeAppend(\@context,Q_MATCH);
			$self->_treeNodeAppend(\@context,Q_PATH);
			$self->_treeNodeAppend(\@context,Q_CLASSPATH);
			$self->_treeNodeAppend(\@context,Q_ELEMENTS);
			$self->_treeNodeAppend(\@context,Q_ELEMENT);
		    }
		}
		
		
		############################################################
		
	    } elsif (@context[@context - 1]->[0] eq Q_EXPRESSION) {
		push @rndParens, Q_EXPRESSION;
		$self->_treeNodeAppend(\@context, Q_EXPRESSION);
	    } elsif (@context[@context - 1]->[0] eq Q_FUNCTION) {
		push @rndParens, Q_FUNCTION;
		$self->_treeNodeAppend(\@context, Q_ELEMENTPATH);
		$self->_treeNodeAppend(\@context,Q_ELEMENT);
	    } elsif (@context[@context - 1]->[0] eq Q_ELEMENT) {
		if (@context[@context - 2]->[0] eq Q_ELEMENTS) {
		    push @rndParens, Q_ELEMENTS;		
		} else {
		    # we expected element but found expression
		    until ( @context == 0 || 
			    @context[@context - 1]->[0] eq Q_TARGET ||
			    @context[@context - 1]->[0] eq Q_ELEMENTPATH ||
			    @context[@context - 1]->[0] eq Q_PATH ||
			    @context[@context - 1]->[0] eq Q_EXPRESSION) {
			pop @context;
		    }
		    if (@context > 0) {
			my $node = $self->_treeNode(\@context);
			undef %$node;
		    } else {
			_errSyntax ($tokens, $i, \@context, 
				    "Unexpected token");
		    }
		    $self->_treeNodeAppend(\@context, Q_EXPRESSION);
		    $self->_treeNodeAppend(\@context, Q_EXPRESSION);
		    push @rndParens, Q_EXPRESSION;
		}
	    }
	} elsif ($token->{type} eq TOK_RPAREN) {
	    #Q_CONDITION, Q_ELEMENTS, Q_FUNCTION, Q_EXPRESSION
	    my $lastIn = pop @rndParens;
	    my $item = pop @context;
	    until ( @context == 0 || 
		    $item->[0] eq $lastIn) {
		$item = pop @context;
	    }
	    if (@context > 0) {
		pop @context  #element
		  if $item->[0] eq Q_FUNCTION;
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	    
	} elsif ($token->{type} eq TOK_LCUR) {
	} elsif ($token->{type} eq TOK_RCUR) {
	} elsif ($token->{type} eq TOK_PERIOD) {
	    if (@context[@context - 1]->[0] eq Q_ELEMENTPATH ||
		@context[@context - 1]->[0] eq Q_SOURCEPATH) {
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } elsif (@context[@context - 1]->[0] eq Q_ELEMENTS ||
		     @context[@context - 1]->[0] eq Q_CLASSPATH ||
		     @context[@context - 1]->[0] eq Q_PATH) {
		#Q_ELEMENTS is to be removed and optionally Q_CLASSPATH
		#(or anything up to Q_PATH)
		until (@context == 0 || @context[@context - 1]->[0] eq Q_PATH) {
		    pop @context;
		}

		$self->_treeNodeAppend(\@context, Q_ELEMENTS);
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");
	    }
	} elsif ($token->{type} eq TOK_COMMA) {
	    if (@context[@context - 1]->[0] eq Q_EXPRESSION) {
		pop @context;  #Q_EXPRESSION
	    }
	    if (@context[@context - 1]->[0] eq Q_ELEMENTPATH ||
		@context[@context - 1]->[0] eq Q_SOURCEPATH) {
		my $type = @context[@context - 1]->[0];
		pop @context;  #$type
		$self->_treeNodeAppend(\@context, $type);
		$self->_treeNodeAppend(\@context,Q_ELEMENT);
	    } elsif (@context[@context - 1]->[0] eq Q_ELEMENTS) {
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");
	    }
	} elsif ($token->{type} eq TOK_PIPE) {
	    if (@context[@context - 1]->[0] eq Q_EXPRESSION) {
		my $node = $self->_treeNode(\@context);
		$node->{+Q_OPERATION} = [] unless exists $node->{+Q_OPERATION};
		my $index = @{$node->{+Q_OPERATION}};
		$node->{+Q_OPERATION}->[$index] = $token->{value};
		$self->_treeNodeAppend(\@context, Q_EXPRESSION);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_COLON) {
	    unless (@context[@context - 1]->[0] eq Q_NODE) {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_EQ ||
		 $token->{type} eq TOK_LE ||
		 $token->{type} eq TOK_LT ||
		 $token->{type} eq TOK_GE ||
		 $token->{type} eq TOK_GT) {
	    until (@context == 0 || @context[@context - 1]->[0] eq Q_MATCH) {
		pop @context
	    }
	    if (@context > 0) {
		my $node = $self->_treeNode(\@context);
		$node->{+Q_RELATION}->[0] = $token->{value};
		$self->_treeNodeAppend(\@context, Q_PATH);
		$self->_treeNodeAppend(\@context, Q_CLASSPATH);
		$self->_treeNodeAppend(\@context, Q_ELEMENTS);
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }

	} elsif ($token->{type} eq TOK_SELECT) {
	    if (@context[@context - 1]->[0] eq Q_QUERY) {
		$self->_treeNodeAppend(\@context, Q_RESULTSET);
		$self->_treeNodeAppend(\@context, Q_ELEMENTPATH);
		$self->_treeNodeAppend(\@context, Q_ELEMENT); 
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_FROM) {
	    until (@context == 0 || @context[@context - 1]->[0] eq Q_QUERY) {
		pop @context
	    }
	    if (@context > 0) {
		$self->_treeNodeAppend(\@context, Q_SOURCE);
		$self->_treeNodeAppend(\@context, Q_SOURCEPATH);
		$self->_treeNodeAppend(\@context, Q_ELEMENT);
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_WHERE) {
	    until (@context == 0 || @context[@context - 1]->[0] eq Q_QUERY) {
		pop @context
	    }
	    if (@context > 0) {
		$self->_treeNodeAppend(\@context,Q_CONDITION);
		$self->_treeNodeAppend(\@context,Q_CONDITION);
		unless ($tokens->[$i+1]->{type} eq TOK_LPAREN) {
		    $self->_treeNodeAppend(\@context,Q_MATCH);
		    $self->_treeNodeAppend(\@context,Q_PATH);
		    $self->_treeNodeAppend(\@context, Q_CLASSPATH);
		    $self->_treeNodeAppend(\@context, Q_ELEMENTS);
		    $self->_treeNodeAppend(\@context, Q_ELEMENT);
		}
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	} elsif ($token->{type} eq TOK_AND ||
		 $token->{type} eq TOK_OR) {
	    
	    until (@context == 0 ||
		   @context[@context - 1]->[0] eq Q_CONDITION 
		   #|| @context[@context - 1]->[0] eq Q_MATCH
		  ) {
		pop @context;
	    }
	    if (@context > 0) {
		pop @context; #Q_CONDITION 
		my $node = $self->_treeNode(\@context);
		$node->{+Q_CONNECTION} = [] unless exists $node->{+Q_CONNECTION};
		my $index = @{$node->{+Q_CONNECTION}};
		$node->{+Q_CONNECTION}->[$index] = $token->{value};
		$self->_treeNodeAppend(\@context, Q_CONDITION);
		unless ($tokens->[$i+1]->{type} eq TOK_LPAREN) {
		    $self->_treeNodeAppend(\@context,Q_MATCH);
		    $self->_treeNodeAppend(\@context,Q_PATH);
		    $self->_treeNodeAppend(\@context, Q_CLASSPATH);
		    $self->_treeNodeAppend(\@context, Q_ELEMENTS);
		    $self->_treeNodeAppend(\@context, Q_ELEMENT);
		}
	    } else {
		_errSyntax ($tokens, $i, \@context, "Unexpected token");		
	    }
	}
    }
}

sub _treeNode {
    my ($self, $context) = @_;
    #@$context example: ([Q_QUERY, 0],
    #    		 [Q_RESULTSET, 0],
    #			 [Q_ELEMENTPATH, 2])

    my $node = $self;
    foreach (@$context) {
	if (exists $node->{$_->[0]}->[$_->[1]]) {
	    $node = $node->{$_->[0]}->[$_->[1]];
	} else {
	    $node = $node->{$_->[0]}->[$_->[1]] = {};
	}
	
    }
    return $node;
}

sub _treeNodeAppend {
    my ($self, $context, $name) = @_;

    my $node = $self->_treeNode($context);
    $node->{$name} = [] unless defined $node->{$name};
    my $lastIndex = @{$node->{$name}} - 1;
    push @$context, [$name, ++$lastIndex];
    return $self->_treeNode($context);
}
sub _syntaxTree {
    #dump parsed query 
    my ($self, $node, $depth, $indent) = @_;
    if ($depth > 0) {
	if (ref $node) {
	    foreach (keys %$node) {
		print "\n",$indent,$_;
		for (my $i = 0; $i < @{$node->{$_}};$i++) {
		    #		print $i;
		    print "\n--$i--" if $i;
		    $self->_syntaxTree($node->{$_}->[$i], $depth-1, $indent.'    ');
		}
	    }
	} else {
	    print "\n",$indent,$node;
	}
    } else {
	if (ref $node) {
	    foreach (keys %$node) {
		for (my $i = 0; $i < @{$node->{$_}};$i++) {
		    $self->_syntaxTree($node->{$_}->[$i], $depth-1, $indent.'    ');
		}
	    }
	} else {
	    print " $node";
	}
    }
}
############################################################
# Utils

sub _errSyntax {
    my ($tokens, $i, $context, @message) = @_;
    croak 'Syntax error near ',join (' ', $tokens->[$i-2]->{value},
				    $tokens->[$i-1]->{value},
				    "<$tokens->[$i]->{value}>",
				    $tokens->[$i+1]->{value},
				    $tokens->[$i+2]->{value}), "\n", @message;
}


1;
__END__

=head1 NAME

RDF::Core::Query Implementation of query language

=head1 SYNOPSIS

  my %namespaces = (Default => 'http://myApp.gingerall.org/ns#',
                    ns     => 'http://myApp.gingerall.org/ns#',
		   );
  my $functions = new RDF::Core::Function(Data => $model,
	  				  Schema => $schema,
					  Factory => $factory,
					 );

  my $evaluator = new RDF::Core::Evaluator
    (Model => $model,            #an instance of RDF::Core::Model
     Factory => $factory,        #an instance of RDF::Core::NodeFactory
     Functions => $functions,
     Namespaces => \%namespaces,
    );
  my $query = new RDF::Core::Query(Evaluator=> $evaluator);

  my $result = $query->query('Select ?x.title 
                              From store.book{?x}.author{?y} 
                              Where ?y = "Lewis"');
  foreach my $row (@$result) {
      foreach my $node (@$row) {
	  my $label = defined($node) ? $node->getLabel : 'NULL';
	  print $label, ' ';
      }
      print "\n";
  }

=head1 DESCRIPTION

Query module together with RDF::Core::Evaluator and RDF::Core::Function implements a query language. A result of a query is a set of rows, each row containing resources or literals or undef values.

=head2 Interface

=over 4

=item * new(%options)

Available options are:

=over 4

=item * Evaluator

RDF::Core::Evaluator object.

=back

=item * query($queryString)

Evaluates $queryString and returns an array reference, each element points to an array again and that inner array (a row) contains references to RDF::Core::Resource or RDF::Core::Literal or it's value is not defined.

=back

=head2 Query language

Query language has three major parts, beginning with B<select>, B<from> and B<where>. The B<select> part specifies which "columns" of data should be returned. The B<from> part defines the pattern or path in the graph I'm searching for and binds variables to specific points of the path. The B<where> part specifies conditions that each path found must conform.  

Let's start in midst, with B<from> part:

  Select ?x from ?x.ns:author

This will find all resources that have property ns:author. We can chain properties:

  Select ?x from ?x.ns:author.ns:name

This means find all resources that have property ns:author and value of the property has property ns:name. We can bind values to variables to refer them back:

  Select ?x from ?x.ns:author{?author}.ns:name{?name}

This means find the same as in the recent example and bind ?author variable to author value and ?name to name value. The variable is bound to a value of property, not property itself. Now we can add second path, connected to the first one:

  Select ?x 
  From ?x.ns:author{?author}.ns:name{?name}, ?author.ns:birth{?birth}

B<Condition.> Now we described data we talk about and let's put more conditions on them in B<where> section:

  Select ?x 
  From ?x.ns:author{?author}.ns:name{?name}, ?author.ns:birth{?birth}
  Where ?name = 'Lewis' And  ?birth.ns:year < '1900'

This means: get all paths in the graph described in B<from> section and exclude those that don't conform the condition. Only variables declared in B<from> section can be used, binding is not allowed here. There are some shortcuts available in condition. 

First, rdf:type can be queried in this way:

  Select ?x 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author::clss:Writer.name = 'Lewis'

which is equivalent to 

  ...
  Where ?author.rdf:type = clss:Writer And ?author.name = 'Lewis' 

supposing we have defined namespace rdf = 'http://www.w3.org/1999/02/22-rdf-syntax-ns#'. (See B<Names and URIs> paragraph later in the text.)

Second, each resource, predicate or value can be replaced with a list of variants. So we may ask:

  Select ?x 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author.(ns:book,ns:booklet,ns:article).published < '1938'

and it means

  Select ?x 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author.ns:book.published < '1938'
     Or ?author.ns:booklet.published < '1938'
     Or ?author.ns:article.published < '1938'

The list of variants can be combined with rdf:type shortcut:

  Select ?x 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author::(clss:Writer, clss:Teacher).name = 'Lewis'

and it means

  Where (?author.rdf:type = clss:Writer 
         Or ?author.rdf:type = clss:Teacher) 
    And ?author.name = 'Lewis' 

B<Resultset.>  The B<select> section describes how to output each path found. We can think of a path as a n-tuple of values bound to variables.

  Select ?x.ns:title, ?author.ns:name 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author::(clss:Writer, clss:Teacher).name = 'Lewis'

For each n-tuple ?x.ns:title and ?author.ns:name are evaluated and the pair of values is returned as one row of the result. If there is no value for ?x.ns:title, undef is returned instead of the value. If there are more values for one particular ?x.ns:title, all of them are returned in carthesian product with ?author.ns:name.

B<Names and URIs>

'ns:name' is a shortcut for URI, let's say 'http://myApp.gingerall.org/ns#name'. To map names to URIs, we use %namespaces. Each key-value pair of the hash contains namespace prefix and URI it represents. Each prefix:name is evaluated to URI as $namespaces{prefix}.name. If prefix is not present, $namespaces{Default} is taken. URIs can be typed explicitly in square brackets. 

  Select ?x from ?x.[http://myApp.gingerall.org/ns#name]

B<Functions>

Functions can be used to obtain custom values for a resource. They accept recources or literals as parameters and return set of resources or literals. They can be used in place of URI or name. If they are at position of property, they get resource as a special parameter and what they return is considered to be a value of the expression rather then 'real' properties.

Let's have function foo() that always returns resource with URI http://myApp.gingerall.org/ns#name.

  ?x.foo()

This evaluates to  

  [http://myApp.gingerall.org/ns#name], 

not 

  ?x.[http://myApp.gingerall.org/ns#name]

Now we can restate the condition with variants to a condition with a function call.

  Select ?x 
  From ?x.ns:author{?author}, ?author.ns:birth{?birth}
  Where ?author.subproperty(publication).published < '1938'

We consider we have apropriate schema where book, booklet, article etc. are (direct or indirect) rdfs:subPropertyOf publication.

=head1 LICENSE

This package is subject to the MPL (or the GPL alternatively).

=head1 AUTHOR

Ginger Alliance, rdf@gingerall.cz

=head1 SEE ALSO

RDF::Core::Evaluator, RDF::Core::Function

=cut


