#!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 ">";

}