1 #! perl |
|
2 |
|
3 # Read a Foundation system model, mapping file, and System_Definition.xml |
|
4 # and generate a Perforce branchspec to reflect the code reorg |
|
5 |
|
6 use strict; |
|
7 |
|
8 use FindBin; |
|
9 use lib "."; |
|
10 use lib "./lib"; |
|
11 use lib "$FindBin::Bin"; |
|
12 use lib "$FindBin::Bin/lib"; |
|
13 use XML::DOM; |
|
14 #use XML::DOM::ValParser; |
|
15 |
|
16 # produces the "Use of uninitialized value in concatenation (.) or string" warning |
|
17 use XML::XQL; |
|
18 use XML::XQL::DOM; |
|
19 |
|
20 # Read the command line to get the filenames |
|
21 |
|
22 sub Usage($) |
|
23 { |
|
24 my ($reason) = @_; |
|
25 |
|
26 print "Usage: $reason\n" if ($reason); |
|
27 print <<USAGE_EOF; |
|
28 |
|
29 Usage: generate_branchspec.pl <params> [options] |
|
30 |
|
31 params: |
|
32 -s <system_definition> XML version of Symbian System_definition |
|
33 -m <foundation_model> XML version of Foundation System Model |
|
34 |
|
35 options: |
|
36 -o <whats_left> XML file showing unreferenced |
|
37 parts of the System Model |
|
38 -r Remove matched objects from -o output |
|
39 -c <cbr_mapping> Tab separated file showing the Schedule 12 |
|
40 component for each MRP file |
|
41 |
|
42 USAGE_EOF |
|
43 exit(1); |
|
44 } |
|
45 |
|
46 use Getopt::Long; |
|
47 |
|
48 my $foundationmodel = "output_attr.xml"; |
|
49 my $foundationdirs = "foundation_dirs.xml"; |
|
50 my $systemdefinition = "variability/vp_data/templates/System_Definition_template.xml"; |
|
51 my $rootdir = "."; |
|
52 my $remove = 0; |
|
53 my $cbrmappingfile = ""; |
|
54 |
|
55 Usage("Bad arguments") unless GetOptions( |
|
56 'm=s' => \$foundationmodel, |
|
57 's=s' => \$systemdefinition, |
|
58 'o=s' => \$rootdir, |
|
59 'c=s' => \$cbrmappingfile); |
|
60 |
|
61 Usage("Too many arguments") if (scalar @ARGV > 0); |
|
62 Usage("Cannot find $foundationmodel") if (!-f $foundationmodel); |
|
63 |
|
64 |
|
65 my $xmlParser = new XML::DOM::Parser; |
|
66 XML::DOM::ignoreReadOnly(1); |
|
67 |
|
68 my $foundationpath = "."; |
|
69 my $sysdefpath = "."; |
|
70 $foundationpath = $1 if ($foundationmodel =~ /^(.+)\\[^\\]+$/); |
|
71 $sysdefpath = $1 if ($systemdefinition =~ /^(.+)\\[^\\]+$/); |
|
72 #$xmlParser->set_sgml_search_path($foundationpath, $sysdefpath); |
|
73 |
|
74 my $foundationXML = $xmlParser->parsefile ($foundationmodel); |
|
75 chdir($rootdir); |
|
76 |
|
77 # Collect the Schedule12 entries, checking for duplicates |
|
78 |
|
79 my %sch12refs; |
|
80 my %componenttype; |
|
81 my ($foundation) = $foundationXML->getElementsByTagName("SystemDefinition"); |
|
82 Usage("No <SystemDefinition> in $foundationmodel ?") if (!defined $foundation); |
|
83 |
|
84 # Process the Foundation model to get the directory names |
|
85 |
|
86 my %unique_names; |
|
87 my %partnames; |
|
88 my %dirnames; |
|
89 my %component_dirs; |
|
90 my %old_component_mapping; |
|
91 my %component_object; # reference to XML <component> objects |
|
92 my %mrp_mapping; |
|
93 |
|
94 sub process_foundation($$); # declare the prototype for recursive call |
|
95 sub process_foundation($$) |
|
96 { |
|
97 my ($node,$level) = @_; |
|
98 |
|
99 my @children = $node->getChildNodes; |
|
100 foreach my $child (@children) |
|
101 { |
|
102 if ($child->getNodeTypeName ne "ELEMENT_NODE") |
|
103 { |
|
104 # text and comments don't count |
|
105 next; |
|
106 } |
|
107 if ($level == 0) |
|
108 { |
|
109 process_foundation($child,1); |
|
110 next; |
|
111 } |
|
112 |
|
113 next if ($child->getAttribute("contribution") eq "excluded"); |
|
114 |
|
115 my $tagname = $child->getTagName; |
|
116 my $name = $child->getAttribute("name"); |
|
117 my $longname = $child->getAttribute("long-name"); |
|
118 $longname = $name if ($longname eq ""); |
|
119 |
|
120 if ($name ne "") |
|
121 { |
|
122 if (defined $unique_names{$name}) |
|
123 { |
|
124 print "** duplicated name $name\n"; |
|
125 } |
|
126 $unique_names{$name} = 1; |
|
127 } |
|
128 if ($name eq "") |
|
129 { |
|
130 printf "No name in %s\n", $child->toString(); |
|
131 next; |
|
132 } |
|
133 |
|
134 my $dirname = $name; |
|
135 $dirname =~ s/\s+//g; # remove the spaces |
|
136 $dirname =~ s/[\(\)]/_/g; # map troublesome characters |
|
137 $dirname =~ s/[ \.]*$//g; # trailing spaces or dots |
|
138 $partnames{$tagname} = $name; |
|
139 $dirnames{$tagname} = $dirname; |
|
140 |
|
141 print "making directory $dirname\n" if ($level <2); |
|
142 mkdir $dirname; # create the directory |
|
143 |
|
144 if ($tagname eq "component") |
|
145 { |
|
146 $child->printToFile("$dirname/component.txt"); |
|
147 next; |
|
148 } |
|
149 |
|
150 chdir $dirname; |
|
151 if ($tagname eq "block") |
|
152 { |
|
153 # Create a fragment which describes this package |
|
154 open PACKAGE_MODEL, ">package_model.xml"; |
|
155 print PACKAGE_MODEL "<!-- use XINCLUDE to put this fragment into a System_Model -->\n"; |
|
156 print PACKAGE_MODEL $child->toString(); |
|
157 print PACKAGE_MODEL "\n"; |
|
158 close PACKAGE_MODEL; |
|
159 } |
|
160 |
|
161 process_foundation($child,$level+1); |
|
162 chdir ".."; |
|
163 } |
|
164 } |
|
165 |
|
166 my ($model) = $foundationXML->getElementsByTagName("SystemDefinition"); |
|
167 process_foundation($model,0); |
|
168 |
|
169 exit 0; |
|
170 |
|
171 # Dump the old component -> new component -> directory mapping |
|
172 |
|
173 foreach my $component (sort keys %old_component_mapping) |
|
174 { |
|
175 my $new_component = $old_component_mapping{$component}; |
|
176 printf "%s => %s => %s\n", |
|
177 $component, $new_component, $component_dirs{$new_component}; |
|
178 } |
|
179 |
|
180 # Find the old component entries in the XML file |
|
181 |
|
182 my %branchspec; |
|
183 my %reverse_branchspec; |
|
184 my %primary_mrp; |
|
185 my %otherroots; |
|
186 my %ignoreme; |
|
187 |
|
188 sub add_to_branchspec($$;$$); |
|
189 sub add_to_branchspec($$;$$) |
|
190 { |
|
191 my ($olddir,$newdir,$primary,$noexpansion) = @_; |
|
192 $primary = "generate_branchspec.pl" if (!defined $primary); |
|
193 |
|
194 if (defined $ignoreme{$olddir} && $primary !~ /^extra root/) |
|
195 { |
|
196 print "Ignoring $olddir - $ignoreme{$olddir}\n"; |
|
197 next; |
|
198 } |
|
199 if (defined $branchspec{$olddir}) |
|
200 { |
|
201 if ($newdir eq $branchspec{$olddir}) |
|
202 { |
|
203 # reasserting the previous branchspec - not a problem |
|
204 return; |
|
205 } |
|
206 # trying to change the old mapping |
|
207 print "$primary attempted to redefine $olddir mapping\n"; |
|
208 print "Was $branchspec{$olddir} instead of $newdir\n"; |
|
209 exit(1); |
|
210 } |
|
211 |
|
212 if (defined $reverse_branchspec{$newdir}) |
|
213 { |
|
214 print "Branchspec collision from $primary into $newdir\n"; |
|
215 print "Can't send $olddir and $reverse_branchspec{$newdir} to same place\n"; |
|
216 exit(1); |
|
217 } |
|
218 |
|
219 if (defined $otherroots{$olddir} && !$noexpansion) |
|
220 { |
|
221 print "Adjusting branchspec for $primary to include the other roots\n"; |
|
222 my $otherolddir = $olddir; |
|
223 $otherolddir =~ s/([^\/]+)\/$//; |
|
224 my $maindir = $1; |
|
225 add_to_branchspec("$olddir","$newdir$maindir/",$primary,1); # avoid recursion |
|
226 |
|
227 foreach my $otherdir (split /\//, $otherroots{$olddir}) |
|
228 { |
|
229 next if (length($otherdir) == 0); |
|
230 add_to_branchspec("$otherolddir$otherdir/","$newdir$otherdir/","extra root of $primary",1); |
|
231 } |
|
232 } |
|
233 else |
|
234 { |
|
235 $branchspec{$olddir} = $newdir; |
|
236 $reverse_branchspec{$newdir} = $olddir; |
|
237 $primary_mrp{$olddir} = $primary; |
|
238 } |
|
239 } |
|
240 |
|
241 # Workaround for the common/product and cedar/product directories, which don't |
|
242 # have associated CBR components |
|
243 |
|
244 add_to_branchspec("common/product/", "ostools/toolsandutils/ToolsandUtils/product/"); |
|
245 add_to_branchspec("cedar/product/", "ostools/toolsandutils/ToolsandUtils/cedarproduct/"); |
|
246 |
|
247 # Add catchall mappings to get all do the other odds and ends |
|
248 # LHS must be more specific than a single directory, otherwise apply_branchspec hits too many things |
|
249 # RHS must be short, to avoid blowing the Windows path limit when syncing TBAS builds |
|
250 add_to_branchspec("common/generic/", "os/unref/orphan/comgen/", "(Orphans)"); |
|
251 add_to_branchspec("common/techview/", "os/unref/orphan/comtv/", "(Orphans)"); |
|
252 add_to_branchspec("common/testtools/", "os/unref/orphan/comtt/", "(Orphans)"); |
|
253 add_to_branchspec("common/connectqi/", "os/unref/orphan/comqi/", "(Orphans)"); |
|
254 add_to_branchspec("cedar/generic/", "os/unref/orphan/cedgen/", "(Orphans)"); |
|
255 |
|
256 my @clumps = ( |
|
257 "cedar/generic/base/e32/", |
|
258 "cedar/generic/base/f32/", |
|
259 "common/generic/comms-infras/esock/", |
|
260 "common/generic/multimedia/ecam/", |
|
261 "common/generic/multimedia/icl/", |
|
262 "common/generic/multimedia/mmf/", |
|
263 "common/generic/j2me/", # not really a clump, but must be called "j2me" |
|
264 "common/generic/telephony/trp/", |
|
265 "common/generic/security/caf2/test/", |
|
266 "common/generic/networking/dialog/", |
|
267 "common/generic/comms-infras/commsdat/", |
|
268 "common/generic/connectivity/legacy/PLP/", # plpvariant shares PLPInc main PLP group |
|
269 "common/testtools/ResourceHandler/", # entangled versions for Techview, UIQ and S60 |
|
270 ); |
|
271 |
|
272 # Force E32 into a faintly sensible place |
|
273 |
|
274 add_to_branchspec("cedar/generic/base/e32/", "os/kernelhwsrv/kernel/eka/", "(Hand coded E32 location)"); |
|
275 |
|
276 # Force j2me to be called j2me |
|
277 |
|
278 add_to_branchspec("common/generic/j2me/", "app/java/midpprofile/midpmidlet/j2me/", "(Hand coded J2ME location)"); |
|
279 |
|
280 # Peer relationships if x uses "..\y", then add this as $peers{"x"} = "y" |
|
281 |
|
282 my %peers; |
|
283 $peers{"cedar/generic/tools/e32toolp/"} = "cedar/generic/tools/buildsystem/"; |
|
284 |
|
285 # multirooted components, which own several trees that have no common root |
|
286 # Add these to the branchspec automatically alongside the root containing the MRP file |
|
287 |
|
288 $otherroots{"common/generic/networking/inhook6/"} = "inhook6example"; |
|
289 $otherroots{"common/generic/networking/examplecode/"} = "anvltest/cgi/ping/udpecho/udpsend/webserver"; |
|
290 $otherroots{"common/generic/networking/qos/"} = "qostest/QoSTesting"; |
|
291 $otherroots{"common/generic/wap-stack/wapstack/"} = "documentation/confidential"; |
|
292 $otherroots{"common/generic/bluetooth/latest/bluetooth/test/"} = "example/testui"; |
|
293 |
|
294 |
|
295 my %hasbldfile; |
|
296 |
|
297 my %foundationrefs; |
|
298 my %foundationbymrp; |
|
299 my %modelnames; |
|
300 sub match_names($); # declare the prototype for recursive call |
|
301 sub match_names($) |
|
302 { |
|
303 my ($node) = @_; |
|
304 |
|
305 my @children = $node->getChildNodes; |
|
306 foreach my $child (@children) |
|
307 { |
|
308 if ($child->getNodeTypeName ne "ELEMENT_NODE") |
|
309 { |
|
310 # text and comments don't count |
|
311 next; |
|
312 } |
|
313 my $tagname = $child->getTagName; |
|
314 if ($tagname eq "layer") |
|
315 { |
|
316 $partnames{"block"} = undef; |
|
317 $partnames{"subblock"} = undef; |
|
318 $partnames{"collection"} = undef; |
|
319 } |
|
320 if ($tagname eq "block") |
|
321 { |
|
322 $partnames{"subblock"} = undef; |
|
323 $partnames{"collection"} = undef; |
|
324 } |
|
325 if ($tagname eq "subblock") |
|
326 { |
|
327 $partnames{"collection"} = undef; |
|
328 } |
|
329 if ($tagname eq "unit") |
|
330 { |
|
331 # units are the payload |
|
332 |
|
333 my $mrp = $child->getAttribute("mrp"); |
|
334 $mrp =~ s/\\/\//g; # ensure that / separators are used |
|
335 $child->setAttribute("mrp",$mrp); |
|
336 |
|
337 my $blockname = $partnames{"subblock"}; |
|
338 $blockname = $partnames{"block"} if (!defined $blockname); # no subblock |
|
339 $blockname = "Misc" if (!defined $blockname); # no block either |
|
340 my $old_component = join("::", |
|
341 $partnames{"layer"}, $blockname, |
|
342 $partnames{"collection"},$partnames{"component"}); |
|
343 |
|
344 # find corresponding new component |
|
345 |
|
346 my $new_component; |
|
347 |
|
348 if (defined $mrp_mapping{$mrp}) |
|
349 { |
|
350 $new_component = $mrp_mapping{$mrp}; |
|
351 my $othermapping = $old_component_mapping{$old_component}; |
|
352 if (defined $othermapping && $othermapping eq $new_component) |
|
353 { |
|
354 # they agree - lovely. |
|
355 } |
|
356 else |
|
357 { |
|
358 print "MRP mapping $mrp -> $new_component, disagrees with $old_component mapping\n"; |
|
359 } |
|
360 delete $component_object{$new_component}; |
|
361 } |
|
362 if (!defined $new_component) |
|
363 { |
|
364 $new_component = $old_component_mapping{$old_component}; |
|
365 } |
|
366 if (!defined $new_component) |
|
367 { |
|
368 # Some "old_package" information is incorrect - scan for a close match |
|
369 # Strategy 1 - match collection::component |
|
370 my $tail = join ("::", $partnames{"collection"},$partnames{"component"}); |
|
371 my $len = 0-length($tail); |
|
372 |
|
373 foreach my $guess (keys %old_component_mapping) |
|
374 { |
|
375 if (substr($guess,$len) eq $tail) |
|
376 { |
|
377 print "Guessed that $old_component should be $guess\n"; |
|
378 $new_component = $old_component_mapping{$guess}; |
|
379 last; |
|
380 } |
|
381 } |
|
382 } |
|
383 if (!defined $new_component) |
|
384 { |
|
385 # Some "old_package" information is incorrect - scan for a close match |
|
386 # Strategy 2 - just match the component name, |
|
387 # truncate after last / e.g. GPRS/UMTS QoS Framework => UMTS QoS Framework |
|
388 my $tail = "::".$partnames{"component"}; |
|
389 $tail =~ s/^.*\/([^\/]*)$/$1/; |
|
390 my $len = 0-length($tail); |
|
391 |
|
392 foreach my $guess (keys %old_component_mapping) |
|
393 { |
|
394 if (substr($guess,$len) eq $tail) |
|
395 { |
|
396 print "Guessed that $old_component should be $guess\n"; |
|
397 $new_component = $old_component_mapping{$guess}; |
|
398 last; |
|
399 } |
|
400 } |
|
401 } |
|
402 if (!defined $new_component) |
|
403 { |
|
404 print "Rescuing unreferenced $old_component\n"; |
|
405 # later we will infer the new_component directory from the mrp |
|
406 } |
|
407 else |
|
408 { |
|
409 if (!defined $mrp_mapping{$mrp}) |
|
410 { |
|
411 # Copy the unit into the Foundation model (we'll fix it later) |
|
412 |
|
413 my $foundation_comp = $component_object{$new_component}; |
|
414 $node->removeChild($child); |
|
415 $child->setOwnerDocument($foundation_comp->getOwnerDocument); |
|
416 $foundation_comp->addText("\n "); |
|
417 $foundation_comp->appendChild($child); |
|
418 $foundation_comp->addText("\n "); |
|
419 delete $component_object{$new_component}; # remove items after processing |
|
420 } |
|
421 } |
|
422 |
|
423 # determine the root of the component source tree from the mrp attribute |
|
424 |
|
425 if ($mrp =~ /^\//) |
|
426 { |
|
427 print "Skipping absolute MRP $mrp in $old_component\n"; |
|
428 next; |
|
429 } |
|
430 |
|
431 my $current_dir = $mrp; |
|
432 $current_dir =~ s-/[^/]+$-/-; # remove filename; |
|
433 |
|
434 # tree structure special cases |
|
435 $current_dir =~ s-/sms/multimode/Group/-/sms/-; |
|
436 $current_dir =~ s-/agendaserver/TestAgendaSrv/-/agendaserver/-; |
|
437 $current_dir =~ s-/alarmserver/TestAlarmSrv/-/alarmserver/-; |
|
438 $current_dir =~ s-/trace/ulogger/group/-/trace/-; |
|
439 $current_dir =~ s-/ucc/BuildScripts/group/-/ucc/-; |
|
440 $current_dir =~ s-/worldserver/TestWorldSrv/-/worldserver/-; |
|
441 $current_dir =~ s-/adapters/devman/Group/-/adapters/-; # avoid collision with syncml/devman |
|
442 $current_dir =~ s-/mobiletv/hai/dvbh/group/-/mobiletv/-; |
|
443 $current_dir =~ s-/plpgrp/-/-i; # connectivity/legacy/PLP/plpgrp |
|
444 $current_dir =~ s-/(h2|h4)/.*$-/-i; # various baseports |
|
445 |
|
446 # more generic cases |
|
447 $current_dir =~ s-/group/.*$-/-i; # group (& subdirs) |
|
448 $current_dir =~ s-/group[^/]+/.*$-/-i; # groupsql, groupfuture (& subdirs) - cntmodel, s60 header compat |
|
449 $current_dir =~ s-/mmpfiles/-/-i; # comp/mmpfiles |
|
450 |
|
451 # apply clumping rules |
|
452 |
|
453 foreach my $clump (@clumps) |
|
454 { |
|
455 if (substr($current_dir,0,length($clump)) eq $clump) |
|
456 { |
|
457 print "$mrp is part of the component group rooted at $clump\n"; |
|
458 $current_dir = $clump; |
|
459 last; |
|
460 } |
|
461 } |
|
462 |
|
463 # check for inseparable components |
|
464 my $new_dir; |
|
465 my $primary; |
|
466 my $set_peer_directory = 0; |
|
467 |
|
468 if (defined $branchspec{$current_dir}) |
|
469 { |
|
470 $primary = $primary_mrp{$current_dir}; |
|
471 print "Cannot separate $mrp from $primary\n"; |
|
472 $new_dir = $branchspec{$current_dir}; # use the directory for the other component |
|
473 } |
|
474 elsif (defined $peers{$current_dir}) |
|
475 { |
|
476 # apply peering rules |
|
477 my $peer = $peers{$current_dir}; |
|
478 |
|
479 if (defined $branchspec{$peer}) |
|
480 { |
|
481 # peer already defined - adjust our mapping |
|
482 $new_dir = $branchspec{$peer}; |
|
483 $new_dir =~ s/[^\/]+\/$//; |
|
484 $current_dir =~ m/([^\/]+\/)$/; |
|
485 $new_dir .= $1; |
|
486 print "Mapping $mrp to $new_dir to be next to peer $peer\n"; |
|
487 $primary = $mrp; |
|
488 } |
|
489 else |
|
490 { |
|
491 # we are the first to appear, so we determine the directory |
|
492 $set_peer_directory = 1; |
|
493 } |
|
494 } |
|
495 |
|
496 if (!defined $new_dir) |
|
497 { |
|
498 if (defined $new_component) |
|
499 { |
|
500 $new_dir = $component_dirs{$new_component}; |
|
501 } |
|
502 else |
|
503 { |
|
504 $new_dir = "os/unref/$current_dir"; |
|
505 $new_dir =~ s/common\/generic/comgen/; |
|
506 $new_dir =~ s/common\/techview/comtv/; |
|
507 $new_dir =~ s/common\/testtools/comtt/; |
|
508 $new_dir =~ s/common\/connectqi/comqi/; |
|
509 $new_dir =~ s/common\/developerlibrary/devlib/; |
|
510 $new_dir =~ s/cedar\/generic/cedgen/; |
|
511 } |
|
512 $primary = $mrp; |
|
513 } |
|
514 |
|
515 # Update the mrp attribute |
|
516 |
|
517 substr($mrp,0,length($current_dir)) = $new_dir; |
|
518 # $child->setAttribute("mrp",$mrp); |
|
519 |
|
520 # update the bldFile attribute, if any |
|
521 my $bldFile = $child->getAttribute("bldFile"); |
|
522 if ($bldFile) |
|
523 { |
|
524 $bldFile =~ s/\\/\//g; # ensure that / separators are used |
|
525 $child->setAttribute("bldFile",$bldFile); |
|
526 $hasbldfile{$current_dir} = 1; |
|
527 my $saved_bldFile = $bldFile; |
|
528 $bldFile .= "/" if ($bldFile !~ /\/$/); # add trailing / |
|
529 my $previous = substr($bldFile,0,length($current_dir),$new_dir); |
|
530 if ($previous ne $current_dir) |
|
531 { |
|
532 print "*** $old_component bldFile=$saved_bldFile not in $current_dir\n"; |
|
533 } |
|
534 else |
|
535 { |
|
536 $bldFile =~ s/\/+$//; # remove trailing / |
|
537 # $child->setAttribute("bldFile",$bldFile); |
|
538 } |
|
539 } |
|
540 |
|
541 add_to_branchspec($current_dir, $new_dir, $primary); |
|
542 |
|
543 if ($set_peer_directory) |
|
544 { |
|
545 # peer mapping implied by our mapping |
|
546 my $peer = $peers{$current_dir}; |
|
547 $new_dir =~ s/[^\/]+\/$//; |
|
548 $peer =~ m/([^\/]+\/)$/; |
|
549 $new_dir .= $1; |
|
550 print "Implied mapping $peer to $new_dir to be next to $mrp\n"; |
|
551 add_to_branchspec($peer, $new_dir, "$mrp (peer)"); |
|
552 } |
|
553 |
|
554 next; |
|
555 } |
|
556 my $name = $child->getAttribute("name"); |
|
557 $partnames{$tagname} = $name; |
|
558 match_names($child); |
|
559 } |
|
560 } |
|
561 |
|
562 foreach my $missing (sort keys %component_object) |
|
563 { |
|
564 print "No mapping found for Symbian-derived component $missing\n"; |
|
565 } |
|
566 |
|
567 # Output Perforce branchspec, taking care to "subtract" the |
|
568 # places where a subtree is branched to a different place |
|
569 |
|
570 my $from = "//epoc/release/9.4"; |
|
571 my $to = "//epoc/development/personal/williamro/seaside/31"; |
|
572 my %processed; |
|
573 |
|
574 printf "\n\n========== branchspec with %d elements\n", scalar keys %branchspec; |
|
575 |
|
576 foreach my $olddir (sort keys %branchspec) |
|
577 { |
|
578 my $comment = $hasbldfile{$olddir} ? "" : "\t# src"; |
|
579 |
|
580 my $subtraction = ""; |
|
581 my @parts = split /\//, $olddir; |
|
582 my $root = ""; |
|
583 while (@parts) |
|
584 { |
|
585 my $part = shift @parts; |
|
586 $root .= "$part/"; |
|
587 if (defined $processed{$root}) |
|
588 { |
|
589 # Found a containing tree |
|
590 my $remainder = join("/",@parts); |
|
591 $subtraction = sprintf "\t-$from/%s%s/... $to/%s%s/...\n", |
|
592 $root, $remainder, $branchspec{$root}, $remainder; |
|
593 # continue in case there is a containing sub-subtree. |
|
594 } |
|
595 } |
|
596 print $subtraction; # usually empty |
|
597 printf "\t$from/%s... $to/%s...%s\n", $olddir, $branchspec{$olddir},$comment; |
|
598 $processed{$olddir} = 1; |
|
599 } |
|
600 |
|
601 exit(0); |
|
602 |
|
603 # Report on the accuracy of Schedule 12 |
|
604 print STDERR "\n"; |
|
605 my @allnames = (); |
|
606 my $unmatched = 0; |
|
607 foreach my $name (sort keys %sch12refs) |
|
608 { |
|
609 next if (defined $modelnames{$name}); |
|
610 push @allnames, "$name\t(Sch12 $foundationrefs{$name})\n"; |
|
611 print STDERR "No match for $name (associated with $foundationrefs{$name})\n"; |
|
612 $unmatched += 1; |
|
613 } |
|
614 if ($unmatched == 0) |
|
615 { |
|
616 print STDERR "All Schedule 12 entries matched in System Model\n"; |
|
617 } |
|
618 else |
|
619 { |
|
620 printf STDERR "%d Schedule 12 entry references not matched (from a total of %d)\n", $unmatched, scalar keys %sch12refs; |
|
621 } |
|
622 |
|
623 # Remove the matched elements to leave the unmatched parts, |
|
624 # and accumulate the MRP files for each Sch12 component |
|
625 |
|
626 my %sch12bymrp; |
|
627 my %locationbymrp; |
|
628 |
|
629 sub list_mrps($$$); # declare the prototype for recursive call |
|
630 sub list_mrps($$$) |
|
631 { |
|
632 my ($node,$location,$foundationname) = @_; |
|
633 my @children = $node->getChildNodes; |
|
634 my $nodename = $node->getAttribute("name"); |
|
635 |
|
636 my $sublocation = $nodename; |
|
637 $sublocation = "$location/$nodename" if ($location ne ""); |
|
638 |
|
639 foreach my $child (@children) |
|
640 { |
|
641 if ($child->getNodeTypeName ne "ELEMENT_NODE") |
|
642 { |
|
643 # text and comments don't count |
|
644 next; |
|
645 } |
|
646 my $tagname = $child->getTagName; |
|
647 if ($tagname eq "unit" || $tagname eq "package" || $tagname eq "prebuilt") |
|
648 { |
|
649 # these elements have the mrp information, but no substructure |
|
650 my $mrp = $child->getAttribute("mrp"); |
|
651 $mrp = $1 if ($mrp =~ /\\([^\\]+)\.mrp$/i); |
|
652 $foundationbymrp{$mrp} = $foundationname; |
|
653 $locationbymrp{$mrp} = "$location\t$nodename"; |
|
654 next; |
|
655 } |
|
656 my $submatch = $child->getAttribute("MATCHED"); |
|
657 if ($submatch) |
|
658 { |
|
659 list_mrps($child,$sublocation,$submatch); |
|
660 } |
|
661 else |
|
662 { |
|
663 list_mrps($child,$sublocation,$foundationname); |
|
664 } |
|
665 } |
|
666 } |
|
667 |
|
668 sub delete_matched($$); # declare the prototype for recursive call |
|
669 sub delete_matched($$) |
|
670 { |
|
671 my ($node, $location) = @_; |
|
672 my $nodename = $node->getAttribute("name"); |
|
673 |
|
674 my $sublocation = $nodename; |
|
675 $sublocation = "$location/$nodename" if ($location ne ""); |
|
676 |
|
677 my @children = $node->getChildNodes; |
|
678 return 0 if (scalar @children == 0); |
|
679 my $now_empty = 1; |
|
680 foreach my $child (@children) |
|
681 { |
|
682 if ($child->getNodeTypeName ne "ELEMENT_NODE") |
|
683 { |
|
684 # text and comments don't count |
|
685 next; |
|
686 } |
|
687 my $foundationname = $child->getAttribute("MATCHED"); |
|
688 if ($foundationname) |
|
689 { |
|
690 list_mrps($child, $sublocation, $foundationname); |
|
691 $node->removeChild($child) if ($remove); |
|
692 } |
|
693 else |
|
694 { |
|
695 if (delete_matched($child,$sublocation) == 1) |
|
696 { |
|
697 # Child was empty and can be removed |
|
698 $node->removeChild($child) if ($remove); |
|
699 } |
|
700 else |
|
701 { |
|
702 list_mrps($child, $sublocation, "*UNREFERENCED*"); |
|
703 $now_empty = 0; # something left in due to this child |
|
704 } |
|
705 } |
|
706 } |
|
707 return $now_empty; |
|
708 } |
|
709 |
|
710 # scan the tagged model, recording various details as a side-effect |
|
711 |
|
712 my $allgone = delete_matched($model,""); |
|
713 |
|
714 if ($cbrmappingfile ne "") |
|
715 { |
|
716 $componenttype{"*UNREFERENCED*"} = "??"; |
|
717 open CBRMAP, ">$cbrmappingfile" or die("Unable to write to $cbrmappingfile: $!\n"); |
|
718 foreach my $mrp (sort keys %sch12bymrp) |
|
719 { |
|
720 my $component = $foundationbymrp{$mrp}; |
|
721 my $comptype = $componenttype{$component}; |
|
722 my $location = $locationbymrp{$mrp}; |
|
723 print CBRMAP "$mrp\t$location\t$component\t$comptype\n"; |
|
724 } |
|
725 close CBRMAP; |
|
726 print STDERR "MRP -> Schedule 12 mapping written to $cbrmappingfile\n"; |
|
727 } |
|
728 |
|
729 exit 0; |
|