1 #!perl -w

     2 

     3 use strict;

     4 

     5 use XML::Parser;

     6 

     7 my $sysModel = shift or die "First arg must be system model xml file";

     8 my @filters = @ARGV or die "Subsequent arg(s) must be filter(s) to apply";

     9 

    10 # Sort out the positive and negative filters specified

    11 my @negativeFilters;

    12 my @positiveFilters;

    13 foreach my $filter (@filters)

    14 {

    15 	if ($filter =~ m{^!(.*)})

    16 	{

    17 		push @negativeFilters, $1;

    18 	}

    19 	else

    20 	{

    21 		push @positiveFilters, $filter;

    22 	}

    23 }

    24 

    25 # Read input tree

    26 my $parser = new XML::Parser(Style => "Objects") or die;

    27 my $sysTree = eval { $parser->parsefile($sysModel) } or die "Failed to parse $sysModel : $@";

    28 

    29 # Apply filter

    30 filterTree($sysTree->[0], \@negativeFilters, \@positiveFilters);

    31 

    32 # Output total tree

    33 print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";

    34 printTree($sysTree->[0]);

    35 print "\n";

    36 

    37 exit;

    38 

    39 sub filterTree

    40 {

    41 	my $tree = shift;

    42 	my $negativeFilters = shift;

    43 	my $positiveFilters = shift;

    44 

    45 	if (exists $tree->{filter})

    46 	{

    47 		# Work out how this item in the tree is tagged for filtering

    48 		my $itemTags = [split ",", $tree->{filter}];

    49 		my @negativeTags;

    50 		my @positiveTags;

    51 		foreach my $tag (@$itemTags)

    52 		{

    53 			if ($tag =~ m{^!(.*)})

    54 			{

    55 				push @negativeTags, $1;

    56 			}

    57 			else

    58 			{

    59 				push @positiveTags, $tag;

    60 			}

    61 		}

    62 

    63 		# Test whether this item should be removed

    64 		if (intersect(\@positiveTags, $negativeFilters) ||

    65 		    intersect(\@negativeTags, $positiveFilters) )

    66 		{

    67 			# It should!

    68 			# Return false, and the removal will be executed by the

    69 			# calling instance

    70 			# (No need to examine children)

    71 			return 0;

    72 		}

    73 

    74 		# Tidy up the filter attribute

    75 		# Remove tags from this item that have been "used up"

    76 		# Remove the filter attribute entirely if they have all been

    77 		# used up

    78 		my %filterLookup = map { $_ => 1 } (@$negativeFilters, @$positiveFilters);

    79 		@$itemTags = grep { !exists $filterLookup{$_} } @$itemTags;

    80 		if (scalar @$itemTags)

    81 		{

    82 			$tree->{filter} = join ",", @$itemTags;

    83 		}

    84 		else

    85 		{

    86 			delete $tree->{filter};

    87 		}

    88 	}

    89 

    90 	# Now iterate through the children of this item and remove any that

    91 	# should be filtered out

    92 	@{$tree->{Kids}} = grep {

    93 		filterTree($_, $negativeFilters, $positiveFilters)

    94 	} @{$tree->{Kids}};

    95 

    96 	# Return true so that the calling instance will preserve this item in

    97 	# the output tree

    98 	return 1;

    99 }

   100 

   101 # Test whether two sets (arrays) intersect

   102 sub intersect

   103 {

   104 	my $set1 = shift;

   105 	my $set2 = shift;

   106 

   107 	my %set1 = map { $_ => 1 } @$set1;

   108 	foreach (@$set2)

   109 	{

   110 		return 1 if exists $set1{$_};

   111 	}

   112 	return 0;

   113 }

   114 

   115 sub printTree

   116 {

   117 	my $tree = shift or die;

   118 	die unless ref $tree;

   119 

   120 	my $tagName = ref $tree;

   121 	$tagName =~ s{^main::}{};

   122 	if ($tagName eq "Characters")

   123 	{

   124 		print $tree->{Text};

   125 		return;

   126 	}

   127 	

   128 	print "<$tagName";

   129 

   130 	foreach my $attr (

   131 		sort {

   132 			my $order = "unofficial name long-name tech_domain level span schema levels filter introduced deprecated purpose class plugin origin-model bldFile mrp version priority";

   133 			my $ixA = 1 + index $order, $a or die $a;

   134 			my $ixB = 1 + index $order, $b or die $b;

   135 			$ixA - $ixB;

   136 		}

   137 		grep {

   138 			! ref $tree->{$_}

   139 		}

   140 		keys %$tree)

   141 	{

   142 		print " $attr=\"$tree->{$attr}\"";

   143 	}

   144 

   145 	my $children = $tree->{Kids};

   146 	if (scalar @$children)

   147 	{

   148 		print ">";

   149 		foreach my $child (@$children)

   150 		{

   151 			printTree($child);

   152 		}

   153 		print "</$tagName";

   154 	}

   155 	else

   156 	{

   157 		print "/"

   158 	}

   159 

   160 	print ">";

   161 }

   162