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