############################################################################

# Copyright (c) 1998,1999 Enno Derksen

# All rights reserved.

# This program is free software; you can redistribute it and/or modify it

# under the same terms as Perl itself. 

############################################################################

#

# To do (in no particular order):

#

# - Element tag names that are the same as a XQL keyword (e.g. "or", "not", ..)

#   are currently not supported. The parser and lexer needs to be smarter and

#   know what context they are in.

# - output using xql:result etc.

# - xml:space=preserve still needs to be adhered to in text() etc.

#   - I already added xql_preserveSpace. Still need to use it in (raw)text() etc.

# - XQL functions (like value()) should probably work on input lists > 1 node

#   (The code was changed, but it needs to be tested. ancestor() wasn't fixed)

# - verify implementation of xql_namespace

# - verify implementation of end, index

# - check passing of context to the solve() methods

# - functions/methods may be wrong. They receive the entire LHS set,

#   so count() is right, but the rest may be wrong!

# - may need to use different comment delimiters, '#' may be used in future XQL

#   definition (according to Joe Lapp, one of the XQL spec authors)

# - caching of Node xql_values (?)

# - finish the Date class

#   - discuss which classes: Date, Time, and/or DateTime ?

# - conversion of Query result to Perl primitives, i.e. how do we return the

#   result of a query.

# - add support for ordering/formatting the query results, see XML-QL

# - discuss typecasting mechanism

# - error reporting mechanism

#   - yyerror handler doesn't seem to work

#   - passing intermediate exceptions ($@) to the user

#   - more debugging support

# - subst, map etc. 

#   - use rawText for Nodes?

#     - recurse or not?

# - text/rawText default - recurse or not? 

#   - what should default value() implementation use?

# - check if all Syntactic Constraints in XQL spec are implemented

# - support all node types, i.e. Notation, Attlist etc.

#   - sorting in 'document order' doesn't work yet for 'other' DOM nodes

# - generateFunction - support functions that return lists?

# - match() function - what should it return?

# - keeping track of reference nodes not always done right

#   - also think about Perl builtin functions

# - conversion to Perl number throws warnings with -w (in comparisons etc.)

# - sorting

#   - add sorting by attribute name (within same element)

#     (or other criteria)

#   - optional sorting in $union$ ?

#     - could add a flag that says "don't worry about document order for $union$"

#   - user defined sort?

# - OPTIMIZE!

#   - Subscript operator

#   - Filter operator

#   - etc.

package XML::XQL;

use strict;

use Carp;

use XML::RegExp;

use vars qw( @EXPORT $VERSION 

	     $ContextStart $ContextEnd $BoldOn $BoldOff 

	     %Func %Method %FuncArgCount

	     %AllowedOutsideSubquery %ConstFunc %ExpandedType

	     $Restricted $Included $ReXQLName

	     %CompareOper $Token_q $Token_qq $LAST_SORT_KEY

	   );

@EXPORT = qw( $VERSION $Restricted $Included );

BEGIN

{

    $VERSION = '0.63';

    die "XML::XQL is already used/required" if defined $Included;

    $Included = 1;

    # From XQL spec (The '-' was added to allow XPath style function names.)

    $ReXQLName =	  "(?:[-a-zA-Z_]+\\w*)";

    $Token_q = undef;

    $Token_qq = undef;

    $Restricted = 0 unless defined $Restricted;

    if (not $Restricted)

    {

	# Allow names with Perl package prefixes

	$ReXQLName = "(?:$ReXQLName(?:::$ReXQLName)*)";

	# Support q// and qq// strings

	$Token_q = "q";

	$Token_qq = "qq";

    }

};

# To save the user some typing for the simplest cases

sub solve

{

    my ($expr, @args) = @_;

    my $query = new XML::XQL::Query (Expr => $expr);

    my @result = $query->solve (@args);

    $query->dispose;

    @result;

}

#---------- Parser related stuff ----------------------------------------------

# Find (nested) closing delimiter in q{} or qq{} strings

sub parse_q

{

    my ($qname, $q, $str, $d1, $d2) = @_;

    my ($match) = "";

    my ($found);

    while ($str =~ /^([^$d1$d2]*)($d1|($d2))(.*)/s)

    {

	defined ($3) and return ($4, $match . $1);		# $d2 found

	# match delimiters recursively

	$match .= $1 . $2;

	($str, $found) = parse_q ($qname, $q, $4, $d1, $d2);

	$match .= $found . $d2;

    }

    XML::XQL::parseError ("no $qname// closing delimiter found near '$q$d1'");

}

# To support nested delimiters in q{} and qq() strings

my %MatchingCloseDelim =

(

 '{' => '}',

 '(' => ')',

 '<' => '>',

 '[' => ']'

);

sub Lexer 

{

    my($parser)=shift;

    exists($parser->YYData->{LINE})

	or $parser->YYData->{LINE} = 1;

    $parser->YYData->{INPUT}

	or return('', undef);

    print "Lexer input=[" . $parser->YYData->{INPUT} . "]\n"

	if $parser->{yydebug};

    if ($Restricted)

    {

	# strip leading whitespace

	$parser->YYData->{INPUT} =~ s/^\s*//;

    }

    else

    {

	# strip leading whitespace and comments

	$parser->YYData->{INPUT} =~ s/^(\s|#.*)*//;

    }

    for ($parser->YYData->{INPUT}) 

    {

	s#^"([^"]*)"##o	and return ('TEXT', $1);

	s#^'([^']*)'##o	and return ('TEXT', $1);

	if (not $Restricted)

	{

	    # Support q// and qq// string delimiters

	    for my $qname ('q', 'qq')

	    {

		my ($q) = $parser->{Query}->{$qname};

		if (defined ($q) and s/^$q(\[\(\{\<#!=-\+|'":;\.,\?\/!@\%^\*)//)

		{

		    my ($d1, $d2) = ($1, $MatchingCloseDelim{$1});

		    my ($str);

		    if (defined $d2)

		    {

			($parser->YYData->{INPUT}, $str) = parse_q (

					$qname, $q, $_, $d1, $d2);

		    }

		    else	# close delim is same open delim 

		    {

			$d2 = $d1;

			s/([^$d2])*$d2// or XML::XQL::parseError (

			    "no $qname// closing delimiter found near '$q$d1'");

			$str = $1;

		    }

		    return ('TEXT', eval "$q$d1$str$d2");

		}

	    }

	}

	s/^(-?\d+\.(\d+)?)//		and return ('NUMBER', $1);

	s/^(-?\d+)//			and return ('INTEGER', $1);

	s/^(\$|\b)(i?(eq|ne|lt|le|gt|ge))\1(?=\W)//i

					and return ('COMPARE', "\L$2");

	s/^((\$|\b)(any|all|or|and|not|to|intersect)\2)(?=\W)//i

					and return ("\L$3", $1);

  	s/^((\$|\b)union\2(?=\W)|\|)//i	and return ('UnionOp', $1);

  	s/^(;;?)//			and return ('SeqOp', $1);

	if (not $Restricted)

	{

	    s/^(=~|!~)//		and return ('MATCH', $1);

	    s/^\$((no_)?match)\$//i

					and return ('MATCH', "\L$1");

	    s/^\$($ReXQLName)\$//o	and return ('COMPARE', $1);

	}

	s/^(=|!=|<|<=|>|>=)//		and return ('COMPARE', $1);

	s!^(//|/|\(|\)|\.\.?|@|\!|\[|\]|\*|:|,)!!

					and return ($1, $1);

 	s/^($ReXQLName)\s*\(//o

					and return ('XQLName_Paren', $1);

	s/^($XML::RegExp::Name)//o	and return ('NCName', $1);	

    }

}

#------ end Parser related stuff ----------------------------------------------

# Converts result from a Disjunction to a 0 or 1.

# If it's a XML::XQL::Boolean, its value is returned.

# If it's an empty list it returns 0.

# If it's a node or a Text or Number, it returns 1.

# If it's a list with 1 or more elements, it returns 1 if at least one

# element evaluates to 1 (with toBoolean)

sub toBoolean	# static method

{

    my $arg = shift;

    my $type = ref ($arg);

    if ($type eq "ARRAY")

    {

	for my $n (@$arg)

	{

	    return 1 if toBoolean ($n);

	}

	return 0;

    }

    return $arg->xql_toBoolean;

}

sub listContains

{

    my ($list, $x) = @_;

#?? $n should be a PrimitiveType or an XML Node

    for my $y (@$list)

    {

#??	return 1 if $x == $y;

	if (ref($x) eq ref($y))		# same object class

	{

	    my ($src1, $src2) = ($x->xql_sourceNode, $y->xql_sourceNode);

	    next if ((defined $src1 or defined $src2) and $src1 != $src2);

	    return ($x == $y) if (UNIVERSAL::isa ($x, 'XML::XQL::Node'));

	    return 1 if $x->xql_eq ($y);

	}

    }

    0;

}

sub toList

{

    my $r = shift;

    (ref ($r) eq "ARRAY") ? $r : [ $r ];

}

# Prepare right hand side for a comparison, i.e.

# turn it into a single value.

# If it is a list with 2 or more values, it croaks.

sub prepareRvalue

{

    my $r = shift;

    if (ref ($r) eq "ARRAY")

    {

	# more than 1 value gives a runtime error (as per Joe Lapp)

        croak "bad rvalue $r" if @$r > 1;

	$r = $r->[0];

    }

    if (ref ($r) and $r->isa ('XML::XQL::Node'))

    {

	$r = $r->xql_value;

    }

    $r;

}

sub trimSpace

{

    $_[0] =~ s/^\s+//;

    $_[0] =~ s/\s+$//;

    $_[0];

}

# Assumption: max. 32768 (2**15 = 2**($BITS-1)) children (or attributes) per node

# Use setMaxChildren() to support larger offspring.

my $BITS = 16;

$LAST_SORT_KEY = (2 ** $BITS) - 1;

# Call with values: $max = 128 * (256**N), where N=0, 1, 2, ...

sub setMaxChildren

{

    my $max = shift;

    my $m = 128;

    $BITS = 8;

    while ($max > $m)

    {

	$m = $m * 256;

	$BITS += 8;

    }

    $LAST_SORT_KEY = (2 ** $BITS) - 1;

}

sub createSortKey

{

    # $_[0] = parent sort key, $_[1] = child index, 

    # $_[2] = 0 for attribute nodes, 1 for other node types

    my $vec = "";

    vec ($vec, 0, $BITS) = $_[1];

    vec ($vec, 7, 1) = $_[2] if $_[2];	# set leftmost bit (for non-attributes)

    $_[0] . $vec;

}

#--------------- Sorting source nodes ----------------------------------------

# Sort the list by 'document order' (as per the XQL spec.)

# Values with an associated source node are sorted by the position of their 

# source node in the XML document.

# Values without a source node are placed at the end of the resulting list.

# The source node of an Attribute node, is its (parent) Element node 

# (per definition.) The source node of the other types of XML nodes, is itself.

# The order for values with the same source node is undefined.

sub sortDocOrder

{

#?? or should I just use: sort { $a->xql_sortKey cmp $b->xql_sortKey }

    my $list = shift;

#print "before---\n";

#for (@$list)

#{

#    print "key=" . keyStr($_->xql_sortKey) . " node=" . $_->getTagName . " id=" . $_->getAttribute('id') . "\n";

#}

    @$list =	map { $_->[1] }			# 3) extract nodes

		sort { $a->[0] cmp $b->[0] }	# 2) sort by sortKey

		map { [$_->xql_sortKey, $_] }	# 1) make [sortKey,node] records

		@$list;

#print "after---\n";

#for (@$list)

#{

#    print "key=" . keyStr($_->xql_sortKey) . " node=" . $_->getTagName . " id=" . $_->getAttribute('id') . "\n";

#}

    $list;

}

# Converts sort key from createSortKey in human readable form

# For debugging only.

sub keyStr

{

    my $key = shift;

    my $n = $BITS / 8;

    my $bitn = 2 ** ($BITS - 1);

    my $str;

    for (my $i = 0; $i < length $key; $i += $n)

    {

	my $dig = substr ($key, $i, $n);

	my $v = vec ($dig, 0, $BITS);

	my $elem = 0;

	if ($v >= $bitn)

	{

	    $v -= $bitn;

	    $elem = 1;

	}

	$str .= "/" if defined $str;

	$str .= "@" unless $elem;

	$str .= $v;

    }

    $str;

}

sub isEmptyList

{

    my $list = shift;

    (ref ($list) eq "ARRAY") && (@$list == 0);

}

# Used by Element and Attribute nodes

sub buildNameSpaceExpr

{

    my ($nameSpace, $name) = @_;

    $name = ".*" if $name eq "*";

    if (defined $nameSpace)

    {

	$nameSpace = ".*" if $nameSpace eq "*";

	"^$nameSpace:$name\$";

    }

    else

    {

	"^$name\$";

    }

}

sub prepareForCompare

{

    my ($left, $right) = @_;

    my $leftType = $left->xql_primType;

    if ($leftType == 0)		# Node

    {

	$left = $left->xql_value;

	$leftType = $left->xql_primType;

    }

    my $rightType = $right->xql_primType;

    if ($rightType == 0)		# Node

    {

	$right = $right->xql_value;

	$rightType = $right->xql_primType;

    }

    # Note: reverse the order if $leftType < $rightType

    ($leftType < $rightType, $left, $right);

}

sub xql_eq

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_eq ($left, $ignoreCase)

	     : $left->xql_eq ($right, $ignoreCase);

}

sub xql_ne

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_ne ($left, $ignoreCase)

	     : $left->xql_ne ($right, $ignoreCase);

}

sub xql_lt

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_ge ($left, $ignoreCase)

	     : $left->xql_lt ($right, $ignoreCase);

}

sub xql_le

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_gt ($left, $ignoreCase)

	     : $left->xql_le ($right, $ignoreCase);

}

sub xql_gt

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_le ($left, $ignoreCase)

	     : $left->xql_gt ($right, $ignoreCase);

}

sub xql_ge

{

    my ($left, $right, $ignoreCase) = @_;

    my $reverse;

    ($reverse, $left, $right) = prepareForCompare ($left, $right);

    $reverse ? $right->xql_lt ($left, $ignoreCase)

	     : $left->xql_ge ($right, $ignoreCase);

}

sub xql_ieq { xql_eq (@_, 1); }

sub xql_ine { xql_ne (@_, 1); }

sub xql_ilt { xql_lt (@_, 1); }

sub xql_igt { xql_gt (@_, 1); }

sub xql_ige { xql_ge (@_, 1); }

sub xql_ile { xql_le (@_, 1); }

sub tput

{

    # Let me know if I need to add other systems for which 'tput' is not 

    # available.

    if ($^O =~ /Win|MacOS/)

    {

	return undef;

    }

    else

    {

	my $c = shift;

	# tput is only available on Unix systems.

	# Calling `tput ...` on Windows generates warning messages

	# that can not be suppressed.

	return `tput $c`;

    }

}

# Underline the query subexpression that fails (if tput exists)

$ContextStart = tput ('smul') || ">>";	# smul: underline on

$ContextEnd = tput ('rmul') || "<<";	# rmul: underline off

# Used for making the significant keyword of a subexpression bold, e.g. "$and$"

$BoldOn = tput ('bold') || "";