$xpath = $1;
# this is a match-anywhere pattern, which should be tried on
# all nodes
foreach_node { push(@targets, $_) } $get_root->($self), $get_children;
} elsif ($xpath =~ m!^/(.*)$!) {
$xpath = $1;
# this match starts at the root
@targets = ($get_root->($self));
} elsif ($xpath =~ m!^\.\./(.*)$!) {
$xpath = $1;
# this match starts at the parent
@targets = ($get_parent->($self));
} elsif ($xpath =~ m!^\./(.*)$!) {
$xpath = $1;
@targets = ($self);
} else {
# this match starts here
@targets = ($self);
}
# pattern breakdown
my @parts = split('/', $xpath);
my $count = 0;
for (@parts) {
$count++;
if (/^$NAME$/) {
# it's a straight name match
push(@patterns, { name => $_ });
} elsif (/^($NAME)\[(-?\d+)\]$/o) {
# it's an indexed name
push(@patterns, { name => $1, index => $2 });
} elsif (/^($NAME)\[\@($NAME)\s*=\s*"([^"]+)"\]$/o or
/^($NAME)\[\@($NAME)\s*=\s*'([^']+)'\]$/o) {
# it's a string attribute match
push(@patterns, { name => $1, attr => $2, value => $3 });
} elsif (/^($NAME)\[\@($NAME)\s*(=|>|<|<=|>=|!=)\s*(\d+)\]$/o) {
# it's a numeric attribute match
push(@patterns, { name => $1, attr => $2, op => $3, value => $4 });
} elsif (/^($NAME)\[($NAME|\.)\s*=\s*"([^"]+)"\]$/o or
/^($NAME)\[($NAME|\.)\s*=\s*'([^']+)'\]$/o) {
# it's a string child match
push(@patterns, { name => $1, child => $2, value => $3 });
} elsif (/^($NAME)\[($NAME|\.)\s*(=|>|<|<=|>=|!=)\s*(\d+)\]$/) {
# it's a numeric child match
push(@patterns, { name => $1, child => $2, op => $3, value => $4 });
} elsif (/^\@($NAME)$/) {
# it's an attribute name
push(@patterns, { attr => $1 });
# it better be last
croak("Bad call to $args->{call_match}: '$xpath' contains an attribute selector in the middle of the
expression.")
if $count != @parts;
} else {
# unrecognized token
croak("Bad call to $args->{call_match}: '$xpath' contains unknown token '$_'");
}
}
croak("Bad call to $args->{call_match}: '$xpath' contains no search tokens.")
unless @patterns;
# apply the patterns to all available targets and collect results
my @results = map { $pkg->_do_match($_, $args, @patterns) } @targets;
return @results;
}
# the underlying match engine. this takes a list of patterns and
# applies them to child elements
sub _do_match {
my ($pkg, $self, $args, @patterns) = @_;
my ($get_parent, $get_children, $get_name, $get_attr_value, $get_attr_names, $get_content) =
@{$args}{qw(get_parent get_children get_name get_attr_value get_attr_names get_content)};
local $_;
print STDERR "_do_match(" . $get_name->($self) . " => " .
join(', ', map { '{' . join(',', %$_) . '}' } @patterns) .
") called.\n"
if DEBUG;
# get pattern to apply to direct descendants
my $pat = shift @patterns;
# find matches and put in @results
my @results;
my @kids;
{ no warnings 'uninitialized';
@kids = grep { $get_name->($_) eq $pat->{name} } $get_children->($self);
}
if (defined $pat->{index}) {
# get a child by index
push @results, $kids[$pat->{index}]
if (abs($pat->{index}) <= $#kids);
} elsif (defined $pat->{attr}) {
if (defined $pat->{name}) {
# default op is 'eq' for string matching
my $op = $pat->{op} || 'eq';
=2= |