############################################################################+
−
# 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+
−