--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/metatools/sysdeftools/rootsysdef.pl Wed Jul 28 13:20:46 2010 +0100
@@ -0,0 +1,809 @@
+# 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 = $parser->parsefile ($_);
+ 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( -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')
+ {
+ &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;
+ }
+ }
+ }
+ }