#!perl -w+ −
+ −
use strict;+ −
+ −
use FindBin;+ −
use lib "$FindBin::Bin/lib";+ −
+ −
use XML::Parser;+ −
use Text::CSV;+ −
+ −
my $sourcesCSV = shift or die "First arg must be source csv file";+ −
my $backupBaseDir = shift or die "Second arg must be path to tree of package_definitions to use if not found in the source packages";+ −
shift and die "No more than two arguments please";+ −
+ −
# Load CSV+ −
open my $csvText, "<", $sourcesCSV or die;+ −
my $csv = Text::CSV->new();+ −
my @keys;+ −
my @packages;+ −
while (my $line = <$csvText>)+ −
{+ −
chomp $line;+ −
next unless $line;+ −
unless ($csv->parse($line))+ −
{+ −
my $err = $csv->error_input();+ −
die "Failed to parse line '$line': $err";+ −
}+ −
+ −
if (! @keys)+ −
{+ −
# First line - note the column names+ −
@keys = $csv->fields();+ −
}+ −
else+ −
{+ −
# Already got the keys, so get the data+ −
my %package;+ −
# Read into a hash slice+ −
@package{@keys} = $csv->fields();+ −
push @packages, \%package;+ −
}+ −
}+ −
close $csvText;+ −
+ −
my $parser = new XML::Parser(Style => "Objects") or die;+ −
my $outTree;+ −
+ −
# For each package in CSV...+ −
foreach my $package (@packages)+ −
{+ −
# If the sources.csv does not include a sys def for this package, it doesn't get built+ −
next unless $package->{sysdef};+ −
# If it's in the "backup" location, use that one (ie our copy overrides the package's own copy)+ −
my $pkgDef = "$package->{dst}/$package->{sysdef}";+ −
$pkgDef =~ s{^/sf/}{};+ −
$pkgDef =~ s{/[^/]*$}{};+ −
$pkgDef = "$backupBaseDir/$pkgDef/package_definition.xml";+ −
if (!-f $pkgDef)+ −
{+ −
# Not there, so look for the pkg defn in the root of the package tree+ −
warn "Warning: Package $package->{dst} does not appear on the local system\n" unless -d $package->{dst};+ −
$pkgDef = "$package->{dst}/$package->{sysdef}";+ −
}+ −
die "Unable to locate any package_definition at all for $package->{dst}" unless -f $pkgDef;+ −
+ −
warn "Including $pkgDef for $package->{dst}\n";+ −
my $pkgTree = eval { $parser->parsefile($pkgDef) } or die "Failed to parse $pkgDef : $@";+ −
if (!$outTree)+ −
{+ −
# The first file is taken verbatim+ −
$outTree = $pkgTree;+ −
}+ −
else+ −
{+ −
# Merge into output Tree+ −
mergeTrees($outTree->[0], $pkgTree->[0]);+ −
}+ −
}+ −
+ −
# Output total tree+ −
print "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n";+ −
printTree($outTree->[0]);+ −
print "\n";+ −
+ −
exit;+ −
+ −
sub mergeTrees+ −
{+ −
my $baseTree = shift or die;+ −
my $extrasTree = shift or die;+ −
+ −
die ("Package Definitions do not match: ".(ref $baseTree)." vs ".(ref $extrasTree)) unless ref $baseTree eq ref $extrasTree;+ −
return if ref $baseTree eq "main::Characters";+ −
+ −
foreach my $extraChild (@{$extrasTree->{Kids}})+ −
{+ −
# Work out whether this child should be merged with a namesake, or appended+ −
my $mergeIt = undef;+ −
+ −
my $extraChildTag = ref $extraChild;+ −
$extraChildTag =~ s{^main::}{};+ −
+ −
if ($extraChildTag =~ m{^(SystemDefinition|systemModel)$})+ −
{+ −
# Should be merged if there's already one there+ −
# Look for a namesake in the base+ −
$mergeIt = matchTag($baseTree->{Kids}, $extraChild, undef);+ −
}+ −
elsif ($extraChildTag =~ m{layer|block|package|collection|component})+ −
{+ −
# Should be merged if there is another tag with the same "name" attribute+ −
# Look for a namesake in the base+ −
$mergeIt = matchTag($baseTree->{Kids}, $extraChild, "name");+ −
}+ −
+ −
if ($mergeIt)+ −
{+ −
# Merge children+ −
mergeTrees($mergeIt, $extraChild);+ −
}+ −
else+ −
{+ −
# Add this child+ −
push @{$baseTree->{Kids}}, $extraChild;+ −
}+ −
}+ −
}+ −
+ −
sub matchTag+ −
{+ −
my $peers = shift;+ −
my $outsider = shift;+ −
my $attr = shift;+ −
+ −
foreach my $peer (@$peers)+ −
{+ −
if (ref $peer eq ref $outsider && (!defined $attr || $peer->{$attr} eq $outsider->{$attr}))+ −
{+ −
return $peer;+ −
}+ −
}+ −
+ −
return undef;+ −
}+ −
+ −
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 = "name long-name tech_domain level span schema levels filter introduced deprecated purpose class plugin origin-model bldFile mrp version priority";+ −
my $ixA = index $order, $a;+ −
my $ixB = index $order, $b;+ −
die "$a $b" if $ixA + $ixB == -2;+ −
$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 ">";+ −
}+ −
+ −