Data-Edit-Xml
view release on metacpan or search on metacpan
lib/Data/Edit/Xml.pm view on Meta::CPAN
}
sub copyNewAttrs($$@) # Copy all the attributes of the source node to the target node, or, just the named attributes if the optional list of attributes to copy is supplied, without overwriting...
{my ($source, $target, @attr) = @_; # Source node, target node, optional list of attributes to copy
my $s = $source->attributes; # Source attributes hash
my $t = $target->attributes; # Target attributes hash
if (@attr) # Named attributes
{$t->{$_} = $s->{$_} for grep {!exists $t->{$_}} @attr; # Transfer each named attribute not already present in the target
}
else # All attributes
{$t->{$_} = $s->{$_} for grep {!exists $t->{$_}} sort keys %$s; # Transfer each source attribute not already present in the target
}
$source # Return source node
}
sub moveAttrs($$@) # Move all the attributes of the source node to the target node, or, just the named attributes if the optional list of attributes to move is supplied, overwriting any exi...
{my ($source, $target, @attr) = @_; # Source node, target node, attributes to move
my $s = $source->attributes; # Source attributes hash
my $t = $target->attributes; # Target attributes hash
if (@attr) # Named attributes
{$t->{$_} = delete $s->{$_} for @attr; # Transfer each named attribute and delete from the source node
}
else # All attributes
{$t->{$_} = delete $s->{$_} for sort keys %$s; # Transfer each source attribute and delete from source node
}
$source # Return source node
}
sub moveNewAttrs($$@) # Move all the attributes of the source node to the target node, or, just the named attributes if the optional list of attributes to copy is supplied, without overwriting...
{my ($source, $target, @attr) = @_; # Source node, target node, optional list of attributes to move
my $s = $source->attributes; # Source attributes hash
my $t = $target->attributes; # Target attributes hash
if (@attr) # Named attributes
{$t->{$_} = delete $s->{$_} for grep {!exists $t->{$_}} @attr; # Transfer each named attribute and delete it from the source node as long as it does not already exist in the target
}
else # All attributes
{$t->{$_} = delete $s->{$_} for grep {!exists $t->{$_}} sort keys %$s; # Transfer every attribute and delete it from the source node as long as it does not already exist in the target
}
$source # Return source node
}
#D1 Traversal # Traverse the L<parse|/parse> tree in various orders applying a B<sub> to each node.
#D2 Post-order # This order allows you to edit children before their parents.
sub by2($$@) #P Post-order traversal of a L<parse|/parse> tree
{my ($node, $sub, @context) = @_; # Starting node, sub to call for each sub node, accumulated context.
$_->by2($sub, $node, @context) for $node->contents; # Recurse to process sub nodes in deeper context
&$sub(local $_ = $node, @context); # Process specified node last
$node
}
sub By22($$) #P Post-order traversal of a L<parse|/parse> tree or sub tree calling the specified B<sub> at each node and returning the specified starting node. The B<sub> is passed re...
{my ($node, $sub) = @_; # Starting node, sub to call for each sub node
$node->by2($sub); # Recurse through nodes
$node
}
# Doubles performance of by! IT is tempting to think that removing all the parameters would speed things up a lot - it does not as most parse trees are not very deep.
sub by($$) #I Post-order traversal of a L<parse|/parse> tree or sub tree calling the specified B<sub> at each node and returning the specified starting node. The B<sub> is passed re...
{my ($node, $sub) = @_; # Starting node, sub to call for each sub node
my $by; $by = sub # Recurse to process sub nodes in deeper context
{$_ = $_[0]; # Save active node in $_
if (my $c = $_->{content}) # Contents reference
{my @c = @$c; # For some reason we cannot place this directly in a for loop reliably
for(@c) # Each node under the current node
{if (my $d = $_->{content}) # Contents reference
{my @d = @$d; # Content
my $D = $_; # Save $_ so we can use it in the following loop
for(@d) # Each node under the current node
{if (my $e = $_->{content}) # Contents reference
{my @e = @$e; # For some reason we cannot place this directly in a for loop reliably
my $E = $_; # Save $_ so we can use it in the following loop
for(@e) # Each node under the current node
{if (my $f = $_->{content}) # Contents reference
{my @f = @$f; # Content
my $F = $_; # Save $_ so we can use it in the following loop
for(@f) # Each node under the current node
{if (my $g = $_->{content}) # Contents reference
{my @g = @$g; # Content
my $G = $_; # Save $_ so we can use it in the following loop
for(@g) # Each node under the current node
{if (my $h = $_->{content}) # Contents reference
{my @h = @$h; # Content
my $H = $_; # Save $_ so we can use it in the following loop
for(@h) # Each node under the current node
{if (my $i = $_->{content}) # Contents reference
{my @i = @$i; # Content
my $I = $_; # Save $_ so we can use it in the following loop
for(@i) # Each node under the current node
{if (my $j = $_->{content}) # Contents reference
{my @j = @$j; # Content
my $J = $_; # Save $_ so we can use it in the following loop
for(@j) { # Each node under the current node
&$by($_, $J, $I, $H, $G, $F, $E, $D, @_); # Recurse
}
}
&$sub($_, $I, $H, $G, $F, $E, $D, @_); # Process current node in post order
}
}
&$sub($_, $H, $G, $F, $E, $D, @_); # Process current node in post order
}
}
&$sub($_, $G, $F, $E, $D, @_); # Process current node in post order
}
}
&$sub($_, $F, $E, $D, @_); # Process current node in post order
}
}
&$sub($_, $E, $D, @_); # Process current node in post order
}
}
&$sub($_, $D, @_); # Process current node in post order
}
}
&$sub($_, @_); # Process current node in post order
}
}
&$sub(@_); # Process current node in post order
lib/Data/Edit/Xml.pm view on Meta::CPAN
my @n; # Nodes under specified node
$node->down(sub{push @n, $_}); # Retrieve nodes in pre-order
@n # Return list of nodes
}
sub downReverse($$@) # Reverse pre-order traversal down through a L<parse|/parse> tree or sub tree calling the specified B<sub> at each node and returning the specified starting node. The B<s...
{my ($node, $sub, @context) = @_; # Starting node, sub to call for each sub node, accumulated context.
&$sub(local $_ = $node, @context); # Process specified node first
$_->downReverse($sub, $node, @context) for reverse $node->contents; # Recurse to process sub nodes in deeper context
$node
}
sub downReverseX($$@) # Reverse pre-order traversal down through a L<parse|/parse> tree or sub tree calling the specified B<sub> within L<eval>B<{}> at each node and returning the specified st...
{my ($node, $sub, @context) = @_; # Starting node, sub to call for each sub node, accumulated context.
&$sub(local $_ = $node, @context); # Process specified node first
$_->downReverseX($sub, $node, @context) for reverse $node->contents; # Recurse to process sub nodes in deeper context
$node
}
sub downReverseList($@) #C Return a list of all the nodes at and below a specified B<$node> in reverse pre-order or the empty list if the B<$node> is not in the optional B<@context>.
{my ($node, @context) = @_; # Starting node, optional context
return () if @context and !$node->at(@context); # Check optional context
my @n; # Nodes under specified node
$node->downReverse(sub{push @n, $_}); # Retrieve nodes in reverse pre-order
@n # Return list of nodes
}
#D2 Pre and Post order # Visit the parent first, then the children, then the parent again.
sub through($$$@) # Traverse L<parse|/parse> tree visiting each node twice calling the specified sub B<$before> as we go down past the node and sub B<$after> as we go up past the node, fin...
{my ($node, $before, $after, @context) = @_; # Starting node, sub to call when we meet a node, sub to call we leave a node, accumulated context.
&$before(local $_ = $node, @context) if $before; # Process specified node first with before()
$_->through($before, $after, $node, @context) for $node->contents; # Recurse to process sub nodes in deeper context
&$after(local $_ = $node, @context) if $after; # Process specified node last with after()
$node
}
sub throughX($$$@) # Identical to L<through|/through> except the B<$before, $after> subs are called in an L<eval> block to prevent L<die> terminating the traversal of the full tree.
{my ($node, $before, $after, @context) = @_; # Starting node, sub to call when we meet a node, sub to call we leave a node, accumulated context.
&$before(local $_ = $node, @context); # Process specified node first with before()
$_->throughX($before, $after, $node, @context) for $node->contents; # Recurse to process sub nodes in deeper context
&$after(local $_ = $node, @context); # Process specified node last with after()
$node
}
#D2 Range # Ranges of nodes
sub from($@) # Return a list consisting of the specified node and its following siblings optionally including only those nodes that match one of the tags in the specified list.
{my ($start, @match) = @_; # Start node, optional list of tags to match
my $p = $start->parent; # Parent node
confess "No parent" unless $p; # Not possible on a root node
my @c = $p->contents; # Content
shift @c while @c and $c[ 0] != $start; # Position on start node
if (@match) # Select matching nodes if requested
{my %m = map {$_=>1} @match;
return grep {$m{$_->tag}} @c;
}
@c # Elements in the specified range
}
sub to($@) # Return a list of the sibling nodes preceding the specified node optionally including only those nodes that match one of the tags in the specified list.
{my ($end, @match) = @_; # End node, optional list of tags to match
my $q = $end->parent; # Parent node
confess "No parent" unless $q; # Not possible on a root node
my @c = $q->contents; # Content
pop @c while @c and $c[-1] != $end; # Position on end
if (@match) # Select matching nodes if requested
{my %m = map {$_=>1} @match;
return grep {$m{$_->tag}} @c;
}
@c # Elements in the specified range
}
sub fromTo($$@) # Return a list of the nodes between the specified start and end nodes optionally including only those nodes that match one of the tags in the specified list.
{my ($start, $end, @match) = @_; # Start node, end node, optional list of tags to match
my $p = $start->parent; # Parent node
confess "No parent" unless $p; # Not possible on a root node
my $q = $end->parent; # Parent node
confess "No parent" unless $q; # Not possible on a root node
confess "Not siblings" unless $p == $q; # Not possible unless the two nodes are siblings under the same parent
my @c = $p->contents; # Content
shift @c while @c and $c[ 0] != $start; # Position on start node
pop @c while @c and $c[-1] != $end; # Position on end
if (@match) # Select matching nodes if requested
{my %m = map {$_=>1} @match;
return grep {$m{$_->tag}} @c;
}
@c # Elements in the specified range
}
#D1 Location # Locate the line numbers and columns of a specified node and write that information as a L<Oxygen Message|/https://www.oxygenxml.com/doc/versions/20.1/ug-author/topics/l...
sub parseLineLocation($) #PS Parse a line location
{my ($loc) = @_; # Location
my ($l, $c, $L, $C) = split m/[.:]/, $loc; # Position of node in source
for my $n($l, $c, $L) # Check that some-one else is not using xtrf for some other reason
{return () unless $n and $n =~ m(\A\d+\Z)s;
}
return () if $L and $L !~ m(\A\d+\Z)s;
unless(defined $C) # Same line
{$C = $L;
$L = 0;
}
$L += $l; # Final line
($l, $c, $L, $C) # Return parsed line location
}
sub lineLocation($) #U Return the line number.column location of this tag in its source file or string if the source was parsed with the L<line number|/lineNumber> option on.
{my ($node) = @_; # Node
my $loc = $node->attr(q(xtrf)); # Location of node in source
return q() unless $loc; # No location specified
my @c = my ($l, $c, $L, $C) = parseLineLocation $loc; # Position of node in source
for(@c)
{return q() unless defined $_;
}
if ($l eq $L) # All on one line
{return qq(on line $l from $c to $C) # Single line
}
lib/Data/Edit/Xml.pm view on Meta::CPAN
return $node if $node->attr(q(xtrf)); # Node has a location so return it.
my $best; # Best location so far
if ($node->parser->lineNumbers) # Search through tree for closest node if line numbering is in effect
{my $before = 1; # Best node before (after) the specified node
for my $p($node->parser->downList) # Preorder traversal
{if ($before or !$best) # Before or at the node
{$best = $p if $p->attr(q(xtrf));
}
$before = 0 if $p == $node and $before; # Pass the node
}
}
$best # Return best node if known
}
sub approxLocation($;$) #U Return the line number.column location of the node nearest to this node in the source file if the source was parsed with the L<line number|/lineNumber> option on.
{my ($node, $file) = @_; # Node, optionally the location of the source.
return location(@_) if $node->attr(q(xtrf)); # Node has a location so return it.
my $best = $node->closestLocation; # Search through tree for closest node if line numbering is in effect
return location($best, $file) if $best; # Nearby node has a location so return it.
my $f = $file // $node->parser->inputFile; # Parser input file if known
return qq( in file: ).$f if $f; # Position of node in source
q() # Unknown location
}
sub formatOxygenMessage($$$@) #U Write an error message in Oxygen format
{my ($node, $level, $url, @message) = @_; # Node, error level [F|E|W], explanatory Url, message text
my ($line, $col, $Line, $Col) = sub # Position in Oxygen format
{my $best = $node->closestLocation; # Closest node with line number information
return parseLineLocation $best->xtrfX if $best; # Return numbers
(1,1,0,0)
}->();
my $m = nws(join '', @message);
my $u = $url ? qq( $url) : q();
<<END; # To get this message to Oxygen simply write on STDOUT or STDERR
Type: $level
Line: $line
Column: $col
EndLine: $Line
EndColumn: $Col
AdditionalInfoURL:$u
Description: $m
END
}
#D1 Position # Confirm that the position L<navigated|/Navigation> to is the expected position.
sub atPositionMatch($$) #P Confirm that a string matches a match expression.
{my ($tag, $match) = @_; # Starting node, ancestry.
return 1 unless $match; # Undefined match means anything matches
return $tag eq $match unless ref $match; # Match scalar
return $tag =~ m($match)s if ref($match) =~ m(regexp)i; # Match regular expression
return $$match{$tag} if ref($match) =~ m(hash)i; # Match hash key
if (ref($match) =~ m(array)i) # Match array
{my %m = map {$_=>1} @$tag;
return $m{$tag}
}
confess "Unknown match type"; # Do not know how to match
}
sub at($@) #CIYU Confirm that the specified B<$node> has the specified L<ancestry|/ancestry>. Ancestry is specified by providing the expected tags that the B<$node>'s parent, the pa...
{my ($node, @context) = @_; # Node, ancestry.
for(my $x = shift @_; $x; $x = $x->parent) # Up through parents
{return $node unless @_; # OK if no more required context
next if atPositionMatch(-t $x, shift @_); # Match tag against context
return undef # Error if required does not match actual
}
!@_ ? $node : undef # Top of the tree is OK as long as there is no more required context
}
#b <b/>
#b <c/>
#c at b
#c set id idb href bbb
#d Continue if we are in the specified context.
sub atText($$@) #CU Confirm that we are on a text node whose text value matches a regular expression in the optional B<@context>. Return the specified B<$node> on success else B<undef>.
{my ($node, $re, @context) = @_; # Text node, regular expression to match, context
return undef if !$node->isText(@context); # Not a text node in the specified context
$node->text =~ m($re) ? $node : undef # Success if the text matches
}
#b <b>bb</b><c>cc</c>
#c atText cc c
#c up
#c set id CC
#d Continue if we are on a text node whose value matches a regular expression
sub atStringContentMatches($$@) #CU Confirm that we are on a B<$node> whose contents, represented as a string, matches the specified regular expression B<$re> in the optional B<@context>. Return the spe...
{my ($node, $re, @context) = @_; # Text node, regular expression to match, context
return undef if @context and !$node->at(@context); # Check optional context
$node->stringContent =~ m($re) ? $node : undef # Success if the content, as a string, matches the re
}
#b <b><c>cc</c><d>dd</d></b>
#c atStringContentMatches qr(dd)
#c set id yes
#d Continue if we are on a node whose content represented as a string matches a regular expression
sub atTop($) #U Return the current node if it is the root == top of a parse tree else return B<undef>.
{my ($node) = @_; # Node
return $node unless $node->parent; # Has no parent so must be at the top
undef # Has a parent and so is not at the top
}
#a at
#b <b/>
#c atTop
#c set id top
#d Continue if we are at the top.
sub attrAt($$@) #CU Return the specified B<$node> if it has the specified B<$attribute> and the $node is in the optional B<@context> else return B<undef>.
{my ($node, $attribute, @context) = @_; # Starting node, attribute, context
return undef if @context and !$node->at(@context); # Not in specified context
defined($node->attributes->{$attribute}) ? $node : undef # Node has attribute
}
#a set
#b <b id='b'/><b id='bb'/>
#c attrValueAt id bb
#c set class here
#d Continue if an attribute has a specific value.
sub attrValueAt($$$@) #CU Return the specified B<$node> if it has the specified B<$attribute> with the specified B<$value> and the $node is in the optional B<@context> else return B<undef>.
{my ($node, $attribute, $value, @context) = @_; # Starting node, attribute, wanted value of attribute, context
return undef if @context and !$node->at(@context); # Not in specified context
lib/Data/Edit/Xml.pm view on Meta::CPAN
}
return $node if @c >= 0 and @tags == 0; # The last child nodes match the specified tags
undef # Wrong number of tags
}
BEGIN{*olt=*overLastTags}
sub matchAfter($$@) #CY Confirm that the string representing the tags following the specified B<$node> matches a regular expression where each pair of tags is separated by a single space. Us...
{my ($node, $re, @context) = @_; # Node, regular expression, optional context.
return undef if @context and !$node->at(@context); # Not in specified context
$node->contentAfterAsTags =~ m/$re/ ? $node : undef
}
sub matchAfter2($$@) #CY Confirm that the string representing the tags following the specified B<$node> matches a regular expression where each pair of tags have two spaces between them and t...
{my ($node, $re, @context) = @_; # Node, regular expression, optional context.
return undef if @context and !$node->at(@context); # Not in specified context
$node->contentAfterAsTags2 =~ m/$re/ ? $node : undef
}
sub matchBefore($$@) #CY Confirm that the string representing the tags preceding the specified B<$node> matches a regular expression where each pair of tags is separated by a single space. Us...
{my ($node, $re, @context) = @_; # Node, regular expression, optional context.
return undef if @context and !$node->at(@context); # Not in specified context
$node->contentBeforeAsTags =~ m/$re/ ? $node : undef
}
sub matchBefore2($$@) #CY Confirm that the string representing the tags preceding the specified B<$node> matches a regular expression where each pair of tags have two spaces between them and t...
{my ($node, $re, @context) = @_; # Node, regular expression, optional context.
return undef if @context and !$node->at(@context); # Not in specified context
$node->contentBeforeAsTags2 =~ m/$re/ ? $node : undef
}
sub parentage($) #U Return a reference to an array of the nodes along the path from the root to the specified B<$Node> inclusive.
{my ($node) = @_; # Node.
my @p; # Path
for(my $p = $node; $p; $p = $p->parent) # Go up
{push @p, $p; # Save position
}
[reverse @p] # Return path from root
}
BEGIN{*p=*parentage}
sub path($) #U Return a list of strings representing the path to a node from the root of the parse tree which can then be reused by L<go|/go> to retrieve the node as long as the stru...
{my ($node) = @_; # Node.
my @p; # Path
for(my $p = $node; $p and $p->parent; $p = $p->parent) # Go up
{my $i = $p->index; # Position in parent index
push @p, $i if $i; # Save position unless default
push @p, $p->tag; # Save index
}
reverse @p # Return path from root
}
sub pathString($) #bU Return a string representing the L<path|/path> to the specified B<$node> from the root of the parse tree.
{my ($node) = @_; # Node.
join ' ', path($node) # String representation
}
#D2 Match # Locate adjacent nodes that match horizontally and vertically
sub an($$@) #CU Return the next node if the specified B<$node> has the tag specified by B<$current> and the next node is in the specified B<@context>.
{my ($node, $current, @context) = @_; # Node, tag node must match, optional context of the next node.
return undef unless $node->at($current); # Check node has the right tag
$node->next(@context) # Next node if it matches the context else B<undef>
}
sub ap($$@) #CU Return the previous node if the specified B<$node> has the tag specified by B<$current> and the previous node is in the specified B<@context>.
{my ($node, $current, @context) = @_; # Node, tag node must match, optional context of the previous node.
return undef unless $node->at($current); # Check node has the right tag
$node->prev(@context) # Previous node if it matches the context else B<undef>
}
sub apn($$$@) #KU Return (previous node, next node) if the B<$previous> and B<$current> nodes have the specified tags and the next node is in the specified B<@context> else return B<()...
{my ($node, $prev, $current, @context) = @_; # Current node, tag for the previous node, tag for specified node, context for the next node.
return () if !@context or !$node->at($current) or # Check context
$node->isLast or $node->isFirst; # Check existence of surrounding nodes
my $p = $node->prev($prev); # Previous node
my $n = $node->next(@context); # Next node
return ($p, $n) if $p and $n; # Successful match
() # Match failed
}
sub matchesFirst($@) #U Return the specified B<$node> if its children L<match|/atPositionMatch> the specified <@sequence> forwards from the first child else return B<undef>.
{my ($node, @sequence) = @_; # Node, sequence.
my @c = $node->contents; # Child nodes
while(@sequence and @c) # Match node contents against tags
{return undef unless atPositionMatch(-t shift @c, shift @sequence); # Continue unless we fail to match
}
return $node unless @sequence; # The following nodes match the specified tags
undef # Wrong number of tags
}
sub matchesLast($@) #U Return the specified B<$node> if its children L<match|/atPositionMatch> the specified <@sequence> backwards from the last child else return B<undef>.
{my ($node, @sequence) = @_; # Node, sequence.
my @c = reverse $node->contents; # Child nodes
while(@sequence and @c) # Match node contents against tags
{return undef unless atPositionMatch(-t shift @c, shift @sequence); # Continue unless we fail to match
}
return $node unless @sequence; # The following nodes match the specified tags
undef # Wrong number of tags
}
sub matchesNext($@) #U Return the specified B<$node> if its following siblings L<match|/atPositionMatch> the specified <@sequence> else return B<undef>.
{my ($node, @sequence) = @_; # Node, sequence.
my @c = $node->contentAfter; # Following node
while(@sequence and @c) # Match node contents against tags
{return undef unless atPositionMatch(-t shift @c, shift @sequence); # Continue unless we fail to match
}
return $node unless @sequence; # The following nodes match the specified tags
undef # Wrong number of tags
}
sub matchesPrev($@) #U Return the specified B<$node> if the siblings before $node L<match|/atPositionMatch> the specified <@sequence> with the first element of @sequence nearest to $node and...
{my ($node, @sequence) = @_; # Node, sequence.
my @c = reverse $node->contentBefore; # Prior nodes
while(@sequence and @c) # Match node contents against tags
{return undef unless atPositionMatch(-t shift @c, shift @sequence); # Continue unless we fail to match
}
return $node unless @sequence; # The prior nodes match the specified tags
undef # Wrong number of tags
}
#D2 Child of, Parent of, Sibling of # Nodes that are directly above, below or adjacent to another node.
sub parentOf($$@) #C Returns the specified B<$parent> node if it is the parent of the specified B<$child> node and the B<$parent> node is in the specified optional context.
{my ($parent, $child, @context) = @_; # Parent, child, optional context
return undef if @context and !$parent->at(@context); # Check context
return $parent if $child->parent == $parent; # Check child has the parent as its parent
undef # Wrong parent
}
sub childOf($$@) #C Returns the specified B<$child> node if it is a child of the specified B<$parent> node and the B<$child> node is in the specified optional context.
{my ($child, $parent, @context) = @_; # Child, parent, optional context
return undef if @context and !$child->at(@context); # Check context
return $child if $child->parent == $parent; # Check child has the parent as its parent
undef # Wrong parent
}
sub succeedingSiblingOf($$@) #C Returns the specified B<$child> node if it has the same parent as B<$sibling> and occurs after B<$sibling> and has the optionally specified context else returns B<unde...
{my ($child, $sibling, @context) = @_; # Child, sibling thought to occur before child, optional context
return undef if @context and !child->at(@context); # Check context
return undef unless $child->parent == $sibling->parent; # Check child has the parent as its prior sibling
$child->after($sibling); # Check child occurs after prior sibling
}
sub precedingSiblingOf($$@) #C Returns the specified B<$child> node if it has the same parent as B<$sibling> and occurs before B<$sibling> and has the optionally specified context else returns B<und...
{my ($child, $sibling, @context) = @_; # Child, sibling thought to occur after child, optional context
return undef if @context and !child->at(@context); # Check context
return undef unless $child->parent == $sibling->parent; # Check child has the parent as its prior sibling
$child->before($sibling); # Check child occurs after prior sibling
}
#D1 Navigation # Move around in the L<parse|/parse> tree.
sub go($@) #IYU Return the node reached from the specified B<$node> via the specified L<path|/path>: (index positionB<?>)B<*> where index is the tag of the next node to be chosen an...
{my ($node, @path) = @_; # Node, search specification.
my $p = $node; # Current node
while(@path) # Position specification
{my $i = shift @path; # Index name
return undef unless $p; # There is no node of the named type under this node
reindexNode($p); # Create index for this node
my $q = $p->indexes->{$i}; # Index
return undef unless defined $q; # Complain if no such index
if (@path) # Position within index
{if ($path[0] =~ /\A([-+]?\d+)\Z/) # Numeric position in index from start
{shift @path;
$p = $q->[$1]
}
elsif (@path == 1 and $path[0] =~ /\A\*\Z/) # Final index wanted
{return @$q;
}
else {$p = $q->[0]} # Step into first sub node by default
}
else {$p = $q->[0]} # Step into first sub node by default on last step
}
$p
}
#a up
#b <b><c/><c><d/><d/><d/><d/></c><c/></b>
#c go c 1 d 2
#c set id arrived_here
#d Follow a path from the current node.
sub c($$) #U Return an array of all the nodes with the specified tag below the specified B<$node>.
{my ($node, $tag) = @_; # Node, tag.
reindexNode($node); # Create index for this node
my $c = $node->indexes->{$tag}; # Index for specified tags
$c ? @$c : () # Contents as an array
}
sub cText($) #U Return an array of all the text nodes immediately below the specified B<$node>.
{my ($node) = @_; # Node.
reindexNode($node); # Create index for this node
$node->c(cdata); # Index for text data
}
sub findById($$) #U Find a node in the parse tree under the specified B<$node> with the specified B<$id>.
{my ($node, $id) = @_; # Parse tree, id desired.
my $i; # Node found
eval {$node->by(sub # Look for an instance of such a node
{if ($_->idX eq $id) {$i = $_; die} # Found the node - die to stop the search from going further
})};
$i # Node found if any
}
sub matchesNode($$@) # Return the B<$first> node if it matches the B<$second> node's tag and the specified B<@attributes> else return B<undef>.
{my ($first, $second, @attributes) = @_; # First node, second node, attributes to match on
return undef unless -t $first eq -t $second; # Check tags match
my $f = $first->attributes; # Attributes for first node
my $s = $second->attributes; # Attributes for second node
for my $a(@attributes)
{return undef unless defined($f->{$a}) and defined($s->{$a}) and
$f->{$a} eq $s->{$a};
}
$first # Nodes match on specified attributes
}
lib/Data/Edit/Xml.pm view on Meta::CPAN
}
return undef # No such node
}
sub prevOn($@) #U Step backwards as far as possible while remaining on nodes with the specified tags. In scalar context return the last such node reached or the starting node if no such...
{my ($node, @tags) = @_; # Start node, tags identifying nodes that can be step on to context.
return wantarray ? ($node) : $node if $node->isFirst; # Easy case
my $parent = $node->parent; # Parent node
confess "No parent" unless $parent; # Not possible on a root node
my @c = reverse $parent->contents; # Content backwards
shift @c while @c and $c[0] != $node; # Position on current node
confess "Node not found in parent" unless @c; # Something wrong with parent/child relationship
my %tags = map {$_=>1} @tags; # Hashify tags of acceptable commands
if (wantarray) # Return node and following matching nodes if array wanted
{my @a = (shift @c);
push @a, shift @c while @c and $tags{$c[0]->tag}; # Proceed forwards staying on acceptable tags
@a # Current node and matching following nodes
}
else
{shift @c while @c > 1 and $tags{$c[1]->tag}; # Proceed forwards but staying on acceptable tags
return $c[0] # Current node or last acceptable tag reached while staying on acceptable tags
}
}
sub prevWhile($@) #U Go to the previous sibling of the specified B<$node> and continue backwards while the tag of each sibling node matches one of the specified B<@tags>. Return the first ...
{my ($node, @tags) = @_; # Parent node, child tags to avoid.
my %tags = map {$_=>1} @tags; # Hashify tags
for(reverse $node->contentBefore) # Search backwards through siblings
{return $_ unless $tags{$_->tag}; # Find first tag that fails to match
}
return undef # No such node
}
sub prevUntil($@) #U Go to the previous sibling of the specified B<$node> and continue backwards until the tag of a sibling node matches one of the specified B<@tags>. Return the matching ...
{my ($node, @tags) = @_; # Node, tags to look for.
my %tags = map {$_=>1} @tags; # Hashify tags
for($node->contentBefore) # Search forwards through following siblings
{return $_ if $tags{$_->tag}; # Find next node that matches on of the supplied tags
}
undef # No such node
}
#D2 Up # Methods for moving up the L<parse|/parse> tree from a node.
sub top($@) #CYU Return the top of the parse tree containing the current B<$node> after optionally checking that the $node is in the optional B<@context>.
{my ($node, @context) = @_; # Start node, optional context
return undef if @context and !$node->at(@context); # Check the context if supplied
for (my $p = $node;; $p = $p->parent) # Walk up the parse tree
{return $p unless $p->parent; # Continue up the parse tree unless we are at the top - if not, let us hope that Zorn's lemma applies soon rather than later
}
}
BEGIN {*root = *top}
#a
#b <b><c/></b>
#c top
#c set id top
#d Go to the top of the parse tree.
sub up($@) #CYU Return the parent of the current node optionally checking the parent node's context or return B<undef> if the specified B<$node> is the root of the L<parse|/parse> t...
{my ($node, @context) = @_; # Start node, optional context of parent.
return $node->parent unless @context; # Parent with no context check
my $p = $node->parent;
$p->at(@context) ? $p : undef; # Check context of parent
}
#a
#b <b><c/></b>
#c at c
#c up
#c set id above_c
#d Go up one level.
sub upn($$@) #CU Go up the specified number of levels from the specified B<$node> and return the node reached optionally checking the parent node's context or B<undef> if there is no ...
{my ($node, $levels, @context) = @_; # Start node, number of levels to go up, optional context.
for(my $c = 0; $node and $c < $levels; $node = $node->parent, ++$c) {} # Number of levels move up
return $node unless @context; # Return node reached unless context check required
$node ? $node->at(@context) : undef; # Check context
}
sub upWhile($@) #YU Go up one level from the specified B<$node> and then continue up while each node matches on of the specified <@tags>. Return the last matching node or B<undef> if no ...
{my ($node, @tags) = @_; # Start node, tags to match
my %tags = map {$_=>1} @tags; # Hashify tags
my $lastMatch; # Last good match
for(my $p = $node->parent; $p; $p = $p->parent) # Go up
{last unless $tags{-t $p}; # Found an ancestor that does not match
$lastMatch = $p;
}
$lastMatch # Last good match
}
sub upWhileFirst($@) #CU Move up from the specified B<$node> as long as each node is a first node or return B<undef> if the specified B<$node> is not a first node.
{my ($node, @context) = @_; # Start node, optional context
return undef if @context && !$node->at(@context) or !$node->isFirst; # Check the context if supplied and that the node is first
my $lastMatch = $node; # First node
for(my $p = $node->parent; $p; $p = $p->parent) # Go up
{return $lastMatch unless $p->isFirst; # Return last node which was first
$lastMatch = $p # Update last matching position
}
$lastMatch # Root node matches
}
sub upWhileLast($@) #CU Move up from the specified B<$node> as long as each node is a last node or return B<undef> if the specified B<$node> is not a last node.
{my ($node, @context) = @_; # Start node, optional context
return undef if @context && !$node->at(@context) or !$node->isLast; # Check the context if supplied and that the node is last
my $lastMatch = $node; # Last node
for(my $p = $node->parent; $p; $p = $p->parent) # Go up
{return $lastMatch unless $p->isLast; # Return last node which was last
$lastMatch = $p # Update last matching position
}
$lastMatch # Root node matches
}
sub upWhileIsOnlyChild($@) #CU Move up from the specified B<$node> as long as each node is an only child or return B<undef> if the specified B<$node> is not an only child.
{my ($node, @context) = @_; # Start node, optional context
return undef if @context && !$node->at(@context) or !$node->isOnlyChild; # Check the context if supplied and that the node is an only child
my $lastMatch = $node; # Last node
for(my $p = $node->parent; $p; $p = $p->parent) # Go up
{return $lastMatch unless $p->isOnlyChild; # Return last node which was an only child
$lastMatch = $p # Update last matching position
}
lib/Data/Edit/Xml.pm view on Meta::CPAN
sub printAttributesExtendingIdsWithLabels($) #UP Print the attributes of a node extending the id with the labels.
{my ($node) = @_; # Node whose attributes are to be printed.
my %a = %{$node->attributes}; # Clone attributes
my %l = %{$node->labels}; # Clone labels
my $i = $a{id} ? $a{id}.q(, ) : q(); # Format id
$a{id} = join '', $i, join ', ', sort keys %l if keys %l; # Extend id with labels in cloned attributes
defined($a{$_}) ? undef : delete $a{$_} for keys %a; # Remove undefined attributes
return '' unless keys %a; # No attributes
my $s = ' '; $s .= $_.'="'.$a{$_}.'" ' for sort keys %a; chop($s); # Attributes enclosed in "" in alphabetical order
$s
}
sub checkParentage($) #UP Check the parent pointers are correct in a L<parse|/parse> tree.
{my ($x) = @_; # Parse tree.
$x->by(sub
{my ($o) = @_;
for($o->contents)
{my $p = $_->parent;
$p == $o or confess "No parent: ". $_->tag;
$p and $p == $o or confess "Wrong parent: ".$o->tag. ", ". $_->tag;
}
});
}
sub checkParser($) #UP Check that every node has a L<parse|/parse>r.
{my ($x) = @_; # Parse tree.
$x->by(sub
{$_->parser or confess "No parser for ". $_->tag;
$_->parser == $x or confess "Wrong parser for ". $_->tag;
})
}
sub goFish($@) #U A debug version of L<go|/go> that returns additional information explaining any failure to reach the node identified by the L<path|/path>.\mReturns ([B<reachable tag>....
{my ($node, @path) = @_; # Node, search specification.
my $p = $node; # Current node
my @p; # Elements of the path successfully processed
while(@path) # Position specification
{my $i = shift @path; # Index name
return ([@p], $i, [sort keys %{$p->indexes}]) unless $p; # There is no node of the named type under this node
reindexNode($p); # Create index for this node
my $q = $p->indexes->{$i}; # Index
return ([@p], $i, [sort keys %{$p->indexes}]) unless defined $q; # Complain if no such index
push @p, $i;
if (@path) # Position within index
{if ($path[0] =~ /\A([-+]?\d+)\Z/) # Numeric position in index from start
{my $n = shift @path; # Next path item
my $N = scalar(@$q); # Dimension of index
return ([@p], $n, [0..$N]) unless defined($p = $q->[$n]); # Complain if no such index
push @p, $n; # Save successfully processed index
}
elsif (@path == 1 and $path[0] =~ /\A\*\Z/) # Final index wanted
{return [@p];
}
else {$p = $q->[0]} # Step into first sub node by default
}
else {$p = $q->[0]} # Step into first sub node by default on last step
}
[@p] # Success!
}
sub nn($) #P Replace new lines in a string with N to make testing easier.
{my ($s) = @_; # String.
$s =~ s/\n/N/gsr
}
#D1 Validation # Validate Xml
sub checkAllPaths($) #S Create a representation of all the paths permitted in a block of L<xml>. The syntax of each line is a word representing an L<xml> tag followed by one of: tag B<1 * + ?...
{my ($valid) = @_; # Path descriptions
my %valid; # Perl representation of validating string
my @stack; # Tag stack
my @lines = split m/\n/, $valid; # Split into lines
for my $i(keys @lines) # Each line
{my $line = $lines[$i] =~ s(\s*#.*\Z) ()r; # Remove trailing comments
next unless $line =~ m(\S); # Ignore blank lines
my sub error(@) # Write an error message
{confess join ' ', @_, 'on line:', $i + 1, "\n";
};
my $tag = $line =~ s(\A\s*) ()r; # Check indentation carefully as it shows the desired structure
my $indent = length($line) - length($tag);
$indent % 2 and error "Indentation is not even";
my $indent2 = $indent / 2;
$i == 0 and $indent != 0 and error "Indent is not zero";
@stack+1 < $indent2 and error "Too much indentation";
while(@stack) # Reduce the stack to the current level
{if (@stack > $indent2)
{pop @stack;
next;
}
last;
}
my ($tagName, @words) = split m/\s+/, $tag; # Save tag on the tag stack
push @stack, $tagName;
my $count = sub # The count indicator optionally follows the tag
{return 1 unless @words; # The default is just one and it is required
my $c = shift @words;
return $c if $c =~ m(\A[-1+*?]\Z)i; # Valid operators
1
}->();
if (@stack > 1) # Element description
{$valid{join ' ', @stack[1..$#stack]} =
[$count, my $comment = join ' ', @words];
}
}
my ($root) = @stack; # The root tag
for my $a(sort keys %valid) # Create get methods
{for my $b(sort keys %valid)
{my $c = $valid{$b}[0]; # Count field
my @b = split m/\s+/, $b;
my $m = pop @b;
if ($a eq join " ", @b or !@b) # Has children
{my @m = ($root, @b);
( run in 1.590 second using v1.01-cache-2.11-cpan-5b529ec07f3 )