# Copyright (c) 2010 Nokia Corporation and/or its subsidiary(-ies).
# All rights reserved.
# This component and the accompanying materials are made available
# under the terms of "Eclipse Public License v1.0"
# which accompanies this distribution, and is available
# at the URL "http://www.eclipse.org/legal/epl-v10.html".
#
# Initial Contributors:
# Nokia Corporation - initial contribution.
#
# Contributors:
#
# Description:
#  This will create a new root system definition file based on the provided template
#!/usr/bin/perl

use strict;


use FindBin;		# for FindBin::Bin
use lib $FindBin::Bin;
use lib "$FindBin::Bin/lib";

use Cwd;
use Cwd 'abs_path';
use Getopt::Long;
use File::Basename;
use File::Spec;
use XML::DOM;

my $output;
my $path;
my $defaultns = 'http://www.symbian.org/system-definition';	# needed if no DTD
my @searchpaths;
my @searchroots;
my %additional;
my %add;
my %newNs;
my $warning = "Error";
my $placeholders=0;
my $sysmodelname;

my @tdOrder =("hb","se", "lo","dc", "vc" , "pr", "dm", "de", "mm", "ma" , "ui",  "rt", "to" );

sub help
	{
	my $name= $0; $name=~s,^.*[\\/],,;
	print STDERR "usage: $name  [options...] template\n\nThis will create a new root system definition file based on the provided template by globbing for pkgdefs in the filesystem. Any found pkgdef files are added to the end of their layer or at the end of their tech domain section, if one is defined",
	"\nvalid options are:\n",
		"  -path [dir]\tspecifies the full system-model path to the file which is being processed. By default this is  \"/os/deviceplatformrelease/foundation_system/system_model/system_definition.xml\"\n",
		"\t\tThis is only needed when creating a stand-alone sysdef as the output",

		"  -output [file]\tspecifies the file to save the output to. If set, all hrefs will set to be relative to this location. If not specified all href will be absolute file URIs and this will write to stdout\n\n",

		"  -w [Note|Warning|Error]\tspecifies prefix text for any notifications. Defautls to Error\n\n",
		"  -root [dir]\tspecifies the root directory of the filesystem. All globbing will be done relative to this path\n\n",

		"  -glob [wildcard path]\tThe wildcard search to look for pkgdef files. eg  \"\\*\\*\\package_definition.xml\". Can specify any number of these.\n",
		"  -placeholders [bool]\tif set, all packages not found in the template will be left in as empty placeholders\n";
		"  -name [text]\tthe name in <systemModel> to use for the generated root sysdef. If not present, this will use the name from the templat\n";
	exit(1);
	}

GetOptions
	(
	 'path=s' => \$path,
	 'name=s' => \$sysmodelname,
	'output=s' => \$output,
	'w=s' => \$warning,
	'root=s' => \@searchroots,
	'glob=s' => \@searchpaths,
	'placeholders=s' => \$placeholders
	);


 if($path eq '') {$path = '/os/deviceplatformrelease/foundation_system/system_model/system_definition.xml'}

if(!($warning =~/^(Note|Warning|Error)$/)) {$warning="Error"}

# path is the system model path of the processed sysdef file. This is only used when creating a stand-alone sysdef as the output
# output specifies the file this is saved in. If specified, all (relative) paths will be modified to be relative to it. If not, all paths will be absolute
# w is the warning level: Note, Warning or Error.
# root = -root g:\sf
# glob = -glob "\*\*\package_definition.xml"

#Example command lines:
#rootsysdef.pl -root F:\sftest\mcl\sf  -glob "\*\*\package_definition.xml"  -output  F:\sftest\mcl\build\system_definition.sf.xml   F:\sftest\mcl\sf\os\deviceplatformrelease\foundation_system\system_model\system_definition.xml
#rootsysdef.pl -root F:\sftest\mcl\sf  -glob "\*\*\*\*\package_definition.xml"  -output  F:\sftest\mcl\build\system_definition.mine.xml   F:\sftest\mcl\sf\os\deviceplatformrelease\foundation_system\system_model\system_definition.xml
if(!scalar @ARGV && !scalar @searchpaths) {&help()};


my %replacefile;
my $dir;
foreach(@searchpaths)
	{
	my $ndir = shift(@searchroots);
	if($ndir ne '') {$dir=$ndir}
	foreach my $file (glob "$dir$_")
		{
		my $map =substr($file,length($dir));
		$map=~tr/\\/\//;
		$additional{$map}=$file;
		$replacefile{&abspath($file)}=$map;
		$add{&abspath($file)}=1;
		}
	}

my $parser = new XML::DOM::Parser;
my $sysdef;
my %rootmap;
my  $sysdefdoc;
if(scalar @ARGV)
	{
	$sysdef = &abspath(shift);	# resolve the location of the root sysdef

	# rootmap is a mapping from the filesystem to the paths in the doc
	%rootmap = &rootMap($path,$sysdef);	

	$sysdefdoc = $parser->parsefile ($sysdef);
	}
else 
	{
	$sysdefdoc = $parser->parse('<SystemDefinition schema="3.0.1"><systemModel name="System Model"/></SystemDefinition>');
	}

my %nsmap;
my %urimap;

my $mapmeta;
my $modpath;
if($output eq '')
	{ #figure out mapping path
	my @fspath = split(/[\\\/]/,$sysdef);
	my @smpath = split(/[\\\/]/,$path);
	while(lc($smpath[$#smpath]) eq lc($fspath[$#fspath] )) {
		pop(@smpath);
		pop(@fspath);
	}
	my $mappath = join('/',@fspath);
	my $topath = join('/',@smpath);
	$mappath=~s,^/?,file:///,;
	$mapmeta = $sysdefdoc->createElement('meta');
	$mapmeta->setAttribute('rel','link-mapping');
	my $node = $sysdefdoc->createElement('map-prefix');
	$node->setAttribute('link',$mappath);
	$topath ne '' && $node->setAttribute('to',$topath);
	$mapmeta->appendChild($node);
	}
else
	{
	$modpath = &relativeTo(&abspath($output), $sysdef);
	}


# find all the namespaces used in all the fragments and use that 
# to set the namespaces in the root element of the created doc
#   should be able to optimise by only parsing each doc once and 
#	maybe skipping the contends of <meta>
my @nslist = &namespaces($sysdef,$sysdefdoc->getDocumentElement());

my %replacing;
my %newContainer;
my %foundDescendants;

foreach(keys %add)
	{

	my   $fragment;
	
	eval {
		$fragment  = $parser->parsefile ($_);
	};
	$fragment || die "could not parse $_";
	my $fdoc = $fragment->getDocumentElement();
	my $topmost =&firstElement($fdoc);
	if(!$topmost) {
		print STDERR "$warning: $_ has no content. Skipping\n";
		next;
	}
	my $type = $topmost->getTagName;
	my $id = $topmost->getAttribute('id');
	my ($localid,$ns) = &idns($topmost,$id);	
	my @path = &guessIdInPath($localid,$_);
	if($type eq 'layer') {@path=@path[0]}
	elsif($type eq 'package')  {@path=@path[0..1]}
	elsif($type eq 'collection')  {@path=@path[0..2]}
	elsif($type eq 'component')  {@path=@path[0..3]}
	@path = reverse(@path);
	$add{$_}=join('/',@path)." $localid $ns";
	$replacing{$type}->{"$localid $ns"} = $_;
	# keys with a space are namespaced and fully identified, and contain the filename as the content.
	# keys with no space have unknown namespace and contain a hash of the content
	$newContainer{join('/',@path[0..$#path-1])}->{"$localid $ns"} = $_;
	for(my $i=-1;$i<$#path-1;$i++)
		{
		$foundDescendants{$path[$i+1]}=1;
		$newContainer{join('/',@path[0..$i])}->{$path[$i+1]}=1;
		}
	}


while(@nslist)
	{
	my $uri = shift(@nslist);
	my $prefix =shift(@nslist);
	if($prefix eq 'id namespace'){$prefix=''}
	if(defined $urimap{$uri}) {next} # already done this uri
	$urimap{$uri} = $prefix;
	if($nsmap{$prefix})
		{ # need a new prefix for this, guess from the URI (for readability)
		if($uri=~/http:\/\/(www\.)?([^.\/]+)\./) {$prefix = $2}
		my $i=0;
		while($nsmap{$prefix})
			{ # still no prefix, just make up 
			$prefix="ns$i";
			$i++;
			# next line not really necessary, but it's a good safety to stop infinite loops
			$i eq 1000 && die "ERROR: cannot create namespace prefix for $uri";
			}
		}
	$nsmap{$prefix}=$uri;
	}

my $docroot =  $sysdefdoc->getDocumentElement;

my $ns = $docroot->getAttribute('id-namespace');
if(!$ns && $nsmap{''})
	{
	$docroot->setAttribute('id-namespace',$nsmap{''});
	}
while(my($pre,$uri) = each(%nsmap))
	{
	$pre ne '' || next ;
	$docroot->setAttribute("xmlns:$pre",$uri);
	}

&walk($sysdef,$docroot);

if($output eq '') 
	{
	print $sysdefdoc->toString;
	}
else
	{
	$sysdefdoc->printToFile($output);
	}

 
sub abspath
	{
	# normalize the path into an absolute one
	my  ($name,$path) = fileparse($_[0]);
	if($path eq '' && $name eq '') {return};
	$path=~tr,\\,/,;
	if ($path eq './')
		{
		return abs_path('.').$name;
		}
	if( -e $path)
		{
		return abs_path($path)."/$name";
		}
	my @dir = split('/',$_[0]);
	my @new;
	foreach my $d (@dir)
		{
		if($d eq '.') {next}
		if($d eq '..')
			{
			pop(@new);
			next;
			}
		push(@new,$d)
		}
	return join('/',@new);
	}


 
sub normpath
	{
	# normalize the path 
	my @norm;
	foreach my $dir(split(/[\\\/]/,shift)) {
		if($dir eq '.') {next}
		if($dir eq '..')
			{
			if($#norm == -1 || $norm[$#norm] eq '..')
				{ # keep  as is
				push(@norm,$dir);
				}
			elsif($#norm == 0 && $norm[0] eq '')
				{  # path begins with /, interpret /.. as just / -- ie toss out
				next
				}
			else
				{
				pop(@norm);
				}
			}
		else
			{
			push(@norm,$dir);
			}
	}

	return join('/',@norm)
	}


sub rootMap {
	my @pathdirs = split(/\//,$_[0]);
	my @rootdirs = split(/\//,$_[1]);

	while(lc($rootdirs[$#rootdirs])  eq lc($pathdirs[$#pathdirs])  )
		{
		pop(@rootdirs);
		pop(@pathdirs);
		}
	return (join('/',@rootdirs)  => join('/',@pathdirs) );
	}

sub replacedBy
	{ # can only check once. Destroys data
	my $node = shift;
	my $fullid= join(' ',&idns($node));
	my $type =  $node->getTagName;
	my $repl = $replacing{$type}->{$fullid};
	delete $replacing{$type}->{$fullid};
	return $repl;
	}

sub walk
	{
	#' walk through the doc, resolving all links
	my $file = shift;
	my $node = shift;
	my $type = $node->getNodeType;
	if($type!=1) {return}
	my $tag = $node->getTagName;
	if($tag=~/^(layer|package|collection|component)$/ )
		{
		if($file eq $sysdef)
			{
			&fixIDs($node);	# normalise all IDs in the root doc.
			}
		my $override = &replacedBy($node);
		my $link= $node->getAttribute('href');
		if($override eq '' )
			{
			my ($id,$ns)=&idns($node);
			if($foundDescendants{$id})
				{ # keep this node, it'll be populated by what we found
				if($link)
					{
					$node->removeAttribute('href');
					}
				}
			elsif($link || !$placeholders)
				{ # not going to be used, remove
				$node->getParentNode->removeChild($node) ; # not present, remove
				return;
				}
			}
		else
			{	
			my $href = $node->getAttribute('href');	
			my $ppath =  join('/',&parentPath($node->getParentNode));
			delete $newContainer{$ppath}->{join(' ',&idns($node))};		# remove this from list of things which need to be added
			if(&resolvePath($file,$href) ne $override)
				{ # file has changed, update
				print STDERR "$warning: Replacing $tag ",$node->getAttribute('id')," with $override\n";
				&setHref($node,$override);
				return;
				}
			}
		my @curpath = &parentPath($node);
		my $curitem = $curpath[$#curpath];
		my $curp = join('/',@curpath[0..$#curpath-1]);
		delete $newContainer{$curp}->{$curitem};

		if($link)
			{
			foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children
			&fixHref($node,$file);
			return;
			}
		}
	elsif($tag eq 'systemModel' && $mapmeta)
		{ # need absolute paths for all links
		$node->insertBefore ($mapmeta,$node->getFirstChild);
		$sysmodelname eq '' || $node->setAttribute('name',$sysmodelname);
		}
	elsif($tag=~/^(SystemDefinition|systemModel)$/ )
		{
		($sysmodelname ne '' && $tag eq 'systemModel') && $node->setAttribute('name',$sysmodelname);
		}
	elsif($tag eq 'unit')
		{
		foreach my $atr ('bldFile','mrp','base','proFile')
			{
			my $link= $node->getAttribute($atr);
			if($link && !($link=~/^\//))
				{
				if($mapmeta)
					{ # use absolute paths
					$link= &abspath(File::Basename::dirname($file)."/$link");
					foreach my $a (keys %rootmap)
						{
						$link=~s,^$a,$rootmap{$a},ie;
						}
					}
				else
					{ # modified relative path 
					$link = &normpath($modpath.$link);
					}
				$node->setAttribute($atr,$link);
				}
			}
		}
	elsif($tag eq 'meta' && $node->getAttribute('href'))
		{
		&fixHref($node,$file);
		foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children
		&processMeta($node);
		next;
		}
	else {return}
	foreach my $item (@{$node->getChildNodes})
		{
		#print $item->getNodeType,"\n";
		&walk($file,$item);
		}
	if($tag=~/^(systemModel|layer|package|collection|component)$/ )
		{ # check for appending
		my $ppath =  join('/',&parentPath($node));
		if($newContainer{$ppath}) {
			foreach my $item (sort keys %{$newContainer{$ppath}})
				{
				&appendNewItem($node,$item,$newContainer{$ppath}->{$item});
				}
			}
		}
	}


sub getNs
	{
	# find the ns URI that applies to the specified prefix.
	my $node = shift;
	my $pre = shift;
	my $uri = $node->getAttribute("xmlns:$pre");
	if($uri) {return $uri}
	my $parent = $node->getParentNode;
	if($parent && $parent->getNodeType==1)
		{
		return getNs($parent,$pre);
		}
	}


sub fixIDs
	{
	# translate the ID to use the root doc's namespaces 
	my $node = shift;
	foreach my $id ('id','before')
		{
		&fixID($node,$id);
		}
}

sub idns
	{ # return the namespace of an ID
	my $node = shift;
	my $id = shift;
	if($id eq '' ) {$id = $node->getAttribute('id'); }
	if($id=~s/^(.*)://)
		{ # it's got a ns, find out what it is
		my $pre = $1;
		return ($id,&getNs($node,$pre));
		}
		return ($id,$node->getOwnerDocument->getDocumentElement->getAttribute("id-namespace") ||	$defaultns);
	}

sub fixID
	{
	# translate the ID to use the root doc's namespaces 
	my $node = shift;
	my $attr = shift || 'id';
	my $id = $node->getAttribute($attr);
	if($id eq '') {return}
	my $ns;
	if($id=~s/^(.*)://)
		{ # it's got a ns, find out what it is
		my $pre = $1;
		$ns=&getNs($node,$pre);
		}
	else
		{
		$ns = $node->getOwnerDocument->getDocumentElement->getAttribute("id-namespace") ||
			$defaultns;
		}
	$ns = $urimap{$ns};
	$id = ($ns eq '') ? $id : "$ns:$id";
	return $node->setAttribute($attr,$id);
}

sub firstElement {
	# return the first element in this node
	my $node = shift;
	foreach my $item (@{$node->getChildNodes}) {
		if($item->getNodeType==1) {return $item}
	}
}


sub atts {
	# return a hash of all attribtues defined for this element
	my $node = shift;
	my %at = $node->getAttributes;
	my %list;
	foreach my $a (keys %{$node->getAttributes}) 
		{
		if($a ne '')
			{
			$list{$a} = $node->getAttribute ($a);
			}
		}
	return %list;
}


sub ns 
	{
	# return a hash of ns prefix and uri -- the xmlns: part is stripped off
	my $node = shift;
	my %list;
	foreach my $a (keys %{$node->getAttributes}) 
		{
		my $pre = $a;
		if($pre=~s/^xmlns://)
			{
			$list{$pre} = $node->getAttribute ($a);
			}
		}
	return %list;
	}



sub namespaces
	{
	# return a list of namespace URI / prefix pairs, in the order they're defined
	# these need to be used to define namespaces in the root element
	my $file = shift;
	my $node = shift;
	my $type = $node->getNodeType;
	if($type!=1) {return}
	my $tag = $node->getTagName;
	my @res;
	my %nslist = &ns($node);
	while(my($pre,$uri)=each(%nslist))
		{ # push all namespaces defined here onto the list
		push(@res,$uri,$pre);
		}
	if($tag=~/^(layer|package|collection|component)$/ )
		{ # these have the potential of linking, so check for that
		}
	elsif($tag eq 'SystemDefinition' )
		{
		my $default = $node->getAttribute('id-namespace');
		if($default)
			{# mangle with a space so it's clear it's not a qname
			push(@res,$default,'id namespace');
			}
		}
	foreach my $item (@{$node->getChildNodes})
		{
		push(@res,&namespaces($file,$item));
		}
	return @res;
	}

sub  processMeta
	{
	my $metanode = shift;
	# do nothing. Not supported yet
	}

sub guessIdInPath
	{
	my $id = shift;
	my @path = reverse(split(/\//,$_[0]));
	while(@path)
		{
		my $dir = shift(@path);
		if($dir eq $id)
			{
			return ($id,@path);
			}
		}
	print STDERR "$warning: Non-standard ID $id in $_[0]\n";
	@path = reverse(split(/\//,$_[0]));
	if($path[0] eq 'package_definition.xml')
		{
		return @path[1..$#path];
		}
	}


sub parentPath
	{
	my $node=shift;
	my @path;
	while($node)
		{
		if(!$node) {return @path}
		my $id=$node->getAttribute('id');
		if($id eq '') {return @path}
		$id=~s/^.*://;
		@path = ($id,@path);
		$node = $node->getParentNode();
		}
	return @path;
	}

sub childTag
	{
	my $tag = shift;
	if($tag eq 'systemModel') {return 'layer'}
	if($tag eq 'layer') {return 'package'}
	if($tag eq 'package') {return 'collection'}
	if($tag eq 'collection') {return 'component'}
	die "ERROR: no child for $tag";
	}

sub appendNewItem
	{
	my $node = shift;
	my $doc = $node->getOwnerDocument;
	my $id = shift;
	if($id eq '') {return}
	my $fullid=$id;
	my $contents = shift;
	my $tag = &childTag($node->getTagName());
	my $new = $doc->createElement($tag);
	if($id=~/^(.*) (.*)/)
		{
		$id=$1;
		$ns = getNamespacePrefix($node,$2);
		if($ns ne '') {$id="$ns:$id"}
		}
	else
		{
		$contents = '';
		}
	$new->setAttribute('id',$id);		# default namespace
	$node->appendChild($new);
	my $ppath =  join('/',&parentPath($new));
	if($contents eq '')
		{ # look for additions
		print STDERR "$warning: Adding new $tag: $id\n";
		if($newContainer{$ppath}) {
			foreach my $item (sort keys %{$newContainer{$ppath}})
				{
				&appendNewItem($new,$item,$newContainer{$ppath}->{$item});
				}
			}
		}
	else
		{ # this one item is defined in the specified file
		if($tag eq 'package') 
			{ #include some package data in root
			my $fragment = $parser->parsefile ($contents);
			my $fdoc = $fragment->getDocumentElement();
			my $topmost =&firstElement($fdoc);
			my %at = &atts($topmost);
			foreach my $arg ('tech-domain','level','span')
				{
				if($at{$arg}) {	$new->setAttribute($arg,$at{$arg})}
				}
			if($at{'tech-domain'}) {&positionByTechDomain($new)}
			}
		&setHref($new,$contents);
		print STDERR "$warning: Adding found $tag $id from $contents\n";
		delete $replacing{$tag}->{$fullid};
		}
	# newline after each new tag so output's not ugly
	if($new->getNextSibling)
		{
		$node->insertBefore($doc->createTextNode ("\n"),$new->getNextSibling);
		}
	else
		{
		$node->appendChild($doc->createTextNode ("\n"));
		}
	delete $newContainer{$ppath};
	}


sub getNamespacePrefix
	{
	my $node = shift;
	my $ns = shift;
	my $root = $node->getOwnerDocument->getDocumentElement;
	my $idns = $root->getAttribute("id-namespace");
	if($idns && $idns eq $ns) {return}
	if(!$idns && $defaultns eq $ns) {return}
	foreach my $a (keys %{$root->getAttributes}) 
		{
		my $pre = $a;
		if($pre=~s/^xmlns://)
			{
			if($root->getAttribute ($a) eq $ns)  {return $pre}
			}
		}
	die "ERROR: no namespace prefix defined for $ns";
	}


sub resolvePath
	{
	# return full path to 2nd arg relative to first (path or absolute URI)
	my $base = shift;
	my $path = shift;
	if($path=~m,^/,) {return $path } # path is absolute, but has no drive. Let OS deal with it.
	if($path=~s,^file:///([a-zA-Z]:/),$1,) {return $path } # file URI with drive letter
	if($path=~m,^file://,) {return $path } # file URI with no drive letter (unit-style). Just pass on as is with leading / and let OS deal with it
	if($path=~m,^[a-z0-9][a-z0-9]+:,i) {return $path } # absolute URI -- no idea how to handle, so just return
	return &abspath(File::Basename::dirname($base)."/$path");
	}


sub fixHref {
	my $node = shift;
	my $base = shift;
	my $link= $node->getAttribute('href');
	if($link=~/^(ftp|http)s:\/\//) {return} # remote link, do nothing
	my $path = &resolvePath($base,$link);
	if(!-e $path) 
		{ # no such file, delete
		my $tag  =$node->getTagName;
		my $id = $node->getAttribute('id');
		print STDERR "$warning: $tag $id not found at $link\n";	
		$node->getParentNode->removeChild($node);
		return;
		}
	foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children
	if($output eq '')
		{
		$path=~s,^/?,file:///,;
		$node->setAttribute('href',$path);	# replace with absolute URI
		return;
		}
	$node->setAttribute('href',&normpath($modpath.$link));	# make relative path to output file
	}


sub setHref {
	my $node = shift;
	my $file = shift;
	if($output eq '') 
		{
		$path = &abspath($file);
		$path=~s,^/?,file:///,;
		$node->setAttribute('href',$path);	# replace with absolute URI
		}
	else 
		{
		$node->setAttribute('href',&relativeTo(&abspath($output),$file,'file'));
		}
	while(my $child =  $node->getFirstChild ) {$node->removeChild($child)}
}


sub relativeTo {
	if($_[0] eq '') {return &abspath($_[1])}
	my @outfile = split(/[\\\/]/,lc(shift));
	my @infile  = split(/[\\\/]/,lc(shift));
	my $asdir = shift ne 'file';
	while($outfile[0] eq $infile[0])
		{
		shift(@outfile);
		shift(@infile);
		}
	$modpath = '../' x (scalar(@outfile) - 1);
	if($asdir) {
		if(scalar @infile > 1)  {$modpath .=  join('/',@infile[0..$#infile - 1]).'/'}
	} else   {$modpath .=  join('/',@infile)}
	return $modpath;
}

sub positionByTechDomain 
	{
	my $node=shift;
	my $td = $node->getAttribute('tech-domain');
	my %before;
	foreach my $t (@tdOrder)
		{
		$before{$t}=1;
		if($t eq $td) {last}
		}
	my $prev = $node->getPreviousSibling;
	foreach my $child (reverse @{$node->getParentNode->getChildNodes})
		{
		if($child->getNodeType==1 && $child->getTagName eq 'package' && $child!=$node)
			{
			if($before{$child->getAttribute('tech-domain')})
				{
				my $next = $child->getNextSibling;
				while($next &&  $next->getNodeType!=1) {$next = $next->getNextSibling}
				if($next) {
					$node->getParentNode->insertBefore ($node,$next);
				}
				last;
				}
			}
		}
	}
