diff -r 7c11c3d8d025 -r 60be34e1b006 deprecated/buildtools/buildsystemtools/lib/XML/XQL.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/deprecated/buildtools/buildsystemtools/lib/XML/XQL.pm Wed Oct 27 16:03:51 2010 +0800 @@ -0,0 +1,3947 @@ +############################################################################ +# 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') || ""; +$BoldOff = tput ('rmul') . tput ('smul') || ""; +# rmul reverts the string back to normal text, smul makes it underlined again, +# so the rest of the subexpresion will be underlined. + +sub setErrorContextDelimiters +{ + ($ContextStart, $ContextEnd, $BoldOn, $BoldOff) = @_; +} + +sub delim +{ + my ($str, $node, $contextNode) = @_; + if ($node == $contextNode) + { + $str =~ s/\016([^\017]*)\017/$BoldOn$1$BoldOff/g; + "$ContextStart$str$ContextEnd"; + } + else + { + $str =~ s/\016([^\017]*)\017/$1/g; + $str; + } +} + +sub bold +{ + my $x = shift; + "\016$x\017"; # arbitrary ASCII codes +} + +sub parseError +{ + my ($msg) = @_; + print STDERR $msg . "\n"; + croak $msg; +} + +# Builtin XQL functions (may not appear after Bang "!") +%Func = +( + ancestor => \&XML::XQL::Func::ancestor, + attribute => \&XML::XQL::Func::attribute, + comment => \&XML::XQL::Func::comment, + element => \&XML::XQL::Func::element, + id => \&XML::XQL::Func::id, + node => \&XML::XQL::Func::node, + pi => \&XML::XQL::Func::pi, + textNode => \&XML::XQL::Func::textNode, + true => \&XML::XQL::Func::true, + false => \&XML::XQL::Func::false, + +# NOTE: date() is added with: use XML::XQL::Date; +); + +# Builtin XQL methods (may appear after Bang "!") +%Method = +( + baseName => \&XML::XQL::Func::baseName, + count => \&XML::XQL::Func::count, + end => \&XML::XQL::Func::end, + 'index' => \&XML::XQL::Func::xql_index, + namespace => \&XML::XQL::Func::namespace, + nodeName => \&XML::XQL::Func::nodeName, + nodeType => \&XML::XQL::Func::nodeType, + nodeTypeString => \&XML::XQL::Func::nodeTypeString, + prefix => \&XML::XQL::Func::prefix, + text => \&XML::XQL::Func::text, + rawText => \&XML::XQL::Func::rawText, + value => \&XML::XQL::Func::value, +); + +# Number of arguments for builtin XQL functions: +# Value is either an integer or a range. Value is 0 if not specified. +# Range syntax: +# +# range ::= '[' start ',' end [ ',' start ',' end ]* ']' +# start ::= INTEGER +# end ::= INTEGER | '-1' ('-1' means: "or more") +# +# Example: [2, 4, 7, 7, 10, -1] means (2,3,4,7,10,11,...) + +%FuncArgCount = +( + ancestor => 1, + attribute => [0,1], + count => [0,1], +# date => 1, + element => [0,1], + id => 1, + text => [0,1], + rawText => [0,1], +); + +%AllowedOutsideSubquery = +( + ancestor => 1, + attribute => 1, + comment => 1, + element => 1, + id => 1, + node => 1, + pi => 1, + textNode => 1, + +#?? what about subst etc. +); + +# Functions that always return the same thing if their arguments are constant +%ConstFunc = +( + true => 1, + false => 1, +# date => 1, +); + +%ExpandedType = +( + "boolean" => "XML::XQL::Boolean", + "text" => "XML::XQL::Text", + "number" => "XML::XQL::Number", + "date" => "XML::XQL::Date", + "node" => "XML::XQL::Node", +); + +sub expandType +{ + my ($type) = @_; + # Expand "number" to "XML::XQL::Number" etc. + my $expanded = $ExpandedType{"\L$type"}; + defined $expanded ? $expanded : $type; +} + +sub defineExpandedTypes +{ + my (%args) = @_; + while (my ($key, $val) = each %args) + { + # Convert keys to lowercase + $ExpandedType{"\L$key"} = $val; + } +} + +sub generateFunction +{ + my ($name, $funcName, $returnType, $argCount, $allowedOutsideSubquery, + $const, $queryArg) = @_; + $argCount = 0 unless defined $argCount; + $allowedOutsideSubquery = 1 unless defined $allowedOutsideSubquery; + $const = 0 unless defined $const; + $queryArg = 0 unless defined $queryArg; + + $returnType = expandType ($returnType); + my $wrapperName = "xql_wrap_$name"; + $wrapperName =~ s/\W/_/g; # replace colons etc. + + my $func; + my $code = <solve (\$context, \$list)); + } + else + { + \$arg[\$i] = XML::XQL::prepareRvalue (\$arg[\$i]->solve (\$context, \$list)); + return [] if XML::XQL::isEmptyList (\$arg[\$i]); + \$arg[\$i] = \$arg[\$i]->xql_toString; + } + } +END_CODE + + if (ref ($argCount) eq "ARRAY" && @$argCount == 2 && + $argCount->[0] == $argCount->[1]) + { + $argCount = $argCount->[0]; + } + + if ($queryArg != -1) + { + $code .=<xql_toString; +END_CODE + } + + if (ref ($argCount) ne "ARRAY") + { + $code .= " my \$result = $funcName ("; + for my $i (0 .. $argCount-1) + { + $code .= ", " if $i; + $code .= "\$arg[$i]"; + } + $code .= ");\n"; + } + elsif (@$argCount == 2) + { + my ($start, $end) = ($argCount->[0], $argCount->[1]); + if ($end == -1) + { + $code .= " my \$result = $funcName ("; + for my $i (0 .. ($start - 1)) + { + $code .= ", " if $i; + $code .= "\$arg[$i]"; + } + $code .= ", \@arg[" . $start . " .. \$#arg]);\n"; + } + else + { + $code .= " my \$n = \@arg;\n my \$result;\n "; + for my $j ($argCount->[0] .. $argCount->[1]) + { + $code .= " els" unless $j == $argCount->[0]; + $code .= ($j == $argCount->[1] ? "e\n" : + "if (\$n == $j)\n"); + $code .= " {\n \$result = $funcName ("; + for my $i (0 .. $j-1) + { + $code .= ", " if $i; + $code .= "\$arg[$i]"; + } + $code .= ");\n }\n"; + } + } + } + else #?? what now... + { + $code .= " my \$result = $funcName (\@arg);\n"; + } + + if ($returnType eq "*") # return result as is + { + $code .= " \$result = [] unless defined \$result;\n"; + } + else + { + $code .= " \$result = defined \$result ? new $returnType (\$result) : [];\n"; + } + + if ($queryArg == -1) + { + $code .= " \$result;\n}\n"; + } + else + { + $code .= " push \@result, \$result;\n }\n \\\@result;\n}\n"; + } + $code .= "\$func = \\\&$wrapperName;"; + +#print "CODE=$code\n"; + + eval "$code"; + if ($@) { croak "generateFunction failed for $funcName: $@\n"; } + + defineFunction ($name, $func, $argCount, + $allowedOutsideSubquery, $const); +} + +sub defineFunction +{ + my ($name, $func, $argCount, $allowedOutside, $const) = @_; + $Func{$name} = $func; + $FuncArgCount{$name} = $argCount; + $AllowedOutsideSubquery{$name} = 1 if $allowedOutside; + $ConstFunc{$name} = $const; +} + +sub defineMethod +{ + my ($name, $func, $argCount, $allowedOutside) = @_; + $Method{$name} = $func; + $FuncArgCount{$name} = $argCount; + $AllowedOutsideSubquery{$name} = 1 if $allowedOutside; +} + +%CompareOper = +( + 'eq' => \&XML::XQL::xql_eq, + 'ne' => \&XML::XQL::xql_ne, + 'le' => \&XML::XQL::xql_le, + 'ge' => \&XML::XQL::xql_ge, + 'gt' => \&XML::XQL::xql_gt, + 'lt' => \&XML::XQL::xql_lt, + + 'ieq' => \&XML::XQL::xql_ieq, + 'ine' => \&XML::XQL::xql_ine, + 'ile' => \&XML::XQL::xql_ile, + 'ige' => \&XML::XQL::xql_ige, + 'igt' => \&XML::XQL::xql_igt, + 'ilt' => \&XML::XQL::xql_ilt, + + '=' => \&XML::XQL::xql_eq, + '!=' => \&XML::XQL::xql_ne, + '>' => \&XML::XQL::xql_gt, + '>=' => \&XML::XQL::xql_ge, + '<' => \&XML::XQL::xql_lt, + '<=' => \&XML::XQL::xql_le, +); + +sub defineComparisonOperators +{ + my (%args) = @_; + %CompareOper = (%CompareOper, %args); +} + +sub defineTokenQ +{ + $Token_q = $_[0]; +} + +sub defineTokenQQ +{ + $Token_qq = $_[0]; +} + +my %ElementValueType = (); +my $ElementValueTypeCount = 0; + +sub elementValue +{ + my ($elem) = @_; + +#?? raw text/recursive ? + + return new XML::XQL::Text ($elem->xql_text, $elem) + if $ElementValueTypeCount == 0; # user hasn't defined any types + + my $tagName = $elem->xql_nodeName; + my $func = $ElementValueType{$tagName}; + return new XML::XQL::Text ($elem->xql_text, $elem) unless defined $func; + + &$func ($elem, $tagName); +} + +sub defineElementValueConvertor +{ + my ($elemTagName, $func) = @_; + my $prev = defined $ElementValueType{$elemTagName}; + $ElementValueType{$elemTagName} = $func; + if (defined $func != $prev) + { + defined $func ? $ElementValueTypeCount++ : $ElementValueTypeCount--; + } +} + +my %AttrValueType = (); +my $AttrValueTypeCount = 0; + +sub attrValue +{ + my ($attr) = @_; + +#?? raw text/recursive ? + return new XML::XQL::Text ($attr->xql_text, $attr) + if $AttrValueTypeCount == 0; # user hasn't defined any types + + my $elem = $attr->xql_parent->xql_nodeName; + my $attrName = $attr->xql_nodeName; + my $func = $AttrValueType{"$elem $attrName"}; + + if (not defined $func) + { + $elem = "*"; + $func = $AttrValueType{"$elem $attrName"}; + } + return new XML::XQL::Text ($attr->xql_text, $attr) unless defined $func; + + &$func ($attr, $attrName, $elem); +} + +sub defineAttrValueConvertor +{ + my ($elemTagName, $attrName, $type) = @_; + my $both = "$elemTagName $attrName"; + + my $prev = defined $AttrValueType{$both}; + $AttrValueType{$both} = $type; + if (defined $type != $prev) + { + defined $type ? $AttrValueTypeCount++ : $AttrValueTypeCount--; + } +} + +#=== debug + +sub exception +{ + my ($ex) = @_; + print "Exception: $ex\n" if $ex; + $ex; +} + +sub d +{ + my $n = shift; + my $type = ref $n; + + if ($type eq "ARRAY") + { + my $str = ""; + for my $i (@$n) + { + $str .= ", " unless $str eq ""; + $str .= d ($i); + } + return "[$str]"; + } + elsif ($type eq "HASH") + { + my $str = ""; + while (my ($key, $val) = %$n) + { + $str .= ", " unless $str eq ""; + $str .= $key . " => " . d ($val); + } + return "{$str}"; + } + elsif ($type) + { + return $n->xql_contextString if ($n->isa ('XML::XQL::Operator')); + return "${type}\[" . $n->xql_toString . "]" if $n->isa ('XML::XQL::PrimitiveType'); +# return "${type}\[" . $n->toString . "]" if $n->isa ('XML::DOM::Element'); + } + $n; +} + + +package XML::XQL::Query; + +use Carp; +use XML::XQL::Parser; + +use vars qw( %Func %FuncArgCount ); + +my $parser = new XML::XQL::Parser; + +# This is passed as 'yyerror' to YYParse +sub Error +{ + my($parser) = shift; + + print STDERR "Error in Query Expression near: " . $parser->YYData->{INPUT} . "\n"; +} + +sub defineFunction +{ + my ($self, $name, $func, $argCount, $allowedOutside, $const) = @_; + $self->{Func}->{$name} = $func; + $self->{FuncArgCount}->{$name} = $argCount; + $self->{AllowedOutsideSubquery}->{$name} = 1 if $allowedOutside; + $self->{ConstFunc} = $const; +} + +sub defineMethod +{ + my ($self, $name, $func, $argCount, $allowedOutside) = @_; + $self->{Method}->{$name} = $func; + $self->{FuncArgCount}->{$name} = $argCount; + $self->{AllowedOutsideSubquery}->{$name} = 1 if $allowedOutside; +} + +sub defineComparisonOperators +{ + my ($self, %args) = @_; + $self->{CompareOper} = \%args; +} + +sub defineTokenQ +{ + $_[0]->{'q'} = $_[1]; +} + +sub defineTokenQQ +{ + $_[0]->{'qq'} = $_[1]; +} + +sub new +{ + my ($class, %args) = @_; + + croak "no Expr specified" unless defined $args{Expr}; + + my $self = bless \%args, $class; + + my $error = $self->{'Error'} || \&XML::XQL::Query::Error; + my $debug = defined ($self->{Debug}) ? $self->{Debug} : 0; # 0x17; + + $self->{'q'} = $XML::XQL::Token_q unless exists $self->{'q'}; + $self->{'qq'} = $XML::XQL::Token_qq unless exists $self->{'qq'}; + + # Invoke the query expression parser + $parser->YYData->{INPUT} = $self->{Expr}; + $parser->{Query} = $self; + $self->{Tree} = $parser->YYParse (yylex => \&XML::XQL::Lexer, + yyerror => $error, + yydebug => $debug); + + # Nothing but whitespace should be left over + if ($parser->YYData->{INPUT} !~ /^\s*$/) + { + XML::XQL::parseError ("Error when parsing expression. Unexpected characters at end of expression [" . $parser->YYData->{INPUT} . "]") + } + + XML::XQL::parseError ("Error when parsing expression") + unless defined $self->{Tree}; + + $self->{Tree}->{Query} = $self; + $self->{Tree}->xql_check (0, 0); # inSubQuery=0, inParam=0 + + print "Expression parsed successfully\n" if $debug; + + $self; +} + +sub dispose +{ + my $self = shift; + + undef $self->{Tree}->{Query}; + + $self->{Tree}->dispose; + delete $self->{Tree}; +} + +sub isNodeQuery +{ + $_[0]->{NodeQuery}; +} + +sub solve +{ + my ($self, @list) = @_; + my $context = undef; + + # clear cached "once" values + $self->{Tree}->xql_prepCache; + my $result = $self->{Tree}->solve ($context, \@list); + ref ($result) eq "ARRAY" ? @$result : ($result); +} + +sub toString +{ + $_[0]->{Expr}; +} + +sub toDOM +{ + my ($self, $doc) = @_; + my $root = $doc->createElement ("XQL"); + $doc->appendChild ($root); + $root->appendChild ($self->{Tree}->xql_toDOM ($doc)); + $doc; +} + +sub findComparisonOperator +{ + my ($self, $name) = @_; + my $cmp; + if (exists $self->{CompareOper}->{$name}) + { + $cmp = $self->{CompareOper}->{$name}; + } + else + { + $cmp = $XML::XQL::CompareOper{$name}; + } + if (not defined $cmp) + { + XML::XQL::parseError ("undefined comparison operator '$name'"); + } + $cmp; +} + +# Return function pointer. Croak if wrong number of arguments. +sub findFunctionOrMethod +{ + my ($self, $name, $args) = @_; + + my $func; + my $type = "function"; + if (exists $self->{Func}->{$name}) + { + $func = $self->{Func}->{$name}; + } + elsif (exists $self->{Method}->{$name}) + { + $func = $self->{Method}->{$name}; + $type = "method"; + } + elsif (defined $XML::XQL::Func{$name}) + { + $func = $XML::XQL::Func{$name}; + } + elsif (defined $XML::XQL::Method{$name}) + { + $func = $XML::XQL::Method{$name}; + $type = "method"; + } + elsif (not $XML::XQL::Restricted) + { + $func = XML::XQL::generatePerlWrapper ($name); + } + + XML::XQL::parseError ("undefined function/method '$name' in query '" . + $self->toString . "'") + unless defined &$func; + + my $funcArgCount = $self->{FuncArgCount}->{$name} + || $XML::XQL::FuncArgCount{$name} || 0; + + # Check number of args + my $nargs = @$args; + +#print "$args " . XML::XQL::d($args) . "\n"; + + my $ok = 0; + if (ref ($funcArgCount) eq "ARRAY") + { + my $i = 0; + my $n = @$funcArgCount; + while ($i < $n) + { + my $s = $funcArgCount->[$i++]; + my $e = $funcArgCount->[$i++] || $s; # same as $s if odd #args + if ($nargs >= $s && ($e == -1 || $nargs <= $e)) + { + $ok = 1; # found it + last; + } + } + } + else + { + $ok = ($nargs eq $funcArgCount); + } + + XML::XQL::parseError ("wrong number of args ($nargs) for $type $name in query '" . + $self->toString . "', it should be " . XML::XQL::d($funcArgCount)) + if not $ok; + + return ($func, $type); +} + +sub isAllowedOutsideSubquery +{ + my ($self, $funcName) = @_; + my ($ok) = $self->{AllowedOutsideSubquery}->{$funcName}; + return $ok if defined $ok; + $XML::XQL::AllowedOutsideSubquery{$funcName}; +} + +package XML::XQL::Operator; +use fields qw{ Left Right Parent }; + +sub new +{ + my ($class, %attr) = @_; + my $self = bless \%attr, $class; + + $self->{Left}->setParent ($self) if defined $self->{Left}; + $self->{Right}->setParent ($self) if defined $self->{Right}; + + $self; +} + +sub dispose +{ + my $self = shift; + if (defined ($self->{Left})) + { + $self->{Left}->dispose; + undef $self->{Left}; + } + if (defined ($self->{Right})) + { + $self->{Right}->dispose; + undef $self->{Right}; + } + + undef $self->{Parent}; +} + +sub xql_check +{ + my ($self, $inSubQuery, $inParam) = @_; + $self->{Left}->xql_check ($inSubQuery, $inParam); + $self->{Right}->xql_check ($inSubQuery, $inParam) if defined $self->{Right}; +} + +sub xql_prepCache +{ + my ($self) = @_; + $self->{Left}->xql_prepCache; + $self->{Right}->xql_prepCache if defined $self->{Right}; +} + +sub xql_toDOM +{ + my ($self, $doc) = @_; + my $name = ref $self; + $name =~ s/.*:://; + my $elem = $doc->createElement ($name); + if (defined $self->{Left}) + { + my $left = $doc->createElement ("left"); + $elem->appendChild ($left); + $left->appendChild ($self->{Left}->xql_toDOM ($doc)); + } + if (defined $self->{Right}) + { + my $right = $doc->createElement ("right"); + $elem->appendChild ($right); + $right->appendChild ($self->{Right}->xql_toDOM ($doc)); + } + $elem; +} + +sub isConstant +{ + 0; +} + +# Overriden by Union and Path operators +sub mustSort +{ + 0; +} + +sub setParent +{ + $_[0]->{Parent} = $_[1]; +} + +sub warning +{ + my ($self, $msg) = @_; + print STDERR "WARNING: $msg"; + print STDERR " Context: " . $self->toContextString . "\n"; +} + +sub root +{ + my ($self) = @_; + my $top = $self; + + while (defined ($top->{Parent})) + { + $top = $top->{Parent}; + } + $top; +} + +sub query +{ + $_[0]->root->{Query}; +} + +sub toContextString +{ + my ($self) = @_; + $self->root->xql_contextString ($self); +} + +sub debugString +{ + my ($self) = @_; + my $str = "[" . ref($self); + while (my ($key, $val) = each %$self) + { + $str .= "$key=>" . XML::XQL::d($val); + } + $str . "]"; +} + +sub verbose +{ + my ($self, $str, $list) = @_; +# print STDERR "$self - $str: " . XML::XQL::d($list) . "\n"; + $list; +} + +package XML::XQL::Root; # "/" at start of XQL expression +use base 'XML::XQL::Operator'; # L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + return [] if (@$list < 1); + +#?? what if first value is not a XML::XQL::Node? should we try the second one? + [$list->[0]->xql_document]; +} +#?? add isOnce here? + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub xql_contextString +{ + XML::XQL::delim ("/", @_); +} + +package XML::XQL::Path; +use base 'XML::XQL::Operator'; # L -> L +use fields qw{ PathOp }; + +sub new +{ + my ($class, %arg) = @_; + my $self = bless \%arg, $class; + + $self->{Left} ||= new XML::XQL::Root; + + $self->{Left}->setParent ($self); + $self->{Right}->setParent ($self); + + $self; +} + +sub solve +{ + my ($self, $context, $list) = @_; + $list = $self->{Left}->solve ($context, $list); + $self->verbose ("left", $list); + + return $list if @$list < 1; + + if ($self->{PathOp} eq '/') + { + $self->verbose ("result", $self->{Right}->solve ($context, $list)); + } + else # recurse "//" + { + my $new_list = []; + my $n = @$list; + NODE: for (my $i = 0; $i < $n; $i++) + { + my $node = $list->[$i]; + # Node must be an Element or must be allowed to contain Elements + # i.e. must be an Element or a Document + # (DocumentFragment is not expected here) + my $nodeType = $node->xql_nodeType; + next NODE unless ($nodeType == 1 || $nodeType == 9); + + # Skip the node if one of its ancestors is part of the input $list + # (and therefore already processed) + my $parent = $node->xql_parent; + while (defined $parent) + { + for (my $j = $i - 1; $j >= 0; $j--) + { + next NODE if ($parent == $list->[$j]); + } + $parent = $parent->xql_parent; + } + recurse ($node, $new_list); + } + + my $results = $self->{Right}->solve ($context, $new_list); + + # Sort the result list unless the parent Operator will sort + my $parent = $self->{Parent}; + XML::XQL::sortDocOrder ($results) + unless defined ($parent) and $parent->mustSort; + + $self->verbose ("result //", $results); + } +} + +sub mustSort +{ + $_[0]->{PathOp} eq '//'; +} + +sub recurse +{ + my ($node, $list) = @_; + push @$list, $node; + for my $kid (@{$node->xql_element}) + { + recurse ($kid, $list); + } +} + +sub xql_contextString +{ + my $self = shift; + + my $str = $self->{Left}->isa ('XML::XQL::Root') ? + "" : $self->{Left}->xql_contextString (@_); + + XML::XQL::delim ($str . XML::XQL::bold($self->{PathOp}) . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +sub xql_toDOM +{ + my ($self, $doc) = @_; + my $elem = $self->SUPER::xql_toDOM ($doc); + $elem->setAttribute ("pathOp", $self->{PathOp}); + $elem; +} + +package XML::XQL::Sequence; # "elem;elem" or "elem;;elem" +use base 'XML::XQL::Operator'; # L -> L +use fields qw{ Oper }; + +# See "The Design of XQL" by Jonathan Robie +# +# for definition of Sequence operators. + +# Note that the "naive" implementation slows things down quite a bit here... +sub solve +{ + my ($self, $context, $list) = @_; + my $left = $self->{Left}->solve ($context, $list); + $self->verbose ("left", $left); + return [] unless @$left; + + my $right = $self->{Right}->solve ($context, $list); + $self->verbose ("right", $right); + return [] unless @$right; + + my @result; + if ($self->{Oper} eq ';') # immediately precedes + { + my %hleft; @hleft{@$left} = (); # initialize all values to undef + my %pushed; + + for my $r (@$right) + { + # Find previous sibling that is not a text node that has only + # whitespace that can be ignored (because xml:space=preserve) + my $prev = $r->xql_prevNonWS; + # $prev must be defined and must exist in $left + next unless $prev and exists $hleft{$prev}; + + # Filter duplicates (no need to sort afterwards) + push @result, $prev unless $pushed{$prev}++; + push @result, $r unless $pushed{$r}++; + } + } + else # oper eq ';;' (i.e. precedes) + { + my %pushed; + + for my $r (@$right) + { + for my $l (@$left) + { + # If left node precedes right node, add them + if ($l->xql_sortKey lt $r->xql_sortKey) + { + # Filter duplicates + push @result, $l unless $pushed{$l}++; + push @result, $r unless $pushed{$r}++; + } + } + +#?? optimize - left & right are already sorted... + # sort in document order + XML::XQL::sortDocOrder (\@result) if @result; + } + } + \@result; +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold($self->{Oper}) . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Current; # "." +use base 'XML::XQL::Operator'; # L -> L + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub solve +{ + my ($self, $context, $list) = @_; + $list; +} + +sub xql_contextString +{ + XML::XQL::delim (".", @_); +} + +package XML::XQL::Parent; # ".." +use base 'XML::XQL::Operator'; + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + for my $node (@$list) + { + push @result, $node->xql_parent; + } + \@result; +} + +sub xql_contextString +{ + XML::XQL::delim ("..", @_); +} + +package XML::XQL::Element; # "elem" +use base 'XML::XQL::Operator'; # L -> L +use fields qw{ Name NameSpace Expr }; + +sub new +{ + my ($class, %args) = @_; + if (not defined ($args{NameSpace})) + { + if ($args{Name} eq "*") + { + return bless \%args, 'XML::XQL::AllElements'; + } + else + { + return bless \%args, 'XML::XQL::SimpleElement'; + } + } + + $args{Expr} = XML::XQL::buildNameSpaceExpr ($args{NameSpace}, + $args{Name}); + bless \%args, $class; +} + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + + my $expr = $self->{Expr}; + for my $node (@$list) + { + for my $kid (@{$node->xql_element}) + { + push @result, $kid if $kid->xql_nodeName =~ /$expr/; + } + } + \@result; +} + +sub xql_contextString +{ + my $self = shift; + my $name = $self->{Name}; + my $space = $self->{NameSpace}; + + my $str = defined($space) ? "$space:$name" : $name; + + XML::XQL::delim ($str, $self, @_); +} + +sub xql_toDOM +{ + my ($self, $doc) = @_; + my $elem = $self->SUPER::xql_toDOM ($doc); + + my $name = $self->{Name}; + my $space = $self->{NameSpace}; + my $str = defined($space) ? "$space:$name" : $name; + + $elem->setAttribute ("name", $str); + $elem; +} + +package XML::XQL::SimpleElement; # "elem" +use base 'XML::XQL::Element'; # L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + my $name = $self->{Name}; + + for my $node (@$list) + { + push @result, @{ $node->xql_element ($name) }; + } + \@result; +} + +package XML::XQL::AllElements; # "*" +use base 'XML::XQL::Element'; # L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + + for my $node (@$list) + { + push @result, @{$node->xql_element}; + } + \@result; +} + +package XML::XQL::Attribute; # "@attr" +use base 'XML::XQL::Operator'; # L -> L of Attributes +use fields qw{ Name NameSpace Expr }; + +sub new +{ + my ($class, %args) = @_; + + if (not defined ($args{NameSpace})) + { + if ($args{Name} eq "*") + { + return bless \%args, 'XML::XQL::AllAttr'; + } + else + { + return bless \%args, 'XML::XQL::SimpleAttr'; + } + } + + $args{Expr} = XML::XQL::buildNameSpaceExpr ($args{NameSpace}, + $args{Name}); + bless \%args, $class; +} + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + + my $expr = $self->{Expr}; + for my $node (@$list) + { + for my $kid (@{$node->xql_attribute}) + { + push @result, $kid if $kid->xql_nodeName =~ /$expr/; + } + } +} + +sub xql_contextString +{ + my $self = shift; + my $name = $self->{Name}; + my $space = $self->{NameSpace}; + + my $str = defined($space) ? "\@$space:$name" : ('@' . $name); + + XML::XQL::delim ($str, $self, @_); +} + +package XML::XQL::SimpleAttr; # "@attr" +use base 'XML::XQL::Attribute'; # L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + my $name = $self->{Name}; + + for my $node (@$list) + { + push @result, @{ $node->xql_attribute ($name) }; + } + \@result; +} + +package XML::XQL::AllAttr; # "@*" +use base 'XML::XQL::Attribute'; # L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my @result = (); + + for my $node (@$list) + { + push @result, @{$node->xql_attribute}; + } + \@result; +} + +package XML::XQL::Subscript; # "[3, 5 $to$ 7, -1]" +use base 'XML::XQL::Operator'; # L -> L +use fields qw{ IndexList }; + +#?? optimize for simple subscripts +sub solve +{ + my ($self, $context, $inlist) = @_; + my @result = (); + + for my $node (@$inlist) + { + + my $list = $self->{Left}->solve ($context, [$node]); + $self->verbose("Left", $list); + + my $n = int (@$list); + next if ($n == 0); + + # build ordered index list + my @indexFlags = (); + $#indexFlags = $n - 1; + + my $index = $self->{IndexList}; + my $len = @$index; + +#?? this is done a lot - optimize.... + my $i = 0; + while ($i < $len) + { + my $start = $index->[$i++]; + $start += $n if ($start < 0); + my $end = $index->[$i++]; + $end += $n if ($end < 0); + + next unless $start <= $end && $end >=0 && $start < $n; + $start = 0 if ($start < 0); + $end = $n-1 if ($end >= $n); + + for my $j ($start .. $end) + { + $indexFlags[$j] = 1; + } + } + for $i (0 .. $n-1) + { + push @result, $list->[$i] if $indexFlags[$i]; + } + } + \@result; +} + +sub xql_contextString +{ + my $self = shift; + + my $index = $self->{IndexList}; + my $str = XML::XQL::bold("["); + for (my $i = 0; $i < @$index; $i++) + { + $str .= ", " if $i > 0; + + my $s = $index->[$i++]; + my $e = $index->[$i]; + $str = ($s == $e) ? $s : "$s \$to\$ $e"; + } + $str .= XML::XQL::bold("]"); + + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . $str, $self, @_); +} + +sub xql_toDOM +{ + my ($self, $doc) = @_; + my $elem = $self->SUPER::xql_toDOM ($doc); + + my $index = $self->{IndexList}; + my $str = ""; + for (my $i = 0; $i < @$index; $i++) + { + $str .= ", " if $i > 0; + + my $s = $index->[$i++]; + my $e = $index->[$i]; + $str .= ($s == $e) ? $s : "$s \$to\$ $e"; + } + + my $ie = $doc->createElement ("index"); + $ie->setAttribute ("list", $str); + $elem->appendChild ($ie); + $elem; +} + +package XML::XQL::Union; # "book $union$ magazine", also "|" +use base 'XML::XQL::Operator'; # L x L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my $left = XML::XQL::toList ($self->{Left}->solve ($context, $list)); + my $right = XML::XQL::toList ($self->{Right}->solve ($context, $list)); + + return $right if (@$left < 1); + return $left if (@$right < 1); + + my @result = @$left; + for my $node (@$right) + { + push @result, $node unless XML::XQL::listContains ($left, $node); + } + + my $parent = $self->{Parent}; + + # Don't sort if parent is a Union or //, because the parent will do the sort + unless (defined $parent and $parent->mustSort) + { + XML::XQL::sortDocOrder (\@result) + } +# $self->verbose ("Union result", \@result); + + \@result; +} + +sub mustSort +{ + 1; +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold (" \$union\$ ") . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Intersect; # "book $intersect$ magazine" +use base 'XML::XQL::Operator'; # L x L -> L + +sub solve +{ + my ($self, $context, $list) = @_; + my $left = XML::XQL::toList ($self->{Left}->solve ($context, $list)); + return [] if @$left < 1; + + my $right = XML::XQL::toList ($self->{Right}->solve ($context, $list)); + return [] if @$right < 1; + + # Assumption: $left and $right don't have duplicates themselves + my @result = (); + for my $node (@$left) + { +#? reimplement with hash - faster! + push @result, $node if XML::XQL::listContains ($right, $node); + } + \@result; +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold (" \$intersect\$ ") . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Filter; # "elem[expr]" +use base 'XML::XQL::Operator'; # L -> L + +sub solve +{ + my ($self, $context, $inlist) = @_; + my @result = (); + + for my $node (@$inlist) + { + + my $list = $self->{Left}->solve ($context, [$node]); + next if @$list == 0; + + my $subQuery = $self->{Right}; + + $context = [0, scalar (@$list)]; + for my $node (@$list) + { +#?? optimize? only need the first one to succeed + my $r = $subQuery->solve ($context, [ $node ]); + push @result, $node if XML::XQL::toBoolean ($r); + $context->[0]++; # increase the index for the index() method + } + } + \@result; +} + +sub xql_check +{ + my ($self, $inSubQuery, $inParam) = @_; + $self->{Left}->xql_check ($inSubQuery, $inParam); + $self->{Right}->xql_check (1, $inParam); +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold ("[") . + $self->{Right}->xql_contextString (@_) . + XML::XQL::bold ("]"), $self, @_); +} + +package XML::XQL::BooleanOp; +use base 'XML::XQL::Operator'; + +package XML::XQL::Or; +use base 'XML::XQL::BooleanOp'; + +sub solve +{ + my ($self, $context, $list) = @_; + my $left = $self->{Left}->solve ($context, $list); + return $XML::XQL::Boolean::TRUE if XML::XQL::toBoolean ($left); + return $self->{Right}->solve ($context, $list); +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold (" \$or\$ ") . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::And; +use base 'XML::XQL::BooleanOp'; + +sub solve +{ + my ($self, $context, $list) = @_; + my $left = $self->{Left}->solve ($context, $list); + return $XML::XQL::Boolean::FALSE unless XML::XQL::toBoolean ($left); + return $self->{Right}->solve ($context, $list); +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold (" \$and\$ ") . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Not; +use base 'XML::XQL::BooleanOp'; + +sub solve +{ + my ($self, $context, $list) = @_; + my $left = $self->{Left}->solve ($context, $list); + return XML::XQL::toBoolean ($left) ? $XML::XQL::Boolean::FALSE : $XML::XQL::Boolean::TRUE; +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim (XML::XQL::bold ("\$not\$ ") . + $self->{Left}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Compare; +use base 'XML::XQL::Operator'; +use fields qw{ Func All }; + +use Carp; + +sub solve +{ + my ($self, $context, $list) = @_; + + my $type; + my $cmpFunc = $self->{Func}; + + my $left = $self->verbose ("left", XML::XQL::toList ($self->{Left}->solve ($context, $list))); + return [] if @$left < 1; + + my $right; + eval { + $right = $self->verbose ("right", XML::XQL::prepareRvalue ($self->{Right}->solve ($context, $list))); + }; + return [] if XML::XQL::exception ($@); + + if ($self->{All}) + { + for my $node (@$left) + { + eval { + # Stop if any of the comparisons fails + return [] unless &$cmpFunc ($node, $right); + }; + return [] if XML::XQL::exception ($@); + } + return $left; + } + else # $any$ + { + my @result = (); + for my $node (@$left) + { + eval { + push (@result, $node) + if &$cmpFunc ($node, $right); + }; + return [] if XML::XQL::exception ($@); + } + return \@result; + } +} + +sub xql_contextString +{ + my $self = shift; + my $all = $self->{All} ? "\$all\$ " : ""; + + XML::XQL::delim ($all . $self->{Left}->xql_contextString (@_) . " " . + XML::XQL::bold ($self->{Oper}) . " " . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Func; + +use Carp; + +sub count +{ + my ($context, $list, $expr) = @_; + + my $cnt; + if (defined $expr) + { + $list = XML::XQL::toList ($expr->solve ($context, $list)); + $cnt = @$list; + } + else + { + $cnt = $context->[1]; + } +#?? ref node? + new XML::XQL::Number ($cnt); +} + +sub id +{ + my ($context, $list, $query) = @_; + + return [] if @$list == 0; + + my $id = XML::XQL::prepareRvalue ($query->solve ($context, $list)); +#?? check result? + +#?? if [0] is not a Node, I should probably try the next one + my $doc = $list->[0]->xql_document; + + _findId ($doc->xql_element->[0], $id); +} + +sub _findId # static method +{ + my ($elem, $id) = @_; + my $attr = $elem->xql_attribute ("id"); + return [$elem] if (@$attr == 1 && $attr->[0]->xql_nodeName eq $id); + + for my $kid (@{$elem->xql_element}) + { + $attr = _findId ($kid); + return $attr if @$attr; + } + return []; +} + +sub end +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + new XML::XQL::Boolean ($context->[0] == $context->[1] - 1); +} + +sub xql_index +{ + my ($context, $list) = @_; + +# print "index: " . XML::XQL::d($context) . "\n"; +#?? wrong! + return [] if @$list == 0; + new XML::XQL::Number ($context->[0]); +} + +sub ancestor +{ + my ($context, $list, $query) = @_; + + return [] if @$list == 0; + + my @anc = (); +#?? fix for @$list > 1 + my $parent = $list->[0]->xql_parent; + + while (defined $parent) + { + # keep list of ancestors so far + unshift @anc, $parent; + + # solve the query for the ancestor + my $result = $query->solve ($context, [$parent]); + for my $node (@{$result}) + { + for my $anc (@anc) + { + return [$node] if $node == $anc; + } + } + $parent = $parent->xql_parent; + } + return []; +} + +sub node +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + return $list->[0]->xql_node if @$list == 1; + + my @result; + for my $node (@$list) + { + push @result, @{ $node->xql_node }; + } + XML::XQL::sortDocOrder (\@result); +} + +sub _nodesByType +{ + my ($list, $type) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + for my $kid (@{ $node->xql_node }) + { + push @result, $kid if $kid->xql_nodeType == $type; + } + } + @$list > 1 ? XML::XQL::sortDocOrder (\@result) : \@result; +} + +sub pi +{ + my ($context, $list, $pi_name) = @_; + if (defined $pi_name) + { + return [] if @$list == 0; + + $pi_name = $pi_name->solve ($context, $list)->xql_toString; + + my @result; + for my $node (@$list) + { + for my $kid (@{ $node->xql_node }) + { + push @result, $kid + if $kid->xql_nodeType == 7 && $kid->getTarget eq $pi_name; + } + } + return @$list > 1 ? XML::XQL::sortDocOrder (\@result) : \@result; + } + + return _nodesByType ($_[1], 7); +} + +sub comment +{ + _nodesByType ($_[1], 8); +} + +sub textNode +{ + _nodesByType ($_[1], 3); +} + +sub nodeName +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + push @result, new XML::XQL::Text ($node->xql_nodeName, $node); + } + \@result; +} + +sub namespace +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + my $namespace = $node->xql_namespace; + next unless defined $namespace; + push @result, new XML::XQL::Text ($namespace, $node); + } + \@result; +} + +sub prefix +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + my $prefix = $node->xql_prefix; + next unless defined $prefix; + push @result, new XML::XQL::Text ($prefix, $node); + } + \@result; +} + +sub baseName +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + my $basename = $node->xql_baseName; + next unless defined $basename; + push @result, new XML::XQL::Text ($basename, $node); + } + \@result; +} + +sub nodeType +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + push @result, new XML::XQL::Number ($node->xql_nodeType, $node); + } + \@result; +} + +sub nodeTypeString +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + push @result, new XML::XQL::Text ($node->xql_nodeTypeString, $node); + } + @result; +} + +sub value +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + push @result, $node->xql_value; # value always returns an object + } + \@result; +} + +sub text +{ + my ($context, $list, $recurse) = @_; + + return [] if @$list == 0; + + if (defined $recurse) + { + $recurse = $recurse->solve ($context, $list)->xql_toString; + } + else + { + $recurse = 1; # default + } + + my @result; + for my $node (@$list) + { + my $text = $node->xql_text ($recurse); + next unless defined $text; + + push @result, new XML::XQL::Text ($text, $node); + } + \@result; +} + +sub rawText +{ + my ($context, $list, $recurse) = @_; + + return [] if @$list == 0; + + if (defined $recurse) + { + $recurse = $recurse->solve ($context, $list)->xql_toString; + } + else + { + $recurse = 1; # default + } + + my @result; + for my $node (@$list) + { + my $text = $node->xql_rawText ($recurse); + next unless defined $text; + + push @result, new XML::XQL::Text ($text, $node); + } + \@result; +} + +sub true +{ + return $XML::XQL::Boolean::TRUE; +} + +sub false +{ + return $XML::XQL::Boolean::FALSE; +} + +#sub date() is in XQL::XML::Date + +sub element +{ + my ($context, $list, $text) = @_; + + return [] if @$list == 0; + + my @result; + if (defined $text) + { + $text = XML::XQL::prepareRvalue ($text->solve ($context, $list))->xql_toString; + for my $node (@$list) + { + push @result, @{$node->xql_element ($text)}; + } + } + else + { + for my $node (@$list) + { + push @result, @{$node->xql_element}; + } + } + @$list > 1 ? XML::XQL::sortDocOrder (\@result) : \@result; +} + +sub attribute +{ + my ($context, $list, $text) = @_; + + return [] if @$list == 0; + + my @result; + if (defined $text) + { + $text = XML::XQL::prepareRvalue ($text->solve ($context, $list))->xql_toString; + for my $node (@$list) + { + push @result, @{ $node->xql_attribute ($text) }; + } + } + else + { + for my $node (@$list) + { + push @result, @{ $node->xql_attribute }; + } + } + \@result; +} + +package XML::XQL::Bang; +use base 'XML::XQL::Operator'; + +sub solve +{ + my ($self, $context, $list) = @_; + $list = $self->{Left}->solve ($context, $list); + $self->{Right}->solve ($context, $list); +} + +sub xql_contextString +{ + my $self = shift; + XML::XQL::delim ($self->{Left}->xql_contextString (@_) . + XML::XQL::bold ("!") . + $self->{Right}->xql_contextString (@_), $self, @_); +} + +package XML::XQL::Invocation; +use base 'XML::XQL::Operator'; +use fields qw{ Args Name Type Once ConstVal }; + +use Carp; + +sub new +{ + my ($class, %args) = @_; + + my $self = bless \%args, $class; + for my $par (@{$self->{Args}}) + { + $par->setParent ($self); + } + $self; +} + +sub dispose +{ + my $self = shift; + for (@{ $self->{Args} }) + { + $_->dispose; + } + undef $self->{Args}; + + undef $self->{Parent}; +} + +sub isConstant +{ + my ($self) = @_; + + # An Invocation is constant, if all it's arguments are constant + # and it's a "constant" function + my $name = $self->{Name}; + my $cf = $self->query->{ConstFunc}; + my $const = exists ($cf->{$name}) ? + $cf->{name} : $XML::XQL::ConstFunc{$name}; + return 0 unless $const; + + for my $par (@{$self->{Args}}) + { + return 0 unless $par->isConstant; + } + 1; +} + +sub xql_check +{ + my ($self, $inSubQuery, $inParam) = @_; + + # Syntactic Constraint 7: + # In a node query this function or method is only valid inside an instance + # of Subquery, unless it appears within an instance of Param. + # Functions and methods are valid anywhere in a full query. + + my $query; + if (not ($inSubQuery or $inParam) and ($query = $self->query)->isNodeQuery) + { + unless ($query->isAllowedOutsideSubquery ($self->{Name})) + { + XML::XQL::parseError $self->{Type} . " " . $self->{Name} . + " is only allowed inside a Subquery or Param for 'Node Queries'." . + " Context: " . $self->toContextString; + } + } + for my $par (@{$self->{Args}}) + { + $par->xql_check ($inSubQuery, 1); # these are Params + } + # once() should only be evaluated once per query + # "constant" functions should only be evaluated once *ever* + $self->{Once} = $self->isOnce || $self->isConstant; +} + +sub xql_prepCache +{ + my ($self) = @_; + # once() should only be evaluated once per query + # "constant" functions should only be evaluated once *ever* + delete $self->{ConstVal} if $self->isOnce; + + for my $par (@{$self->{Args}}) + { + $par->xql_prepCache; + } +} + +sub isOnce +{ + $_[0]->{Name} eq "once"; +} + +sub isMethod +{ + $_[0]->{Type} eq "method"; +} + +sub solve +{ + my ($self, $context, $list) = @_; + + # Use the cached value if it's a "constant" function + return $self->{ConstVal} if (exists $self->{ConstVal}); + + my $func = $self->{Func}; + + my $result; + eval { + $result = &$func ($context, $list, @{$self->{Args}}); + $self->{ConstVal} = $result if $self->{Once}; + }; + if ($@) + { +#?? or croak + $self->warning ("invocation of '" . $self->{Name} . "' failed:\n\t$@"); + $self->{ConstVal} = [] if $self->{Once}; + return []; + } + $result; +} + +sub xql_contextString +{ + my $self = shift; + + my $str = XML::XQL::bold ($self->{Name}) . "("; + for (my $i = 0; $i < @{$self->{Args}}; $i++) + { + $str .= ", " if $i > 0; + $str .= $self->{Args}->[$i]->xql_contextString (@_); + } + $str .= ")"; + + XML::XQL::delim ($str, $self, @_); +} + +# Base class shared by Node and PrimitiveType +package XML::XQL::PrimitiveTypeBase; + +sub dispose +{ +} + +sub xql_check +{ +} + +sub xql_prepCache +{ +} + +sub xql_prevSibling +{ + undef; +} + +# This method returns an integer that determines how values should be casted +# for comparisons. If the left value (LHS) has a higher xql_primType, the +# right value (RHS) is cast to the type of the LHS (otherwise, the LHS is casted +# to the type of the LHS) +# +# Values for certain types: +# Node 0 (always cast a node to a Text string first) +# Text 1 +# Number 2 +# Boolean 3 +# Date 4 (other classes automatically use 4 by default) + +sub xql_primType +{ + 4; # default for all classes other then Node, Text, Number, Boolean +} + +sub xql_toBoolean +{ + 1; # it is true if it exists +} + +sub xql_namespace +{ + undef; +} + +sub xql_baseName +{ + undef; +} + +sub xql_prefix +{ + undef; +} + +sub xql_sortKey +{ + my $src = $_[0]->xql_sourceNode; + $src ? $src->xql_sortKey : $XML::XQL::LAST_SORT_KEY; +} + +sub xql_toDOM +{ + my ($self, $doc) = @_; + my $name = ref $self; + $name =~ s/.*:://; + my $elem = $doc->createElement ($name); + $elem->setAttribute ("value", $self->xql_toString); + $elem; +} + +package XML::XQL::PrimitiveType; +use vars qw( @ISA ); +@ISA = qw( XML::XQL::PrimitiveTypeBase ); + +sub new +{ + my ($class, $val, $srcNode) = @_; + bless [$val, $srcNode], $class; +} + +sub isConstant +{ + 1; +} + +sub setParent +{ + # not defined +} + +sub solve +{ + $_[0]; # evaluates to itself +} + +# +# Derived classes should not override this method. +# Override xql_toString instead. +# +sub xql_contextString +{ + my $self = shift; + + XML::XQL::delim ($self->xql_toString, $self, @_); +} + +# +# Return the value of the Object as a primitive Perl value, i.e. an integer, +# a float, or a string. +# +sub xql_toString +{ + $_[0]->[0]; +} + +sub xql_sourceNode +{ + $_[0]->[1]; +} + +sub xql_setSourceNode +{ + $_[0]->[1] = $_[1]; +} + +sub xql_setValue +{ + # This could potentially change the value of a constant in the XQL + # query expression. + $_[0]->[0] = $_[1]; +} + +sub xql_nodeType +{ + 0; # it's not a Node +} + +sub xql_compare +{ + # Temporarily switch off $WARNING flag, to disable messages a la: + # Argument "1993-02-14" isn't numeric in ncmp + local $^W = 0; + $_[0]->[0] <=> $_[1]->xql_toString; +} + +sub xql_eq { my $self = shift; $self->xql_compare (@_) == 0; } +sub xql_ne { my $self = shift; $self->xql_compare (@_) != 0; } +sub xql_lt { my $self = shift; $self->xql_compare (@_) < 0; } +sub xql_le { my $self = shift; $self->xql_compare (@_) <= 0; } +sub xql_gt { my $self = shift; $self->xql_compare (@_) > 0; } +sub xql_ge { my $self = shift; $self->xql_compare (@_) >= 0; } + +package XML::XQL::Boolean; +use vars qw( @ISA @EXPORT $TRUE $FALSE ); + +use Carp; + +@ISA = qw( XML::XQL::PrimitiveType ); +@EXPORT = qw( $TRUE $FALSE ); + +$TRUE = new XML::XQL::Boolean (1); +$FALSE = new XML::XQL::Boolean (0); + +sub xql_primType +{ + 3; +} + +sub xql_toBoolean +{ + $_[0]->[0]; # evaluate it to its value +} + +sub xql_negate +{ +#?? do we need to keep track of a source node here? + $_[0]->[0] ? $FALSE : $TRUE; +} + +sub xql_compare +{ +#?? how do we convert string to boolean value + $_[0]->[0] <=> ($_[1]->xql_toString ? 1 : 0); +} + +sub xql_lt { badComparisonError (@_); } +sub xql_gt { badComparisonError (@_); } +sub xql_le { badComparisonError (@_); } +sub xql_ge { badComparisonError (@_); } + +sub badComparisonError +{ + croak 'comparison operator (other than =, !=, $ieq$, $ine$) not defined for type Boolean'; +} + +package XML::XQL::Number; +use vars qw( @ISA ); +@ISA = qw( XML::XQL::PrimitiveType ); + +#use overload +# 'fallback' => 1, # use default operators, if not specified +# '""' => \&debug; + +sub debug +{ + "Number[" . $_[0]->[0] . "]"; +} + +sub xql_primType +{ + 2; +} + +package XML::XQL::Text; +use vars qw( @ISA ); +@ISA = qw( XML::XQL::PrimitiveType ); + +#use overload +# 'fallback' => 1, # use default operators, if not specified +# '""' => \&debug; + +sub debug +{ + "Text[" . $_[0]->[0] . "]"; +} + +sub xql_primType +{ + 1; +} + +sub xql_compare +{ + my ($self, $other, $ignoreCase) = @_; + if ($ignoreCase) + { + my $lhs = $self->[0]; + my $rhs = $other->xql_toString; + "\U$lhs" cmp "\U$rhs"; + } + else + { + $self->[0] cmp $other->xql_toString; + } +} + +# Declare package XML::XQL::Node so that XML implementations can say +# that their nodes derive from it: +# +# This worked for me when I added XQL support for XML::DOM: +# +# BEGIN +# { +# push @XML::DOM::Node::ISA, 'XML::XQL::Node'; +# } +# + +package XML::XQL::Node; + +use vars qw( @ISA ); +@ISA = qw( XML::XQL::PrimitiveTypeBase ); + +use Carp; + +sub xql_primType +{ + 0; +} + +sub xql_toBoolean +{ + 1; # it is true if it exists +} + +sub xql_attribute +{ + []; +} + +sub xql_sourceNode +{ + $_[0]; +} + +# Default implementation - override this for speed +sub xql_element +{ + my ($node, $elem) = @_; + + my @list = (); + if (defined $elem) + { + for my $kid (@{$_[0]->xql_node}) + { + # 1: element + push @list, $kid + if $kid->xql_nodeType == 1 && $kid->xql_nodeName eq $elem; + } + } + else + { + for my $kid (@{$_[0]->xql_node}) + { + push @list, $kid if $kid->xql_nodeType == 1; # 1: element + } + } + \@list; +} + +sub xql_text +{ + undef; +} + +sub xql_rawText +{ + undef; +} + +sub xql_rawTextBlocks +{ + undef; +} + +sub xql_value +{ + new XML::XQL::Text ($_[0]->xql_text ($_[1]), $_[0]); +} + +# Convert xql_value to Perl string (or undef if xql_value is undefined) +sub xql_toString +{ + my $val = $_[0]->xql_value; + return undef if XML::XQL::isEmptyList ($val); + + $val->xql_toString; +} + +sub xql_setValue +{ + # Not implemented for most node types +} + +sub xql_data +{ + ""; +} + +sub xql_nodeType +{ + 0; +} + +sub xql_nodeName +{ + []; +} + +# Java code from "XML:: Namespaces in 20 lines" by James Clark: +# see: http://www.oasis-open.org/cover/clarkNS-980804.html +# +# String expandName(String name, Element element, boolean isAttribute) { +# // The index of the colon character in the name. +# int colonIndex = name.indexOf(':'); +# // The name of the attribute that declares the namespace prefix. +# String declAttName; +# if (colonIndex == -1) { +# // Default namespace applies only to element type names. +# if (isAttribute) +# return name; +# declAttName = "xmlns"; +# } +# else { +# String prefix = name.substring(0, colonIndex); +# // "xml:" is special +# if (prefix.equals("xml")) +# return name; +# declAttName = "xmlns:" + prefix; +# } +# for (; element != null; element = element.getParent()) { +# String ns = element.getAttributeValue(declAttName); +# if (ns != null) { +# // Handle special meaning of xmlns="" +# if (ns.length() == 0 && colonIndex == -1) +# return name; +# return ns + '+' + name.substring(colonIndex + 1); +# } +# } +# return null; +# } + +# From "Namespaces in XML" +# at http://www.w3.org/TR/1998/WD-xml-names-19980916 +# +# The prefix xml is by definition bound to the namespace name +# urn:Connolly:input:required. The prefix xmlns is used only for +# namespace bindings and is not itself bound to any namespace name. + +my $DEFAULT_NAMESPACE = undef; +my $XML_NAMESPACE = "urn:Connolly:input:required"; +#?? default namespace + +sub xql_namespace +{ + my ($self) = @_; + my $nodeType = $self->xql_nodeType; + my $element = $self; + + if ($nodeType == 2) # 2: Attr + { + $element = $self->xql_parent; + } + elsif ($nodeType != 1) # 1: Element + { + return undef; + } + my $name = $self->xql_nodeName; + my $declAttName; + + if ($name =~ /([^:]+):([^:]+)/) + { + my ($prefix, $basename) = ($1, $2); + + # "xml:" is special + return $XML_NAMESPACE if $prefix eq "xml"; + + $declAttName = "xmlns:$prefix"; + } + else + { + # Default namespace applies only to element type names. + return $DEFAULT_NAMESPACE if $nodeType == 2; # 2: Attr +#?? default namespace? + $declAttName = "xmlns"; + } + + do + { + my $ns = $element->xql_attribute ($declAttName); + next unless defined $ns; + return $ns->xql_rawText; + + $element = $element->xql_parent; + } + while (defined ($element) and $element->xql_nodeType == 1); + + # namespace not found + undef; +} + +sub xql_basename +{ + my ($self) = @_; + my $nodeType = $self->xql_nodeType; + return undef unless $nodeType == 1 || $nodeType == 2; + + my $name = $self->xql_nodeName; + $name =~ s/^[^:]://; # strip prefix + $name; +} + +sub xql_prefix +{ + my ($self) = @_; + my $nodeType = $self->xql_nodeType; + return undef unless $nodeType == 1 || $nodeType == 2; + + $self->xql_nodeName =~ /^([^:]+):/; + $1; +} + +# Used by ancestor() +sub xql_parent +{ + undef; +} + +my @NodeTypeString = +( + "", "element", "attribute", "text", "", "", "", "processing_instruction", + "comment", "document" +); + +sub xql_nodeTypeString +{ + my $i = $_[0]->xql_nodeType; + return $NodeTypeString[$i] if ($i >= 1 && $i <= 3 || $i >= 7 && $i <= 9); + +#?? what should this return? + ""; +} + +if (not $XML::XQL::Restricted) +{ + require XML::XQL::Plus; +} + +# All nodes should implement: + +#?? this section must be updated!! + +# - xql_document +# - xql_node: return an unblessed list reference with childNodes (not +# attributes) +# - xql_nodeType (default implementation for XML::XQL::Node returns 0): +# Element: 1 +# Element Attribute: 2 +# Markup-Delimited Region of Text (Text and CDATASection): 3 +# Processing Instruction: 7 +# Comment: 8 +# Document (Entity): 9 +# - xql_text +# - xql_value (default implementation is xql_text) +# - xql_parent: return parent node or undef (Document, DocumentFragment) +# +# Element should define/override the following: +# - xql_nodeName: return the element name +# - xql_attribute("attributeName"): return an unblessed reference to a list +# with the attribute, or [] if no such attribute +# - xql_attribute(): return an unblessed reference to a list with +# all attribute nodes +# - xql_baseName, xql_prefix +# +# Attribute: +# - xql_nodeName: return the attribute name +# - xql_baseName, xql_prefix +# +# EntityReference: +# - xql_data: return expanded text value +# +# Text, CDATASection: +# - xql_data: return expanded text value +# +# -xql_element could be overriden to speed up performance +# + +1; + +__END__ + +=head1 NAME + +XML::XQL - A perl module for querying XML tree structures with XQL + +=head1 SYNOPSIS + + use XML::XQL; + use XML::XQL::DOM; + + $parser = new XML::DOM::Parser; + $doc = $parser->parsefile ("file.xml"); + + # Return all elements with tagName='title' under the root element 'book' + $query = new XML::XQL::Query (Expr => "book/title"); + @result = $query->solve ($doc); + $query->dispose; # Avoid memory leaks - Remove circular references + + # Or (to save some typing) + @result = XML::XQL::solve ("book/title", $doc); + + # Or (to save even more typing) + @result = $doc->xql ("book/title"); + +=head1 DESCRIPTION + +The XML::XQL module implements the XQL (XML Query Language) proposal +submitted to the XSL Working Group in September 1998. +The spec can be found at: L +Most of the contents related to the XQL syntax can also be found in the +L that comes with this distribution. +Note that XQL is not the same as XML-QL! + +The current implementation only works with the L module, but once the +design is stable and the major bugs are flushed out, other extensions might +follow, e.g. for XML::Grove. + +XQL was designed to be extensible and this implementation tries to stick to that. +Users can add their own functions, methods, comparison operators and data types. +Plugging in a new XML tree structure (like XML::Grove) should be a piece of cake. + +To use the XQL module, either + + use XML::XQL; + +or + + use XML::XQL::Strict; + +The Strict module only provides the core XQL functionality as found in the +XQL spec. By default (i.e. by using XML::XQL) you get 'XQL+', which has +some additional features. + +See the section L for the differences. + +This module is still in development. See the To-do list in XQL.pm for what +still needs to be done. Any suggestions are welcome, the sooner these +implementation issues are resolved, the faster we can all use this module. + +If you find a bug, you would do me great favor by sending it to me in the +form of a test case. See the file t/xql_template.t that comes with this distribution. + +If you have written a cool comparison operator, function, method or XQL data +type that you would like to share, send it to enno@att.com and I will +add it to this module. + +=head1 XML::XQL global functions + +=over 4 + +=item solve (QUERY_STRING, INPUT_LIST...) + + @result = XML::XQL::solve ("doc//book", $doc); + +This is provided as a shortcut for: + + $query = new XML::XQL::Query (Expr => "doc//book"); + @result = $query->solve ($doc); + $query->dispose; + +Note that with L, you can also write (see L +for details): + + @result = $doc->xql ("doc//book"); + +=item setDocParser (PARSER) + +Sets the XML::DOM::Parser that is used by the new XQL+ document() method. +By default it uses an XML::DOM::Parser that was created without any arguments, +i.e. + + $PARSER = new XML::DOM::Parser; + +=item defineFunction (NAME, FUNCREF, ARGCOUNT [, ALLOWED_OUTSIDE [, CONST, [QUERY_ARG]]]) + +Defines the XQL function (at the global level, i.e. for all newly created +queries) with the specified NAME. The ARGCOUNT parameter can either be a single +number or a reference to a list with numbers. +A single number expands to [ARGCOUNT, ARGCOUNT]. The list contains pairs of +numbers, indicating the number of arguments that the function allows. The value +-1 means infinity. E.g. [2, 5, 7, 9, 12, -1] means that the function can have +2, 3, 4, 5, 7, 8, 9, 12 or more arguments. +The number of arguments is checked when parsing the XQL query string. + +The second parameter must be a reference to a Perl function or an anonymous +sub. E.g. '\&my_func' or 'sub { ... code ... }' + +If ALLOWED_OUTSIDE (default is 0) is set to 1, the function or method may +also be used outside subqueries in I. +(See NodeQuery parameter in Query constructor) + +If CONST (default is 0) is set to 1, the function is considered to be +"constant". See L for details. + +If QUERY_ARG (default is 0) is not -1, the argument with that index is +considered to be a 'query parameter'. If the query parameter is a subquery, +that returns multiple values, the result list of the function invocation will +contain one result value for each value of the subquery. +E.g. 'length(book/author)' will return a list of Numbers, denoting the string +lengths of all the author elements returned by 'book/author'. + +Note that only methods (not functions) may appear after a Bang "!" operator. +This is checked when parsing the XQL query string. + +See also: defineMethod + +=item generateFunction (NAME, FUNCNAME, RETURN_TYPE [, ARGCOUNT [, ALLOWED_OUTSIDE [, CONST [, QUERY_ARG]]]]) + +Generates and defines an XQL function wrapper for the Perl function with the +name FUNCNAME. The function name will be NAME in XQL query expressions. +The return type should be one of the builtin XQL Data Types or a class derived +from XML::XQL::PrimitiveType (see L.) +See defineFunction for the meaning of ARGCOUNT, ALLOWED_OUTSIDE, CONST and +QUERY_ARG. + +Function values are always converted to Perl strings with xql_toString before +they are passed to the Perl function implementation. The function return value +is cast to an object of type RETURN_TYPE, or to the empty list [] if the +result is undef. It uses expandType to expand XQL primitive type names. +If RETURN_TYPE is "*", it returns the function +result as is, unless the function result is undef, in which case it returns []. + +=item defineMethod (NAME, FUNCREF, ARGCOUNT [, ALLOWED_OUTSIDE]) + +Defines the XQL method (at the global level, i.e. for all newly created +queries) with the specified NAME. The ARGCOUNT parameter can either be a single +number or a reference to a list with numbers. +A single number expands to [ARGCOUNT, ARGCOUNT]. The list contains pairs of +numbers, indicating the number of arguments that the method allows. The value +-1 means infinity. E.g. [2, 5, 7, 9, 12, -1] means that the method can have +2, 3, 4, 5, 7, 8, 9, 12 or more arguments. +The number of arguments is checked when parsing the XQL query string. + +The second parameter must be a reference to a Perl function or an anonymous +sub. E.g. '\&my_func' or 'sub { ... code ... }' + +If ALLOWED_OUTSIDE (default is 0) is set to 1, the function or method may +also be used outside subqueries in I. +(See NodeQuery parameter in Query constructor) + +Note that only methods (not functions) may appear after a Bang "!" operator. +This is checked when parsing the XQL query string. + +See also: defineFunction + +=item defineComparisonOperators (NAME => FUNCREF [, NAME => FUNCREF]*) + +Defines XQL comparison operators at the global level. +The FUNCREF parameters must be a references to a Perl function or an anonymous +sub. E.g. '\&my_func' or 'sub { ... code ... }' + +E.g. define the operators $my_op$ and $my_op2$: + + defineComparisonOperators ('my_op' => \&my_op, + 'my_op2' => sub { ... insert code here ... }); + +=item defineElementValueConvertor (TAG_NAME, FUNCREF) + +Defines that the result of the value() call for Elements with the specified +TAG_NAME uses the specified function. The function will receive +two parameters. The second one is the TAG_NAME of the Element node +and the first parameter is the Element node itself. +FUNCREF should be a reference to a Perl function, e.g. \&my_sub, or +an anonymous sub. + +E.g. to define that all Elements with tag name 'date-of-birth' should return +XML::XQL::Date objects: + + defineElementValueConvertor ('date-of-birth', sub { + my $elem = shift; + # Always pass in the node as the second parameter. This is + # the reference node for the object, which is used when + # sorting values in document order. + new XML::XQL::Date ($elem->xql_text, $elem); + }); + +These convertors can only be specified at a global level, not on a per query +basis. To undefine a convertor, simply pass a FUNCREF of undef. + +=item defineAttrValueConvertor (ELEM_TAG_NAME, ATTR_NAME, FUNCREF) + +Defines that the result of the value() call for Attributes with the specified +ATTR_NAME and a parent Element with the specified ELEM_TAG_NAME +uses the specified function. An ELEM_TAG_NAME of "*" will match regardless of +the tag name of the parent Element. The function will receive +3 parameters. The third one is the tag name of the parent Element (even if +ELEM_TAG_NAME was "*"), the second is the ATTR_NAME and the first is the +Attribute node itself. +FUNCREF should be a reference to a Perl function, e.g. \&my_sub, or +an anonymous sub. + +These convertors can only be specified at a global level, not on a per query +basis. To undefine a convertor, simply pass a FUNCREF of undef. + +=item defineTokenQ (Q) + +Defines the token for the q// string delimiters at a global level. +The default value for XQL+ is 'q', for XML::XQL::Strict it is undef. +A value of undef will deactivate this feature. + +=item defineTokenQQ (QQ) + +Defines the token for the qq// string delimiters at a global level. +The default value for XQL+ is 'qq', for XML::XQL::Strict it is undef. +A value of undef will deactivate this feature. + +=item expandType (TYPE) + +Used internally to expand type names of XQL primitive types. +E.g. it expands "Number" to "XML::XQL::Number" and is not case-sensitive, so +"number" and "NuMbEr" will both expand correctly. + +=item defineExpandedTypes (ALIAS, FULL_NAME [, ...]) + +For each pair of arguments it allows the class name FULL_NAME to be abbreviated +with ALIAS. The definitions are used by expandType(). +(ALIAS is always converted to lowercase internally, because expandType +is case-insensitive.) + +Overriding the ALIAS for "date", also affects the object type returned by the +date() function. + +=item setErrorContextDelimiters (START, END, BOLD_ON, BOLD_OFF) + +Sets the delimiters used when printing error messages during query evaluation. +The default delimiters on Unix are `tput smul` (underline on) and `tput rmal` +(underline off). On other systems (that don't have tput), the delimiters are +">>" and "<<" resp. + +When printing the error message, the subexpression that caused the error will +be enclosed by the delimiters, i.e. underlined on Unix. + +For certain subexpressions the significant keyword, e.g. "$and$" is enclosed in +the bold delimiters BOLD_ON (default: `tput bold` on Unix, "" elsewhere) and +BOLD_OFF (default: (`tput rmul` . `tput smul`) on Unix, "" elsewhere, +see $BoldOff in XML::XQL::XQL.pm for details.) + +=item isEmptyList (VAR) + +Returns 1 if VAR is [], else 0. Can be used in user defined functions. + +=back + +=head1 Additional Features in XQL+ + +=over 4 + +=item Parent operator '..' + +The '..' operator returns the parent of the current node, where '.' would +return the current node. This is not part of any XQL standard, because you +would normally use return operators, which are not implemented here. + +=item Sequence operators ';' and ';;' + +The sequence operators ';' (precedes) and ';;' (immediately precedes) are +not in the XQL spec, but are described in 'The Design of XQL' by Jonathan Robie +who is one of the designers of XQL. It can be found at +L +See also the XQL Tutorial for a description of what they mean. + +=item q// and qq// String Tokens + +String tokens a la q// and qq// are allowed. q// evaluates like Perl's single +quotes and qq// like Perl's double quotes. Note that the default XQL strings do +not allow escaping etc., so it's not possible to define a string with both +single and double quotes. If 'q' and 'qq' are not to your liking, you may +redefine them to something else or undefine them altogether, by assigning undef +to them. E.g: + + # at a global level - shared by all queries (that don't (re)define 'q') + XML::XQL::defineTokenQ ('k'); + XML::XQL::defineTokenQQ (undef); + + # at a query level - only defined for this query + $query = new XML::XQL::Query (Expr => "book/title", q => 'k', qq => undef); + +From now on k// works like q// did and qq// doesn't work at all anymore. + +=item Query strings can have embedded Comments + +For example: + + $queryExpr = "book/title # this comment is inside the query string + [. = 'Moby Dick']"; # this comment is outside + +=item Optional dollar delimiters and case-insensitive XQL keywords + +The following XQL keywords are case-insensitive and the dollar sign delimiters +may be omitted: $and$, $or$, $not$, $union$, $intersect$, $to$, $any$, $all$, +$eq$, $ne$, $lt$, $gt$, $ge$, $le$, $ieq$, $ine$, $ilt$, $igt$, $ige$, $ile$. + +E.g. $AND$, $And$, $aNd$, and, And, aNd are all valid replacements for $and$. + +Note that XQL+ comparison operators ($match$, $no_match$, $isa$, $can$) still +require dollar delimiters and are case-sensitive. + +=item Comparison operator: $match$ or '=~' + +E.g. "book/title =~ '/(Moby|Dick)/']" will return all book titles containing +Moby or Dick. Note that the match expression needs to be quoted and should +contain the // or m// delimiters for Perl. + +When casting the values to be matched, both are converted to Text. + +=item Comparison operator: $no_match$ or '!~' + +E.g. "book/title !~ '/(Moby|Dick)/']" will return all book titles that don't +contain Moby or Dick. Note that the match expression needs to be quoted and +should contain the // or m// delimiters for Perl. + +When casting the values to be matched, both are converted to Text. + +=item Comparison operator: $isa$ + +E.g. '//. $isa$ "XML::XQL::Date"' returns all elements for which the value() +function returns an XML::XQL::Date object. (Note that the value() function can +be overridden to return a specific object type for certain elements and +attributes.) It uses expandType to expand XQL primitive type names. + +=item Comparison operator: $can$ + +E.g. '//. $can$ "swim"' returns all elements for which the value() +function returns an object that implements the (Perl) swim() method. +(Note that the value() function can be overridden to return a specific object +type for certain elements and attributes.) + +=item Function: once (QUERY) + +E.g. 'once(id("foo"))' will evaluate the QUERY expression only once per query. +Certain query results (like the above example) will always return the same +value within a query. Using once() will cache the QUERY result for the +rest of the query. + +Note that "constant" function invocations are always cached. +See also L + +=item Function: subst (QUERY, EXPR, EXPR [,MODIFIERS, [MODE]]) + +E.g. 'subst(book/title, "[M|m]oby", "Dick", "g")' will replace Moby or moby +with Dick globally ("g") in all book title elements. Underneath it uses Perl's +substitute operator s///. Don't worry about which delimiters are used underneath. +The function returns all the book/titles for which a substitution occurred. +The default MODIFIERS string is "" (empty.) The function name may be abbreviated +to "s". + +For most Node types, it converts the value() to a string (with xql_toString) +to match the string and xql_setValue to set the new value in case it matched. +For XQL primitives (Boolean, Number, Text) and other data types (e.g. Date) it +uses xql_toString to match the String and xql_setValue to set the result. +Beware that performing a substitution on a primitive that was found in the +original XQL query expression, changes the value of that constant. + +If MODE is 0 (default), it treats Element nodes differently by matching and +replacing I occurring in the Element node. A text block is defined +as the concatenation of the raw text of subsequent Text, CDATASection and +EntityReference nodes. In this mode it skips embedded Element nodes. +If a text block matches, it is replaced by a single Text node, regardless +of the original node type(s). + +If MODE is 1, it treats Element nodes like the other nodes, i.e. it converts +the value() to a string etc. Note that the default implementation of value() +calls text(), which normalizes whitespace and includes embedded Element +descendants (recursively.) This is probably not what you want to use in most +cases, but since I'm not a professional psychic... :-) + +=item Function: map (QUERY, CODE) + +E.g. 'map(book/title, "s/[M|m]oby/Dick/g; $_")' will replace Moby or moby +with Dick globally ("g") in all book title elements. Underneath it uses Perl's +map operator. The function returns all the book/titles for which a +change occurred. + +??? add more specifics + +=item Function: eval (EXPR [,TYPE]) + +Evaluates the Perl expression EXPR and returns an object of the specified TYPE. +It uses expandType to expand XQL primitive type names. +If the result of the eval was undef, the empty list [] is returned. + +E.g. 'eval("2 + 5", "Number")' returns a Number object with the value 7, and + 'eval("%ENV{USER}")' returns a Text object with the user name. + +Consider using once() to cache the return value, when the invocation will +return the same result for each invocation within a query. + +??? add more specifics + +=item Function: new (TYPE [, QUERY [, PAR] *]) + +Creates a new object of the specified object TYPE. The constructor may have any +number of arguments. The first argument of the constructor (the 2nd argument +of the new() function) is considered to be a 'query parameter'. +See defineFunction for a definition of I. +It uses expandType to expand XQL primitive type names. + +=item Function: document (QUERY) or doc (QUERY) + +The document() function creates a new L for each result +of QUERY (QUERY may be a simple string expression, like "/usr/enno/file.xml". +See t/xql_document.t or below for an example with a more complex QUERY.) + +document() may be abbreviated to doc(). + +document() uses an XML::DOM::Parser underneath, which can be set with +XML::XQL::setDocParser(). By default it uses a parser that was created without +any arguments, i.e. + + $PARSER = new XML::DOM::Parser; + +Let's try a more complex example, assuming $doc contains: + + + + + + +Then the following query will return two Ls, +one for file1.xml and one for file2.xml: + + @result = XML::XQL::solve ("document(doc/file/@name)", $doc); + +The resulting documents can be used as input for following queries, e.g. + + @result = XML::XQL::solve ("document(doc/file/@name)/root/bla", $doc); + +will return all /root/bla elements from the documents returned by document(). + +=item Method: DOM_nodeType () + +Returns the DOM node type. Note that these are mostly the same as nodeType(), +except for CDATASection and EntityReference nodes. DOM_nodeType() returns +4 and 5 respectively, whereas nodeType() returns 3, because they are +considered text nodes. + +=item Function wrappers for Perl builtin functions + +XQL function wrappers have been provided for most Perl builtin functions. +When using a Perl builtin function like "substr" in an XQL+ querry, an +XQL function wrapper will be generated on the fly. The arguments to these +functions may be regular XQL+ subqueries (that return one or more values) for +a I (see generateFunction for a definition.) +Most wrappers of Perl builtin functions have argument 0 for a query parameter, +except for: chmod (parameter 1 is the query parameter), chown (2) and utime (2). +The following functions have no query parameter, which means that all parameters +should be a single value: atan2, rand, srand, sprintf, rename, unlink, system. + +The function result is casted to the appropriate XQL primitive type (Number, +Text or Boolean), or to an empty list if the result was undef. + +=back + +=head2 XPath functions and methods + +The following functions were found in the XPath specification: + +=over 4 + +=item Function: concat (STRING, STRING, STRING*) + +The concat function returns the concatenation of its arguments. + +=item Function: starts-with (STRING, STRING) + +The starts-with function returns true if the first argument string starts with +the second argument string, and otherwise returns false. + +=item Function: contains (STRING, STRING) + +The contains function returns true if the first argument string contains the +second argument string, and otherwise returns false. + +=item Function: substring-before (STRING, STRING) + +The substring-before function returns the substring of the first argument +string that precedes the first occurrence of the second argument string +in the first argument string, or the empty string if the first argument +string does not contain the second argument string. For example, + + substring-before("1999/04/01","/") returns 1999. + +=item Function: substring-after (STRING, STRING) + +The substring-after function returns the substring of the first argument string +that follows the first occurrence of the second argument string in +the first argument string, or the empty string if the first argument string does +not contain the second argument string. For example, + + substring-after("1999/04/01","/") returns 04/01, + +and + + substring-after("1999/04/01","19") returns 99/04/01. + +=item Function: substring (STRING, NUMBER [, NUMBER] ) + +The substring function returns the substring of the first argument starting at +the position specified in the second argument with length specified in +the third argument. For example, + + substring("12345",2,3) returns "234". + +If the third argument is not specified, it returns the substring +starting at the position specified in the second argument and continuing to +the end of the string. For example, + + substring("12345",2) returns "2345". + +More precisely, each character in the string is considered +to have a numeric position: the position of the first character is 1, +the position of the second character is 2 and so on. + +NOTE: This differs from the B method , in which the +method treats the position of the first character as 0. + +The XPath spec says this about rounding, but that is not true in this +implementation: +I + +=item Method: string-length ( [ QUERY ] ) + +The string-length returns the number of characters in the string. +If the argument is omitted, it defaults to the context node +converted to a string, in other words the string-value of the context node. + +Note that the generated XQL wrapper for the Perl built-in B does not +allow the argument to be omitted. + +=item Method: normalize-space ( [ QUERY ] ) + +The normalize-space function returns the argument string with whitespace +normalized by stripping leading and trailing whitespace and replacing +sequences of whitespace characters by a single space. Whitespace characters are +the same as those allowed by the S production in XML. If the +argument is omitted, it defaults to the context node converted to a string, in +other words the string-value of the context node. + +=item Function: translate (STRING, STRING, STRING) + +The translate function returns the first argument string with occurrences of +characters in the second argument string replaced by the character at +the corresponding position in the third argument string. For example, + + translate("bar","abc","ABC") returns the string BAr. + +If there is a +character in the second argument string with no character at a corresponding +position in the third argument string (because the second argument +string is longer than the third argument string), then occurrences of that +character in the first argument string are removed. For example, + + translate("--aaa--","abc-","ABC") returns "AAA". + +If a character occurs more than once in the second argument string, then the +first occurrence determines the replacement character. If the third argument +string is longer than the second argument string, then excess characters +are ignored. + +NOTE: The translate function is not a sufficient solution for case conversion +in all languages. A future version may +provide additional functions for case conversion. + +This function was implemented using tr///d. + +=item Function: sum ( QUERY ) + +The sum function returns the sum of the QUERY results, by +converting the string values of each result to a number. + +=item Function: floor (NUMBER) + +The floor function returns the largest (closest to positive infinity) number +that is not greater than the argument and that is an integer. + +=item Function: ceiling (NUMBER) + +The ceiling function returns the smallest (closest to negative infinity) number +that is not less than the argument and that is an integer. + +=item Function: round (NUMBER) + +The round function returns the number that is closest to the argument +and that is an integer. If there are two such numbers, then the one that is +closest to positive infinity is returned. + +=back + +=head1 Implementation Details + +=over 4 + +=item XQL Builtin Data Types + +The XQL engine uses the following object classes internally. Only Number, +Boolean and Text are considered I: + +=over 4 + +=item * XML::XQL::Number + +For integers and floating point numbers. + +=item * XML::XQL::Boolean + +For booleans, e.g returned by true() and false(). + +=item * XML::XQL::Text + +For string values. + +=item * XML::XQL::Date + +For date, time and date/time values. E.g. returned by the date() function. + +=item * XML::XQL::Node + +Superclass of all XML node types. E.g. all subclasses of XML::DOM::Node subclass +from this. + +=item * Perl list reference + +Lists of values are passed by reference (i.e. using [] delimiters). +The empty list [] has a double meaning. It also means 'undef' in certain +situations, e.g. when a function invocation or comparison failed. + +=back + +=item Type casting in comparisons + +When two values are compared in an XML comparison (e.g. $eq$) the values are +first casted to the same data type. Node values are first replaced by their +value() (i.e. the XQL value() function is used, which returns a Text value by +default, but may return any data type if the user so chooses.) +The resulting values are then casted to the type of the object with the highest +xql_primType() value. They are as follows: Node (0), Text (1), Number (2), +Boolean (3), Date (4), other data types (4 by default, but this may be +overriden by the user.) + +E.g. if one value is a Text value and the other is a Number, the Text value is +cast to a Number and the resulting low-level (Perl) comparison is (for $eq$): + + $number->xql_toString == $text->xql_toString + +If both were Text values, it would have been + + $text1->xql_toString eq $text2->xql_toString + +Note that the XQL spec is vague and even conflicting where it concerns type +casting. This implementation resulted after talking to Joe Lapp, one of the +spec writers. + +=item Adding Data Types + +If you want to add your own data type, make sure it derives from +XML::XQL::PrimitiveType and implements the necessary methods. + +I will add more stuff here to explain it all, but for now, look at the code +for the primitive XQL types or the Date class (L in Date.pm.) + +=item Document Order + +The XQL spec states that query results always return their values in +I, which means the order in which they appeared in the original +XML document. Values extracted from Nodes (e.g. with value(), text(), rawText(), +nodeName(), etc.) always have a pointer to the reference node (i.e. the Node +from which the value was extracted.) These pointers are acknowledged when +(intermediate) result lists are sorted. Currently, the only place where a +result list is sorted is in a $union$ expression, which is the only place +where the result list can be unordered. +(If you find that this is not true, let me know.) + +Non-node values that have no associated reference node, always end up at the end +of the result list in the order that they were added. +The XQL spec states that the reference node for an XML Attribute is the Element +to which it belongs, and that the order of values with the same reference node +is undefined. This means that the order of an Element and its attributes would +be undefined. +But since the XML::DOM module keeps track of the order of the attributes, the +XQL engine does the same, and therefore, the attributes of an Element are +sorted and appear after their parent Element in a sorted result list. + +=item Constant Function Invocations + +If a function always returns the same value when given "constant" arguments, +the function is considered to be "constant". A "constant" argument can be +either an XQL primitive (Number, Boolean, Text) or a "constant" function +invocation. E.g. + + date("12-03-1998") + true() + sin(0.3) + length("abc") + date(substr("12-03-1998 is the date", 0, 10)) + +are constant, but not: + + length(book[2]) + +Results of constant function invocations are cached and calculated only once +for each query. See also the CONST parameter in defineFunction. +It is not necessary to wrap constant function invocations in a once() call. + +Constant XQL functions are: date, true, false and a lot of the XQL+ +wrappers for Perl builtin functions. Function wrappers for certain builtins +are not made constant on purpose to force the invocation to be evaluated +every time, e.g. 'mkdir("/user/enno/my_dir", "0644")' (although constant +in appearance) may return different results for multiple invocations. +See %PerlFunc in Plus.pm for details. + +=item Function: count ([QUERY]) + +The count() function has no parameters in the XQL spec. In this implementation +it will return the number of QUERY results when passed a QUERY parameter. + +=item Method: text ([RECURSE]) + +When expanding an Element node, the text() method adds the expanded text() value +of sub-Elements. When RECURSE is set to 0 (default is 1), it will not include +sub-elements. This is useful e.g. when using the $match$ operator in a recursive +context (using the // operator), so it won't return parent Elements when one of +the children matches. + +=item Method: rawText ([RECURSE]) + +See text(). + +=back + +=head1 SEE ALSO + +L, L, L + +The Japanese version of this document can be found on-line at +L + +The L manual page. The Japanese version can be found at +L + +The XQL spec at L + +The Design of XQL at L + +The DOM Level 1 specification at L + +The XML spec (Extensible Markup Language 1.0) at L + +The L and L manual pages. + +=head1 AUTHOR + +Please send bugs, comments and suggestions to Enno Derksen > + +=cut