--- 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 = <<END_CODE;
-sub $wrapperName {
- my (\$context, \$list, \@arg) = \@_;
- for my \$i (0 .. \$#arg)
- {
- if (\$i == $queryArg)
- {
- \$arg[\$i] = XML::XQL::toList (\$arg[\$i]->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 .=<<END_CODE;
- my \@result = ();
- my \@qp = \@{\$arg[$queryArg]};
- for (my \$k = 0; \$k < \@qp; \$k++)
- {
- \$arg[$queryArg] = \$qp[\$k]->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
-# <URL:http://www.texcel.no/whitepapers/xql-design.html>
-# 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?
- "<unknown xql_nodeType $i>";
-}
-
-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<http://www.w3.org/TandS/QL/QL98/pp/xql.html>
-Most of the contents related to the XQL syntax can also be found in the
-L<XML::XQL::Tutorial> that comes with this distribution.
-Note that XQL is not the same as XML-QL!
-
-The current implementation only works with the L<XML::DOM> 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<Additional Features in XQL+> 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<XML::XQL::DOM>, you can also write (see L<XML::DOM::Node>
-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<node queries>.
-(See NodeQuery parameter in Query constructor)
-
-If CONST (default is 0) is set to 1, the function is considered to be
-"constant". See L<Constant Function Invocations> 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<Adding Data Types>.)
-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<node queries>.
-(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<http://www.texcel.no/whitepapers/xql-design.html>
-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<Constant Function Invocations>
-
-=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<text blocks> 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<query parameter>.
-It uses expandType to expand XQL primitive type names.
-
-=item Function: document (QUERY) or doc (QUERY)
-
-The document() function creates a new L<XML::XML::Document> 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:
-
- <doc>
- <file name="file1.xml"/>
- <file name="file2.xml"/>
- </doc>
-
-Then the following query will return two L<XML::XML::Document>s,
-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<query parameter> (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<substr> 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<The returned substring contains those characters for which the position of the
-character is greater than or equal to the rounded value of the
-second argument and, if the third argument is specified, less than the
-sum of the rounded value of the second argument and the rounded value of
-the third argument; the comparisons and addition used for the above
-follow the standard IEEE 754 rules; rounding is done as if by a call to the
-round function.>
-
-=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<substr> 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<primitive XQL types>:
-
-=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<XML::XQL::Date> in Date.pm.)
-
-=item Document Order
-
-The XQL spec states that query results always return their values in
-I<document order>, 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<XML::XQL::Query>, L<XML::XQL::DOM>, L<XML::XQL::Date>
-
-The Japanese version of this document can be found on-line at
-L<http://member.nifty.ne.jp/hippo2000/perltips/xml/xql.htm>
-
-The L<XML::XQL::Tutorial> manual page. The Japanese version can be found at
-L<http://member.nifty.ne.jp/hippo2000/perltips/xml/xql/tutorial.htm>
-
-The XQL spec at L<http://www.w3.org/TandS/QL/QL98/pp/xql.html>
-
-The Design of XQL at L<http://www.texcel.no/whitepapers/xql-design.html>
-
-The DOM Level 1 specification at L<http://www.w3.org/TR/REC-DOM-Level-1>
-
-The XML spec (Extensible Markup Language 1.0) at L<http://www.w3.org/TR/REC-xml>
-
-The L<XML::Parser> and L<XML::Parser::Expat> manual pages.
-
-=head1 AUTHOR
-
-Please send bugs, comments and suggestions to Enno Derksen <F<enno@att.com>>
-
-=cut