This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use Getopt::Std::getopts() as it comes with all Perl 5 versions.
[metaconfig.git] / bin / mlint
CommitLineData
6092c506 1#!/usr/bin/perl
459d3fb5
MBT
2
3BEGIN { $ENV{LC_ALL} = "C"; }
a8ae8817
DH
4
5use FindBin;
a1e7d93d 6use Getopt::Std;
a8ae8817
DH
7
8$p5_metaconfig_base = "$FindBin::Bin/../";
9chdir "$p5_metaconfig_base/perl" ||
10 die "perl/ directory missing in $p5_metaconfig_base\n";
459d3fb5 11
ba12031e
DH
12-l '.package' && -l 'U' or
13 die ".package and U should be symlinks as per README\n";
14
459d3fb5
MBT
15# $Id: mlint.SH 22 2008-05-28 08:01:59Z rmanfredi $
16#
17# Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
18#
19# You may redistribute only under the terms of the Artistic Licence,
20# as specified in the README file that comes with the distribution.
21# You may reuse parts of this distribution only within the terms of
22# that same Artistic Licence; a copy of which may be found at the root
23# of the source tree for dist 4.0.
24#
25# Original Author: Harlan Stenn <harlan@mumps.pfcs.com>
26#
27# $Log: mlint.SH,v $
28# Revision 3.0.1.3 1994/05/06 15:20:42 ram
29# patch23: added -L switch to override public unit repository path
30#
31# Revision 3.0.1.2 1994/01/24 14:21:00 ram
32# patch16: added ~/.dist_profile awareness
33#
34# Revision 3.0.1.1 1993/08/19 06:42:27 ram
35# patch1: leading config.sh searching was not aborting properly
36#
37# Revision 3.0 1993/08/18 12:10:17 ram
38# Baseline for dist 3.0 netwide release.
39#
40
41# Perload ON
42
a8ae8817 43$MC = "$p5_metaconfig_base/dist";
459d3fb5
MBT
44$version = '3.5';
45$patchlevel = '0';
46$grep = '/usr/bin/grep';
47&profile; # Read ~/.dist_profile
a1e7d93d 48&usage unless getopts("hklVL:oOs");
459d3fb5
MBT
49
50if ($opt_V) {
51 print STDERR "metalint $version PL$patchlevel\n";
52 exit 0;
53} elsif ($opt_h) {
54 &usage;
55}
56
57chop($date = `date`);
58$MC = $opt_L if $opt_L; # May override library path
59$MC = &tilda_expand($MC); # ~name expansion
60chop($WD = `pwd`); # Working directory
61chdir $MC || die "Can't chdir to $MC: $!\n";
62chop($MC = `pwd`); # Real metalint lib path (no symbolic links)
63chdir $WD || die "Can't chdir back to $WD: $!\n";
64
65&init; # Various initializations
66`mkdir .MT 2>&1` unless -d '.MT'; # For private temporary files
67
68&locate_units; # Fill in @ARGV with a unit list
69&extract_dependencies; # Extract dependencies from units
70&sanity_checks; # Perform sanity checks
71
72if ($opt_k) {
73 print "Leaving subdirectory .MT unremoved so you can peruse it.\n"
74 unless $opt_s;
75} else {
76 `rm -rf .MT 2>&1`;
77}
78print "Done.\n" unless $opt_s;
79
80# General initializations
81sub init {
82 &init_except; # Token which have upper-cased letters
83 &init_depend; # The %Depend array records control line handling
84}
85
86# Record the exceptions -- all symbols but these are lower case
87sub init_except {
88 $Except{'Author'}++;
89 $Except{'Date'}++;
90 $Except{'Header'}++;
91 $Except{'Id'}++;
92 $Except{'Locker'}++;
93 $Except{'Log'}++;
94 $Except{'RCSfile'}++;
95 $Except{'Revision'}++;
96 $Except{'Source'}++;
97 $Except{'State'}++;
98}
99
100# Print out metalint's usage and exits
101sub usage {
102 print STDERR <<EOM;
103Usage: metalint [-hklsV] [-L dir]
104 -h : print this help message and exits.
105 -k : keep temporary directory.
106 -l : also report problems from library units.
107 -s : silent mode.
108 -L : specify main units repository.
109 -V : print version number and exits.
110EOM
111 exit 1;
112}
113
114package locate;
115
116# Locate the units and push their path in @ARGV (sorted alphabetically)
117sub main'locate_units {
118 print "Locating units...\n" unless $main'opt_s;
119 local(*WD) = *main'WD; # Current working directory
120 local(*MC) = *main'MC; # Public metaconfig library
121 undef %myUlist; # Records private units paths
122 undef %myUseen; # Records private/public conflicts
123 &private_units; # Locate private units in @myUlist
124 &public_units; # Locate public units in @ARGV
125 @ARGV = sort @ARGV; # Sort it alphabetically
126 push(@ARGV, sort @myUlist); # Append user's units sorted
127 &dump_list if $main'opt_v; # Dump the list of units
128}
129
130# Dump the list of units on stdout
131sub dump_list {
132 print "\t";
133 $, = "\n\t";
134 print @ARGV;
135 $, = '';
136 print "\n";
137}
138
139# Scan private units
140sub private_units {
141 return unless -d 'U'; # Nothing to be done if no 'U' entry
142 local(*ARGV) = *myUlist; # Really fill in @myUlist
143 local($MC) = $WD; # We are really in the working directory
144 &units_path("U"); # Locate units in the U directory
145 local($unit_name); # Unit's name (without .U)
146 local(@kept); # Array of kept units
147 # Loop over the units and remove duplicates (the first one seen is the one
148 # we keep). Also set the %myUseen H table to record private units seen.
149 foreach (@ARGV) {
150 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
151 next if $myUseen{$unit_name}; # Already recorded
152 $myUseen{$unit_name} = 1; # Record pirvate unit
153 push(@kept, $_); # Keep this unit
154 }
155 @ARGV = @kept;
156}
157
158# Scan public units
159sub public_units {
160 chdir($MC) || die "Can't find directory $MC.\n";
161 &units_path("U"); # Locate units in public U directory
162 chdir($WD) || die "Can't go back to directory $WD.\n";
163 local($path); # Relative path from $WD
164 local($unit_name); # Unit's name (without .U)
165 local(*Unit) = *main'Unit; # Unit is a global from main package
166 local(@kept); # Units kept
167 local(%warned); # Units which have already issued a message
168 # Loop over all the units and keep only the ones that were not found in
169 # the user's U directory. As it is possible two or more units with the same
170 # name be found in
171 foreach (@ARGV) {
172 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
173 next if $warned{$unit_name}; # We have already seen this unit
174 $warned{$unit_name} = 1; # Remember we have warned the user
175 if ($myUseen{$unit_name}) { # User already has a private unit
176 $path = $Unit{$unit_name}; # Extract user's unit path
177 next if $path eq $_; # Same path, we must be in mcon/
178 $path =~ s|^$WD/||o; # Weed out leading working dir path
179 $::opt_O and next;
180 print " Your private $path overrides the public one.\n"
181 unless $main'opt_s;
182 } else {
183 push(@kept, $_); # We may keep this one
184 }
185 }
186 @ARGV = @kept;
187}
188
189# Recursively locate units in the directory. Each file ending with .U has to be
190# a unit. Others are stat()'ed, and if they are a directory, they are also
191# scanned through. The $MC and @ARGV variable are dynamically set by the caller.
192sub units_path {
193 local($dir) = @_; # Directory where units are to be found
194 local(@contents); # Contents of the directory
195 local($unit_name); # Unit's name, without final .U
196 local($path); # Full path of a unit
197 local(*Unit) = *main'Unit; # Unit is a global from main package
198 unless (opendir(DIR, $dir)) {
199 warn("Cannot open directory $dir.\n");
200 return;
201 }
202 print "Locating in $MC/$dir...\n" if $main'opt_v;
203 @contents = readdir DIR; # Slurp the whole thing
204 closedir DIR; # And close dir, ready for recursion
205 foreach (@contents) {
206 next if $_ eq '.' || $_ eq '..';
207 if (/\.U$/) { # A unit, definitely
208 ($unit_name) = /^(.*)\.U$/;
209 $path = "$MC/$dir/$_"; # Full path of unit
210 push(@ARGV, $path); # Record its path
211 if (defined $Unit{$unit_name}) { # Already seen this unit
212 if ($main'opt_v) {
213 ($path) = $Unit{$unit_name} =~ m|^(.*)/.*|;
214 print " We've already seen $unit_name.U in $path.\n";
215 }
216 } else {
217 $Unit{$unit_name} = $path; # Map name to path
218 }
219 next;
220 }
221 # We have found a file which does not look like a unit. If it is a
222 # directory, then scan it. Otherwise skip the file.
223 unless (-d "$dir/$_") {
224 print " Skipping file $_ in $dir.\n" if $main'opt_v;
225 next;
226 }
227 &units_path("$dir/$_");
228 print "Back to $MC/$dir...\n" if $main'opt_v;
229 }
230}
231
232package main;
233
234# Initialize the extraction process by setting some variables.
235# We return a string to be eval'ed to do more customized initializations.
236sub init_extraction {
237 $c_symbol = ''; # Current symbol seen in ?C: lines
238 $s_symbol = ''; # Current symbol seen in ?S: lines
239 $m_symbol = ''; # Current symbol seen in ?M: lines
240 $h_section = 0; # 0 = no ?H: yet, 1 = in ?H:, 2 = ?H:. seen
241 $h_section_warned = 0; # Whether we warned about terminated ?H: section
242 $heredoc = ''; # Last "here" document symbol seen
243 $heredoc_nosubst = 0; # True for <<'EOM' here docs
244 $heredoc_line = 0; # Line were last "here" document started
245 $last_interpreted = 0; # True when last line was an '@' one
246 $past_first_line = 0; # True when first body line was already seen
247 $wiped_unit = 0; # True if unit will be "wiped" for macro subst
248 %csym = (); # C symbols described
249 %ssym = (); # Shell symbols described
250 %hcsym = (); # C symbols used by ?H: lines
251 %hssym = (); # Shell symbols used by ?H: lines
252 %msym = (); # Magic symbols defined by ?M: lines
253 %mdep = (); # C symbol dependencies introduced by ?M:
254 %symset = (); # Records all the shell symbol set
255 %symused = (); # Records all the shell symbol used
256 %tempseen = (); # Temporary shell variable seen
257 %fileseen = (); # Produced files seen
258 %fileused = (); # Files used, by unit (private UU files)
259 %filemisused = (); # Files not used as ./file or ...UU/file
260 %filetmp = (); # Local temporary files in ?F: directives
261 %filesetin = (); # Lists units defining a temporary file
262 %filecreated = (); # Records files created in this unit
263 %prodfile = (); # Unit where a given file is said to be created
264 %defseen = (); # Symbol defintions claimed
265 %lintset = (); # Symbols declared set by a ?LINT: line
266 %lintsdesc = (); # Symbols declared described by a ?LINT: line
267 %lintcdesc = (); # Symbols declared described by a ?LINT: line
268 %lintseen = (); # Symbols declared known by a ?LINT: line
269 %lintchange = (); # Symbols declared changed by a ?LINT: line
270 %lintuse = (); # Symbols declared used by unit
271 %lintextern = (); # Symbols known to be externally defined
272 %lintcreated = (); # Files declared as created by a ?LINT: line
273 %linthere = (); # Unclosed here document from ?LINT: line
274 %lintnothere = (); # False here document names, from ?LINT: line
275 %lintfused = (); # Records files markedas used in ?LINT: line
276 %lintchange_used = (); # Tracks symbols for which %lintchange was used
277 %lintuse_used = (); # Tracks symbols for which %lintuse was used
278 %lintseen_used = (); # Tracks symbols for which %lintseen was used
279 %lintcdesc_used = (); # Tracks symbols for which %lintcdesc was used
280 %lintsdesc_used = (); # Tracks symbols for which %lintsdesc was used
281 %lintset_used = (); # Tracks symbols for which %lintset was used
282 %lintnocomment = (); # Signals it's OK for unit to lack a : comment
283 %condsym = (); # Records all the conditional symbols
284 %condseen = (); # Records conditional dependencies
285 %depseen = (); # Records full dependencies
286 %shvisible = (); # Records units making a symbol visible
287 %shspecial = (); # Records special units listed as wanted
288 %shdepend = (); # Records units listed in one's dependency list
289 %shmaster = (); # List of units defining a shell symbol
290 %cmaster = (); # List of units defining a C symbol
291 %symdep = (); # Records units where symbol is a dependency
292 @make = (); # Records make dependency lines
293 $body = 'p_body'; # Procedure to handle body
294 $ending = 'p_end'; # Called at the end of each unit
295 @wiping = qw( # The keywords we recognize for "wiped" units
296 PACKAGENAME
297 MAINTLOC
298 VERSION
299 PATCHLEVEL
300 DATE
301 BASEREV
302 );
303}
304
305# End the extraction process
306sub end_extraction {
307}
308
0e8e6dd2
MBT
309# Process the command line of ?MAKE: lines
310sub p_make_command {
311 local ($_) = @_;
312 my $where = "\"$file\", line $. (?MAKE:)";
313 unless (s/^\t+//) {
314 warn "$where: command line must start with a leading TAB character.\n";
315 s/^\s+//; # Remove spaces and continue
316 }
317 return unless s/^-?pick\b//;
318 # Validate the special "pick" make command, processed internally
319 # by metaconfig.
320 my %valid = map { $_ => 1 } qw(
321 add add.Config_sh add.Null
322 c_h_weed cm_h_weed close.Config_sh
323 prepend weed wipe
324
325 );
326 my $cmd;
327 $cmd = $1 if s/^\s+(\S+)//;
328 unless (defined $cmd) {
329 warn "$where: pick needs a command argument.\n";
330 return;
331 }
332 $wiped_unit++ if $cmd eq 'wipe';
333 warn "$where: unknown pick command '$cmd'.\n" unless $valid{$cmd};
334 s/^\s+//;
335 unless (s/^\$\@//) {
336 warn "$where: third pick argument must be \$\@\n";
337 return;
338 }
339 s/^\s+//;
340 my $target;
341 $target = $1 if s/^(\S+)//;
342 unless (defined $target) {
343 warn "$where: fourth pick argument is missing\n";
344 return;
345 }
346 return if $target =~ m|^\./|;
347 warn "$where: weird fourth argument '$target' to pick.\n"
348 unless $target =~ /^\w+$/;
349}
350
459d3fb5
MBT
351# Process the ?MAKE: line
352sub p_make {
353 local($_) = @_;
354 local(@ary); # Locally defined symbols
355 local(@dep); # Dependencies
356 local($where) = "\"$file\", line $. (?MAKE:)";
357 unless (/^[\w+ ]*:/) {
0e8e6dd2 358 &p_make_command;
459d3fb5
MBT
359 return; # We only want the main dependency rule
360 }
361 warn "$where: ignoring duplicate dependency listing line.\n"
362 if $makeseen{$unit}++;
363 return if $makeseen{$unit} > 1;
364
365 # Reset those once for every unit
366 # (assuming there is only one depend line)
367 $h_section = 0; # 0 = no ?H: yet, 1 = in ?H:, 2 = ?H:. seen
368 $h_section_warned = 0; # Whether we warned about terminated ?H: section
369 $wiped_unit = 0; # Whether macros like "<MAINTLOC> will be wiped
370 undef %condseen;
371 undef %depseen;
372 undef %defseen;
373 undef %tempseen;
374 undef %symset;
375 undef %symused;
376 undef %csym;
377 undef %ssym;
378 undef %hcsym;
379 undef %hssym;
380 undef %lintuse;
381 undef %lintuse_used;
382 undef %lintseen;
383 undef %lintchange;
384 undef %lintchange_used;
385 undef %lintextern;
386 undef %lintcreated;
387 undef %fileseen;
388 undef %lintseen_used;
389 undef %filetmp;
390 undef %filecreated;
391 undef %linthere;
392 undef %lintnothere;
393 undef %lintfused;
394 undef %lintsdesc;
395 undef %lintsdesc_used;
396 undef %lintcdesc;
397 undef %lintcdesc_used;
398 undef %lintset;
399 undef %lintset_used;
400
401 s|^\s*||; # Remove leading spaces
402 chop;
403 s/:(.*)//;
404 @dep = split(' ', $1); # Dependencies
405 @ary = split(' '); # Locally defined symbols
406 local($nowarn); # True when +Special is seen
407 foreach $sym (@ary) {
408 # Ignore "internal use only" symbols as far as metalint goes.
409 # Actually, we record the presence of a '+' in front of a special
410 # unit name and use that as a hint to suppress the presence of that
411 # special unit in the defined symbol section.
412 $nowarn = ($sym =~ s/^\+//);
413
414 # We record for each shell symbol the list of units which claim to make
415 # it, so as to report duplicates.
416 if ($sym =~ /^[_a-z]/ || $Except{$sym}) {
417 $shmaster{"\$$sym"} .= "$unit ";
418 ++$defseen{$sym};
419 } else {
420 warn "$where: special unit '$sym' should not be listed as made.\n"
421 unless $sym eq $unit || $nowarn;
422 }
423 }
424 # Record dependencies for later perusal
425 push(@make, join(' ', @ary) . ':' . join(' ', @dep));
426 foreach $sym (@dep) {
427 if ($sym =~ /^\+[_A-Za-z]/) {
428 $sym =~ s|^\+||;
429 ++$condseen{$sym}; # Conditional symbol wanted
430 ++$condsym{$sym}; # %condsym has a greater lifetime
431 } else {
432 ++$depseen{$sym}; # Full dependency
433 }
434
435 # Each 'wanted' special unit (i.e. one starting with a capital letter)
436 # is remembered, so as to prevent exported symbols from being reported
437 # as "undefined". For instance, Myread exports $dflt, $ans and $rp.
438 $shspecial{$unit} .= "$sym " if substr($sym, 0, 1) =~ /^[A-Z]/;
439
440 # Record all known dependencies (special or not) for this unit
441 $shdepend{$unit} .= "$sym ";
442
443 # Remember where wanted symbol is defined, so that we can report
444 # stale dependencies later on (i.e. dependencies which refer to non-
445 # existent symbols).
446 $symdep{$sym} .= "$unit "; # This symbol is wanted here
447 }
448 # Make sure we do not want a symbol twice, nor do we want it once as a full
449 # dependency and once as a conditional dependency.
450 foreach $sym (@dep) {
451 if ($sym =~ /^\+[_A-Za-z]/) {
452 $sym =~ s|^\+||;
453 warn "$where: '+$sym' is listed $condseen{$sym} times.\n"
454 if $condseen{$sym} > 1;
455 $condseen{$sym} = 1 if $condseen{$sym}; # Avoid multiple messages
456 } else {
457 warn "$where: '$sym' is listed $depseen{$sym} times.\n"
458 if $depseen{$sym} > 1;
459 $depseen{$sym} = 1 if $depseen{$sym}; # Avoid multiple messages
460 }
461 warn "$where: '$sym' listed as both conditional and full dependency.\n"
462 if $condseen{$sym} && $depseen{$sym};
463 }
464 # Make sure every unit "inherits" from the symbols exported by 'Init'.
465 $shspecial{$unit} .= 'Init ' unless $shspecial{$unit} =~ /Init\b/;
466}
467
468# Process the ?O: line
469sub p_obsolete {
470 local($_) = @_;
471 chop;
472 $Obsolete{"$unit.U"} = $_; # Message to print if unit is used
473}
474
475# Process the ?S: lines
476sub p_shell {
477 local($_) = @_;
478 local($where) = "\"$file\", line $. (?S:)";
479 warn "$where: directive should come after ?MAKE declarations.\n"
480 unless $makeseen{$unit};
481 if (/^(\w+)\s*(\(.*\))*\s*:/) {
482 &check_last_declaration;
483 $s_symbol = $1;
484 print " ?S: $s_symbol\n" if $opt_d;
485 # Make sure we do not define symbol twice and that the symbol is indeed
486 # listed in the ?MAKE: line.
487 warn "$where: duplicate description for variable '\$$s_symbol'.\n"
488 if $ssym{$s_symbol}++;
489 unless ($defseen{$s_symbol}) {
490 warn "$where: variable '\$$s_symbol' is not listed " .
491 "on ?MAKE: line.\n" unless $lintseen{$s_symbol};
492 $lintseen_used{$s_symbol}++ if $lintseen{$s_symbol};
493 }
494 # Deal with obsolete symbol list (enclosed between parenthesis)
495 &record_obsolete("\$$_") if /\(/;
496 } else {
497 unless ($s_symbol) {
498 warn "$where: syntax error in ?S: construct.\n";
499 return;
500 }
501 }
502
503 m|^\.\s*$| && ($s_symbol = ''); # End of comment
504}
505
506# Process the ?C: lines
507sub p_c {
508 local($_) = @_;
509 local($where) = "\"$file\", line $. (?C:)";
510 warn "$where: directive should come after ?MAKE declarations.\n"
511 unless $makeseen{$unit};
512 # The previous ?H: section, if present, must have been closed
513 if ($h_section && $h_section != 2) {
514 warn "$where: unclosed ?H: section.\n";
515 }
516 $h_section = 0;
517 if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) {
518 &check_last_declaration;
519 $c_symbol = $2; # Alias for definition in config.h
520 # Record symbol definition for further duplicate spotting
521 $cmaster{$1} .= "$unit " unless $csym{$1};
522 print " ?C: $1 ~ $c_symbol\n" if $opt_d;
523 # Make sure we do not define symbol twice
524 warn "$where: duplicate description for symbol '$1'.\n"
525 if $csym{$1}++;
526 # Deal with obsolete symbol list (enclosed between parenthesis)
527 &record_obsolete("$_") if /\(/;
528 } elsif (/^(\w+)\s*(\(.*\))*\s*:/) {
529 &check_last_declaration;
530 $c_symbol = $1;
531 # Record symbol definition for further duplicate spotting
532 $cmaster{$c_symbol} .= "$unit " unless $csym{$c_symbol};
533 print " ?C: $c_symbol\n" if $opt_d;
534 # Make sure we do not define symbol twice
535 warn "$where: duplicate description for symbol '$c_symbol'.\n"
536 if $csym{$c_symbol}++;
537 # Deal with obsolete symbol list (enclosed between parenthesis)
538 &record_obsolete("$_") if /\(/;
539 } else {
540 unless ($c_symbol) {
541 warn "$where: syntax error in ?C: construct.\n";
542 return;
543 }
544 }
545
546 s|^(\w+)|?$c_symbol:/* $1| || # Start of comment
547 (s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) || # End of comment
548 s|^(.*)|?$c_symbol: *$1|; # Middle of comment
549}
550
551# Process the ?H: lines
552sub p_config {
553 local($_) = @_;
554 local($where) = "\"$file\", line $. (?H)" unless $where;
555 warn "$where: directive should come after ?MAKE declarations.\n"
556 unless $makeseen{$unit};
557 unless ($h_section){ # Entering ?H: section
558 $h_section = 1;
559 $h_section_warned = 0;
560 }
561 if ($h_section == 2) {
562 warn "$where: section was already terminated by '?H:.'.\n"
563 unless $h_section_warned++;
564 return;
565 }
566 if ($_ eq ".\n") {
567 $h_section = 2; # Marks terminated ?H: section
568 return;
569 }
570 (my $constraint) = m/^\?(\w+):/;
571 s/^\?\w+://; # Remove leading '?var:' constraint
572 if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) {
573 # Case: #$d_var VAR "$var"
574 warn "$where: symbol '$2' was already defined.\n" if $hcsym{$2}++;
575 &check_definition("$1");
576 &check_definition("$3");
577 } elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) {
578 # Case: #define VAR(x) $var
579 warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++;
580 &check_definition("$3");
581 } elsif (m|^#\$define\s+(\w+)|) {
582 # Case: #$define VAR
583 warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++;
584 } elsif (m|^#\$(\w+)\s+(\w+)|) {
585 # Case: #$d_var VAR
586 warn "$where: symbol '$2' was already defined.\n" if $hcsym{$2}++;
587 &check_definition("$1");
588 } elsif (m|^#define\s+(\w+).*\$(\w+)|) {
589 # Case: #define VAR "$var"
590 warn "$where: symbol '$1' was already defined.\n" if $hcsym{$1}++;
591 &check_definition("$2");
592 } elsif (m|^#define\s+(\w+)|) {
593 # Case: #define VAR
594 $hcsym{$1}++; # Multiple occurrences may be legitimate
595 } else {
596 if (/^#/) {
597 warn "$where: uncommon cpp line should be protected with '?%<:'.\n"
598 if $constraint eq '';
599 } elsif (!/^\@(if|elsif|else|end)\b/) {
600 warn "$where: line should not be listed here but in '?C:'.\n";
601 }
602 }
603
604 # Ensure the constraint is either %< (unit base name) or a known symbol.
605 if ($constraint ne '' && $constraint ne $unit) {
606 warn "$where: constraint '$constraint' is an unknown symbol.\n"
607 unless $csym{$constraint} || $ssym{$constraint};
608 }
609}
610
611# Process the ?M: lines
612sub p_magic {
613 local($_) = @_;
614 local($where) = "\"$file\", line $. (?M)";
615 warn "$where: directive should come after ?MAKE declarations.\n"
616 unless $makeseen{$unit};
617 if (/^(\w+):\s*([\w\s]*)\n$/) {
618 &check_last_declaration;
619 $m_symbol = $1;
620 $msym{$1} = "$unit"; # p_wanted ensure we do not define symbol twice
621 $mdep{$1} = $2; # Save C symbol dependencies
622 &p_wanted("$unit:$m_symbol");
623 } else {
624 unless ($m_symbol) {
625 warn "$where: syntax error in ?M: construct.\n";
626 return;
627 }
628 }
629 m|^\.\s*$| && ($m_symbol = ''); # End of comment
630}
631
632# Process the ?INIT: lines
633sub p_init {
634 local($_) = @_;
635 local($where) = "\"$file\", line $. (?INIT)";
636 warn "$where: directive should come after ?MAKE declarations.\n"
637 unless $makeseen{$unit};
638 &p_body($_, 1); # Pass it along as a body line (leading ?INIT: removed)
639}
640
641# Process the ?D: lines
642sub p_default {
643 local($_) = @_;
644 local($where) = "\"$file\", line $. (?D)";
645 warn "$where: directive should come after ?MAKE declarations.\n"
646 unless $makeseen{$unit};
647 local($sym) = /^(\w+)=/;
648 $hasdefault{$sym}++;
649 unless ($defseen{$sym}) {
650 warn "$where: variable '\$$sym' is not listed " .
651 "on ?MAKE: line.\n" unless $lintseen{$sym};
652 $lintseen_used{$sym}++ if $lintseen{$sym};
653 }
654 s/^\w+=//; # So that p_body does not consider variable as being set
655 &p_body($_, 1); # Pass it along as a body line (leading ?D: + var removed)
656}
657
658# Process the ?V: lines
659sub p_visible {
660 local($where) = "\"$file\", line $. (?V)";
661 warn "$where: directive should come after ?MAKE declarations.\n"
662 unless $makeseen{$unit};
663
664 # A visible symbol can freely be manipulated by any unit which includes the
665 # current unit in its dependencies. Symbols before ':' may be only used for
666 # reading while symbols after ':' may be used for both reading and writing.
667 # The array %shvisible records symbols as keys. Read-only symbols have a
668 # leading '$' while read-write symbols are recorded as-is.
669
670 unless (substr($unit, 0, 1) =~ /^[A-Z]/) {
671 warn "$where: visible declaration in non-special unit ignored.\n";
672 return;
673 }
674 local($read_only) = $_[0] =~ /^([^:]*):?/;
675 local($read_write) = $_[0] =~ /:(.*)/;
676 local(@rsym) = split(' ', $read_only);
677 local(@rwsym) = split(' ', $read_write);
678 local($w);
679 foreach (@rsym) { # Read only symbols
680 warn "$where: wanted variable '\$$_' made visible.\n" if &wanted($_);
681 warn "$where: defined variable '\$$_' made visible.\n"
682 if &defined($_) && !$lintseen{$_};
683 $w = $shvisible{"\$$_"};
684 warn "$where: variable '\$$_' already made visible by unit $w.\n" if $w;
685 $w = $shvisible{$_};
686 warn "$where: variable '\$$_' already read-write visible in $w.\n" if $w;
687 $shvisible{"\$$_"} = $unit unless $w;
688 }
689 foreach (@rwsym) { # Read/write symbols
690 warn "$where: wanted variable '\$$_' made visible.\n" if &wanted($_);
691 warn "$where: defined variable '\$$_' made visible.\n"
692 if &defined($_) && !$lintseen{$_};
693 $w = $shvisible{$_};
694 warn "$where: variable '\$$_' already made visible by unit $w.\n" if $w;
695 $w = $shvisible{"\$$_"};
696 warn "$where: variable '\$$_' already read-only visible in $w.\n" if $w;
697 $shvisible{$_} = $unit unless $w;
698 }
699}
700
701# Process the ?W: lines
702sub p_wanted {
703 local($where) = "\"$file\", line $. (?W)" unless $where;
704 warn "$where: directive should come after ?MAKE declarations.\n"
705 unless $makeseen{$unit};
706 # Somehow, we should check that none of the symbols to activate are stale
707 # ones, i.e. they all finally resolve to some known target -- FIXME
708 local($active) = $_[0] =~ /^([^:]*):/; # Symbols to activate
709 local($look_symbols) = $_[0] =~ /:(.*)/; # When those are used
710 local(@symbols) = split(' ', $look_symbols);
711 # A "?W:symbol" line asks metaconfig to define 'symbol' in the wanted file
712 # as a C target iff that word is found within the sources. This is mainly
713 # intended for the built-in interpreter to check for definedness.
714 local($w);
715 foreach (@symbols) {
716 warn "$where: variable '\$$_' already wanted.\n" if &wanted($_);
717 warn "$where: variable '\$$_' also locally defined.\n" if &defined($_);
718 $w = $cwanted{$_};
719 if ($msym{$_} ne '') {
720 warn "$where: symbol '$_' already listed on a ?M: line in '$w'.\n"
721 if $w;
722 } else {
723 warn "$where: variable '\$$_' already listed on a ?W: line in '$w'.\n"
724 if $w;
725 }
726 $cwanted{$_} = $unit unless $w;
727 }
728}
729
730# Process the ?Y: lines
731sub p_layout {
732 local($where) = "\"$file\", line $. (?Y)";
733 warn "$where: directive should come after ?MAKE declarations.\n"
734 unless $makeseen{$unit};
735 local($_) = @_;
736 chop;
737 s/^\s+//;
738 tr/A-Z/a-z/; # Layouts are record in lowercase
739 warn "$where: unknown layout directive '$_'.\n"
740 unless defined $Lcmp{$_};
741}
742
743# Process the ?P: lines
744sub p_public {
745 # FIXME
746}
747
748# Process the ?L: lines
749sub p_library {
750 # There should not be any '-l' in front of the library name
751 # FIXME
752}
753
754# Process the ?I: lines
755sub p_include {
756 # FIXME
757}
758
759# Process the ?T: lines
760sub p_temp {
761 local($where) = "\"$file\", line $. (?T:)";
762 warn "$where: directive should come after ?MAKE declarations.\n"
763 unless $makeseen{$unit};
764 local($_) = @_;
765 local(@sym) = split(' ', $_);
766 foreach $sym (@sym) {
767 warn "$where: temporary symbol '\$$sym' multiply declared.\n"
768 if $tempseen{$sym}++ == 1;
769 $tempmaster{$sym} .= "$unit " if $tempseen{$sym} == 1;
770 }
771}
772
773# Process the ?F: lines
774sub p_file {
775 local($where) = "\"$file\", line $. (?F:)";
776 warn "$where: directive should come after ?MAKE declarations.\n"
777 unless $makeseen{$unit};
778 local($_) = @_;
779 local(@files) = split(' ', $_);
780 local($uufile); # Name of file produced in the UU directory
781 local($tmpfile); # Name of a temporary file
782 # We care only about UU files, i.e. files produced in the UU directory
783 # and which are identified by the convention ./filename. Files !filename
784 # are not produced, i.e. they are temporary or externally provided.
785 # The %prodfile table records all the files produced, so we may detect
786 # inconsistencies between units, while %filemaster records the (first) unit
787 # defining a given UU file to make sure that (special) unit is named in the
788 # dependency line when that UU file if used. Duplicates will be caught in
789 # the sanity check phase thanks to %prodfile.
790 # Temporary files are recorded in %filesetin, so that we may later compare
791 # the list with the UU files to detect possible overwrites.
792 my $is_special = substr($unit, 0, 1) =~ /^[A-Z]/;
793 foreach $file (@files) {
794 warn "$where: produced file '$file' multiply declared.\n"
795 if $fileseen{$file}++ == 1;
796 if (($tmpfile = $file) =~ s/^!//) {
797 $filetmp{$tmpfile} = 'x ';
798 $filesetin{$tmpfile} .= "$unit " if $fileseen{$file} == 1;
799 next; # Is not a UU file for sure, so skip
800 }
801 $prodfile{$file} .= "$unit " if $fileseen{$file} == 1;
802 ($uufile = $file) =~ s|^\./(\S+)$|$1|;
803 next if $file eq $uufile; # Don't care about non-UU files
804 unless ($is_special || $lintcreated{$uufile}) {
805 warn "$where: UU file '$uufile' in non-special unit ignored.\n";
806 delete $lintcreated{$uufile}; # Detect spurious LINT
807 next;
808 }
809 delete $lintcreated{$uufile} if !$is_special; # Detect spurious LINT
810 $filemaster{$uufile} = $unit unless defined $filemaster{$uufile};
811 $filecreated{$uufile} = 'a'; # Will be automagically incremented
812 }
813}
814
815# Process the ?LINT: lines
816sub p_lint {
817 local($_) = @_;
818 local(@sym);
819 local($where) = "\"$file\", line $. (?LINT:)";
820 s/^\s+//; # Strip leading spaces
821 unless ($makeseen{$unit}) {
822 warn "$where: directive should come after ?MAKE declarations.\n"
823 unless m/^empty/;
824 }
825 if (s/^set//) { # Listed variables are set
826 @sym = split(' ', $_); # Spurious ones will be flagged
827 foreach (@sym) {
828 $lintset{$_}++; # Shell variable set
829 }
830 } elsif (s/^desc\w+//) { # Listed shell variables are described
831 @sym = split(' ', $_); # Spurious ones will be flagged
832 foreach (@sym) {
833 $lintsdesc{$_}++; # Shell variable described
834 }
835 } elsif (s/^creat\w+//) { # Listed created files in regular units
836 @sym = split(' ', $_);
837 foreach (@sym) {
838 $lintcreated{$_}++; # Persistent UU file created
839 }
840 } elsif (s/^known//) { # Listed C variables are described
841 @sym = split(' ', $_); # Spurious ones will be flagged
842 foreach (@sym) {
843 $lintcdesc{$_}++; # C symbol described
844 }
845 } elsif (s/^change//) { # Shell variable ok to be changed
846 @sym = split(' ', $_); # Spurious ones will be flagged
847 foreach (@sym) {
848 $lintchange{$_}++; # Do not complain if changed
849 }
850 } elsif (s/^extern//) { # Variables known to be externally defined
851 @sym = split(' ', $_);
852 foreach (@sym) {
853 $lintextern{$_}++; # Do not complain if used in a ?H: line
854 }
855 } elsif (s/^usefile//) { # Files marked as being used
856 @sym = split(' ', $_);
857 foreach (@sym) {
858 $lintfused{$_}++;
859 }
860 } elsif (s/^use//) { # Variables declared as used by unit
861 @sym = split(' ', $_); # Spurious ones will be flagged
862 foreach (@sym) {
863 $lintuse{$_}++; # Do not complain if on ?MAKE and not used
864 }
865 } elsif (s/^def\w+//) { # Listed variables are defined
866 @sym = split(' ', $_); # Spurious ones will be flagged
867 foreach (@sym) {
868 $lintseen{$_}++; # Shell variable defined in this unit
869 }
870 } elsif (m/^empty/) { # Empty unit file
871 $lintempty{$unit}++;
872 } elsif (m/^unclosed/) { # Unclosed here-documents
873 @sym = split(' ', $_);
874 foreach (@sym) {
875 $linthere{$_}++;
876 }
877 } elsif (s/^nothere//) { # Not a here-document name
878 @sym = split(' ', $_);
879 foreach (@sym) {
880 $lintnothere{$_}++;
881 }
882 } elsif (s/^nocomment//) { # OK if leading unit ': comment' missing
883 $lintnocomment{$unit}++;
884 } else {
885 local($where) = "\"$file\", line $." unless $where;
886 local($word) = /^(\w+)/;
887 warn "$where: unknown LINT request '$word' ignored.\n";
888 }
889}
890
891# Process the body of the unit
892sub p_body {
893 return unless $makeseen{$unit};
894 local($_, $special) = @_;
895 local($where) = "\"$file\", line $." unless $where;
896 # Ensure there is no control line in the body of the unit
897 local($control) = /^\?([\w\-]+):/;
898 local($known) = $control ? $Depend{$control} : "";
899 warn "$where: control sequence '?$control:' ignored within body.\n"
900 if $known && !/^\?X:|^\?LINT:/;
901 if (s/^\?LINT://) { # ?LINT directives allowed within body
902 $_ .= &complete_line(FILE) if s/\\\s*$//;
903 &p_lint($_);
904 }
905 return if $known;
906 # First non-special line should be a ': description' line
907 unless ($special || /^\?/ || /^@/) {
908 warn "$where: first body line should be a general ': description'.\n"
909 unless $past_first_line++ || $lintnocomment{$unit} || /^:\s+\w+/;
910 }
911 # Ensure ': comment' lines do not hold any meta-character
912 # We assume ":)" introduces a case statement.
913 if (/^\s*:/ && !/^\s*:\)/) {
914 warn "$where: missing space after ':' to make it a comment.\n"
915 unless /^\s*:\s/;
916 s/\\.//g; # simplistic ignoring of "escaped" chars
917 s/".*?"//g;
918 s/'.*?'//g;
919 if ($wiped_unit) {
920 s/<\$\w+>//g;
921 foreach my $wipe (@wiping) {
922 s/<$wipe>//g;
923 }
924 }
925 warn "$where: found unquoted meta-character $1 on comment line.\n"
926 while s/([`()<>;&\{\}\|])//g;
927 warn "$where: found dangling quote on ':' comment line.\n" if /['"]/;
928 return;
929 }
930 # Ingnore interpreted lines and their continuations
931 if ($last_interpreted) {
932 return if /\\$/; # Still part of the interpreted line
933 $last_interpreted = 0; # End of interpreted lines
934 return; # This line was the last interpreted
935 }
936 # Look for interpreted lines and ignore them
937 if (/^@/) {
938 $last_interpreted = /\\$/; # Set flag if line is continued
939 return; # And skip this line
940 }
941 # Detect ending of "here" documents
942 if ($heredoc ne '' && $_ eq "$heredoc\n") {
943 $heredoc = ''; # Close here-document
944 $heredoc_nosubst = 0;
945 return;
946 }
947 # Detect beginning of "here" document
948 my $began_here = 0;
949 if ($heredoc eq '') {
950 if (/<<\s*''/) {
951 # Discourage it, because we're not processing those...
952 warn "$where: empty here-document name discouraged.\n";
953 } elsif (/<<\s*'([^']+)'/ && !$lintnothere{$1}) {
954 $heredoc = $1;
955 $heredoc_nosubst = 1;
956 $began_here++;
957 } elsif (/<<\s*(\S+)/ && !$lintnothere{$1}) {
958 $heredoc = $1;
959 $began_here++;
960 }
961 # Continue, as we need to look for possible ">file" on the same line
962 # as a possible here document, as in "cat <<EOM >file".
963 } else {
964 return if $heredoc_nosubst; # Completely opaque to interpretation
965 }
966 $heredoc_line = $. if $began_here;
967
968 # If we've just entered a here document and we're generating a file
969 # that is exported by the unit, then we need to monitor the variables
970 # used to make sure there's no missing dependency.
971 $heredoc_nosubst = 0
972 if $began_here && />>?\s*(\S+)/ && $filemaster{$1} eq $unit;
973
974 # From now on, do all substitutes with ':' since it would be dangerous
975 # to remove things plain and simple. It could yields false matches
976 # afterwards...
977
978 my $check_vars = 1;
979 $chek_vars = 0 if $heredoc_nosubst && !$began_here;
980
981 # Record any attempt made to set a shell variable
982 local($sym);
983 while ($check_vars && s/(\W?)(\w+)=/$1:/) {
984 my $before = $1;
985 $sym = $2;
986 next unless $before eq '' || $before =~ /["'` \t]/;
987 next if $sym =~ /^\d+/; # Ignore $1 and friends
988 $symset{$sym}++; # Shell variable set
989 # Not part of a $cc -DWHATEVER line and not made nor temporary
990 unless ($sym =~ /^D/ || &defined($sym)) {
991 if (&wanted($sym)) {
992 warn "$where: variable '\$$sym' is changed.\n"
993 unless $lintchange{$sym};
994 $lintchange_used{$sym}++ if $lintchange{$sym};
995 } else {
996 # Record that the variable is set but not listed locally.
997 if ($shset{$unit} !~ /\b$sym\b/) {
998 $shset{$unit} .= "$sym " unless $lintchange{$sym};
999 $lintchange_used{$sym}++ if $lintchange{$sym};
1000 }
1001 }
1002 }
1003 }
1004 # Now look at the shell variables used: can be $var or ${var}
1005 local($var);
1006 local($line) = $_;
1007 while ($check_vars && s/\$\{?(\w+)\}?/$1/) {
1008 $var = $1;
1009 next if $var =~ /^\d+/; # Ignore $1 and friends
1010 # Record variable as undeclared but do not issue a message right now.
1011 # That variable could be exported via ?V: (as $dflt in Myread) or be
1012 # defined by a special unit (like $inlibc by unit Inlibc).
1013 $shunknown{$unit} .= "$var " unless
1014 $lintextern{$var} || &declared($var) ||
1015 $shunknown{$unit} =~ /\b$var\b/;
1016 $shused{$unit} .= "\$$var " unless $shused{$unit} =~ /\$$var\b/;
1017 }
1018
1019 return if $heredoc ne '' && !$began_here; # Still in here-document
1020
1021 # Now look at private files used by the unit (./file or ..../UU/file)
1022 # We look at things like '. ./myread' and `./loc ...` as well as "< file"
1023 local($file);
1024 $_ = $line;
1025 s/<\S+?>//g; # <header.h> would set-off our <file detection
1026 while (
1027 s!(\.\s+|`\s*)(\S*UU|\.)/([^\$/`\s;]+)\s*!! ||
1028 s!(`\s*\$?)cat\s+(\./)?([^\$/`\s;]+)\s*`!! ||
1029 s!(\s+)(\./)([^\$/`\s;]+)\s*!! ||
1030 s!(\s+)<\s*(\./)?([^<\$/`'"\s;]+)!!
1031 ) {
1032 $file = $3;
1033 # Found some ". ./file" or `./file` execution, `$cat file`, or even
1034 # "blah <file"...
1035 # Record file as used. Later on, we will make sure we had the right
1036 # to use that file: either we are in the unit that defines it, or we
1037 # include the unit that creates it in our dependencies, relying on ?F:.
1038 $fileused{$unit} .= "$file " unless
1039 $filetmp{$file} || $fileused{$unit} =~ /\b$file\b/;
1040 # Mark temporary file as being used, to spot useless local declarations
1041 $filetmp{$file} .= ' used'
1042 if defined $filetmp{$file} && $filetmp{$file} !~ /\bused/;
1043 }
1044 # Try to detect things like . myread or `loc` to warn that they
1045 # should rather use . ./myread and `./loc`. Also things like 'if prog',
1046 # or usage in conditional expressions such as || and &&. Be sure the file
1047 # name is always in $2...
1048 while (
1049 s!(\.\s+|`\s*)([^\$/`\s;]+)\s*!: ! || # . myread or `loc`
1050 s!(if|\|\||&&)\s+([^\$/`\s;]+)\s*!: ! # if prog, || prog, && prog
1051 ) {
1052 $file = $2;
1053 $filemisused{$unit} .= "$file " unless
1054 $filetmp{$file} || $filemisused{$unit} =~ /\b\Q$file\E\b/;
1055 # Temporary files should be used with ./ anyway
1056 $filetmp{$file} .= ' misused'
1057 if defined $filetmp{$file} && $filetmp{$file} !~ /\bmisused/;
1058 }
1059 # Locate file creation, >>file or >file
1060 while (s!>>?\s*([^\$/`\s;]+)\s*!: !) {
1061 $file = $1;
1062 next if $file =~ /&\d+/; # skip >&4 and friends
1063 $filecreated{$file}++;
1064 }
1065 # Look for mentions of known temporary files to avoid complaining
1066 # that they were not used.
1067 while (s!\s+(\S+)!!) {
1068 $file = $1;
1069 $filetmp{$file} .= ' used'
1070 if defined $filetmp{$file} && $filetmp{$file} !~ /\bused/;
1071 }
1072}
1073
1074# Called at the end of each unit
1075sub p_end {
1076 local($last) = @_; # Last processed line
1077 local($where) = "\"$file\"";
1078
1079 # The ?H: section, if present, must have been closed
1080 if ($h_section && $h_section != 2) {
1081 warn "$where: unclosed ?H: section.\n";
1082 }
1083 $h_section = 0; # For next unit, which may be empty
1084
1085 # All opened here-documents must be closed.
1086 if ($heredoc ne '') {
1087 my $q = $heredoc_nosubst ? "'" : "";
1088 warn "$where: unclosed here-document $q$heredoc$q " .
1089 "started line $heredoc_line.\n"
1090 unless $linthere{$heredoc};
1091 }
1092
1093 # Reinitialize for next unit.
1094 $heredoc = '';
1095 $heredoc_nosubst = 0;
1096 $past_first_line = 0;
1097 $last_interpreted = 0;
1098
1099 unless ($makeseen{$unit}) {
1100 warn "$where: no ?MAKE: line describing dependencies.\n"
1101 unless $lintempty{$unit};
1102 return;
1103 }
1104
1105 # Each unit should end with a blank line. Unfortunately, some units
1106 # may also end with an '@end' request and have the blank line above it.
1107 # Currently, we do not have enough information to correctly diagnose
1108 # whether it is valid or not so just skip it.
1109 # Same thing for U/Obsol_sh.U which ends with a shell comment.
1110
1111 warn "$where: not ending with a blank line.\n" unless
1112 $last =~ /^\s*$/ || $last =~ /^\@end/ || $last =~ /^#|\?/;
1113
1114 # For EMACS users. It would be fatal to the Configure script...
1115 warn "$where: last line not ending with a new-line character.\n"
1116 unless $last =~ /\n$/;
1117
1118 # Make sure every shell symbol described in ?MAKE had a description
1119 foreach $sym (sort keys %defseen) {
1120 unless ($ssym{$sym}) {
1121 warn "$where: symbol '\$$sym' was not described.\n"
1122 unless $lintsdesc{$sym};
1123 $lintsdesc_used{$sym}++ if $lintsdesc{$sym};
1124 }
1125 }
1126 # Ensure all the C symbols defined by ?H: lines have a description
1127 foreach $sym (sort keys %hcsym) {
1128 unless ($csym{$sym}) {
1129 warn "$where: C symbol '$sym' was not described.\n"
1130 unless $lintcdesc{$sym};
1131 $lintcdesc_used{$sym}++ if $lintcdesc{$sym};
1132 }
1133 }
1134 # Ensure all the C symbols described by ?C: lines are defined in ?H:
1135 foreach $sym (sort keys %csym) {
1136 warn "$where: C symbol '$sym' was not defined by any ?H: line.\n"
1137 unless $hcsym{$sym};
1138 }
1139 # Make sure each defined symbol was set, unless it starts with an
1140 # upper-case letter in which case it is not a "true" shell symbol.
1141 # I don't care about the special symbols defined in %Except as I know
1142 # they are handled correctly.
1143 foreach $sym (sort keys %defseen) {
1144 unless ($symset{$sym} || substr($sym, 0, 1) =~ /^[A-Z]/) {
1145 warn "$where: variable '\$$sym' should have been set.\n"
1146 unless $lintset{$sym};
1147 $lintset_used{$sym}++ if $lintset{$sym};
1148 }
1149 }
1150 # Make sure every non-special unit declared as wanted is indeed needed
1151 foreach $sym (sort keys %depseen) {
1152 if ($shused{$unit} !~ /\$$sym\b/ && substr($sym, 0, 1) !~ /^[A-Z]/) {
1153 warn "$where: unused dependency variable '\$$sym'.\n" unless
1154 $lintchange{$sym} || $lintuse{$sym};
1155 $lintchange_used{$sym}++ if $lintchange{$sym};
1156 $lintuse_used{$sym}++ if $lintuse{$sym};
1157 }
1158 }
1159 # Idem for conditionally wanted symbols
1160 foreach $sym (sort keys %condseen) {
1161 if ($shused{$unit} !~ /\$$sym\b/ && substr($sym, 0, 1) !~ /^[A-Z]/) {
1162 warn "$where: unused conditional variable '\$$sym'.\n" unless
1163 $lintchange{$sym} || $lintuse{$sym};
1164 $lintchange_used{$sym}++ if $lintchange{$sym};
1165 $lintuse_used{$sym}++ if $lintuse{$sym};
1166 }
1167 }
1168 # Idem for temporary symbols
1169 foreach $sym (sort keys %tempseen) {
1170 if ($shused{$unit} !~ /\$$sym\b/ && !$symset{$sym}) {
1171 warn "$where: unused temporary variable '\$$sym'.\n" unless
1172 $lintuse{$sym};
1173 $lintuse_used{$sym}++ if $lintuse{$sym};
1174 }
1175 }
1176 # Idem for local files
1177 foreach $file (sort keys %filetmp) {
1178 warn "$where: mis-used temporary file '$file'.\n" if
1179 $filetmp{$file} =~ /\bmisused/;
1180 warn "$where: unused temporary file '$file'.\n" unless
1181 $lintfused{$file} ||
1182 $filetmp{$file} =~ /\bused/ || $filetmp{$file} =~ /\bmisused/;
1183 }
1184 # Make sure each private file listed as created on ?F: is really created.
1185 # When found, a private UU file is entered in the %filecreated array
1186 # with value 'a'. Each time a file creation occurs in the unit, an
1187 # increment is done on that value. Since 'a'++ -> 'b', a numeric value
1188 # in %filecreated means a non-local file, which is skipped. An 'a' means
1189 # the file was not created...
1190 local($value);
1191 foreach $file (sort keys %filecreated) {
1192 $value = $filecreated{$file};
1193 next if $value > 0; # Skip non UU-files.
1194 warn "$where: file '$file' was not created.\n" if $value eq 'a';
1195 }
1196 # Check whether some of the LINT directives were useful
1197 foreach my $sym (sort keys %lintcreated) {
1198 warn "$where: spurious 'LINT create $sym' directive.\n";
1199 }
1200 foreach my $sym (sort keys %lintuse) {
1201 warn "$where: spurious 'LINT use $sym' directive.\n"
1202 unless $lintuse_used{$sym};
1203 }
1204 foreach my $sym (sort keys %lintchange) {
1205 warn "$where: spurious 'LINT change $sym' directive.\n"
1206 unless $lintchange_used{$sym};
1207 }
1208 foreach my $sym (sort keys %lintseen) {
1209 warn "$where: spurious 'LINT define $sym' directive.\n"
1210 unless $lintseen_used{$sym};
1211 }
1212 foreach my $sym (sort keys %lintsdesc) {
1213 warn "$where: spurious 'LINT describe $sym' directive.\n"
1214 unless $lintsdesc_used{$sym};
1215 }
1216 foreach my $sym (sort keys %lintcdesc) {
1217 warn "$where: spurious 'LINT known $sym' directive.\n"
1218 unless $lintcdesc_used{$sym};
1219 }
1220 foreach my $sym (sort keys %lintset) {
1221 warn "$where: spurious 'LINT set $sym' directive.\n"
1222 unless $lintset_used{$sym};
1223 }
1224}
1225
1226# An unknown control line sequence was found (held in $proc)
1227sub p_unknown {
1228 warn "\"$file\", line $.: unknown control sequence '?$proc:'.\n";
1229}
1230
1231# Run sanity checks, to make sure every conditional symbol has a suitable
1232# default value. Also ensure every symbol was defined once.
1233sub sanity_checks {
1234 print "Sanity checks...\n";
1235 local($key, $value);
1236 local($w);
1237 local(%message); # Record messages on a per-unit basis
1238 local(%said); # Avoid duplicate messages
1239 # Warn about symbols ever used in conditional dependency with no default
1240 while (($key, $value) = each(%condsym)) {
1241 unless ($hasdefault{$key}) {
1242 $w = (split(' ', $shmaster{"\$$key"}))[0];
1243 $message{$w} .= "#$key ";
1244 }
1245 }
1246 # Warn about any undeclared variables. They are all listed in %shunknown,
1247 # being the values while the unit where they appear is the key. If the
1248 # symbol is defined by any of the special units included or made visible,
1249 # then no warning is issued.
1250 local($defined); # True if symbol is defined in one unit
1251 local($where); # List of units where symbol is defined
1252 local($myself); # The name of the current unit if itself special
1253 local($visible); # Symbol made visible via a ?V: line
1254 foreach $unit (sort keys %shunknown) {
1255 foreach $sym (split(' ', $shunknown{$unit})) {
1256 $defined = 0;
1257 $where = $shmaster{"\$$sym"};
1258 $defined = 1 if $tempmaster{"\$$sym"} =~ /$unit\b/;
1259 $myself = substr($unit, 0, 1) =~ /^[A-Z]/ ? $unit : '';
1260 # Symbol has to be either defined within one of the special units
1261 # listed in the dependencies or exported via a ?V: line.
1262 unless ($defined) {
1263 $defined = &visible($sym, $unit);
1264 $spneeded{$unit}++ if $defined;
1265 }
1266 $message{$unit} .= "\$$sym " unless $defined;
1267 }
1268 }
1269
1270 # Warn about any undeclared files. Files used in one unit are all within
1271 # the %fileused table, indexed by unit. If a file is used, it must either
1272 # be in the unit that declared it (relying on %filemaster for that) or
1273 # the unit listed in %filemaster must be part of our dependency.
1274 %said = ();
1275 foreach $unit (sort keys %fileused) {
1276 foreach $file (split(' ', $fileused{$unit})) {
1277 $defined = 0;
1278 $where = $filemaster{$file}; # Where file is created
1279 $defined = 1 if $unit eq $where; # We're in the unit defining it
1280 # Private UU files may be only be created by special units
1281 foreach $special (split(' ', $shspecial{$unit})) {
1282 last if $defined;
1283 $defined = 1 if $where eq $special;
1284 }
1285 # Exceptions to above rule possible via a ?LINT:create hint,
1286 # so parse all known dependencies for the unit...
1287 foreach $depend (split(' ', $shdepend{$unit})) {
1288 last if $defined;
1289 $defined = 1 if $where eq $depend;
1290 }
1291 $message{$unit} .= "\@$file " unless
1292 $defined || $said{"$unit/$file"}++; # Unknown file
1293 }
1294 }
1295 undef %fileused;
1296
1297 # Warn about any misused files, kept in %filemisused
1298 foreach $unit (sort keys %filemisused) {
1299 foreach $file (split(' ', $filemisused{$unit})) {
1300 next unless defined $filemaster{$file}; # Skip non UU-files
1301 $message{$unit} .= "\@\@$file "; # Misused file
1302 }
1303 }
1304 undef %filemisused;
1305
1306 # Warn about temporary files which could be created and inadvertently
1307 # override a private UU file (listed in %filemaster).
1308 foreach $tmpfile (keys %filesetin) {
1309 next unless defined $filemaster{$tmpfile};
1310 $where = $filemaster{$tmpfile};
1311 foreach $unit (split(' ', $filesetin{$tmpfile})) {
1312 $message{$unit} .= "\@\@\@$where:$tmpfile ";
1313 }
1314 }
1315 undef %filesetin;
1316
1317 # Warn about any set variable which was not listed.
1318 foreach $unit (sort keys %shset) {
1319 symbol: foreach $sym (split(' ', $shset{$unit})) {
1320 next if $shvisible{$sym};
1321 $defined = 0;
1322 # Symbol has to be either defined within one of the special units
1323 # listed in the dependencies or exported read-write via a ?V: line.
1324 # If symbol is exported read-only, report the attempt to set it.
1325 $where = $shmaster{"\$$sym"};
1326 study $where;
1327 foreach $special (split(' ', $shspecial{$unit})) {
1328 $defined = 1 if $where =~ /\b$special\b/;
1329 last if $defined;
1330 }
1331 $visible = 0;
1332 $defined = $visible = &visible($sym, $unit) unless $defined;
1333 if ($visible && $shvisible{"\$$sym"} ne '') {
1334 # We are allowed to set a read-only symbol in the unit which
1335 # declared it...
1336 next symbol if $shvisible{"\$$sym"} eq $unit;
1337 $message{$unit} .= "\&$sym "; # Read-only symbol set
1338 next symbol;
1339 }
1340 $message{$unit} .= "$sym " unless $defined;
1341 }
1342 }
1343 # Warn about any obsolete variable which may be used
1344 foreach $unit (sort keys %shused) {
1345 foreach $sym (split(' ', $shused{$unit})) {
1346 $message{$unit} .= "!$sym " if $Obsolete{$sym} ne '';
1347 }
1348 }
1349
1350 # Warn about stale dependencies, and prepare successor and predecessor
1351 # tables for later topological sort.
1352
1353 local($targets, $deps);
1354 local(%Succ); # Successors
1355 local(%Prec); # Predecessors
1356
1357 # Split dependencies and build successors array.
1358 foreach $make (@make) {
1359 ($targets, $deps) = $make =~ m|(.*):\s*(.*)|;
1360 $deps =~ s/\+(\w)/$1/g; # Remove conditional targets
1361 foreach $target (split(' ', $targets)) {
1362 $Succ{$target} .= $deps . ' ';
1363 }
1364 }
1365
1366 # Special setup for the End target, which normally has a $W dependency for
1367 # wanted symbols. In order to detect all the possible cycles, we forge a
1368 # huge dependency by making ALL the regular symbols (i.e. those whose first
1369 # letter is not uppercased) wanted.
1370
1371 local($allwant) = '';
1372 {
1373 local($sym, $val);
1374 while (($sym, $val) = each %shmaster) {
1375 $sym =~ s/^\$//;
1376 $allwant .= "$sym " if $val ne '';
1377 }
1378 }
1379
1380 $Succ{'End'} =~ s/\$W/$allwant/;
1381
1382 # Initialize precursors, and spot symbols impossible to 'make', i.e. those
1383 # symbols listed in the successors and with no 'make' target. The data
1384 # structures %Prec and %Succ will also be used by the cycle lookup code,
1385 # in other words, the topological sort.
1386 foreach $target (keys %Succ) {
1387 $Prec{$target} += 0; # Ensure key is recorded without disturbing.
1388 foreach $succ (split(' ', $Succ{$target})) {
1389 $Prec{$succ}++; # Successor has one more precursor
1390 unless (defined $Succ{$succ} || $said{$succ}++) {
1391 foreach $unit (split(' ', $symdep{$succ})) {
1392 $message{$unit} .= "?$succ "; # Stale ?MAKE: dependency
1393 }
1394 }
1395 }
1396 }
1397 undef %symdep;
1398
1399 # Check all ?M: dependencies to spot stale ones
1400 %said = ();
1401 while (($key, $value) = each(%msym)) {
1402 next if $value eq ''; # Value is unit name where ?M: occurred
1403 foreach $sym (split(' ', $mdep{$key})) { # Loop on C dependencies
1404 next if $cmaster{$sym} || $said{$sym};
1405 $message{$value} .= "??$sym "; # Stale ?M: dependency
1406 $said{$sym}++;
1407 }
1408 }
1409
1410 undef %said;
1411 undef %mdep;
1412 undef %msym;
1413
1414 # Now actually emit all the warnings
1415 local($uv); # Unit defining visible symbol or private file
1416 local($w); # Were we are signaling an error
1417 foreach $unit (sort keys %message) {
1418 undef %said;
1419 $w = "\"$unit.U\"";
1420 foreach (split(' ', $message{$unit})) {
1421 if (s/^#//) {
1422 warn "$w: symbol '\$$_' has no default value.\n";
1423 } elsif (s/^\?\?//) {
1424 warn "$w: stale ?M: dependency '$_'.\n";
1425 } elsif (s/^\?//) {
1426 warn "$w: stale ?MAKE: dependency '$_'.\n";
1427 } elsif (s/^\$//) {
1428 if ($shmaster{"\$$_"} ne '') {
1429 warn "$w: symbol '\$$_' missing from ?MAKE.\n";
1430 } elsif (($uv = $shvisible{$_}) ne '') {
1431 warn "$w: missing $uv from ?MAKE for visible '\$$_'.\n";
1432 } elsif (($uv = $shvisible{"\$$_"}) ne '') {
1433 warn "$w: missing $uv from ?MAKE for visible '\$$_'.\n";
1434 } else {
1435 warn "\"$unit.U\": unknown symbol '\$$_'.\n";
1436 }
1437 ++$said{$_};
1438 } elsif (s/^\&//) {
1439 warn "\"$unit.U\": read-only symbol '\$$_' is set.\n";
1440 ++$said{$_};
1441 } elsif (s/^!//) {
1442 warn "\"$unit.U\": obsolete symbol '$_' is used.\n";
1443 ++$said{$_};
1444 } elsif (s/^\@\@\@//) {
1445 $uv = '?'; # To spot format errors
1446 s/^(\w+):// && ($uv = $1);
1447 warn "$w: local file '$_' may override the one set by $uv.U.\n";
1448 } elsif (s/^\@\@//) {
1449 $uv = $filemaster{$_};
1450 warn "$w: you might not always get file '$_' from $uv.U.\n";
1451 } elsif (s/^\@//) {
1452 if ($uv = $filemaster{$_}) {
1453 warn "$w: missing $uv from ?MAKE for private file '$_'.\n";
1454 } else {
1455 warn "$w: unknown private file '$_'.\n";
1456 }
1457 ++$said{"\@$_"};
1458 } else {
1459 warn "\"$unit.U\": undeclared symbol '\$$_' is set.\n"
1460 unless $said{$_};
1461 }
1462 }
1463 }
1464
1465 # Memory cleanup
1466 undef %message;
1467 undef %said;
1468 undef %shused;
1469 undef %shset;
1470 undef %shspecial;
1471 undef %shvisible;
1472 undef %filemaster;
1473
1474 # Spot multiply defined C symbols
1475 foreach $sym (keys %cmaster) {
1476 @sym = split(' ', $cmaster{$sym});
1477 if (@sym > 1) {
1478 warn "C symbol '$sym' is defined in the following units:\n";
1479 foreach (@sym) {
1480 print STDERR "\t$_.U\n";
1481 }
1482 }
1483 }
1484 undef %cmaster; # Memory cleanup
1485
1486 # Warn about multiply defined symbols. There are three kind of symbols:
1487 # target symbols, obsolete symbols and temporary symbols.
1488 # For each of these sets, we make sure the intersection with the other sets
1489 # is empty. Besides, we make sure target symbols are only defined once.
1490
1491 local(@sym);
1492 foreach $sym (keys %shmaster) {
1493 @sym = split(' ', $shmaster{$sym});
1494 if (@sym > 1) {
1495 warn "Shell symbol '$sym' is defined in the following units:\n";
1496 foreach (@sym) {
1497 print STDERR "\t$_.U\n";
1498 }
1499 }
1500 $message{$sym} .= 'so ' if $Obsolete{$sym};
1501 $message{$sym} .= 'st ' if $tempmaster{$sym};
1502 }
1503 foreach $sym (keys %tempmaster) {
1504 $message{$sym} .= 'ot ' if $Obsolete{$sym};
1505 }
1506 local($_);
1507 while (($sym, $_) = each %message) {
1508 if (/so/) {
1509 if (/ot/) {
1510 warn "Shell symbol '$sym' is altogether:\n";
1511 @sym = split(' ', $shmaster{$sym});
1512 @sym = grep(s/$/.U/, @sym);
1513 print STDERR "...defined in: ", join(', ', @sym), "\n";
1514 print STDERR "...obsoleted by $Obsolete{$sym}.\n";
1515 @sym = split(' ', $tempmaster{$sym});
1516 @sym = grep(s/$/.U/, @sym);
1517 print STDERR "...used as temporary in:", join(', ', @sym), "\n";
1518 } else {
1519 warn "Shell symbol '$sym' is both defined and obsoleted:\n";
1520 @sym = split(' ', $shmaster{$sym});
1521 @sym = grep(s/$/.U/, @sym);
1522 print STDERR "...defined in: ", join(', ', @sym), "\n";
1523 print STDERR "...obsoleted by $Obsolete{$sym}.\n";
1524 }
1525 } elsif (/st/) { # Cannot be ot as it would imply so
1526 warn "Shell symbol '$sym' is both defined and used as temporary:\n";
1527 @sym = split(' ', $shmaster{$sym});
1528 @sym = grep(s/$/.U/, @sym);
1529 print STDERR "...defined in: ", join(', ', @sym), "\n";
1530 @sym = split(' ', $tempmaster{$sym});
1531 @sym = grep(s/$/.U/, @sym);
1532 print STDERR "...used as temporary in:", join(', ', @sym), "\n";
1533 } elsif (/ot/) {
1534 warn "Shell symbol '$sym' obsoleted also used as temporary:\n";
1535 print STDERR "...obsoleted by $Obsolete{$sym}.\n";
1536 @sym = split(' ', $tempmaster{$sym});
1537 @sym = grep(s/$/.U/, @sym);
1538 print STDERR "...used as temporary in:", join(', ', @sym), "\n";
1539 }
1540 }
1541
1542 # Spot multiply defined files, either private or public ones
1543 foreach $file (keys %prodfile) {
1544 @sym = split(' ', $prodfile{$file});
1545 if (@sym > 1) {
1546 warn "File '$file' is defined in the following units:\n";
1547 foreach (@sym) {
1548 print STDERR "\t$_\n";
1549 }
1550 }
1551 }
1552 undef %prodfile;
1553
1554
1555 # Memory cleanup (we still need %shmaster for tsort)
1556 undef %message;
1557 undef %tempmaster;
1558 undef %Obsolete;
1559
1560 # Make sure there is no dependency cycle
1561 print "Looking for dependency cycles...\n";
1562 &tsort(*Succ, *Prec); # Destroys info from %Prec
1563}
1564
1565# Make sure last declaration ended correctly with a ?S:. or ?C:. line.
1566# The variable '$where' was correctly positionned by the calling routine.
1567sub check_last_declaration {
1568 warn "$where: definition of '\$$s_symbol' not closed by '?S:.'.\n"
1569 if $s_symbol ne '';
1570 warn "$where: definition of '$c_symbol' not closed by '?C:.'.\n"
1571 if $c_symbol ne '';
1572 warn "$where: magic definition of '$m_symbol' not closed by '?M:.'.\n"
1573 if $m_symbol ne '';
1574 $s_symbol = $c_symbol = $m_symbol = '';
1575}
1576
1577# Make sure the variable is mentionned on the ?MAKE line, if possible in the
1578# definition section.
1579# The variable '$where' was correctly positionned by the calling routine.
1580sub check_definition {
1581 local($var) = @_;
1582 warn "$where: variable '\$$var' not even listed on ?MAKE: line.\n"
1583 unless $defseen{$var} || $condseen{$var} || $depseen{$var};
1584 warn "$where: variable '\$$var' is defined externally.\n"
1585 if !$lintextern{$var} && !$defseen{$var} && &wanted($var);
1586}
1587
1588# Is symbol declared somewhere?
1589sub declared {
1590 &defined($_[0]) || &wanted($_[0]);
1591}
1592
1593# Is symbol defined by unit?
1594sub defined {
1595 $tempseen{$_[0]} || $defseen{$_[0]} || $lintseen{$_[0]};
1596}
1597
1598# Is symbol wanted by unit?
1599sub wanted {
1600 $depseen{$_[0]} || $condseen{$_[0]};
1601}
1602
1603# Is symbol visible from the unit?
1604# Locate visible symbols throughout the special units. Each unit having
1605# some special dependencies (special units wanted) have an entry in the
1606# %shspecial array, listing all those special dependencies. And each
1607# symbol made visible by ONE special unit has an entry in the %shvisible
1608# array.
1609sub visible {
1610 local($symbol, $unit) = @_;
1611 local(%explored); # Special units we've already explored
1612 &explore($symbol, $unit); # Perform recursive search
1613}
1614
1615# Recursively explore the dependencies to locate a visible symbol
1616sub explore {
1617 local($symbol, $unit) = @_;
1618 # If unit was already explored, we know it has not been found by following
1619 # that path.
1620 return 0 if defined $explored{$unit};
1621 $explored{$unit} = 0; # Assume nothing found in this unit
1622 local($specials) = $shspecial{$unit};
1623 # Don't waste any time if unit does not have any special units listed
1624 # in its dependencies.
1625 return 0 unless $specials;
1626 foreach $special (split(' ', $specials)) {
1627 return 1 if (
1628 $shvisible{"\$$symbol"} eq $unit ||
1629 $shvisible{$symbol} eq $unit ||
1630 &explore($symbol, $special)
1631 );
1632 }
1633 0;
1634}
1635
1636# The %Depend array records the functions we use to process the configuration
1637# lines in the unit, with a special meaning. It is important that all the
1638# known control symbols be listed below, so that metalint does not complain.
1639# The %Lcmp array contains valid layouts and their comparaison value.
1640sub init_depend {
1641 %Depend = (
1642 'MAKE', 'p_make', # The ?MAKE: line records dependencies
1643 'INIT', 'p_init', # Initializations printed verbatim
1644 'LINT', 'p_lint', # Hints for metalint
1645 'RCS', 'p_ignore', # RCS comments are ignored
1646 'C', 'p_c', # C symbols
1647 'D', 'p_default', # Default value for conditional symbols
1648 'E', 'p_example', # Example of usage
1649 'F', 'p_file', # Produced files
1650 'H', 'p_config', # Process the config.h lines
1651 'I', 'p_include', # Added includes
1652 'L', 'p_library', # Added libraries
1653 'M', 'p_magic', # Process the confmagic.h lines
1654 'O', 'p_obsolete', # Unit obsolescence
1655 'P', 'p_public', # Location of PD implementation file
1656 'S', 'p_shell', # Shell variables
1657 'T', 'p_temp', # Shell temporaries used
1658 'V', 'p_visible', # Visible symbols like 'rp', 'dflt'
1659 'W', 'p_wanted', # Wanted value for interpreter
1660 'X', 'p_ignore', # User comment is ignored
1661 'Y', 'p_layout', # User-defined layout preference
1662 );
1663 %Lcmp = (
1664 'top', -1,
1665 'default', 0,
1666 'bottom', 1,
1667 );
1668}
1669
1670# Extract dependencies from units held in @ARGV
1671sub extract_dependencies {
1672 local($proc); # Procedure used to handle a ctrl line
1673 local($file); # Current file scanned
1674 local($dir, $unit); # Directory and unit's name
1675 local($old_version) = 0; # True when old-version unit detected
1676 local($mc) = "$MC/U"; # Public metaconfig directory
1677 local($line); # Last processed line for metalint
1678
1679 printf "Extracting dependency lists from %d units...\n", $#ARGV+1
1680 unless $opt_s;
1681
1682 chdir $WD; # Back to working directory
1683 &init_extraction; # Initialize extraction files
1684 $dependencies = ' ' x (50 * @ARGV); # Pre-extend
1685 $dependencies = '';
1686
1687 # We do not want to use the <> construct here, because we need the
1688 # name of the opened files (to get the unit's name) and we want to
1689 # reset the line number for each files, and do some pre-processing.
1690
1691 file: while ($file = shift(@ARGV)) {
1692 close FILE; # Reset line number
1693 $old_version = 0; # True if unit is an old version
1694 if (open(FILE, $file)) {
1695 ($dir, $unit) = ('', $file)
1696 unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|);
1697 $unit =~ s|\.U$||; # Remove extension
1698 } else {
1699 warn("Can't open $file.\n");
1700 }
1701 # If unit is in the standard public directory, keep only the unit name
1702 $file = "$unit.U" if $dir eq $mc;
1703 print "$dir/$unit.U:\n" if $opt_d;
1704 line: while (<FILE>) {
1705 $line = $_; # Save last processed unit line
1706 if (s/^\?([\w\-]+)://) { # We may have found a control line
1707 $proc = $Depend{$1}; # Look for a procedure to handle it
1708 unless ($proc) { # Unknown control line
1709 $proc = $1; # p_unknown expects symbol in '$proc'
1710 eval '&p_unknown'; # Signal error (metalint only)
1711 next line; # And go on next line
1712 }
1713 # Long lines may be escaped with a final backslash
1714 $_ .= &complete_line(FILE) if s/\\\s*$//;
1715 # Run macros substitutions
1716 s/%</$unit/g; # %< expands into the unit's name
1717 if (s/%\*/$unit/) {
1718 # %* expanded into the entire set of defined symbols
1719 # in the old version. Now it is only the unit's name.
1720 ++$old_version;
1721 }
1722 eval { &$proc($_) }; # Process the line
1723 } else {
1724 next file unless $body; # No procedure to handle body
1725 do {
1726 $line = $_; # Save last processed unit line
1727 eval { &$body($_) } ; # From now on, it's the unit body
1728 } while (defined ($_ = <FILE>));
1729 next file;
1730 }
1731 }
1732 } continue {
1733 warn(" Warning: $file is a pre-3.0 version.\n") if $old_version;
1734 &$ending($line) if $ending; # Post-processing for metalint
1735 }
1736
1737 &end_extraction; # End the extraction process
1738}
1739
1740# The first line was escaped with a final \ character. Every following line
1741# is to be appended to it (until we found a real \n not escaped). Note that
1742# the leading spaces of the continuation line are removed, so any space should
1743# be added before the former \ if needed.
1744sub complete_line {
1745 local($file) = @_; # File where lines come from
1746 local($_);
1747 local($read) = ''; # Concatenation of all the continuation lines found
1748 while (<$file>) {
1749 s/^\s+//; # Remove leading spaces
1750 if (s/\\\s*$//) { # Still followed by a continuation line
1751 $read .= $_;
1752 } else { # We've reached the end of the continuation
1753 return $read . $_;
1754 }
1755 }
1756}
1757
1758# Record obsolete symbols association (new versus old), that is to say for a
1759# given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended
1760# for all shell variables
1761sub record_obsolete {
1762 local($_) = @_;
1763 local(@obsoleted); # List of obsolete symbols
1764 local($symbol); # New symbol which must be used
1765 local($dollar) = s/^\$// ? '$':''; # The '$' or a null string
1766 # Syntax for obsolete symbols specification is
1767 # list of symbols (obsolete ones):
1768 if (/^(\w+)\s*\((.*)\)\s*:$/) {
1769 $symbol = "$dollar$1";
1770 @obsoleted = split(' ', $2); # List of obsolete symbols
1771 } else {
1772 if (/^(\w+)\s*\((.*):$/) {
1773 warn "\"$file\", line $.: final ')' before ':' missing.\n";
1774 $symbol = "$dollar$1";
1775 @obsoleted = split(' ', $2);
1776 } else {
1777 warn "\"$file\", line $.: syntax error.\n";
1778 return;
1779 }
1780 }
1781 foreach $val (@obsoleted) {
1782 $_ = $dollar . $val;
1783 if (defined $Obsolete{$_}) {
1784 warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n";
1785 } else {
1786 $Obsolete{$_} = $symbol; # Record (old, new) tuple
1787 }
1788 }
1789}
1790
1791# Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and
1792# Obsol_sh.U to record old versus new mappings if the -o option was used.
1793sub dump_obsolete {
1794 unless (-f 'Obsolete') {
1795 open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n";
1796 }
1797 open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n";
1798 open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n";
1799 local($file); # File where obsolete symbol was found
1800 local($old); # Name of this old symbol
1801 local($new); # Value of the new symbol to be used
1802 # Leave a blank line at the top so that anny added ^L will stand on a line
1803 # by itself (the formatting process adds a ^L when a new page is needed).
1804 format OBSOLETE_TOP =
1805
1806 File | Old symbol | New symbol
1807-----------------------------------+----------------------+---------------------
1808.
1809 format OBSOLETE =
1810@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<<
1811$file, $old, $new
1812.
1813 local(%seen);
1814 foreach $key (sort keys %ofound) {
1815 ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/);
1816 write(OBSOLETE) unless $file eq 'XXX';
1817 next unless $opt_o; # Obsolete mapping done only with -o
1818 next if $seen{$old}++; # Already remapped, thank you
1819 if ($new =~ s/^\$//) { # We found an obsolete shell symbol
1820 $old =~ s/^\$//;
1821 print OBSOL_SH "$old=\"\$$new\"\n";
1822 } else { # We found an obsolete C symbol
1823 print OBSOL_H "#ifdef $new\n";
1824 print OBSOL_H "#define $old $new\n";
1825 print OBSOL_H "#endif\n\n";
1826 }
1827 }
1828 close OBSOLETE;
1829 close OBSOL_H;
1830 close OBSOL_SH;
1831 if (-s 'Obsolete') {
1832 print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n";
1833 } else {
1834 unlink 'Obsolete';
1835 }
1836 undef %ofound; # Not needed any more
1837}
1838
1839#
1840# Topological sort of Makefile dependencies with cycle enhancing.
1841#
1842
1843package tsort;
1844
1845# Perform the topological sort of the items and outline cycles.
1846sub main'tsort {
1847 local(*Succ, *Prec) = @_; # Tables of succesors and predecessors
1848 local(@Out); # The outsider set
1849 local(@keys); # Current active precursors
1850 local($item); # Item to sort
1851
1852 for (@keys = keys %Prec; @keys || @Out; @keys = keys %Prec) {
1853 &resync; # Resynchronize outsiders
1854 if (@Out == 0) { # Cycle detected
1855 &extract_cycle(*Prec, *Succ);
1856 next;
1857 }
1858 $item = shift(@Out); # Sort current item (don't care which one)
1859 &sort($item); # Update internal structures
1860 }
1861}
1862
1863# Resynchronize the outsiders stack (those items that have no more precursors).
1864# If the outsiders stack becomes empty, then there is a cycle.
1865sub resync {
1866 foreach $target (keys %Prec) {
1867 if ($Prec{$target} == 0) {
1868 delete $Prec{$target}; # We're done with this item
1869 push(@Out, $target); # Ready to be sorted
1870 }
1871 }
1872}
1873
1874# Sort item
1875sub sort {
1876 local($item) = @_;
1877 print "(ok) $item\n" if $main'opt_d && !$Cycle;
1878 print "(fx) $item\n" if $main'opt_d && $Cycle;
1879 foreach $succ (split(' ', $Succ{$item})) {
1880 # The test for definedness is necessary, since when a cycle is found,
1881 # one item is forced out of %Prec. If we had the guarantee of no
1882 # cycle, the the test would not be necessary and no decrementation
1883 # could go past 0.
1884 $Prec{$succ}-- if defined $Prec{$succ};
1885 }
1886}
1887
1888# Extract cycle... We look through the %Prec array and find all those items
1889# with the same lowest value. Those are a cycle, so we dump them, and make
1890# them new outsiders by resetting their count to 0.
1891sub extract_cycle {
1892 local(*Prec, *Succ) = @_;
1893 local($item) = (&sort_by_value(*Prec))[0];
1894 local($min) = $Prec{$item}; # Minimum value
1895 local($key, $value);
1896 local(%candidate); # Superset of the cycle we found
1897 warn " Cycle found for:\n";
1898 $Cycle++;
1899 while (($key, $value) = each %Prec) {
1900 $candidate{$key}++ if $value == $min;
1901 }
1902 local(%state); # State of visited nodes (1 = cycle, -1 = dead)
1903 local($CYCLE) = 1; # Possible member of a cycle
1904 local($DEAD) = -1; # Dead end, no cycling possible
1905 foreach $key (keys %candidate) {
1906 last if $CYCLE == &visit($key, $Succ{$key});
1907 }
1908 while (($key, $value) = each %candidate) {
1909 next unless $state{$key} == $CYCLE;
1910 $Prec{$key} = 0; # Members of cycle are new outsiders
1911 warn "\t(#$Cycle) $key\n";
1912 }
1913 local(%involved); # Items involved in the cycle...
1914 while (($key, $value) = each %state) {
1915 $involved{$key}++ if $state{$key} == $CYCLE;
1916 }
1917 &outline_cycle(*Succ, *involved);
1918}
1919
1920sub outline_cycle {
1921 local(*Succ, *member) = @_;
1922 local($key, $value);
1923 local($depends);
1924 local($unit);
1925 warn " Cycle involves:\n";
1926 while (($key, $value) = each %Succ) {
1927 next unless $member{$key};
1928 $depends = '';
1929 foreach $item (split(' ', $value)) {
1930 $depends .= "$item " if $member{$item};
1931 }
1932 $unit = $main'shmaster{"\$$key"};
1933 $unit =~ s/\s+$//;
1934 $unit = '?' if $unit eq '';
1935 warn "\t($unit) $key: $depends\n";
1936 }
1937}
1938
1939# Visit a tree node, following all its successors, until we find a cycle.
1940# Return $CYCLE if the exploration of the node leaded to a cycle, $DEAD
1941# otherwise.
1942sub visit {
1943 local($node, $children) = @_; # A node and its children
1944 # If we have already visited the node, return the status value attached
1945 # to it.
1946 return $state{$node} if $state{$node};
1947 $state{$node} = $CYCLE; # Assume member of cycle
1948 local($all_dead) = 1; # Set to 0 if at least one cycle found
1949 foreach $child (split(' ', $children)) {
1950 $all_dead = 0 if $CYCLE == &visit($child, $Succ{$child});
1951 }
1952 $state{$node} = $DEAD if $all_dead;
1953 $state{$node};
1954}
1955
1956# Sort associative array by value
1957sub sort_by_value {
1958 local(*x) = @_;
1959 sub _by_value { $x{$a} <=> $x{$b}; }
1960 sort _by_value keys %x;
1961}
1962
1963package main;
1964
19651;
1966# Perform ~name expansion ala ksh...
1967# (banish csh from your vocabulary ;-)
1968sub tilda_expand {
1969 local($path) = @_;
1970 return $path unless $path =~ /^~/;
1971 $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e; # ~name
1972 $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e; # ~
1973 $path;
1974}
1975
1976# Set up profile components into %Profile, add any profile-supplied options
1977# into @ARGV and return the command invocation name.
1978sub profile {
1979 local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
1980 local($me) = $0; # Command name
1981 $me =~ s|.*/(.*)|$1|; # Keep only base name
1982 return $me unless -s $profile;
1983 local(*PROFILE); # Local file descriptor
1984 local($options) = ''; # Options we get back from profile
1985 unless (open(PROFILE, $profile)) {
1986 warn "$me: cannot open $profile: $!\n";
1987 return;
1988 }
1989 local($_);
1990 local($component);
1991 while (<PROFILE>) {
1992 next if /^\s*#/; # Skip comments
1993 next unless /^$me/o;
1994 if (s/^$me://o) { # progname: options
1995 chop;
1996 $options .= $_; # Merge options if more than one line
1997 }
1998 elsif (s/^$me-([^:]+)://o) { # progname-component: value
1999 $component = $1;
2000 chop;
2001 s/^\s+//; # Trim leading and trailing spaces
2002 s/\s+$//;
2003 $Profile{$component} = $_;
2004 }
2005 }
2006 close PROFILE;
2007 return unless $options;
2008 require 'shellwords.pl';
2009 local(@opts);
2010 eval '@opts = &shellwords($options)'; # Protect against mismatched quotes
2011 unshift(@ARGV, @opts);
2012 return $me; # Return our invocation name
2013}
2014