Updated capabilities of findPhysicalDrive to support imminent work on locating the hg cache.
#!perl -w
use strict;
use XML::Parser;
my $sysModel = shift or die "First arg must be system model xml file";
my @filters = @ARGV or die "Subsequent arg(s) must be filter(s) to apply";
# Sort out the positive and negative filters specified
my @negativeFilters;
my @positiveFilters;
foreach my $filter (@filters)
{
if ($filter =~ m{^!(.*)})
{
push @negativeFilters, $1;
}
else
{
push @positiveFilters, $filter;
}
}
# Read input tree
my $parser = new XML::Parser(Style => "Objects") or die;
my $sysTree = eval { $parser->parsefile($sysModel) } or die "Failed to parse $sysModel : $@";
# Apply filter
filterTree($sysTree->[0], \@negativeFilters, \@positiveFilters);
# Output total tree
print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";
printTree($sysTree->[0]);
print "\n";
exit;
sub filterTree
{
my $tree = shift;
my $negativeFilters = shift;
my $positiveFilters = shift;
if (exists $tree->{filter})
{
# Work out how this item in the tree is tagged for filtering
my $itemTags = [split ",", $tree->{filter}];
my @negativeTags;
my @positiveTags;
foreach my $tag (@$itemTags)
{
if ($tag =~ m{^!(.*)})
{
push @negativeTags, $1;
}
else
{
push @positiveTags, $tag;
}
}
# Test whether this item should be removed
if (intersect(\@positiveTags, $negativeFilters) ||
intersect(\@negativeTags, $positiveFilters) )
{
# It should!
# Return false, and the removal will be executed by the
# calling instance
# (No need to examine children)
return 0;
}
# Tidy up the filter attribute
# Remove tags from this item that have been "used up"
# Remove the filter attribute entirely if they have all been
# used up
my %filterLookup = map { $_ => 1 } (@$negativeFilters, @$positiveFilters);
@$itemTags = grep { !exists $filterLookup{$_} } @$itemTags;
if (scalar @$itemTags)
{
$tree->{filter} = join ",", @$itemTags;
}
else
{
delete $tree->{filter};
}
}
# Now iterate through the children of this item and remove any that
# should be filtered out
@{$tree->{Kids}} = grep {
filterTree($_, $negativeFilters, $positiveFilters)
} @{$tree->{Kids}};
# Return true so that the calling instance will preserve this item in
# the output tree
return 1;
}
# Test whether two sets (arrays) intersect
sub intersect
{
my $set1 = shift;
my $set2 = shift;
my %set1 = map { $_ => 1 } @$set1;
foreach (@$set2)
{
return 1 if exists $set1{$_};
}
return 0;
}
sub printTree
{
my $tree = shift or die;
die unless ref $tree;
my $tagName = ref $tree;
$tagName =~ s{^main::}{};
if ($tagName eq "Characters")
{
print $tree->{Text};
return;
}
print "<$tagName";
foreach my $attr (
sort {
my $order = "unofficial name long-name tech_domain level span schema levels filter introduced deprecated purpose class plugin origin-model bldFile mrp version priority";
my $ixA = 1 + index $order, $a or die $a;
my $ixB = 1 + index $order, $b or die $b;
$ixA - $ixB;
}
grep {
! ref $tree->{$_}
}
keys %$tree)
{
print " $attr=\"$tree->{$attr}\"";
}
my $children = $tree->{Kids};
if (scalar @$children)
{
print ">";
foreach my $child (@$children)
{
printTree($child);
}
print "</$tagName";
}
else
{
print "/"
}
print ">";
}