diff -r 8b87ea768cb8 -r 60053dab7e2a dummy_foundation/lib/XML/XQL.pm --- a/dummy_foundation/lib/XML/XQL.pm Wed Jun 03 18:33:51 2009 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3947 +0,0 @@ -############################################################################ -# 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