|
1 #!/bin/perl -w |
|
2 |
|
3 # Copyright (c) 2004-2009 Nokia Corporation and/or its subsidiary(-ies). |
|
4 # All rights reserved. |
|
5 # This component and the accompanying materials are made available |
|
6 # under the terms of "Eclipse Public License v1.0" |
|
7 # which accompanies this distribution, and is available |
|
8 # at the URL "http://www.eclipse.org/legal/epl-v10.html". |
|
9 # |
|
10 # Initial Contributors: |
|
11 # Nokia Corporation - initial contribution. |
|
12 # |
|
13 # Contributors: |
|
14 # |
|
15 # Description: |
|
16 # distillsrc.pm - compiles a list of source used in .mrp files, and deletes |
|
17 # any unused source |
|
18 # |
|
19 # |
|
20 |
|
21 package CDistillSrc; |
|
22 |
|
23 use strict; |
|
24 use File::Spec; |
|
25 use File::Path; |
|
26 use File::Basename; |
|
27 use FindBin; |
|
28 use lib $FindBin::Bin; |
|
29 use ReadMrp; |
|
30 |
|
31 use lib File::Spec->catdir($FindBin::Bin, '..', 'makecbr'); |
|
32 use CConfig; |
|
33 |
|
34 |
|
35 |
|
36 # Constructor |
|
37 # |
|
38 # Parameters: |
|
39 # |
|
40 # $aSrcRoot : The root from which all src statements are based |
|
41 # $aSrcPath : The path under aSrcRoot to the source tree to be processed |
|
42 # $aSrcPrefix : An optional prefix which can be stripped from all src statements |
|
43 # $aPlatform : e.g 'beech' - used to locate the platform specific product directory |
|
44 # |
|
45 # Returns: The object (or undef if there was a problem) |
|
46 # |
|
47 sub New($$$$) |
|
48 { |
|
49 my $proto = shift; |
|
50 my ($aSrcRoot, $aSrcPath, $aSrcPrefix, $aPlatform, $aCheckCase) = @_; |
|
51 |
|
52 my $class = ref($proto) || $proto; |
|
53 |
|
54 my $self = {}; |
|
55 bless($self, $class); |
|
56 |
|
57 my $error = 0; |
|
58 |
|
59 if (!defined($aSrcRoot)) |
|
60 { |
|
61 print "ERROR: RealTimeBuild: A srcroot must be given, to specify where all 'source' declarations originate from\n"; |
|
62 $error = 1; |
|
63 } |
|
64 |
|
65 if (!defined($aSrcPath)) |
|
66 { |
|
67 print "ERROR: RealTimeBuild: A srcpath must be given, to specify which source under the srcroot is to be filtered. Use '\\' to filter the entire srcroot\n"; |
|
68 $error = 1; |
|
69 } |
|
70 |
|
71 if (!defined($aPlatform)) |
|
72 { |
|
73 print "ERROR: RealTimeBuild: A platform must be given, to locate the product directory\n"; |
|
74 $error = 1; |
|
75 } |
|
76 |
|
77 if ($error) |
|
78 { |
|
79 print "\n"; |
|
80 } |
|
81 else |
|
82 { |
|
83 if ($aSrcPath =~ /\.\./) |
|
84 { |
|
85 print "ERROR: RealTimeBuild: The source path must be relative to the srcroot, and must not contain '..'\n"; |
|
86 $error = 1; |
|
87 } |
|
88 |
|
89 $self->iSrcRoot($aSrcRoot); |
|
90 $self->iSrcPath($aSrcPath); |
|
91 $self->iSrcPrefix($aSrcPrefix); |
|
92 $self->iPlatform($aPlatform); |
|
93 $self->iSrcItems({}); |
|
94 $self->iCheckCase(!!$aCheckCase); |
|
95 |
|
96 $self->AddSrcItem("os/buildtools/toolsandutils/productionbldtools/unref/orphan/cedprd/SuppKit", "non-shipped"); |
|
97 $self->AddSrcItem("os/buildtools/toolsandutils/productionbldtools/unref/orphan/cedprd/tools", "non-shipped"); |
|
98 $self->AddSrcItem("os/buildtools/toolsandutils/productionbldtools/unref/orphan/cedprd/DevKit", "non-shipped"); |
|
99 $self->AddSrcItem("os/buildtools/toolsandutils/productionbldtools", "non-shipped"); |
|
100 } |
|
101 |
|
102 if ($error) |
|
103 { |
|
104 $self = undef; |
|
105 } |
|
106 |
|
107 return $self; |
|
108 } |
|
109 |
|
110 # Object data |
|
111 # |
|
112 sub iSrcRoot() |
|
113 { |
|
114 my $self = shift; |
|
115 if (@_) { $self->{iSRCROOT} = shift; } |
|
116 return $self->{iSRCROOT}; |
|
117 } |
|
118 |
|
119 sub iSrcPath() |
|
120 { |
|
121 my $self = shift; |
|
122 if (@_) { $self->{iSRCPATH} = shift; } |
|
123 return $self->{iSRCPATH}; |
|
124 } |
|
125 |
|
126 sub iSrcPrefix() |
|
127 { |
|
128 my $self = shift; |
|
129 if (@_) { $self->{iSRCPREFIX} = shift; } |
|
130 return $self->{iSRCPREFIX}; |
|
131 } |
|
132 |
|
133 sub iPlatform() |
|
134 { |
|
135 my $self = shift; |
|
136 if (@_) { $self->{iPLATFORM} = shift; } |
|
137 return $self->{iPLATFORM}; |
|
138 } |
|
139 |
|
140 sub iSrcItems() |
|
141 { |
|
142 my $self = shift; |
|
143 if (@_) { $self->{iSRCITEMS} = shift; } |
|
144 return $self->{iSRCITEMS}; |
|
145 } |
|
146 |
|
147 sub iCheckCase() |
|
148 { |
|
149 my $self = shift; |
|
150 if (@_) { $self->{iCHECKCASE} = shift; } |
|
151 return $self->{iCHECKCASE}; |
|
152 } |
|
153 |
|
154 sub iCorrectedCase() |
|
155 { |
|
156 my $self = shift; |
|
157 if (@_) { $self->{iCORRECTEDCASE} = shift; } |
|
158 return $self->{iCORRECTEDCASE}; |
|
159 } |
|
160 |
|
161 # LoadMrps - Records the source lines out of all .mrp files |
|
162 # |
|
163 # Parameters: |
|
164 # $aConfig - optional configuration file, as used by makecbr |
|
165 # $aLists - optional component lists, as used by makecbr |
|
166 # $aMrps - optional .mrp files |
|
167 # |
|
168 # Returns: True, if the load was successful. False otherwise |
|
169 # |
|
170 sub LoadMrps($$$) |
|
171 { |
|
172 my $self = shift; |
|
173 my ($aConfig, $aLists, $aMrps) = @_; |
|
174 # Load in config file |
|
175 |
|
176 my @lists = @$aLists; |
|
177 my @mrps; |
|
178 foreach my $mrp (@$aMrps){ |
|
179 { |
|
180 push @mrps, [$mrp, '']; |
|
181 } |
|
182 } |
|
183 my @configMrps = (); |
|
184 if (defined($aConfig)) |
|
185 { |
|
186 my @configs = $self->_LoadConfig($aConfig); |
|
187 |
|
188 # Add mrps and lists (after planting them in srcroot) |
|
189 push @lists, map($self->_PlantFile($_), @{$configs[0]}); |
|
190 @configMrps = map($self->_PlantFile($_), @{$configs[1]}); |
|
191 foreach my $mrp (@configMrps) |
|
192 { |
|
193 push @mrps, [$mrp, '']; |
|
194 } |
|
195 } |
|
196 |
|
197 # Load in mrp lists |
|
198 foreach my $file (@lists) |
|
199 { |
|
200 if (open (MRPLIST, $file)) |
|
201 { |
|
202 foreach my $line (<MRPLIST>) |
|
203 { |
|
204 chomp $line; |
|
205 $line =~ s/#.*$//; # Remove comments |
|
206 $line =~ s/^\s*//; # Remove extraneous spaces |
|
207 $line =~ s/\s*$//; |
|
208 |
|
209 if ($line ne "") |
|
210 { |
|
211 my @parms = split(/\s+/, $line); |
|
212 |
|
213 if (scalar(@parms) != 2) |
|
214 { |
|
215 warn "ERROR: RealTimeBuild: Entries in component list '$file' should be of the form 'name mrp_location'. Problem in line: $line\n"; |
|
216 next; |
|
217 } |
|
218 else |
|
219 { |
|
220 # Ignore *nosource* entries |
|
221 next if ($parms[1] eq '*nosource*'); |
|
222 |
|
223 push @mrps, [$self->_PlantFile($parms[1]), $parms[0]]; |
|
224 } |
|
225 } |
|
226 } |
|
227 close MRPLIST or warn "ERROR: RealTimeBuild: Couldn't close '$file' : $!\n"; |
|
228 } |
|
229 else |
|
230 { |
|
231 warn "Couldn't open '$file' : $!\n"; |
|
232 } |
|
233 } |
|
234 |
|
235 # Load all .mrp files |
|
236 if (scalar(@mrps) == 0) |
|
237 { |
|
238 die "ERROR: RealTimeBuild: No .mrp files were specified\n"; |
|
239 } |
|
240 |
|
241 my $loaded = 1; |
|
242 |
|
243 foreach my $mrp (@mrps) |
|
244 { |
|
245 # Get path of mrp file (from here) |
|
246 my ($name, $path) = fileparse($mrp->[0]); |
|
247 # Convert to path from source root |
|
248 if (!($self->_RemoveBaseFromPath($self->iSrcRoot(), \$path))) |
|
249 { |
|
250 warn "ERROR: Mrp file $mrp->[0] isn't under the source root (".$self->iSrcRoot().")\n"; |
|
251 next; |
|
252 } |
|
253 |
|
254 my $mrpobj; |
|
255 |
|
256 # To indicate the correct case and where the .mrp file comes from if failed to check letter case |
|
257 if (!($self->_CheckCase($mrp->[0]))) { |
|
258 my $mrp_error_source = "optional component list(by -f) or optional .mrp list(by -m)"; |
|
259 foreach my $myName (@configMrps) { |
|
260 if ($myName eq $mrp->[0]) { |
|
261 $mrp_error_source = "config file '".$aConfig."'"; |
|
262 last; |
|
263 } |
|
264 } |
|
265 print "WARNING: Case of '".$mrp->[0]."' supplied in ".$mrp_error_source." does not match the file system. Should be ".$self->iCorrectedCase()."\n"; |
|
266 } |
|
267 |
|
268 if (!eval { $mrpobj = New ReadMrp($mrp->[0]) }) |
|
269 { |
|
270 $loaded = 0; |
|
271 my $message = $@; |
|
272 $message =~ s/^(ERROR:\s*)?/ERROR: RealTimeBuild: /i; |
|
273 print $message; |
|
274 } |
|
275 else |
|
276 { |
|
277 my $selfowned = 0; |
|
278 my $mrpComponentName = $mrpobj->GetComponent(); |
|
279 if( ($mrp->[1] ne '') && (lc($mrp->[1]) ne lc($mrpComponentName))) |
|
280 { |
|
281 print "ERROR: RealTimeBuild: Component name \'$mrp->[1]\' does not match \'$mrpComponentName\' in $mrp->[0]\n"; |
|
282 } |
|
283 foreach my $srcitem (@{$mrpobj->GetSrcItems()}) |
|
284 { |
|
285 if ($srcitem =~ /^[\/\\]/) |
|
286 { |
|
287 # Remove source prefix |
|
288 $srcitem = $self->_StripFile($srcitem); |
|
289 } |
|
290 else |
|
291 { |
|
292 # Relative source item |
|
293 $srcitem = File::Spec->catdir($path, $srcitem); |
|
294 } |
|
295 |
|
296 my $rootedmrp = $path.$name; |
|
297 if ($self->_RemoveBaseFromPath($srcitem, \$rootedmrp)) |
|
298 { |
|
299 $selfowned = 1; |
|
300 } |
|
301 |
|
302 $self->AddSrcItem($srcitem, $mrpComponentName); |
|
303 } |
|
304 if ($self->iCheckCase()) |
|
305 { |
|
306 foreach my $binexpitem (@{$mrpobj->GetBinExpItems()}) |
|
307 { |
|
308 # Check lower case |
|
309 if ($binexpitem =~ /[A-Z]/) |
|
310 { |
|
311 print "REMARK: [$mrpComponentName] Binary/export file $binexpitem should be lower case\n"; |
|
312 } |
|
313 } |
|
314 } |
|
315 |
|
316 if (!$selfowned) |
|
317 { |
|
318 print "REMARK: .mrp file '$mrp->[0]' does not include itself as source\n"; |
|
319 } |
|
320 } |
|
321 } |
|
322 return $loaded; |
|
323 } |
|
324 |
|
325 # AddSrcItem - Records a source file, usually taken from an .mrp file |
|
326 # |
|
327 # Parameters: |
|
328 # $aItem - the source file name |
|
329 # $aComponent - the name of the component which claimed the file |
|
330 # |
|
331 # Returns: None |
|
332 # Dies: Not normally; only if the source hash data structure gets corrupted |
|
333 sub AddSrcItem($$) |
|
334 { |
|
335 my $self = shift; |
|
336 my ($aItem, $aComponent) = @_; |
|
337 |
|
338 my $item = $aItem; |
|
339 |
|
340 # Worth checking that the file exists |
|
341 my $truePath = File::Spec->catdir($self->iSrcRoot(), $item); |
|
342 if (($item !~ /^\\component_defs/i) && (!-e $truePath)) |
|
343 { |
|
344 print "ERROR: RealTimeBuild: '$aComponent' owns $item, but that path doesn't exist\n"; |
|
345 $item = ""; # No point adding this path to the tree |
|
346 } |
|
347 else |
|
348 { |
|
349 # Check case consistency |
|
350 $self->_CheckCase($truePath) or print "WARNING: [$aComponent] Case of '".$truePath."' does not match the file system. Should be ".$self->iCorrectedCase()."\n"; |
|
351 } |
|
352 |
|
353 $item =~ s/^[\/\\]*//; # Remove preceding slashes |
|
354 |
|
355 my @path = split(/[\/\\]+/,$item); |
|
356 |
|
357 my $dir = $self->iSrcItems(); |
|
358 while ((scalar @path) > 0) |
|
359 { |
|
360 my $subdir = lc(shift @path); |
|
361 |
|
362 if (scalar(@path) == 0) |
|
363 { |
|
364 # Just enter the final path segment |
|
365 if (exists($dir->{$subdir})) |
|
366 { |
|
367 # Someone already owns at least part of this path |
|
368 if (!ref($dir->{$subdir})) |
|
369 { |
|
370 # Someone owns the whole of this path |
|
371 my $conflict = $dir->{$subdir}; |
|
372 |
|
373 print "REMARK: $aComponent and $conflict both own $item\n"; |
|
374 } |
|
375 else |
|
376 { |
|
377 if (ref($dir->{$subdir}) ne "HASH") |
|
378 { |
|
379 die "ERROR: Source hash is corrupted\n"; |
|
380 } |
|
381 else |
|
382 { |
|
383 # Someone owns a child of this path |
|
384 my $childtree = $dir->{$subdir}; |
|
385 |
|
386 my @conflicts = $self->_GetTreeComps($childtree); |
|
387 print "REMARK: $aComponent owns $item, which is already owned by the following component(s): ".join(", ",@conflicts)."\n"; |
|
388 } |
|
389 } |
|
390 } |
|
391 $dir->{$subdir} = $aComponent; |
|
392 } |
|
393 else |
|
394 { |
|
395 # Need to enter another subdirectory |
|
396 |
|
397 if (exists($dir->{$subdir})) |
|
398 { |
|
399 if (ref($dir->{$subdir})) |
|
400 { |
|
401 # Someone already has - just do a quick integrity check |
|
402 |
|
403 if (ref($dir->{$subdir}) ne "HASH") |
|
404 { |
|
405 die "ERROR: Source hash is corrupted\n"; |
|
406 } |
|
407 } |
|
408 else |
|
409 { |
|
410 # The path from this point on is already owned by a component |
|
411 my $conflict = $dir->{$subdir}; |
|
412 |
|
413 print "REMARK: $aComponent and $conflict both own $item\n"; |
|
414 last; |
|
415 } |
|
416 } |
|
417 else |
|
418 { |
|
419 $dir->{$subdir} = {}; |
|
420 } |
|
421 } |
|
422 |
|
423 $dir = $dir->{$subdir}; |
|
424 } |
|
425 } |
|
426 |
|
427 # DistillSrc - Compare the recorded source lines against the source path. Delete anything which doesn't match. |
|
428 # |
|
429 # Parameters: |
|
430 # $aDummy - A flag - non-zero means don't actually delete |
|
431 # |
|
432 # Returns: None |
|
433 sub DistillSrc($$) |
|
434 { |
|
435 my $self = shift; |
|
436 my ($aDummy) = @_; |
|
437 |
|
438 my $tree = $self->iSrcItems(); |
|
439 my $path = File::Spec->catdir($self->iSrcRoot(), $self->iSrcPath()); |
|
440 |
|
441 $path=~s/[\/\\]+/\\/; # Remove multiple slashes |
|
442 |
|
443 # Pop the srcpath off the front of the tree |
|
444 my @path = split(/[\/\\]/,$self->iSrcPath()); |
|
445 |
|
446 foreach my $dir (@path) |
|
447 { |
|
448 if ($dir eq ".") |
|
449 { |
|
450 next; |
|
451 } |
|
452 elsif (exists($tree->{lc($dir)})) |
|
453 { |
|
454 $tree = $tree->{lc($dir)}; |
|
455 |
|
456 if (!ref($tree)) |
|
457 { |
|
458 # Some component owns all of the srcpath |
|
459 last; |
|
460 } |
|
461 } |
|
462 else |
|
463 { |
|
464 # No mrp files claimed any of the source |
|
465 $tree = undef; |
|
466 last; |
|
467 } |
|
468 } |
|
469 |
|
470 # Now recurse into the tree and delete files |
|
471 if (defined($tree)) |
|
472 { |
|
473 if (ref($tree)) |
|
474 { |
|
475 $self->_DistillTree($tree, $path, $aDummy); |
|
476 } |
|
477 else |
|
478 { |
|
479 print "REMARK: All source owned by component '$tree'; no action\n"; |
|
480 } |
|
481 } |
|
482 else |
|
483 { |
|
484 print "WARNING: No .mrp files claim any source; removing $path\n"; |
|
485 $self->_DeletePath($path, $aDummy); |
|
486 } |
|
487 } |
|
488 |
|
489 # Print - Display the source tree |
|
490 # |
|
491 # Parameters: |
|
492 # $aDepth - The number of levels of the tree to show. 0 = all levels |
|
493 # |
|
494 # Returns: None |
|
495 sub Print($$) |
|
496 { |
|
497 my $self = shift; |
|
498 |
|
499 my ($aDepth) = @_; |
|
500 |
|
501 $self->_PrintTree("", $self->iSrcItems(), $aDepth); |
|
502 } |
|
503 |
|
504 # *** Private methods *** |
|
505 # *** |
|
506 |
|
507 # _LoadConfig - (private) Reads a configuration file, as used by makecbr |
|
508 # |
|
509 # Parameters: |
|
510 # $aConfig - filename of the configuration file |
|
511 # |
|
512 # Returns: |
|
513 # (files, mrps) - where files and mrps are listrefs containing component lists and |
|
514 # mrp files respectively |
|
515 # |
|
516 sub _LoadConfig($) |
|
517 { |
|
518 my $self = shift; |
|
519 my ($aConfig) = @_; |
|
520 |
|
521 my @files = (); |
|
522 my @mrps = (); |
|
523 |
|
524 my $config = New CConfig($aConfig); |
|
525 |
|
526 if (!defined $config) |
|
527 { |
|
528 die "Couldn't load config file '$aConfig'\n"; |
|
529 } |
|
530 |
|
531 # Extract the interesting items into our lists |
|
532 push @mrps, $config->Get("gt+techview baseline mrp location"); |
|
533 push @mrps, $config->Get("gt only baseline mrp location"); |
|
534 push @files, $config->Get("techview component list"); |
|
535 push @files, $config->Get("gt component list"); |
|
536 |
|
537 # Remove any items we couldn't find |
|
538 @mrps = grep(defined($_), @mrps); |
|
539 @files = grep(defined($_), @files); |
|
540 |
|
541 return (\@files, \@mrps); |
|
542 } |
|
543 |
|
544 # _StripFile - (private) Remover of src prefix. Also maps product directories |
|
545 # |
|
546 # Parameters: |
|
547 # $aFile - Filename to process |
|
548 # |
|
549 # Returns: The processed filename |
|
550 # |
|
551 sub _StripFile($) |
|
552 { |
|
553 my $self = shift; |
|
554 my ($aFile) = @_; |
|
555 |
|
556 my $file = $aFile; |
|
557 |
|
558 # Map the product dirs |
|
559 my $platform = $self->iPlatform(); |
|
560 $file =~ s#^[\/\\]?product[\/\\]#/sf/os/unref/orphan/cedprd/#i; |
|
561 |
|
562 # Remove the prefix |
|
563 my $prefix = $self->iSrcPrefix(); |
|
564 |
|
565 if (defined $prefix) |
|
566 { |
|
567 my $mapped = $file; # Keep a copy in case we can't remove the prefix |
|
568 |
|
569 if (!$self->_RemoveBaseFromPath($prefix, \$file)) |
|
570 { |
|
571 $file = $mapped; |
|
572 } |
|
573 } |
|
574 |
|
575 return $file; |
|
576 } |
|
577 |
|
578 # _PlantFile - (private) Add src root to file. Also take off src prefix |
|
579 # |
|
580 # Parameters: |
|
581 # $aFile - Filename to process |
|
582 # |
|
583 # Returns: The processed filename |
|
584 # |
|
585 sub _PlantFile($) |
|
586 { |
|
587 my $self = shift; |
|
588 my ($aFile) = @_; |
|
589 |
|
590 my $file = $aFile; |
|
591 |
|
592 # Remove the prefix |
|
593 $file = $self->_StripFile($file); |
|
594 |
|
595 # Plant the file in the src root |
|
596 $file = File::Spec->catdir($self->iSrcRoot(), $file); |
|
597 |
|
598 # Ensure all slashes are normalised to a single backslash |
|
599 $file =~ s/[\/\\]+/\\/; |
|
600 |
|
601 return $file; |
|
602 } |
|
603 |
|
604 # _RemoveBaseFromPath - (private) Remove a base path from the root of a filename. |
|
605 # |
|
606 # Parameters: |
|
607 # $aBase - The base path to remove |
|
608 # $$aFile - Filename to process (scalar reference) |
|
609 # |
|
610 # Returns: True if the file was under the base path, false otherwise |
|
611 # $$aFile may be corrupted if the return is false |
|
612 sub _RemoveBaseFromPath($) |
|
613 { |
|
614 my $self = shift; |
|
615 my ($aBase, $aFile) = @_; |
|
616 |
|
617 my $base = $aBase; |
|
618 $base =~ s/^[\/\\]*//; # Remove extra slashes |
|
619 $base =~ s/[\/\\]*$//; |
|
620 |
|
621 my @base = split(/[\/\\]+/, $base); |
|
622 |
|
623 $$aFile =~ s/^[\/\\]*//; # Remove preceding slashes |
|
624 |
|
625 my $matched = 1; |
|
626 my $filedir; |
|
627 |
|
628 foreach my $dir (@base) |
|
629 { |
|
630 if ($$aFile =~ /[\/\\]/) |
|
631 { |
|
632 # Split off the bottom dir |
|
633 $$aFile =~ /([^\/\\]*)[\/\\]+(.*)$/; |
|
634 ($filedir, $$aFile) = ($1, $2, $3); |
|
635 } |
|
636 else |
|
637 { |
|
638 # Special case - no more dirs |
|
639 $filedir = $$aFile; |
|
640 $$aFile = ""; |
|
641 } |
|
642 if (lc($filedir) ne lc($dir)) |
|
643 { |
|
644 # Base doesn't match |
|
645 $matched = 0; |
|
646 last; |
|
647 } |
|
648 } |
|
649 |
|
650 return $matched; |
|
651 } |
|
652 |
|
653 # _CheckCase - (private) Given a literal filename, compares the case of the |
|
654 # file on the filesystem against the filename i.e. it |
|
655 # can be used to enforce case sensitivity |
|
656 # |
|
657 # Parameters: |
|
658 # $aFilename - The literal filename |
|
659 # |
|
660 # Returns: True if the file matches the supplied case. |
|
661 # True if the file doesn't exist at all (user is expected to check that separately) |
|
662 # True if case checking has been disabled. |
|
663 # False otherwise (if the file exists but under a differing case). |
|
664 # |
|
665 # If false, the correctly cased name is present through $self->iCorrectedCase() |
|
666 sub _CheckCase($) |
|
667 { |
|
668 my $self = shift; |
|
669 my ($aFile) = @_; |
|
670 |
|
671 return 1 if !($self->iCheckCase()); # checking disabled |
|
672 return 1 if ($^O !~ /win32/i); # only works on Windows anyway |
|
673 |
|
674 return 1 if (!-e $aFile); # file not found (under case-insensitive checking) |
|
675 |
|
676 $self->iCorrectedCase(Win32::GetLongPathName($aFile)); |
|
677 return ($aFile eq $self->iCorrectedCase()); |
|
678 } |
|
679 |
|
680 # _DistillTree - (private) Given a src tree and a dir, clean out any unowned files |
|
681 # |
|
682 # Parameters: |
|
683 # %$aTree - The source tree (hash ref containing nested hash refs and string leaves) |
|
684 # $aDir - The directory to compare against |
|
685 # $aDummy - A flag - non-zero means don't do the actual deletion |
|
686 # |
|
687 # Returns: A flag - non-zero if there were any owned files present |
|
688 sub _DistillTree($$$) |
|
689 { |
|
690 my $self = shift; |
|
691 my ($aTree, $aDir, $aDummy) = @_; |
|
692 |
|
693 |
|
694 my $keptsome = 0; |
|
695 |
|
696 if (opendir(DIR, $aDir)) |
|
697 { |
|
698 my $dir = $aDir; |
|
699 $dir =~ s/[\/\\]*$//; # Remove trailing / from dir |
|
700 |
|
701 foreach my $entry (readdir(DIR)) |
|
702 { |
|
703 my $path = $dir."\\".$entry; |
|
704 |
|
705 if ($entry =~ /^\.\.?$/) |
|
706 { |
|
707 next; |
|
708 } |
|
709 elsif (exists $aTree->{lc($entry)}) |
|
710 { |
|
711 my $treeentry = $aTree->{lc($entry)}; |
|
712 if (ref($treeentry) eq "HASH") |
|
713 { |
|
714 # Part of this path is owned |
|
715 if (-d $path) |
|
716 { |
|
717 # Recurse into path |
|
718 my $keep = $self->_DistillTree($treeentry, $path, $aDummy); |
|
719 if ($keep) |
|
720 { |
|
721 $keptsome = 1; |
|
722 } |
|
723 else |
|
724 { |
|
725 # Correction; none of this path was owned |
|
726 $self->_DeletePath($path, $aDummy); |
|
727 } |
|
728 } |
|
729 elsif (-f $path) |
|
730 { |
|
731 my @comps = $self->_GetTreeComps($treeentry); |
|
732 print "ERROR: RealTimeBuild: $path is a file, yet is used as a directory in components: ".join(", ",@comps)."\n"; |
|
733 } |
|
734 else |
|
735 { |
|
736 print "ERROR: $path has disappeared while it was being examined\n"; |
|
737 } |
|
738 } |
|
739 elsif (!ref($treeentry)) |
|
740 { |
|
741 # This path is completely owned |
|
742 $keptsome = 1; |
|
743 next; |
|
744 } |
|
745 else |
|
746 { |
|
747 die "ERROR: Source hash is corrupted\n"; |
|
748 } |
|
749 } |
|
750 else |
|
751 { |
|
752 $self->_DeletePath($path, $aDummy); |
|
753 } |
|
754 } |
|
755 |
|
756 closedir(DIR); |
|
757 } |
|
758 else |
|
759 { |
|
760 warn "ERROR: RealTimeBuild: Couldn't open directory '$aDir' for reading\n"; |
|
761 } |
|
762 |
|
763 return $keptsome; |
|
764 } |
|
765 |
|
766 # _GetTreeComps - (private) Get all the leaves out of a tree (or component |
|
767 # names out of a source tree) |
|
768 # Parameters: |
|
769 # %$aTree - The source tree (hash ref containing nested hash refs and string leaves) |
|
770 # |
|
771 # Returns: A list of strings found at the leaves (or component names) |
|
772 sub _GetTreeComps($) |
|
773 { |
|
774 my $self = shift; |
|
775 my ($aTree) = @_; |
|
776 |
|
777 my @comps = (); |
|
778 |
|
779 foreach my $entry (keys(%$aTree)) |
|
780 { |
|
781 if (ref($aTree->{$entry}) eq "HASH") |
|
782 { |
|
783 push @comps, $self->_GetTreeComps($aTree->{$entry}); |
|
784 } |
|
785 elsif (!ref($aTree->{$entry})) |
|
786 { |
|
787 push @comps, $aTree->{$entry}; |
|
788 } |
|
789 else |
|
790 { |
|
791 die "ERROR: Source hash is corrupted\n"; |
|
792 } |
|
793 } |
|
794 |
|
795 return @comps; |
|
796 } |
|
797 |
|
798 # _DeletePath - (private) Safe path deletion (file or dir) |
|
799 # |
|
800 # $aPath - The path to delet |
|
801 # $aDummy - A flag - non-zero means don't actually delete |
|
802 # |
|
803 # Returns: None. Prints warnings if deletion fails. Dies only in exceptional circumstances |
|
804 sub _DeletePath($$) |
|
805 { |
|
806 my $self = shift; |
|
807 |
|
808 my ($aPath, $aDummy) = @_; |
|
809 |
|
810 if (-d $aPath) |
|
811 { |
|
812 if ($aDummy) |
|
813 { |
|
814 print "DUMMY: Directory $aPath is not specified in any .mrp file\n"; |
|
815 } |
|
816 else |
|
817 { |
|
818 print "REMARK: Deleting directory $aPath; "; |
|
819 my $files = rmtree($aPath); |
|
820 if ($files) |
|
821 { |
|
822 print "$files items removed\n"; |
|
823 } |
|
824 else |
|
825 { |
|
826 print "\nWARNING: Problem removing directory $aPath\n"; |
|
827 } |
|
828 } |
|
829 } |
|
830 elsif (-f $aPath) |
|
831 { |
|
832 if ($aDummy) |
|
833 { |
|
834 print "DUMMY: File $aPath is not specified in any .mrp file\n"; |
|
835 } |
|
836 else |
|
837 { |
|
838 unless($aPath =~ /distribution.policy.s60/i) |
|
839 { |
|
840 print "REMARK: Deleting file $aPath\n"; |
|
841 unlink $aPath or print "WARNING: Problem deleting file $aPath\n"; |
|
842 } |
|
843 } |
|
844 } |
|
845 else |
|
846 { |
|
847 warn "ERROR: Can't delete path $aPath; not a file or directory\n"; |
|
848 } |
|
849 } |
|
850 |
|
851 # _PrintTree - Display a subset of the source tree |
|
852 # |
|
853 # Parameters: |
|
854 # $aPrefix - The string to prefix all paths |
|
855 # $aDepth - The number of levels of the tree to show. 0 = all levels |
|
856 # |
|
857 # Returns: None |
|
858 sub _PrintTree($$$) |
|
859 { |
|
860 my $self = shift; |
|
861 |
|
862 my ($aPrefix, $aTree, $aDepth) = @_; |
|
863 |
|
864 my $prefix = ""; |
|
865 |
|
866 if ($aPrefix ne "") |
|
867 { |
|
868 $prefix = $aPrefix."\\"; |
|
869 } |
|
870 |
|
871 foreach my $key (sort(keys(%$aTree))) |
|
872 { |
|
873 if (ref($aTree->{$key})) |
|
874 { |
|
875 if ($aDepth!=1) |
|
876 { |
|
877 my $newprefix = $prefix.$key; |
|
878 |
|
879 if ($key eq "") |
|
880 { |
|
881 $newprefix.="{empty}"; |
|
882 } |
|
883 |
|
884 $self->_PrintTree($newprefix, $aTree->{$key}, $aDepth-1); |
|
885 } |
|
886 else |
|
887 { |
|
888 print $prefix.$key."\\...\n"; |
|
889 } |
|
890 } |
|
891 else |
|
892 { |
|
893 print $prefix.$key." = ".$aTree->{$key}."\n"; |
|
894 } |
|
895 } |
|
896 } |
|
897 |
|
898 1; |