|
1 # Copyright (c) 2010 Nokia Corporation and/or its subsidiary(-ies). |
|
2 # All rights reserved. |
|
3 # This component and the accompanying materials are made available |
|
4 # under the terms of "Eclipse Public License v1.0" |
|
5 # which accompanies this distribution, and is available |
|
6 # at the URL "http://www.eclipse.org/legal/epl-v10.html". |
|
7 # |
|
8 # Initial Contributors: |
|
9 # Nokia Corporation - initial contribution. |
|
10 # |
|
11 # Contributors: |
|
12 # |
|
13 # Description: |
|
14 # This will create a new root system definition file based on the provided template |
|
15 #!/usr/bin/perl |
|
16 |
|
17 use strict; |
|
18 |
|
19 |
|
20 use FindBin; # for FindBin::Bin |
|
21 use lib $FindBin::Bin; |
|
22 use lib "$FindBin::Bin/lib"; |
|
23 |
|
24 use Cwd; |
|
25 use Cwd 'abs_path'; |
|
26 use Getopt::Long; |
|
27 use File::Basename; |
|
28 use File::Spec; |
|
29 use XML::DOM; |
|
30 |
|
31 my $output; |
|
32 my $path; |
|
33 my $defaultns = 'http://www.symbian.org/system-definition'; # needed if no DTD |
|
34 my @searchpaths; |
|
35 my @searchroots; |
|
36 my %additional; |
|
37 my %add; |
|
38 my %newNs; |
|
39 my $warning = "Error"; |
|
40 my $placeholders=0; |
|
41 my $sysmodelname; |
|
42 |
|
43 my @tdOrder =("hb","se", "lo","dc", "vc" , "pr", "dm", "de", "mm", "ma" , "ui", "rt", "to" ); |
|
44 |
|
45 sub help |
|
46 { |
|
47 my $name= $0; $name=~s,^.*[\\/],,; |
|
48 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", |
|
49 "\nvalid options are:\n", |
|
50 " -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", |
|
51 "\t\tThis is only needed when creating a stand-alone sysdef as the output", |
|
52 |
|
53 " -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", |
|
54 |
|
55 " -w [Note|Warning|Error]\tspecifies prefix text for any notifications. Defautls to Error\n\n", |
|
56 " -root [dir]\tspecifies the root directory of the filesystem. All globbing will be done relative to this path\n\n", |
|
57 |
|
58 " -glob [wildcard path]\tThe wildcard search to look for pkgdef files. eg \"\\*\\*\package_definition.xml\". Can specify any number of these.\n", |
|
59 " -placeholders [bool]\tif set, all packages not found in the template will be left in as empty placeholders\n"; |
|
60 " -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"; |
|
61 exit(1); |
|
62 } |
|
63 |
|
64 GetOptions |
|
65 ( |
|
66 'path=s' => \$path, |
|
67 'name=s' => \$sysmodelname, |
|
68 'output=s' => \$output, |
|
69 'w=s' => \$warning, |
|
70 'root=s' => \@searchroots, |
|
71 'glob=s' => \@searchpaths, |
|
72 'placeholders=s' => \$placeholders |
|
73 ); |
|
74 |
|
75 |
|
76 if($path eq '') {$path = '/os/deviceplatformrelease/foundation_system/system_model/system_definition.xml'} |
|
77 |
|
78 if(!($warning =~/^(Note|Warning|Error)$/)) {$warning="Error"} |
|
79 |
|
80 # path is the system model path of the processed sysdef file. This is only used when creating a stand-alone sysdef as the output |
|
81 # 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 |
|
82 # w is the warning level: Note, Warning or Error. |
|
83 # root = -root g:\sf |
|
84 # glob = -glob "\*\*\package_definition.xml" |
|
85 |
|
86 #Example command lines: |
|
87 #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 |
|
88 #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 |
|
89 if(!scalar @ARGV && !scalar @searchpaths) {&help()}; |
|
90 |
|
91 |
|
92 my %replacefile; |
|
93 my $dir; |
|
94 foreach(@searchpaths) |
|
95 { |
|
96 my $ndir = shift(@searchroots); |
|
97 if($ndir ne '') {$dir=$ndir} |
|
98 foreach my $file (glob "$dir$_") |
|
99 { |
|
100 my $map =substr($file,length($dir)); |
|
101 $map=~tr/\\/\//; |
|
102 $additional{$map}=$file; |
|
103 $replacefile{&abspath($file)}=$map; |
|
104 $add{&abspath($file)}=1; |
|
105 } |
|
106 } |
|
107 |
|
108 my $parser = new XML::DOM::Parser; |
|
109 my $sysdef; |
|
110 my %rootmap; |
|
111 my $sysdefdoc; |
|
112 if(scalar @ARGV) |
|
113 { |
|
114 $sysdef = &abspath(shift); # resolve the location of the root sysdef |
|
115 |
|
116 # rootmap is a mapping from the filesystem to the paths in the doc |
|
117 %rootmap = &rootMap($path,$sysdef); |
|
118 |
|
119 $sysdefdoc = $parser->parsefile ($sysdef); |
|
120 } |
|
121 else |
|
122 { |
|
123 $sysdefdoc = $parser->parse('<SystemDefinition schema="3.0.1"><systemModel name="System Model"/></SystemDefinition>'); |
|
124 } |
|
125 |
|
126 my %nsmap; |
|
127 my %urimap; |
|
128 |
|
129 my $mapmeta; |
|
130 my $modpath; |
|
131 if($output eq '') |
|
132 { #figure out mapping path |
|
133 my @fspath = split(/[\\\/]/,$sysdef); |
|
134 my @smpath = split(/[\\\/]/,$path); |
|
135 while(lc($smpath[$#smpath]) eq lc($fspath[$#fspath] )) { |
|
136 pop(@smpath); |
|
137 pop(@fspath); |
|
138 } |
|
139 my $mappath = join('/',@fspath); |
|
140 my $topath = join('/',@smpath); |
|
141 $mappath=~s,^/?,file:///,; |
|
142 $mapmeta = $sysdefdoc->createElement('meta'); |
|
143 $mapmeta->setAttribute('rel','link-mapping'); |
|
144 my $node = $sysdefdoc->createElement('map-prefix'); |
|
145 $node->setAttribute('link',$mappath); |
|
146 $topath ne '' && $node->setAttribute('to',$topath); |
|
147 $mapmeta->appendChild($node); |
|
148 } |
|
149 else |
|
150 { |
|
151 $modpath = &relativeTo(&abspath($output), $sysdef); |
|
152 } |
|
153 |
|
154 |
|
155 # find all the namespaces used in all the fragments and use that |
|
156 # to set the namespaces in the root element of the created doc |
|
157 # should be able to optimise by only parsing each doc once and |
|
158 # maybe skipping the contends of <meta> |
|
159 my @nslist = &namespaces($sysdef,$sysdefdoc->getDocumentElement()); |
|
160 |
|
161 my %replacing; |
|
162 my %newContainer; |
|
163 my %foundDescendants; |
|
164 |
|
165 foreach(keys %add) |
|
166 { |
|
167 my $fragment = $parser->parsefile ($_); |
|
168 my $fdoc = $fragment->getDocumentElement(); |
|
169 my $topmost =&firstElement($fdoc); |
|
170 if(!$topmost) { |
|
171 print STDERR "$warning: $_ has no content. Skipping\n"; |
|
172 next; |
|
173 } |
|
174 my $type = $topmost->getTagName; |
|
175 my $id = $topmost->getAttribute('id'); |
|
176 my ($localid,$ns) = &idns($topmost,$id); |
|
177 my @path = &guessIdInPath($localid,$_); |
|
178 if($type eq 'layer') {@path=@path[0]} |
|
179 elsif($type eq 'package') {@path=@path[0..1]} |
|
180 elsif($type eq 'collection') {@path=@path[0..2]} |
|
181 elsif($type eq 'component') {@path=@path[0..3]} |
|
182 @path = reverse(@path); |
|
183 $add{$_}=join('/',@path)." $localid $ns"; |
|
184 $replacing{$type}->{"$localid $ns"} = $_; |
|
185 # keys with a space are namespaced and fully identified, and contain the filename as the content. |
|
186 # keys with no space have unknown namespace and contain a hash of the content |
|
187 $newContainer{join('/',@path[0..$#path-1])}->{"$localid $ns"} = $_; |
|
188 for(my $i=-1;$i<$#path-1;$i++) |
|
189 { |
|
190 $foundDescendants{$path[$i+1]}=1; |
|
191 $newContainer{join('/',@path[0..$i])}->{$path[$i+1]}=1; |
|
192 } |
|
193 } |
|
194 |
|
195 |
|
196 while(@nslist) |
|
197 { |
|
198 my $uri = shift(@nslist); |
|
199 my $prefix =shift(@nslist); |
|
200 if($prefix eq 'id namespace'){$prefix=''} |
|
201 if(defined $urimap{$uri}) {next} # already done this uri |
|
202 $urimap{$uri} = $prefix; |
|
203 if($nsmap{$prefix}) |
|
204 { # need a new prefix for this, guess from the URI (for readability) |
|
205 if($uri=~/http:\/\/(www\.)?([^.\/]+)\./) {$prefix = $2} |
|
206 my $i=0; |
|
207 while($nsmap{$prefix}) |
|
208 { # still no prefix, just make up |
|
209 $prefix="ns$i"; |
|
210 $i++; |
|
211 # next line not really necessary, but it's a good safety to stop infinite loops |
|
212 $i eq 1000 && die "ERROR: cannot create namespace prefix for $uri"; |
|
213 } |
|
214 } |
|
215 $nsmap{$prefix}=$uri; |
|
216 } |
|
217 |
|
218 my $docroot = $sysdefdoc->getDocumentElement; |
|
219 |
|
220 my $ns = $docroot->getAttribute('id-namespace'); |
|
221 if(!$ns && $nsmap{''}) |
|
222 { |
|
223 $docroot->setAttribute('id-namespace',$nsmap{''}); |
|
224 } |
|
225 while(my($pre,$uri) = each(%nsmap)) |
|
226 { |
|
227 $pre ne '' || next ; |
|
228 $docroot->setAttribute("xmlns:$pre",$uri); |
|
229 } |
|
230 |
|
231 &walk($sysdef,$docroot); |
|
232 |
|
233 if($output eq '') |
|
234 { |
|
235 print $sysdefdoc->toString; |
|
236 } |
|
237 else |
|
238 { |
|
239 $sysdefdoc->printToFile($output); |
|
240 } |
|
241 |
|
242 |
|
243 sub abspath |
|
244 { |
|
245 # normalize the path into an absolute one |
|
246 my ($name,$path) = fileparse($_[0]); |
|
247 if($path eq '' && $name eq '') {return}; |
|
248 $path=~tr,\\,/,; |
|
249 if( -e $path) |
|
250 { |
|
251 return abs_path($path)."/$name"; |
|
252 } |
|
253 my @dir = split('/',$_[0]); |
|
254 my @new; |
|
255 foreach my $d (@dir) |
|
256 { |
|
257 if($d eq '.') {next} |
|
258 if($d eq '..') |
|
259 { |
|
260 pop(@new); |
|
261 next; |
|
262 } |
|
263 push(@new,$d) |
|
264 } |
|
265 return join('/',@new); |
|
266 } |
|
267 |
|
268 |
|
269 |
|
270 sub normpath |
|
271 { |
|
272 # normalize the path |
|
273 my @norm; |
|
274 foreach my $dir(split(/[\\\/]/,shift)) { |
|
275 if($dir eq '.') {next} |
|
276 if($dir eq '..') |
|
277 { |
|
278 if($#norm == -1 || $norm[$#norm] eq '..') |
|
279 { # keep as is |
|
280 push(@norm,$dir); |
|
281 } |
|
282 elsif($#norm == 0 && $norm[0] eq '') |
|
283 { # path begins with /, interpret /.. as just / -- ie toss out |
|
284 next |
|
285 } |
|
286 else |
|
287 { |
|
288 pop(@norm); |
|
289 } |
|
290 } |
|
291 else |
|
292 { |
|
293 push(@norm,$dir); |
|
294 } |
|
295 } |
|
296 |
|
297 return join('/',@norm) |
|
298 } |
|
299 |
|
300 |
|
301 sub rootMap { |
|
302 my @pathdirs = split(/\//,$_[0]); |
|
303 my @rootdirs = split(/\//,$_[1]); |
|
304 |
|
305 while(lc($rootdirs[$#rootdirs]) eq lc($pathdirs[$#pathdirs]) ) |
|
306 { |
|
307 pop(@rootdirs); |
|
308 pop(@pathdirs); |
|
309 } |
|
310 return (join('/',@rootdirs) => join('/',@pathdirs) ); |
|
311 } |
|
312 |
|
313 sub replacedBy |
|
314 { # can only check once. Destroys data |
|
315 my $node = shift; |
|
316 my $fullid= join(' ',&idns($node)); |
|
317 my $type = $node->getTagName; |
|
318 my $repl = $replacing{$type}->{$fullid}; |
|
319 delete $replacing{$type}->{$fullid}; |
|
320 return $repl; |
|
321 } |
|
322 |
|
323 sub walk |
|
324 { |
|
325 #' walk through the doc, resolving all links |
|
326 my $file = shift; |
|
327 my $node = shift; |
|
328 my $type = $node->getNodeType; |
|
329 if($type!=1) {return} |
|
330 my $tag = $node->getTagName; |
|
331 if($tag=~/^(layer|package|collection|component)$/ ) |
|
332 { |
|
333 if($file eq $sysdef) |
|
334 { |
|
335 &fixIDs($node); # normalise all IDs in the root doc. |
|
336 } |
|
337 my $override = &replacedBy($node); |
|
338 my $link= $node->getAttribute('href'); |
|
339 if($override eq '' ) |
|
340 { |
|
341 my ($id,$ns)=&idns($node); |
|
342 if($foundDescendants{$id}) |
|
343 { # keep this node, it'll be populated by what we found |
|
344 if($link) |
|
345 { |
|
346 $node->removeAttribute('href'); |
|
347 } |
|
348 } |
|
349 elsif($link || !$placeholders) |
|
350 { # not going to be used, remove |
|
351 $node->getParentNode->removeChild($node) ; # not present, remove |
|
352 return; |
|
353 } |
|
354 } |
|
355 else |
|
356 { |
|
357 my $href = $node->getAttribute('href'); |
|
358 my $ppath = join('/',&parentPath($node->getParentNode)); |
|
359 delete $newContainer{$ppath}->{join(' ',&idns($node))}; # remove this from list of things which need to be added |
|
360 if(&resolvePath($file,$href) ne $override) |
|
361 { # file has changed, update |
|
362 print STDERR "$warning: Replacing $tag ",$node->getAttribute('id')," with $override\n"; |
|
363 &setHref($node,$override); |
|
364 return; |
|
365 } |
|
366 } |
|
367 my @curpath = &parentPath($node); |
|
368 my $curitem = $curpath[$#curpath]; |
|
369 my $curp = join('/',@curpath[0..$#curpath-1]); |
|
370 delete $newContainer{$curp}->{$curitem}; |
|
371 |
|
372 if($link) |
|
373 { |
|
374 foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children |
|
375 &fixHref($node,$file); |
|
376 return; |
|
377 } |
|
378 } |
|
379 elsif($tag eq 'systemModel' && $mapmeta) |
|
380 { # need absolute paths for all links |
|
381 $node->insertBefore ($mapmeta,$node->getFirstChild); |
|
382 $sysmodelname eq '' || $node->setAttribute('name',$sysmodelname); |
|
383 } |
|
384 elsif($tag=~/^(SystemDefinition|systemModel)$/ ) |
|
385 { |
|
386 ($sysmodelname ne '' && $tag eq 'systemModel') && $node->setAttribute('name',$sysmodelname); |
|
387 } |
|
388 elsif($tag eq 'unit') |
|
389 { |
|
390 foreach my $atr ('bldFile','mrp','base','proFile') |
|
391 { |
|
392 my $link= $node->getAttribute($atr); |
|
393 if($link && !($link=~/^\//)) |
|
394 { |
|
395 if($mapmeta) |
|
396 { # use absolute paths |
|
397 $link= &abspath(File::Basename::dirname($file)."/$link"); |
|
398 foreach my $a (keys %rootmap) |
|
399 { |
|
400 $link=~s,^$a,$rootmap{$a},ie; |
|
401 } |
|
402 } |
|
403 else |
|
404 { # modified relative path |
|
405 $link = &normpath($modpath.$link); |
|
406 } |
|
407 $node->setAttribute($atr,$link); |
|
408 } |
|
409 } |
|
410 } |
|
411 elsif($tag eq 'meta') |
|
412 { |
|
413 &fixHref($node,$file); |
|
414 foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children |
|
415 &processMeta($node); |
|
416 next; |
|
417 } |
|
418 else {return} |
|
419 foreach my $item (@{$node->getChildNodes}) |
|
420 { |
|
421 #print $item->getNodeType,"\n"; |
|
422 &walk($file,$item); |
|
423 } |
|
424 if($tag=~/^(systemModel|layer|package|collection|component)$/ ) |
|
425 { # check for appending |
|
426 my $ppath = join('/',&parentPath($node)); |
|
427 if($newContainer{$ppath}) { |
|
428 foreach my $item (sort keys %{$newContainer{$ppath}}) |
|
429 { |
|
430 &appendNewItem($node,$item,$newContainer{$ppath}->{$item}); |
|
431 } |
|
432 } |
|
433 } |
|
434 } |
|
435 |
|
436 |
|
437 sub getNs |
|
438 { |
|
439 # find the ns URI that applies to the specified prefix. |
|
440 my $node = shift; |
|
441 my $pre = shift; |
|
442 my $uri = $node->getAttribute("xmlns:$pre"); |
|
443 if($uri) {return $uri} |
|
444 my $parent = $node->getParentNode; |
|
445 if($parent && $parent->getNodeType==1) |
|
446 { |
|
447 return getNs($parent,$pre); |
|
448 } |
|
449 } |
|
450 |
|
451 |
|
452 sub fixIDs |
|
453 { |
|
454 # translate the ID to use the root doc's namespaces |
|
455 my $node = shift; |
|
456 foreach my $id ('id','before') |
|
457 { |
|
458 &fixID($node,$id); |
|
459 } |
|
460 } |
|
461 |
|
462 sub idns |
|
463 { # return the namespace of an ID |
|
464 my $node = shift; |
|
465 my $id = shift; |
|
466 if($id eq '' ) {$id = $node->getAttribute('id'); } |
|
467 if($id=~s/^(.*)://) |
|
468 { # it's got a ns, find out what it is |
|
469 my $pre = $1; |
|
470 return ($id,&getNs($node,$pre)); |
|
471 } |
|
472 return ($id,$node->getOwnerDocument->getDocumentElement->getAttribute("id-namespace") || $defaultns); |
|
473 } |
|
474 |
|
475 sub fixID |
|
476 { |
|
477 # translate the ID to use the root doc's namespaces |
|
478 my $node = shift; |
|
479 my $attr = shift || 'id'; |
|
480 my $id = $node->getAttribute($attr); |
|
481 if($id eq '') {return} |
|
482 my $ns; |
|
483 if($id=~s/^(.*)://) |
|
484 { # it's got a ns, find out what it is |
|
485 my $pre = $1; |
|
486 $ns=&getNs($node,$pre); |
|
487 } |
|
488 else |
|
489 { |
|
490 $ns = $node->getOwnerDocument->getDocumentElement->getAttribute("id-namespace") || |
|
491 $defaultns; |
|
492 } |
|
493 $ns = $urimap{$ns}; |
|
494 $id = ($ns eq '') ? $id : "$ns:$id"; |
|
495 return $node->setAttribute($attr,$id); |
|
496 } |
|
497 |
|
498 sub firstElement { |
|
499 # return the first element in this node |
|
500 my $node = shift; |
|
501 foreach my $item (@{$node->getChildNodes}) { |
|
502 if($item->getNodeType==1) {return $item} |
|
503 } |
|
504 } |
|
505 |
|
506 |
|
507 sub atts { |
|
508 # return a hash of all attribtues defined for this element |
|
509 my $node = shift; |
|
510 my %at = $node->getAttributes; |
|
511 my %list; |
|
512 foreach my $a (keys %{$node->getAttributes}) |
|
513 { |
|
514 if($a ne '') |
|
515 { |
|
516 $list{$a} = $node->getAttribute ($a); |
|
517 } |
|
518 } |
|
519 return %list; |
|
520 } |
|
521 |
|
522 |
|
523 sub ns |
|
524 { |
|
525 # return a hash of ns prefix and uri -- the xmlns: part is stripped off |
|
526 my $node = shift; |
|
527 my %list; |
|
528 foreach my $a (keys %{$node->getAttributes}) |
|
529 { |
|
530 my $pre = $a; |
|
531 if($pre=~s/^xmlns://) |
|
532 { |
|
533 $list{$pre} = $node->getAttribute ($a); |
|
534 } |
|
535 } |
|
536 return %list; |
|
537 } |
|
538 |
|
539 |
|
540 |
|
541 sub namespaces |
|
542 { |
|
543 # return a list of namespace URI / prefix pairs, in the order they're defined |
|
544 # these need to be used to define namespaces in the root element |
|
545 my $file = shift; |
|
546 my $node = shift; |
|
547 my $type = $node->getNodeType; |
|
548 if($type!=1) {return} |
|
549 my $tag = $node->getTagName; |
|
550 my @res; |
|
551 my %nslist = &ns($node); |
|
552 while(my($pre,$uri)=each(%nslist)) |
|
553 { # push all namespaces defined here onto the list |
|
554 push(@res,$uri,$pre); |
|
555 } |
|
556 if($tag=~/^(layer|package|collection|component)$/ ) |
|
557 { # these have the potential of linking, so check for that |
|
558 } |
|
559 elsif($tag eq 'SystemDefinition' ) |
|
560 { |
|
561 my $default = $node->getAttribute('id-namespace'); |
|
562 if($default) |
|
563 {# mangle with a space so it's clear it's not a qname |
|
564 push(@res,$default,'id namespace'); |
|
565 } |
|
566 } |
|
567 foreach my $item (@{$node->getChildNodes}) |
|
568 { |
|
569 push(@res,&namespaces($file,$item)); |
|
570 } |
|
571 return @res; |
|
572 } |
|
573 |
|
574 sub processMeta |
|
575 { |
|
576 my $metanode = shift; |
|
577 # do nothing. Not supported yet |
|
578 } |
|
579 |
|
580 sub guessIdInPath |
|
581 { |
|
582 my $id = shift; |
|
583 my @path = reverse(split(/\//,$_[0])); |
|
584 while(@path) |
|
585 { |
|
586 my $dir = shift(@path); |
|
587 if($dir eq $id) |
|
588 { |
|
589 return ($id,@path); |
|
590 } |
|
591 } |
|
592 print STDERR "$warning: Non-standard ID $id in $_[0]\n"; |
|
593 @path = reverse(split(/\//,$_[0])); |
|
594 if($path[0] eq 'package_definition.xml') |
|
595 { |
|
596 return @path[1..$#path]; |
|
597 } |
|
598 } |
|
599 |
|
600 |
|
601 sub parentPath |
|
602 { |
|
603 my $node=shift; |
|
604 my @path; |
|
605 while($node) |
|
606 { |
|
607 if(!$node) {return @path} |
|
608 my $id=$node->getAttribute('id'); |
|
609 if($id eq '') {return @path} |
|
610 $id=~s/^.*://; |
|
611 @path = ($id,@path); |
|
612 $node = $node->getParentNode(); |
|
613 } |
|
614 return @path; |
|
615 } |
|
616 |
|
617 sub childTag |
|
618 { |
|
619 my $tag = shift; |
|
620 if($tag eq 'systemModel') {return 'layer'} |
|
621 if($tag eq 'layer') {return 'package'} |
|
622 if($tag eq 'package') {return 'collection'} |
|
623 if($tag eq 'collection') {return 'component'} |
|
624 die "ERROR: no child for $tag"; |
|
625 } |
|
626 |
|
627 sub appendNewItem |
|
628 { |
|
629 my $node = shift; |
|
630 my $doc = $node->getOwnerDocument; |
|
631 my $id = shift; |
|
632 if($id eq '') {return} |
|
633 my $fullid=$id; |
|
634 my $contents = shift; |
|
635 my $tag = &childTag($node->getTagName()); |
|
636 my $new = $doc->createElement($tag); |
|
637 if($id=~/^(.*) (.*)/) |
|
638 { |
|
639 $id=$1; |
|
640 $ns = getNamespacePrefix($node,$2); |
|
641 if($ns ne '') {$id="$ns:$id"} |
|
642 } |
|
643 else |
|
644 { |
|
645 $contents = ''; |
|
646 } |
|
647 $new->setAttribute('id',$id); # default namespace |
|
648 $node->appendChild($new); |
|
649 my $ppath = join('/',&parentPath($new)); |
|
650 if($contents eq '') |
|
651 { # look for additions |
|
652 print STDERR "$warning: Adding new $tag: $id\n"; |
|
653 if($newContainer{$ppath}) { |
|
654 foreach my $item (sort keys %{$newContainer{$ppath}}) |
|
655 { |
|
656 &appendNewItem($new,$item,$newContainer{$ppath}->{$item}); |
|
657 } |
|
658 } |
|
659 } |
|
660 else |
|
661 { # this one item is defined in the specified file |
|
662 if($tag eq 'package') |
|
663 { #include some package data in root |
|
664 my $fragment = $parser->parsefile ($contents); |
|
665 my $fdoc = $fragment->getDocumentElement(); |
|
666 my $topmost =&firstElement($fdoc); |
|
667 my %at = &atts($topmost); |
|
668 foreach my $arg ('tech-domain','level','span') |
|
669 { |
|
670 if($at{$arg}) { $new->setAttribute($arg,$at{$arg})} |
|
671 } |
|
672 if($at{'tech-domain'}) {&positionByTechDomain($new)} |
|
673 } |
|
674 &setHref($new,$contents); |
|
675 print STDERR "$warning: Adding found $tag $id from $contents\n"; |
|
676 delete $replacing{$tag}->{$fullid}; |
|
677 } |
|
678 # newline after each new tag so output's not ugly |
|
679 if($new->getNextSibling) |
|
680 { |
|
681 $node->insertBefore($doc->createTextNode ("\n"),$new->getNextSibling); |
|
682 } |
|
683 else |
|
684 { |
|
685 $node->appendChild($doc->createTextNode ("\n")); |
|
686 } |
|
687 delete $newContainer{$ppath}; |
|
688 } |
|
689 |
|
690 |
|
691 sub getNamespacePrefix |
|
692 { |
|
693 my $node = shift; |
|
694 my $ns = shift; |
|
695 my $root = $node->getOwnerDocument->getDocumentElement; |
|
696 my $idns = $root->getAttribute("id-namespace"); |
|
697 if($idns && $idns eq $ns) {return} |
|
698 if(!$idns && $defaultns eq $ns) {return} |
|
699 foreach my $a (keys %{$root->getAttributes}) |
|
700 { |
|
701 my $pre = $a; |
|
702 if($pre=~s/^xmlns://) |
|
703 { |
|
704 if($root->getAttribute ($a) eq $ns) {return $pre} |
|
705 } |
|
706 } |
|
707 die "ERROR: no namespace prefix defined for $ns"; |
|
708 } |
|
709 |
|
710 |
|
711 sub resolvePath |
|
712 { |
|
713 # return full path to 2nd arg relative to first (path or absolute URI) |
|
714 my $base = shift; |
|
715 my $path = shift; |
|
716 if($path=~m,^/,) {return $path } # path is absolute, but has no drive. Let OS deal with it. |
|
717 if($path=~s,^file:///([a-zA-Z]:/),$1,) {return $path } # file URI with drive letter |
|
718 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 |
|
719 if($path=~m,^[a-z0-9][a-z0-9]+:,i) {return $path } # absolute URI -- no idea how to handle, so just return |
|
720 return &abspath(File::Basename::dirname($base)."/$path"); |
|
721 } |
|
722 |
|
723 |
|
724 sub fixHref { |
|
725 my $node = shift; |
|
726 my $base = shift; |
|
727 my $link= $node->getAttribute('href'); |
|
728 if($link=~/^(ftp|http)s:\/\//) {return} # remote link, do nothing |
|
729 my $path = &resolvePath($base,$link); |
|
730 if(!-e $path) |
|
731 { # no such file, delete |
|
732 my $tag =$node->getTagName; |
|
733 my $id = $node->getAttribute('id'); |
|
734 print STDERR "$warning: $tag $id not found at $link\n"; |
|
735 $node->getParentNode->removeChild($node); |
|
736 return; |
|
737 } |
|
738 foreach my $child (@{$node->getChildNodes}) {$node->removeChild($child)} # can't have children |
|
739 if($output eq '') |
|
740 { |
|
741 $path=~s,^/?,file:///,; |
|
742 $node->setAttribute('href',$path); # replace with absolute URI |
|
743 return; |
|
744 } |
|
745 $node->setAttribute('href',&normpath($modpath.$link)); # make relative path to output file |
|
746 } |
|
747 |
|
748 |
|
749 sub setHref { |
|
750 my $node = shift; |
|
751 my $file = shift; |
|
752 if($output eq '') |
|
753 { |
|
754 $path = &abspath($file); |
|
755 $path=~s,^/?,file:///,; |
|
756 $node->setAttribute('href',$path); # replace with absolute URI |
|
757 } |
|
758 else |
|
759 { |
|
760 $node->setAttribute('href',&relativeTo(&abspath($output),$file,'file')); |
|
761 } |
|
762 while(my $child = $node->getFirstChild ) {$node->removeChild($child)} |
|
763 } |
|
764 |
|
765 |
|
766 sub relativeTo { |
|
767 if($_[0] eq '') {return &abspath($_[1])} |
|
768 my @outfile = split(/[\\\/]/,lc(shift)); |
|
769 my @infile = split(/[\\\/]/,lc(shift)); |
|
770 my $asdir = shift ne 'file'; |
|
771 while($outfile[0] eq $infile[0]) |
|
772 { |
|
773 shift(@outfile); |
|
774 shift(@infile); |
|
775 } |
|
776 $modpath = '../' x (scalar(@outfile) - 1); |
|
777 if($asdir) { |
|
778 if(scalar @infile > 1) {$modpath .= join('/',@infile[0..$#infile - 1]).'/'} |
|
779 } else {$modpath .= join('/',@infile)} |
|
780 return $modpath; |
|
781 } |
|
782 |
|
783 sub positionByTechDomain |
|
784 { |
|
785 my $node=shift; |
|
786 my $td = $node->getAttribute('tech-domain'); |
|
787 my %before; |
|
788 foreach my $t (@tdOrder) |
|
789 { |
|
790 $before{$t}=1; |
|
791 if($t eq $td) {last} |
|
792 } |
|
793 my $prev = $node->getPreviousSibling; |
|
794 foreach my $child (reverse @{$node->getParentNode->getChildNodes}) |
|
795 { |
|
796 if($child->getNodeType==1 && $child->getTagName eq 'package' && $child!=$node) |
|
797 { |
|
798 if($before{$child->getAttribute('tech-domain')}) |
|
799 { |
|
800 my $next = $child->getNextSibling; |
|
801 while($next && $next->getNodeType!=1) {$next = $next->getNextSibling} |
|
802 if($next) { |
|
803 $node->getParentNode->insertBefore ($node,$next); |
|
804 } |
|
805 last; |
|
806 } |
|
807 } |
|
808 } |
|
809 } |