diff -r 000000000000 -r 02cd6b52f378 dummy_foundation/lib/XML/XQL/Plus.pm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/dummy_foundation/lib/XML/XQL/Plus.pm Thu May 28 10:10:03 2009 +0100 @@ -0,0 +1,634 @@ +############################################################################ +# Copyright (c) 1998 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. +############################################################################ +# +# Extra functionality that is not part of the XQL spec +# + +package XML::XQL; +use strict; + +BEGIN +{ + die "don't use/require XML::XQL::Plus, either use/require XML::XQL or XML::XQL::Strict" unless $XML::XQL::Included; +}; + +defineComparisonOperators +( + "=~" => \&XML::XQL::match_oper, + "!~" => \&XML::XQL::no_match_oper, + "match" => \&XML::XQL::match_oper, + "no_match" => \&XML::XQL::no_match_oper, + "isa" => \&XML::XQL::isa_oper, + "can" => \&XML::XQL::can_oper, +); + +sub match_oper +{ + my ($node, $expr) = @_; + + return [] if isEmptyList ($node); +#?? can this happen? + + my $str = $node->xql_toString; + + $expr = prepareRvalue ($expr->solve ([$node])); + return [] if isEmptyList ($expr); +#?? can this happen? + + $expr = $expr->xql_toString; + croak "bad search pattern '$expr' for =~" unless $expr =~ m!^\s*[m/]!o; + + my $res = eval "\$str =~ $expr"; + croak "bad search pattern '$expr' for =~ operator: $@" if ($@); + $res; +} + +sub no_match_oper +{ + my ($node, $expr) = @_; + + return [] if isEmptyList ($node); +#?? can this happen? + + my $str = $node->xql_toString; + + $expr = prepareRvalue ($expr->solve ([$node])); + return [] if isEmptyList ($expr); +#?? can this happen? + + $expr = $expr->xql_toString; + croak "bad search pattern '$expr' for !~" unless $expr =~ m!^\s*[m/]!o; + + my $res = eval "\$str !~ $expr"; + croak "bad search pattern '$expr' for !~ operator: $@" if ($@); + $res; +} + +sub isa_oper +{ + my ($node, $expr) = @_; + + return [] if isEmptyList ($node); +#?? can this happen? + + $expr = prepareRvalue ($expr->solve ([$node])); + return [] if isEmptyList ($expr); +#?? can this happen? + + $expr = $expr->xql_toString; + + # Expand "number" to "XML::XQL::Number" etc. + $expr = expandType ($expr); + +#?? I don't think empty lists are possible here. If so, add "[]" as expr + + ref($node) and $node->isa ($expr); +} + +# +# Not sure how useful this is, unless it supports XQL functions/methods... +# +sub can_oper +{ + my ($node, $expr) = @_; + + return [] if isEmptyList ($node); +#?? can this happen? + + $expr = prepareRvalue ($expr->solve ([$node])); + return [] if isEmptyList ($expr); +#?? can this happen? + + $expr = $expr->xql_toString; + + ref ($node) and $node->can ($expr); +} + +sub once +{ + my ($context, $list, $expr) = @_; + $expr->solve ($context, $list); +} + +sub xql_eval +{ + my ($context, $list, $query, $type) = @_; + +# return [] if @$list == 0; + + $query = toList ($query->solve ($context, $list)); + return [] unless @$query; + + if (defined $type) + { + $type = prepareRvalue ($type->solve ($context, $list)); + $type = isEmptyList ($type) ? "Text" : $type->xql_toString; + + # Expand "number" to "XML::XQL::Number" etc. + $type = expandType ($type); + } + else + { + $type = "XML::XQL::Text"; + } + + my @result = (); + for my $val (@$query) + { + $val = $val->xql_toString; + $val = eval $val; + +#print "eval result=$val\n"; +#?? check result? + push @result, eval "new $type (\$val)" if defined $val; + } + \@result; +} + +sub subst +{ + my ($context, $list, $query, $expr, $repl, $mod, $mode) = @_; + +#?? not sure? + return [] if @$list == 0; + + $expr = prepareRvalue ($expr->solve ($context, $list)); + return [] if isEmptyList ($expr); + $expr = $expr->xql_toString; + + $repl = prepareRvalue ($repl->solve ($context, $list)); + return [] if isEmptyList ($repl); + $repl = $repl->xql_toString; + + if (defined $mod) + { + $mod = prepareRvalue ($mod->solve ($context, $list)); + $mod = isEmptyList ($mod) ? "" : $mod->xql_toString; + } + + if (defined $mode) + { + $mode = prepareRvalue ($mode->solve ($context, $list)); + $mode = isEmptyList ($mode) ? 0 : $mode->xql_toString; + } + else + { + $mode = 0; # default mode: use textBlocks for Elements + } + + my @result = (); + my $nodes = toList ($query->solve ($context, $list)); + + for my $node (@$nodes) + { + if ($mode == 0 && $node->xql_nodeType == 1) # 1: Element node + { + # For Element nodes, replace text in consecutive text blocks + # Note that xql_rawtextBlocks, returns the blocks in reverse order, + # so that the indices of nodes within previous blocks don't need + # to be adjusted when a replacement occurs. + my $block_matched = 0; + BLOCK: for my $block ($node->xql_rawTextBlocks) + { + my $str = $block->[2]; + my $result = eval "\$str =~ s/\$expr/\$repl/$mod"; + croak "bad subst expression s/$expr/$repl/$mod: $@" if ($@); + next BLOCK unless $result; + + $block_matched++; + $node->xql_replaceBlockWithText ($block->[0], $block->[1], $str); + } + # Return the input parameter only if a substitution occurred + push @result, $node if $block_matched; + } + else + { + my $str = $node->xql_toString; + next unless defined $str; + + my $result = eval "\$str =~ s/\$expr/\$repl/$mod"; + croak "bad subst expression s/$expr/$repl/$mod: $@" if ($@); + next unless $result; +#print "result=$result for str[$str] =~ s/$expr/$repl/$mod\n"; + + # Return the input parameter only if a substitution occurred + $node->xql_setValue ($str); + push @result, $node; + } + # xql_setValue will actually change the value of the node for an Attr, + # Text, CDataSection, EntityRef or Element + } + \@result; +} + +#?? redo match - what should it return? +sub match +{ + my ($context, $list, $query, $repl, $mod) = @_; + + return [] if @$list == 0; + + $query = prepareRvalue ($query->solve ($context, $list)); + return [] if isEmptyList ($query); + $query = $query->xql_toString; + + if (defined $mod) + { + $mod = prepareRvalue ($mod->solve ($context, $list)); + $mod = isEmptyList ($mod) ? "" : $mod->xql_toString; + } + + my $str = $list->[0]->xql_toString; + return [] unless defined $str; + + my (@matches) = (); + eval "\@matches = (\$str =~ /\$query/$mod)"; + croak "bad match expression m/$query/$mod" if ($@); + +#?? or should I map undef to XML::XQL::Text("") ? + @matches = map { defined($_) ? new XML::XQL::Text ($_) : [] } @matches; + \@matches; +} + +sub xql_map +{ + my ($context, $list, $query, $code) = @_; + +#?? not sure? + return [] if @$list == 0; + + $code = prepareRvalue ($code->solve ($context, $list)); + return [] if isEmptyList ($code); + $code = $code->xql_toString; + + my @result = (); + my $nodes = toList ($query->solve ($context, $list)); + + for my $node (@$nodes) + { + my $str = $node->xql_toString; + next unless defined $str; + + my (@mapresult) = ($str); + +#?? NOTE: the $code should + eval "\@mapresult = map { $code } (\$str)"; + croak "bad map expression '$code' ($@)" if ($@); + + # Return the input parameter only if a change occurred + next unless $mapresult[0] eq $str; + + # xql_setValue will actually change the value of the node for an Attr, + # Text, CDataSection, EntityRef or Element + $node->xql_setValue ($str); + push @result, $node; + } + \@result; +} + +sub xql_new +{ + my ($type, @arg) = @_; + + # Expand "number" to "XML::XQL::Number" etc. + $type = expandType ($type); + + my $obj = eval "new $type (\@arg)"; + $@ ? [] : $obj; # return empty list on exception +} + +my $DOM_PARSER; # used by xql_document (below) +sub setDocParser +{ + $DOM_PARSER = shift; +} + +sub xql_document +{ + my ($docname) = @_; + my $parser = $DOM_PARSER ||= new XML::DOM::Parser; + my $doc; + eval + { + $doc = $parser->parsefile ($docname); + }; + if ($@) + { + warn "xql_document: could not read XML file [$docname]: $@"; + } + return defined $doc ? $doc : []; +} + +#----------- XQL+ methods -------------------------------------------- + + +sub DOM_nodeType +{ + my ($context, $list) = @_; + + return [] if @$list == 0; + + new XML::XQL::Number ($list->[0]->xql_DOM_nodeType, $list->[0]); +} + +#----------- Perl Builtin Functions ---------------------------------- + +# Note that certain functions (like mkdir) are not considered "constant" +# because we don't want their invocation values cached. (We want the +# function to be called every time the Invocation is solved/evaluated.) +my %PerlFunc = +( + # Format: + # "funcName", => [ARGCOUNT, RETURN_TYPE [, CONSTANT = 0, [QUERY_ARG = 0]]] + + #-------- Arithmetic Functions + + "abs" => [1, "Number", 1], + "atan2" => [2, "Number", 1, -1], + "cos" => [1, "Number", 1], + "exp" => [1, "Number", 1], + "int" => [1, "Number", 1], + "log" => [1, "Number", 1], + "rand" => [[0, 1], "Number", 0, -1], + "sin" => [1, "Number", 1], + "sqrt" => [1, "Number", 1], + "srand" => [[0, 1], "Number", 0, -1], + "time" => [0, "Number", 0, -1], + + #-------- Conversion Functions + + "chr" => [1, "Text", 1], +# "gmtime" => [1, "List of Number", 1], + "hex" => [1, "Number", 1], +# "localtime" => [1, "List of Number", 1], + "oct" => [1, "Number", 1], + "ord" => [1, "Text", 1], + "vec" => [3, "Number", 1], + "pack" => [[1, -1], "Text", 1, -1], #?? how should this work?? +# "unpack" => [2, "List of ?", 1], + + #-------- String Functions + + "chomp" => [1, "Text", 1], + "chop" => [1, "Text", 1], + "crypt" => [2, "Text", 1], + "lindex" => [[2, 3], "Number", 1], # "index" is already taken by XQL + "length" => [1, "Number", 1], + "lc" => [1, "Text", 1], + "lcfirst" => [1, "Text", 1], + "quotemeta" => [1, "Text", 1], + "rindex" => [[2, 3], "Number", 1], + "substr" => [[2, 3], "Text", 1], + "uc" => [1, "Text", 1], + "ucfirst" => [1, "Text", 1], + "reverse" => [1, "Text", 1], + "sprintf" => [[1, -1], "Text", 1, -1], + + #-------- Array Functions + + "join" => [[1, -1], "Text", 1], +# "split" => [[2, 3], "List of Text", 1], + + #-------- File Functions + + "chmod" => [2, "Boolean", 0, 1], + "chown" => [3, "Boolean", 0, 2], + "link" => [2, "Number", 0, -1], #?? no return value +# "lstat" => [1, "List of Number"], + "mkdir" => [2, "Boolean"], #?? or is 1 arg also allowed? + "readlink" => [1, "Text"], + "rename" => [2, "Boolean", 0, -1], + "rmdir" => [1, "Boolean"], +# "stat" => [1, "List of Number"], + "symlink" => [2, "Boolean", 0, -1], + "unlink" => [1, "Boolean"], + "utime" => [3, "Boolean", 0, 2], + "truncate" => [2, "Number"], #?? no return value + + #-------- System Interaction + + "exit" => [[0, 1], "Number"], +# "glob" => [1, "List of Text"], + "system" => [[1, -1], "Number", 0, -1], +# "times" => [0, "List of Number"], + + #-------- Miscellaneous + + "defined" => [1, "Boolean"], # is this useful?? + "dump" => [[0, 1], "Number", 0, -1], + "ref" => [1, "Text"], +); +#?? die, warn, croak (etc.), +#?? file test (-X), tr// (same as y//) +#?? array functions, sort + +# Generate wrapper for Perl builtin function on the fly +sub generatePerlWrapper +{ + my ($name) = @_; + my $args = $PerlFunc{$name}; + return undef unless defined $args; # not found + + my ($argCount, $returnType, $const, $queryArg) = @$args; + my $funcName = $name; + if ($name eq "lindex") # "index" is already taken + { + $funcName = "index"; + } + generateFunction ($name, $funcName, $returnType, $argCount, 0, $const, + $queryArg); + $Func{$name}; +} + +#?? Inline functions, do they make sense? E.g. 'elem!sub("code", "arg1")' +#?? Normally, user should use defineFunction, but if most of them have +#?? a lot of common code, I could provide the pre- and post-code. +#?? After processing the user-supplied code block, how should I convert the +#?? user's result back to an Invocation result. E.g. do I get a single value +#?? or a list back? + +defineFunction ("eval", \&XML::XQL::xql_eval, [1, 2]); +defineFunction ("subst", \&XML::XQL::subst, [3, 5], 1); +defineFunction ("s", \&XML::XQL::subst, [3, 5], 1); +defineFunction ("match", \&XML::XQL::match, [1, 2]); +defineFunction ("m", \&XML::XQL::match, [1, 2]); +defineFunction ("map", \&XML::XQL::xql_map, 2, 1); +defineFunction ("once", \&XML::XQL::once, 1, 1); + +defineMethod ("DOM_nodeType", \&XML::XQL::DOM_nodeType, 0, 0); + +generateFunction ("new", "XML::XQL::xql_new", "*", [1, -1], 1, 0, 1); +generateFunction ("document", "XML::XQL::xql_document", "*", 1, 1, 0, 0); + +# doc() is an alias for document() +defineFunction ("doc", \&XML::XQL::xql_wrap_document, 1, 1); + +#------------------------------------------------------------------------------ +# The following functions were found in the XPath spec. + +# Found in XPath but not (yet) implemented in XML::XQL: +# - type casting (string, number, boolean) - Not sure if needed... +# Note that string() converts booleans to 'true' and 'false', but our +# internal type casting converts it to perl values '0' and '1'... +# - math (+,-,*,mod,div) - Use eval() for now +# - last(), position() - Similar to end() and index() except they're 1-based +# - local-name(node-set?), namespace-uri(node-set?) +# - name(node-set?) - Can we pass a node-set in XQL? +# - lang(string) + +sub xpath_concat { join ("", @_) } +sub xpath_starts_with { $_[0] =~ /^\Q$_[1]\E/ } +# ends-with is not part of XPath +sub xpath_ends_with { $_[0] =~ /\Q$_[1]\E$/ } +sub xpath_contains { $_[0] =~ /\Q$_[1]\E/ } + +# The following methods don't know about NaN, +/-Infinity or -0. +sub xpath_floor { use POSIX; POSIX::floor ($_[0]) } +sub xpath_ceiling { use POSIX; POSIX::ceil ($_[0]) } +sub xpath_round { use POSIX; POSIX::floor ($_[0] + 0.5) } + +# Note that the start-index is 1-based in XPath +sub xpath_substring +{ + defined $_[2] ? substr ($_[0], $_[1] - 1, $_[2]) + : substr ($_[0], $_[1] - 1) +} + +sub xpath_substring_before +{ + my $i = index ($_[0], $_[1]); + $i == -1 ? undef : substr ($_[0], 0, $i) +} + +sub xpath_substring_after +{ + my $i = index ($_[0], $_[1]); + $i == -1 ? undef : substr ($_[0], $i + length($_[1])) +} + +# Note that d,c,s are tr/// modifiers. Also can't use open delimiters i.e. {[(< +my @TR_DELIMITERS = split //, "/!%^&*)-_=+|~]}'\";:,.>/?abefghijklmnopqrtuvwxyz"; + +sub xpath_translate +{ + my ($str, $from, $to) = @_; + + my $delim; + for my $d (@TR_DELIMITERS) + { + if (index ($from, $d) == -1 && index ($to, $d) == -1) + { + $delim = $d; + last; + } + } + die "(xpath_)translate: can't find suitable 'tr' delimiter" + unless defined $delim; + + # XPath defines that if length($from) > length($to), characters in $from + # for which there is no match in $to, should be deleted. + # (So we must use the 's' modifier.) + eval "\$str =~ tr$delim$from$delim$to${delim}d"; + $str; +} + +sub xpath_string_length +{ + my ($context, $list, $text) = @_; + + if (defined $text) + { + $text = XML::XQL::prepareRvalue ($text->solve ($context, $list)); + return [] unless defined $text; + + return new XML::XQL::Number (length $text->xql_toString, + $text->xql_sourceNode); + } + else + { + return [] if @$list == 0; + + my @result; + for my $node (@$list) + { + push @result, new XML::XQL::Number (length $node->xql_toString, + $node); + } + return \@result; + } +} + +sub _normalize +{ + $_[0] =~ s/\s+/ /g; + $_[0] =~ s/^\s+//; + $_[0] =~ s/\s+$//; + $_[0]; +} + +sub xpath_normalize_space +{ + my ($context, $list, $text) = @_; + + return [] if @$list == 0; + + if (defined $text) + { + $text = XML::XQL::prepareRvalue ($text->solve ($context, $list)); + return [] unless defined $text; + + return new XML::XQL::Text (_normalize ($text->xql_toString), + $text->xql_sourceNode); + } + else + { + my @result; + for my $node (@$list) + { + push @result, new XML::XQL::Text (_normalize ($node->xql_toString), + $node); + } + return \@result; + } +} + +sub xpath_sum +{ + my ($context, $list, $expr) = @_; + + return [] if @$list == 0; +#?? or return Number(0) ? + + my $sum = 0; + $expr = XML::XQL::toList ($expr->solve ($context, $list)); + for my $r (@{ $expr }) + { + $sum += $r->xql_toString; + } + return new XML::XQL::Number ($sum, undef); +} + +generateFunction ("round", "XML::XQL::xpath_round", "Number", 1, 1); +generateFunction ("floor", "XML::XQL::xpath_floor", "Number", 1, 1); +generateFunction ("ceiling", "XML::XQL::xpath_ceiling", "Number", 1, 1); + +generateFunction ("concat", "XML::XQL::xpath_concat", "Text", [2, -1], 1); +generateFunction ("starts-with", "XML::XQL::xpath_starts_with", "Boolean", 2, 1); +generateFunction ("ends-with", "XML::XQL::xpath_ends_with", "Boolean", 2, 1); +generateFunction ("contains", "XML::XQL::xpath_contains", "Boolean", 2, 1); +generateFunction ("substring-before", "XML::XQL::xpath_substring_before", "Text", 2, 1); +generateFunction ("substring-after", "XML::XQL::xpath_substring_after", "Text", 2, 1); +# Same as Perl substr() except index is 1-based +generateFunction ("substring", "XML::XQL::xpath_substring", "Text", [2, 3], 1); +generateFunction ("translate", "XML::XQL::xpath_translate", "Text", 3, 1); + +defineMethod ("string-length", \&XML::XQL::xpath_string_length, [0, 1], 1); +defineMethod ("normalize-space", \&XML::XQL::xpath_normalize_space, [0, 1], 1); + +defineFunction ("sum", \&XML::XQL::xpath_sum, 1, 1); + +1; # module return code