dist-3.0at70b/mcon/mlint

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