bin/mconfig

   1 #!/usr/bin/perl
   2
   3 use sort "stable";
   4 BEGIN { $ENV{LC_ALL} = "C"; }
   5
   6 use FindBin;
   7 use Getopt::Std;
   8 use Data::Dump qw(dd pp);
   9
  10 $p5_metaconfig_base = "$FindBin::Bin/../";
  11 chdir "$p5_metaconfig_base/perl" or
  12     die "perl/ directory missing in $p5_metaconfig_base\n";
  13
  14 -w 'Configure' && -w 'config_h.SH' or
  15     die "both Configure and config_h.SH must be writable\n";
  16
  17 -l '.package' && -l 'U' or
  18     die ".package and U should be symlinks as per README\n";
  19
  20 # $Id: mconfig.SH 22 2008-05-28 08:01:59Z rmanfredi $
  21 #
  22 #  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
  23 #
  24 #  You may redistribute only under the terms of the Artistic Licence,
  25 #  as specified in the README file that comes with the distribution.
  26 #  You may reuse parts of this distribution only within the terms of
  27 #  that same Artistic Licence; a copy of which may be found at the root
  28 #  of the source tree for dist 4.0.
  29 #
  30 # Original Author: Larry Wall <lwall@netlabs.com>
  31 # Key Contributor: Harlan Stenn <harlan@mumps.pfcs.com>
  32 #
  33 # $Log: mconfig.SH,v $
  34 # Revision 3.0.1.5  1995/07/25  14:19:05  ram
  35 # patch56: new -G option
  36 #
  37 # Revision 3.0.1.4  1994/06/20  07:11:04  ram
  38 # patch30: new -L option to override public library path for testing
  39 #
  40 # Revision 3.0.1.3  1994/01/24  14:20:53  ram
  41 # patch16: added ~/.dist_profile awareness
  42 #
  43 # Revision 3.0.1.2  1993/10/16  13:53:10  ram
  44 # patch12: new -M option for magic symbols and confmagic.h production
  45 #
  46 # Revision 3.0.1.1  1993/08/19  06:42:26  ram
  47 # patch1: leading config.sh searching was not aborting properly
  48 #
  49 # Revision 3.0  1993/08/18  12:10:17  ram
  50 # Baseline for dist 3.0 netwide release.
  51 #
  52
  53 # Perload ON
  54
  55 $MC = "$p5_metaconfig_base/dist";
  56 $version = '3.5';
  57 $patchlevel = '0';
  58 $grep = '/usr/bin/grep';
  59 chop($date = `date`);
  60 &profile;                                               # Read ~/.dist_profile
  61 &usage unless getopts("dhkmoOstvwGMVL:");
  62
  63 $MC = $opt_L if $opt_L;                 # May override public library path
  64 $MC = &tilda_expand($MC);               # ~name expansion
  65 chop($WD = `pwd`);                              # Working directory
  66 chdir $MC || die "Can't chdir to $MC: $!\n";
  67 chop($MC = `pwd`);                              # Real metaconfig lib path (no symbolic links)
  68 chdir $WD || die "Can't chdir back to $WD: $!\n";
  69
  70 ++$opt_k if $opt_d;
  71 ++$opt_M if -f 'confmagic.h';   # Force -M if confmagic.h already there
  72
  73 if ($opt_V) {
  74         print STDERR "metaconfig $version PL$patchlevel\n";
  75         exit 0;
  76 } elsif ($opt_h) {
  77         &usage;
  78 }
  79
  80 unlink 'Wanted' unless $opt_w;                  # Wanted rebuilt if no -w
  81 unlink 'Obsolete' unless $opt_w;                # Obsolete file rebuilt if no -w
  82 &readpackage;                                                   # Merely get the package's name
  83 &init;                                                                  # Various initializations
  84 `mkdir .MT 2>&1` unless -d '.MT';               # For private temporary files
  85
  86 &locate_units;                          # Fill in @ARGV with a unit list
  87 &extract_dependencies;          # Extract dependencies from units
  88 &extract_filenames;                     # Extract files to be scanned for
  89 &build_wanted;                          # Build a list of wanted symbols in file Wanted
  90 &build_makefile;                        # To do the transitive closure of dependencies
  91 &solve_dependencies;            # Now run the makefile to close dependency graph
  92 &create_configure;                      # Create the Configure script and related files
  93 &cosmetic_update;                       # Update the manifests
  94
  95 if ($opt_k) {
  96         print "Leaving subdirectory .MT unremoved so you can peruse it.\n"
  97                 unless $opt_s;
  98 } else {
  99         `rm -rf .MT 2>&1`;
 100 }
 101 system $^X, "Porting/config_h.pl";
 102 print "Done.\n" unless $opt_s;
 103
 104 # General initializations
 105 sub init {
 106         &init_except;                   # Token which have upper-cased letters
 107         &init_keep;                             # The keep status for built-in interpreter
 108         &init_priority;                 # Priorities for diadic operators
 109         &init_constants;                # Define global constants
 110         &init_depend;                   # The %Depend array records control line handling
 111 }
 112
 113 sub init_constants {
 114         $NEWMANI = 'MANIFEST.new';              # List of files to be scanned
 115         $MANI = 'MANIFEST';                             # For manifake
 116
 117         # The distinction between MANIFEST.new and MANIFEST can make sense
 118         # when the "pat" tools are used, but if only metaconfig is used, then
 119         # we can very well leave without a MANIFEST.new.  --RAM, 2006-08-25
 120         $NEWMANI = $MANI if -f $MANI && ! -f $NEWMANI;
 121 }
 122
 123 # Record the exceptions -- almost all symbols but these are lower case
 124 # We also use three symbols from Unix.U for default file suffixes.
 125 sub init_except {
 126         $Except{'Author'}++;
 127         $Except{'Date'}++;
 128         $Except{'Header'}++;
 129         $Except{'Id'}++;
 130         $Except{'Locker'}++;
 131         $Except{'Log'}++;
 132         $Except{'RCSfile'}++;
 133         $Except{'Revision'}++;
 134         $Except{'Source'}++;
 135         $Except{'State'}++;
 136         $Except{'_a'}++;
 137         $Except{'_o'}++;
 138         $Except{'_exe'}++;
 139 }
 140
 141 # Print out metaconfig's usage and exits
 142 sub usage {
 143         print STDERR <<'EOH';
 144 Usage: metaconfig [-dhkmostvwGMV] [-L dir]
 145   -d : debug mode.
 146   -h : print this help message and exits.
 147   -k : keep temporary directory.
 148   -m : assume lots of memory and swap space.
 149   -o : maps obsolete symbols on new ones.
 150   -s : silent mode.
 151   -t : trace symbols as they are found.
 152   -v : verbose mode.
 153   -w : trust Wanted file as being up-to-date.
 154   -G : also provide a GNU configure-like front end.
 155   -L : specify main units repository.
 156   -M : activate production of confmagic.h.
 157   -V : print version number and exits.
 158 EOH
 159         exit 1;
 160 }
 161
 162 package locate;
 163
 164 # Locate the units and push their path in @ARGV (sorted alphabetically)
 165 sub main'locate_units {
 166         print "Locating units...\n" unless $main'opt_s;
 167         local(*WD) = *main'WD;                  # Current working directory
 168         local(*MC) = *main'MC;                  # Public metaconfig library
 169         undef %myUlist;                                 # Records private units paths
 170         undef %myUseen;                                 # Records private/public conflicts
 171         &private_units;                                 # Locate private units in @myUlist
 172         &public_units;                                  # Locate public units in @ARGV
 173         @ARGV = sort @ARGV;                             # Sort it alphabetically
 174         push(@ARGV, sort @myUlist);             # Append user's units sorted
 175         &dump_list if $main'opt_v;              # Dump the list of units
 176 }
 177
 178 # Dump the list of units on stdout
 179 sub dump_list {
 180         print "\t";
 181         $, = "\n\t";
 182         print @ARGV;
 183         $, = '';
 184         print "\n";
 185 }
 186
 187 # Scan private units
 188 sub private_units {
 189         return unless -d 'U';                   # Nothing to be done if no 'U' entry
 190         local(*ARGV) = *myUlist;                # Really fill in @myUlist
 191         local($MC) = $WD;                               # We are really in the working directory
 192         &units_path("U");                               # Locate units in the U directory
 193         local($unit_name);                              # Unit's name (without .U)
 194         local(@kept);                                   # Array of kept units
 195         # Loop over the units and remove duplicates (the first one seen is the one
 196         # we keep). Also set the %myUseen H table to record private units seen.
 197         foreach (@ARGV) {
 198                 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
 199                 next if $myUseen{$unit_name};   # Already recorded
 200                 $myUseen{$unit_name} = 1;               # Record pirvate unit
 201                 push(@kept, $_);                                # Keep this unit
 202         }
 203         @ARGV = @kept;
 204 }
 205
 206 # Scan public units
 207 sub public_units {
 208         chdir($MC) || die "Can't find directory $MC.\n";
 209         &units_path("U");                               # Locate units in public U directory
 210         chdir($WD) || die "Can't go back to directory $WD.\n";
 211         local($path);                                   # Relative path from $WD
 212         local($unit_name);                              # Unit's name (without .U)
 213         local(*Unit) = *main'Unit;              # Unit is a global from main package
 214         local(@kept);                                   # Units kept
 215         local(%warned);                                 # Units which have already issued a message
 216         # Loop over all the units and keep only the ones that were not found in
 217         # the user's U directory. As it is possible two or more units with the same
 218         # name be found in
 219         foreach (@ARGV) {
 220                 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
 221                 next if $warned{$unit_name};    # We have already seen this unit
 222                 $warned{$unit_name} = 1;                # Remember we have warned the user
 223                 if ($myUseen{$unit_name}) {             # User already has a private unit
 224                         $path = $Unit{$unit_name};      # Extract user's unit path
 225                         next if $path eq $_;            # Same path, we must be in mcon/
 226                         $path =~ s|^$WD/||o;            # Weed out leading working dir path
 227                         $::opt_O and next;
 228                         print "    Your private $path overrides the public one.\n"
 229                                 unless $main'opt_s;
 230                 } else {
 231                         push(@kept, $_);                        # We may keep this one
 232                 }
 233         }
 234         @ARGV = @kept;
 235 }
 236
 237 # Recursively locate units in the directory. Each file ending with .U has to be
 238 # a unit. Others are stat()'ed, and if they are a directory, they are also
 239 # scanned through. The $MC and @ARGV variable are dynamically set by the caller.
 240 sub units_path {
 241         local($dir) = @_;                                       # Directory where units are to be found
 242         local(@contents);                                       # Contents of the directory
 243         local($unit_name);                                      # Unit's name, without final .U
 244         local($path);                                           # Full path of a unit
 245         local(*Unit) = *main'Unit;                      # Unit is a global from main package
 246         unless (opendir(DIR, $dir)) {
 247                 warn("Cannot open directory $dir.\n");
 248                 return;
 249         }
 250         print "Locating in $MC/$dir...\n" if $main'opt_v;
 251         @contents = readdir DIR;                        # Slurp the whole thing
 252         closedir DIR;                                           # And close dir, ready for recursion
 253         foreach (sort @contents) {
 254                 next if $_ eq '.' || $_ eq '..';
 255                 if (/\.U$/) {                                   # A unit, definitely
 256                         ($unit_name) = /^(.*)\.U$/;
 257                         $path = "$MC/$dir/$_";                          # Full path of unit
 258                         push(@ARGV, $path);                                     # Record its path
 259                         if (defined $Unit{$unit_name}) {        # Already seen this unit
 260                                 if ($main'opt_v) {
 261                                         ($path) = $Unit{$unit_name} =~ m|^(.*)/.*|;
 262                                         print "    We've already seen $unit_name.U in $path.\n";
 263                                 }
 264                         } else {
 265                                 $Unit{$unit_name} = $path;              # Map name to path
 266                         }
 267                         next;
 268                 }
 269                 # We have found a file which does not look like a unit. If it is a
 270                 # directory, then scan it. Otherwise skip the file.
 271                 unless (-d "$dir/$_") {
 272                         print "    Skipping file $_ in $dir.\n" if $main'opt_v;
 273                         next;
 274                 }
 275                 &units_path("$dir/$_");
 276                 print "Back to $MC/$dir...\n" if $main'opt_v;
 277         }
 278 }
 279
 280 package main;
 281
 282 # Initialize the extraction process by setting some variables.
 283 # We return a string to be eval to do more customized initializations.
 284 sub init_extraction {
 285         open(INIT, ">$WD/.MT/Init.U") ||
 286                 die "Can't create .MT/Init.U\n";
 287         open(CONF_H, ">$WD/.MT/Config_h.U") ||
 288                 die "Can't create .MT/Config_h.U\n";
 289         open(EXTERN, ">$WD/.MT/Extern.U") ||
 290                 die "Can't create .MT/Extern.U\n";
 291         open(MAGIC_H, ">$WD/.MT/Magic_h.U") ||
 292                 die "Can't create .MT/Magic_h.U\n";
 293
 294         $c_symbol = '';                         # Current symbol seen in ?C: lines
 295         $s_symbol = '';                         # Current symbol seen in ?S: lines
 296         $m_symbol = '';                         # Current symbol seen in ?M: lines
 297         $heredoc = '';                          # Last "here" document symbol seen
 298         $heredoc_nosubst = 0;           # True for <<'EOM' here docs
 299         $condlist = '';                         # List of conditional symbols
 300         $defined = '';                          # List of defined symbols in the unit
 301         $body = '';                                     # No procedure to handle body
 302         $ending = '';                           # No procedure to clean-up
 303 }
 304
 305 # End the extraction process
 306 sub end_extraction {
 307         close EXTERN;                   # External dependencies (libraries, includes...)
 308         close CONF_H;                   # C symbol definition template
 309         close INIT;                             # Required initializations
 310         close MAGIC;                    # Magic C symbol redefinition templates
 311
 312         print $dependencies if $opt_v;  # Print extracted dependencies
 313 }
 314
 315 # Process the ?MAKE: line
 316 sub p_make {
 317         local($_) = @_;
 318         local(@ary);                                    # Locally defined symbols
 319         local(@dep);                                    # Dependencies
 320         if (/^[\w+ ]*:/) {                              # Main dependency rule
 321                 s|^\s*||;                                       # Remove leading spaces
 322                 chop;
 323                 s/:(.*)//;
 324                 @dep = split(' ', $1);                  # Dependencies
 325                 @ary = split(' ');                              # Locally defined symbols
 326                 foreach $sym (@ary) {
 327                         # Symbols starting with a '+' are meant for internal use only.
 328                         next if $sym =~ s/^\+//;
 329                         # Only sumbols starting with a lowercase letter are to
 330                         # appear in config.sh, excepted the ones listed in Except.
 331                         if ($sym =~ /^[_a-z]/ || $Except{$sym}) {
 332                                 $shmaster{"\$$sym"} = undef;
 333                                 push(@Master,"?$unit:$sym=''\n");       # Initializations
 334                         }
 335                 }
 336                 $condlist = '';                         # List of conditional symbols
 337                 local($sym);                            # Symbol copy, avoid @dep alteration
 338                 foreach $dep (@dep) {
 339                         if ($dep =~ /^\+[A-Za-z]/) {
 340                                 ($sym = $dep) =~ s|^\+||;
 341                                 $condlist .= "$sym ";
 342                                 push(@Cond, $sym) unless $condseen{$sym};
 343                                 $condseen{$sym}++;              # Conditionally wanted
 344                         }
 345                 }
 346                 # Append to already existing dependencies. The 'defined' variable
 347                 # is set for &write_out, used to implement ?L: and ?I: canvas. It is
 348                 # reset each time a new unit is parsed.
 349                 # NB: leading '+' for defined symbols (internal use only) have been
 350                 # removed at this point, but conditional dependencies still bear it.
 351                 $defined = join(' ', @ary);             # Symbols defined by this unit
 352                 $dependencies .= $defined . ':' . join(' ', @dep) . "\n";
 353                 $dependencies .= "      -cond $condlist\n" if $condlist;
 354         } else {
 355                 $dependencies .= $_;            # Building rules
 356         }
 357 }
 358
 359 # Process the ?O: line
 360 sub p_obsolete {
 361         local($_) = @_;
 362         $Obsolete{"$unit.U"} .= $_;             # Message(s) to print if unit is used
 363 }
 364
 365 # Process the ?S: lines
 366 sub p_shell {
 367         local($_) = @_;
 368         unless ($s_symbol) {
 369                 if (/^(\w+).*:/) {
 370                         $s_symbol = $1;
 371                         print "  ?S: $s_symbol\n" if $opt_d;
 372                 } else {
 373                         warn "\"$file\", line $.: syntax error in ?S: construct.\n";
 374                         $s_symbol = $unit;
 375                         return;
 376                 }
 377                 # Deal with obsolete symbol list (enclosed between parenthesis)
 378                 &record_obsolete("\$$_") if /\(/;
 379         }
 380         m|^\.\s*$| && ($s_symbol = '');         # End of comment
 381 }
 382
 383 # Process the ?C: lines
 384 sub p_c {
 385         local($_) = @_;
 386         unless ($c_symbol) {
 387                 if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) {
 388                         # The ~ operator aliases the main C symbol to another symbol which
 389                         # is to be used instead for definition in config.h. That is to say,
 390                         # the line '?C:SYM ~ other:' would look for symbol 'other' instead,
 391                         # and the documentation for symbol SYM would only be included in
 392                         # config.h if 'other' were actually wanted.
 393                         $c_symbol = $2;                 # Alias for definition in config.h
 394                         print "  ?C: $1 ~ $c_symbol\n" if $opt_d;
 395                 } elsif (/^(\w+).*:/) {
 396                         # Default behaviour. Include in config.h if symbol is needed.
 397                         $c_symbol = $1;
 398                         print "  ?C: $c_symbol\n" if $opt_d;
 399                 } else {
 400                         warn "\"$file\", line $.: syntax error in ?C: construct.\n";
 401                         $c_symbol = $unit;
 402                         return;
 403                 }
 404                 # Deal with obsolete symbol list (enclosed between parenthesis) and
 405                 # make sure that list do not appear in config.h.SH by removing it.
 406                 &record_obsolete("$_") if /\(/;
 407                 s/\s*\(.*\)//;                                  # Get rid of obsolete symbol list
 408         }
 409         s|^(\w+)\s*|?$c_symbol:/* $1| ||                                                # Start of comment
 410         (s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) || # End of comment
 411         s|^(.*)|?$c_symbol: *$1|;                                                               # Middle of comment
 412         &p_config("$_");                                        # Add comments to config.h.SH
 413 }
 414
 415 # Process the ?H: lines
 416 sub p_config {
 417         local($_) = @_;
 418         local($constraint);                                     # Constraint to be used for inclusion
 419         ++$old_version if s/^\?%1://;           # Old version
 420         if (s/^\?(\w+)://) {                            # Remove leading '?var:'
 421                 $constraint = $1;                               # Constraint is leading '?var'
 422         } else {
 423                 $constraint = '';                               # No constraint
 424         }
 425         if (/^#.*\$/) {                                         # Look only for cpp lines
 426                 if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) {
 427                         # Case: #$d_var VAR "$var"
 428                         $constraint = $2 unless $constraint;
 429                         print "  ?H: ($constraint) #\$$1 $2 \"\$$3\"\n" if $opt_d;
 430                         $cmaster{$2} = undef;
 431                         $cwanted{$2} = "$1\n$3";
 432                 } elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) {
 433                         # Case: #define VAR(x) $var
 434                         $constraint = $1 unless $constraint;
 435                         print "  ?H: ($constraint) #define $1($2) \$$3\n" if $opt_d;
 436                         $cmaster{$1} = undef;
 437                         $cwanted{$1} = $3;
 438                 } elsif (m|^#\$define\s+(\w+)|) {
 439                         # Case: #$define VAR
 440                         $constraint = $1 unless $constraint;
 441                         print "  ?H: ($constraint) #define $1\n" if $opt_d;
 442                         $cmaster{$1} = undef;
 443                         $cwanted{$1} = "define\n$unit";
 444                 } elsif (m|^#\$(\w+)\s+(\w+)|) {
 445                         # Case: #$d_var VAR
 446                         $constraint = $2 unless $constraint;
 447                         print "  ?H: ($constraint) #\$$1 $2\n" if $opt_d;
 448                         $cmaster{$2} = undef;
 449                         $cwanted{$2} = $1;
 450                 } elsif (m|^#define\s+(\w+).*\$(\w+)|) {
 451                         # Case: #define VAR "$var"
 452                         $constraint = $1 unless $constraint;
 453                         print "  ?H: ($constraint) #define $1 \"\$$2\"\n" if $opt_d;
 454                         $cmaster{$1} = undef;
 455                         $cwanted{$1} = $2;
 456                 } else {
 457                         $constraint = $unit unless $constraint;
 458                         print "  ?H: ($constraint) $_" if $opt_d;
 459                 }
 460         } else {
 461                 print "  ?H: ($constraint) $_" if $opt_d;
 462         }
 463         # If not a single ?H:. line, add the leading constraint
 464         s/^\.// || s/^/?$constraint:/;
 465         print CONF_H;
 466 }
 467
 468 # Process the ?M: lines
 469 sub p_magic {
 470         local($_) = @_;
 471         unless ($m_symbol) {
 472                 if (/^(\w+):\s*([\w\s]*)\n$/) {
 473                         # A '?M:sym:' line implies a '?W:%<:sym' since we'll need to know
 474                         # about the wantedness of sym later on when building confmagic.h.
 475                         # Buf is sym is wanted, then the C symbol dependencies have to
 476                         # be triggered. That is done by introducing sym in the mwanted
 477                         # array, known by the Wanted file construction process...
 478                         $m_symbol = $1;
 479                         print "  ?M: $m_symbol\n" if $opt_d;
 480                         $mwanted{$m_symbol} = $2;               # Record C dependencies
 481                         &p_wanted("$unit:$m_symbol");   # Build fake ?W: line
 482                 } else {
 483                         warn "\"$file\", line $.: syntax error in ?M: construct.\n";
 484                 }
 485                 return;
 486         }
 487         (s/^\.\s*$/?$m_symbol:\n/ && ($m_symbol = '', 1)) ||    # End of block
 488         s/^/?$m_symbol:/;
 489         print MAGIC_H;                                  # Definition goes to confmagic.h
 490         print "  ?M: $_" if $opt_d;
 491 }
 492
 493 sub p_ignore {}         # Ignore comment line
 494 sub p_lint {}           # Ignore lint directives
 495 sub p_visible {}        # No visible checking in metaconfig
 496 sub p_temp {}           # No temporary variable control
 497 sub p_file {}           # Ignore produced file directives (for now)
 498
 499 # Process the ?W: lines
 500 sub p_wanted {
 501         # Syntax is ?W:<shell symbols>:<C symbols>
 502         local($active) = $_[0] =~ /^([^:]*):/;          # Symbols to activate
 503         local($look_symbols) = $_[0] =~ /:(.*)/;        # When those are used
 504         local(@syms) = split(/ /, $look_symbols);       # Keep original spacing info
 505         $active =~ s/\s+/\n/g;                                          # One symbol per line
 506
 507         # Concatenate quoted strings, so saying something like 'two words' will
 508         # be introduced as one single symbol "two words".
 509         local(@symbols);                                # Concatenated symbols to look for
 510         local($concat) = '';                    # Concatenation buffer
 511         foreach (@syms) {
 512                 if (s/^\'//) {
 513                         $concat = $_;
 514                 } elsif (s/\'$//) {
 515                         push(@symbols, $concat . ' ' . $_);
 516                         $concat = '';
 517                 } else {
 518                         push(@symbols, $_) unless $concat;
 519                         $concat .= ' ' . $_ if $concat;
 520                 }
 521         }
 522
 523         # Now record symbols in master and wanted tables
 524         foreach (@symbols) {
 525                 $cmaster{$_} = undef;                                   # Asks for look-up in C files
 526                 $cwanted{$_} = "$active" if $active;    # Shell symbols to activate
 527         }
 528 }
 529
 530 # Process the ?INIT: lines
 531 sub p_init {
 532         local($_) = @_;
 533         print INIT "?$unit:", $_;               # Wanted only if unit is loaded
 534 }
 535
 536 # Process the ?D: lines
 537 sub p_default {
 538         local($_) = @_;
 539         s/^([A-Za-z_]+)=(.*)/\@if !$1\n%$1:$1=$2\n\@define $1\n\@end/
 540                 && ($hasdefault{$1}++, print INIT $_);
 541 }
 542
 543 # Process the ?P: lines
 544 sub p_public {
 545         local($_) = @_;
 546         local($csym);                                   # C symbol(s) we're trying to look at
 547         local($nosym);                                  # List of symbol(s) which mustn't be wanted
 548         local($cfile);                                  # Name of file implementing csym (no .ext)
 549         ($csym, $nosym, $cfile) = /([^()]+)\s*(\(.*\))\s*:\s*(\S+)/;
 550         unless ($csym eq '' || $cfile eq '') {
 551                 # Add dependencies for each C symbol, of the form:
 552                 #       -pick public <sym> <file> <notdef symbols list>
 553                 # and the file will be added to config.c whenever sym is wanted and
 554                 # none of the notdef symbols is wanted.
 555                 foreach $sym (split(' ', $csym)) {
 556                         $dependencies .= "\t-pick public $sym $cfile $nosym\n";
 557                 }
 558         }
 559 }
 560
 561 # Process the ?Y: lines
 562 # Valid layouts are for now are: top, bottom, default.
 563 #
 564 # NOTA BENE:
 565 # This routine relies on the $defined variable, a global variable set
 566 # during the ?MAKE: processing, which lists all the defined symbols in
 567 # the unit (the optional leading '+' for internal symbols has been removed
 568 # if present).
 569 #
 570 # The routine fills up a %Layout table, indexed by symbol, yielding the
 571 # layout imposed to this unit. That table will then be used later on when
 572 # we sort wanted symbols for the Makefile.
 573 sub p_layout {
 574         local($_) = @_;
 575         local($layout) = /^\s*(\w+)/;
 576         $layout =~ tr/A-Z/a-z/;         # Case is not significant for layouts
 577         unless (defined $Lcmp{$layout}) {
 578                 warn "\"$file\", line $.: unknown layout directive '$layout'.\n";
 579                 return;
 580         }
 581         foreach $sym (split(' ', $defined)) {
 582                 $Layout{$sym} = $Lcmp{$layout};
 583         }
 584 }
 585
 586 # Process the ?L: lines
 587 # There should not be any '-l' in front of the library name
 588 sub p_library {
 589         &write_out("L:$_");
 590 }
 591
 592 # Process the ?I: lines
 593 sub p_include {
 594         &write_out("I:$_");
 595 }
 596
 597 # Write out line in file Extern.U. The information recorded there has the
 598 # following prototypical format:
 599 #   ?symbol:L:inet bsd
 600 # If 'symbol' is wanted, then 'inet bsd' will be added to $libswanted.
 601 sub write_out {
 602         local($_) = @_;
 603         local($target) = $defined;              # By default, applies to defined symbols
 604         $target = $1 if s/^(.*)://;             # List is qualified "?L:target:symbols"
 605         local(@target) = split(' ', $target);
 606         chop;
 607         foreach $key (@target) {
 608                 print EXTERN "?$key:$_\n";      # EXTERN file defined in xref.pl
 609         }
 610 }
 611
 612 # The %Depend array records the functions we use to process the configuration
 613 # lines in the unit, with a special meaning. It is important that all the
 614 # known control symbols be listed below, so that metalint does not complain.
 615 # The %Lcmp array contains valid layouts and their comparaison value.
 616 sub init_depend {
 617         %Depend = (
 618                 'MAKE', 'p_make',                               # The ?MAKE: line records dependencies
 619                 'INIT', 'p_init',                               # Initializations printed verbatim
 620                 'LINT', 'p_lint',                               # Hints for metalint
 621                 'RCS', 'p_ignore',                              # RCS comments are ignored
 622                 'C', 'p_c',                                             # C symbols
 623                 'D', 'p_default',                               # Default value for conditional symbols
 624                 'E', 'p_example',                               # Example of usage
 625                 'F', 'p_file',                                  # Produced files
 626                 'H', 'p_config',                                # Process the config.h lines
 627                 'I', 'p_include',                               # Added includes
 628                 'L', 'p_library',                               # Added libraries
 629                 'M', 'p_magic',                                 # Process the confmagic.h lines
 630                 'O', 'p_obsolete',                              # Unit obsolescence
 631                 'P', 'p_public',                                # Location of PD implementation file
 632                 'S', 'p_shell',                                 # Shell variables
 633                 'T', 'p_temp',                                  # Shell temporaries used
 634                 'V', 'p_visible',                               # Visible symbols like 'rp', 'dflt'
 635                 'W', 'p_wanted',                                # Wanted value for interpreter
 636                 'X', 'p_ignore',                                # User comment is ignored
 637                 'Y', 'p_layout',                                # User-defined layout preference
 638         );
 639         %Lcmp = (
 640                 'top',          -1,
 641                 'default',      0,
 642                 'bottom',       1,
 643         );
 644 }
 645
 646 # Extract dependencies from units held in @ARGV
 647 sub extract_dependencies {
 648         local($proc);                                           # Procedure used to handle a ctrl line
 649         local($file);                                           # Current file scanned
 650         local($dir, $unit);                                     # Directory and unit's name
 651         local($old_version) = 0;                        # True when old-version unit detected
 652         local($mc) = "$MC/U";                           # Public metaconfig directory
 653         local($line);                                           # Last processed line for metalint
 654
 655         printf "Extracting dependency lists from %d units...\n", $#ARGV+1
 656                 unless $opt_s;
 657
 658         chdir $WD;                                                      # Back to working directory
 659         &init_extraction;                                       # Initialize extraction files
 660         $dependencies = ' ' x (50 * @ARGV);     # Pre-extend
 661         $dependencies = '';
 662
 663         # We do not want to use the <> construct here, because we need the
 664         # name of the opened files (to get the unit's name) and we want to
 665         # reset the line number for each files, and do some pre-processing.
 666
 667         file: while ($file = shift(@ARGV)) {
 668                 close FILE;                                             # Reset line number
 669                 $old_version = 0;                               # True if unit is an old version
 670                 if (open(FILE, $file)) {
 671                         ($dir, $unit) = ('', $file)
 672                                 unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|);
 673                         $unit =~ s|\.U$||;                      # Remove extension
 674                 } else {
 675                         warn("Can't open $file.\n");
 676                 }
 677                 # If unit is in the standard public directory, keep only the unit name
 678                 $file = "$unit.U" if $dir eq $mc;
 679                 print "$dir/$unit.U:\n" if $opt_d;
 680                 line: while (<FILE>) {
 681                         $line = $_;                                     # Save last processed unit line
 682                         if (s/^\?([\w\-]+)://) {        # We may have found a control line
 683                                 $proc = $Depend{$1};    # Look for a procedure to handle it
 684                                 unless ($proc) {                # Unknown control line
 685                                         $proc = $1;                     # p_unknown expects symbol in '$proc'
 686                                         eval '&p_unknown';      # Signal error (metalint only)
 687                                         next line;                      # And go on next line
 688                                 }
 689                                 # Long lines may be escaped with a final backslash
 690                                 $_ .= &complete_line(FILE) if s/\\\s*$//;
 691                                 # Run macros substitutions
 692                                 s/%</$unit/g;                   # %< expands into the unit's name
 693                                 if (s/%\*/$unit/) {
 694                                         # %* expanded into the entire set of defined symbols
 695                                         # in the old version. Now it is only the unit's name.
 696                                         ++$old_version;
 697                                 }
 698                                 eval { &$proc($_) };            # Process the line
 699                         } else {
 700                                 next file unless $body;         # No procedure to handle body
 701                                 do {
 702                                         $line = $_;                             # Save last processed unit line
 703                                         eval { &$body($_) } ;   # From now on, it's the unit body
 704                                 } while (defined ($_ = <FILE>));
 705                                 next file;
 706                         }
 707                 }
 708         } continue {
 709                 warn("    Warning: $file is a pre-3.0 version.\n") if $old_version;
 710                 &$ending($line) if $ending;                     # Post-processing for metalint
 711         }
 712
 713         &end_extraction;                # End the extraction process
 714 }
 715
 716 # The first line was escaped with a final \ character. Every following line
 717 # is to be appended to it (until we found a real \n not escaped). Note that
 718 # the leading spaces of the continuation line are removed, so any space should
 719 # be added before the former \ if needed.
 720 sub complete_line {
 721         local($file) = @_;              # File where lines come from
 722         local($_);
 723         local($read) = '';              # Concatenation of all the continuation lines found
 724         while (<$file>) {
 725                 s/^\s+//;                               # Remove leading spaces
 726                 if (s/\\\s*$//) {               # Still followed by a continuation line
 727                         $read .= $_;
 728                 } else {                                # We've reached the end of the continuation
 729                         return $read . $_;
 730                 }
 731         }
 732 }
 733
 734 # Extract filenames from manifest
 735 sub extract_filenames {
 736         &build_filext;                  # Construct &is_cfile and &is_shfile
 737         print "Extracting filenames (C and SH files) from $NEWMANI...\n"
 738                 unless $opt_s;
 739         open(NEWMANI,$NEWMANI) || die "Can't open $NEWMANI.\n";
 740         local($file);
 741         while (<NEWMANI>) {
 742                 ($file) = split(' ');
 743                 next if $file eq 'config_h.SH';                 # skip config_h.SH
 744                 next if $file eq 'Configure';                   # also skip Configure
 745                 next if $file eq 'confmagic.h' && $opt_M;
 746                 push(@SHlist, $file) if &is_shfile($file);
 747                 push(@clist, $file) if &is_cfile($file);
 748         }
 749 }
 750
 751 # Construct two file identifiers based on the file suffix: one for C files,
 752 # and one for SH files (using the $cext and $shext variables) defined in
 753 # the .package file.
 754 # The &is_cfile and &is_shfile routine may then be called to known whether
 755 # a given file is a candidate for holding C or SH symbols.
 756 sub build_filext {
 757         &build_extfun('is_cfile', $cext, '.c .h .y .l');
 758         &build_extfun('is_shfile', $shext, '.SH');
 759 }
 760
 761 # Build routine $name to identify extensions listed in $exts, ensuring
 762 # that $minimum is at least matched (both to be backward compatible with
 763 # older .package and because it is really the minimum requirred).
 764 sub build_extfun {
 765         local($name, $exts, $minimum) = @_;
 766         local(@single);         # Single letter dot extensions (may be grouped)
 767         local(@others);         # Other extensions
 768         local(%seen);           # Avoid duplicate extensions
 769         foreach $ext (split(' ', "$exts $minimum")) {
 770                 next if $seen{$ext}++;
 771                 if ($ext =~ s/^\.(\w)$/$1/) {
 772                         push(@single, $ext);
 773                 } else {
 774                         # Convert into perl's regexp
 775                         $ext =~ s/\./\\./g;             # Escape .
 776                         $ext =~ s/\?/./g;               # ? turns into .
 777                         $ext =~ s/\*/.*/g;              # * turns into .*
 778                         push(@others, $ext);
 779                 }
 780         }
 781         local($fn) = &q(<<EOF);         # Function being built
 782 :sub $name {
 783 :       local(\$_) = \@_;
 784 EOF
 785         local($single);         # Single regexp: .c .h grouped into .[ch]
 786         $single = '\.[' . join('', @single) . ']' if @single;
 787         $fn .= &q(<<EOL) if @single;
 788 :       return 1 if /$single\$/;
 789 EOL
 790         foreach $ext (@others) {
 791                 $fn .= &q(<<EOL);
 792 :       return 1 if /$ext\$/;
 793 EOL
 794         }
 795         $fn .= &q(<<EOF);
 796 :       0;      # None of the extensions may be applied to file name
 797 :}
 798 EOF
 799         print $fn if $opt_d;
 800         eval $fn;
 801         chop($@) && die "Can't compile '$name':\n$fn\n$@.\n";
 802 }
 803
 804 # Remove ':' quotations in front of the lines
 805 sub q {
 806         local($_) = @_;
 807         s/^://gm;
 808         $_;
 809 }
 810
 811 # Build a wanted file from the files held in @SHlist and @clist arrays
 812 sub build_wanted {
 813         # If wanted file is already there, parse it to map obsolete if -o option
 814         # was used. Otherwise, build a new one.
 815         if (-f 'Wanted') {
 816                 &map_obsolete if $opt_o;                        # Build Obsol*.U files
 817                 &dump_obsolete;                                         # Dump obsolete symbols if any
 818                 return;
 819         }
 820         &parse_files;
 821 }
 822
 823 sub parse_files {
 824         print "Building a Wanted file...\n" unless $opt_s;
 825         open(WANTED,"| sort | uniq >Wanted") || die "Can't create Wanted.\n";
 826         unless (-f $NEWMANI) {
 827                 &manifake;
 828                 die "No $NEWMANI--can't build a Wanted file.\n" unless -f $NEWMANI;
 829         }
 830
 831         local($search);                                                 # Where to-be-evaled script is held
 832         local($_) = ' ' x 50000 if $opt_m;              # Pre-extend pattern search space
 833         local(%visited);                                                # Records visited files
 834         local(%lastfound);                                              # Where last occurence of key was
 835
 836         # Now we are a little clever, and build a loop to eval so that we don't
 837         # have to recompile our patterns on every file.  We also use "study" since
 838         # we are searching the same string for many different things.  Hauls!
 839
 840         if (@clist) {
 841                 local($others) = $cext ? " $cext" : '';
 842                 print "    Scanning .[chyl]$others files for symbols...\n"
 843                         unless $opt_s;
 844                 $search = ' ' x (40 * (@cmaster + @ocmaster));  # Pre-extend
 845                 $search = "while (<>) {study;\n";                               # Init loop over ARGV
 846                 foreach $key (keys(%cmaster)) {
 847                         $search .= "&cmaster('$key') if /\\b$key\\b/;\n";
 848                 }
 849                 foreach $key (grep(!/^\$/, keys %Obsolete)) {
 850                         $search .= "&ofound('$key') if /\\b$key\\b/;\n";
 851                 }
 852                 $search .= "}\n";                       # terminate loop
 853                 print $search if $opt_d;
 854                 @ARGV = @clist;
 855                 # Swallow each file as a whole, if memory is available
 856                 undef $/ if $opt_m;
 857                 eval $search;
 858                 eval '';
 859                 $/ = "\n";
 860                 while (($key,$value) = each(%cmaster)) {
 861                         print WANTED $cwanted{$key}, "\n", ">$key", "\n" if $value;
 862                 }
 863         }
 864
 865         # If they don't use magic but use magically guarded symbols without
 866         # their corresponding C symbol dependency, warn them, since they might
 867         # not know about that portability issue.
 868
 869         if (@clist && !$opt_M) {
 870                 local($nused);                                  # list of non-used symbols
 871                 local($warning) = 0;                    # true when one warning issued
 872                 foreach $cmag (keys %mwanted) { # loop over all used magic symbols
 873                         next unless $cmaster{$cmag};
 874                         $nused = '';
 875                         foreach $cdep (split(' ', $mwanted{$cmag})) {
 876                                 $nused .= " $cdep" unless $cmaster{$cdep};
 877                         }
 878                         $nused =~ s/^ //;
 879                         $nused = "one of " . $nused if $nused =~ s/ /, /g;
 880                         if ($nused ne '') {
 881                                 print "    Warning: $cmag is used without $nused.\n";
 882                                 $warning++;
 883                         }
 884                 }
 885                 if ($warning) {
 886                         local($those) = $warning == 1 ? 'that' : 'those';
 887                         local($s) = $warning == 1 ? '' : 's';
 888                         print "Note: $those previous warning$s may be suppressed by -M.\n";
 889                 }
 890         }
 891
 892         # Cannot remove $cmaster as it is used later on when building Configure
 893         undef @clist;
 894         undef %cwanted;
 895         undef %mwanted;
 896         %visited = ();
 897         %lastfound = ();
 898
 899         if (@SHlist) {
 900                 local($others) = $shext ? " $shext" : '';
 901                 print "    Scanning .SH$others files for symbols...\n" unless $opt_s;
 902                 $search = ' ' x (40 * (@shmaster + @oshmaster));        # Pre-extend
 903                 $search = "while (<>) {study;\n";
 904                 # All the keys already have a leading '$'
 905                 foreach $key (keys(%shmaster)) {
 906                         $search .= "&shmaster('$key') if /\\$key\\b/;\n";
 907                 }
 908                 foreach $key (grep (/^\$/, keys %Obsolete)) {
 909                         $search .= "&ofound('$key') if /\\$key\\b/;\n";
 910                 }
 911                 $search .= "}\n";
 912                 print $search if $opt_d;
 913                 @ARGV = @SHlist;
 914                 # Swallow each file as a whole, if memory is available
 915                 undef $/ if $opt_m;
 916                 eval $search;
 917                 eval '';
 918                 $/ = "\n";
 919                 while (($key,$value) = each(%shmaster)) {
 920                         if ($value) {
 921                                 $key =~ s/^\$//;
 922                                 print WANTED $key, "\n";
 923                         }
 924                 }
 925         }
 926
 927         # Obsolete symbols, if any, are written in the Wanted file preceded by a
 928         # '!' character. In case -w is used, we'll thus be able to correctly build
 929         # the Obsol_h.U and Obsol_sh.U files.
 930
 931         &add_obsolete;                                          # Add obsolete symbols in Wanted file
 932
 933         close WANTED;
 934
 935         # If obsolete symbols where found, write an Obsolete file which lists where
 936         # each of them appear and the new symbol to be used. Also write Obsol_h.U
 937         # and Obsol_sh.U in .MT for later perusal.
 938
 939         &dump_obsolete;                                         # Dump obsolete symbols if any
 940
 941         die "No desirable symbols found--aborting.\n" unless -s 'Wanted';
 942
 943         # Clean-up memory by freeing useless data structures
 944         undef @SHlist;
 945         undef %shmaster;
 946 }
 947
 948 # This routine records matches of C master keys
 949 sub cmaster {
 950         local($key) = @_;
 951         $cmaster{$key}++;                                       # This symbol is wanted
 952         return unless $opt_t || $opt_M;         # Return if neither -t nor -M
 953         if ($opt_t &&
 954                 $lastfound{$key} ne $ARGV               # Never mentionned for this file ?
 955         ) {
 956                 $visited{$ARGV}++ || print $ARGV,":\n";
 957                 print "\t$key\n";
 958                 $lastfound{$key} = $ARGV;
 959         }
 960         if ($opt_M &&
 961                 defined($mwanted{$key})                 # Found a ?M: symbol
 962         ) {
 963                 foreach $csym (split(' ', $mwanted{$key})) {
 964                         $cmaster{$csym}++;                      # Activate C symbol dependencies
 965                 }
 966         }
 967 }
 968
 969 # This routine records matches of obsolete keys (C or shell)
 970 sub ofound {
 971         local($key) = @_;
 972         local($_) = $Obsolete{$key};            # Value of new symbol
 973         $ofound{"$ARGV $key $_"}++;                     # Record obsolete match
 974         $cmaster{$_}++ unless /^\$/;            # A C hit
 975         $shmaster{$_}++ if /^\$/;                       # Or a shell one
 976         return unless $opt_t;                           # Continue if trace option on
 977         if ($lastfound{$key} ne $ARGV) {        # Never mentionned for this file ?
 978                 $visited{$ARGV}++ || print $ARGV,":\n";
 979                 print "\t$key (obsolete, use $_)\n";
 980                 $lastfound{$key} = $ARGV;
 981         }
 982 }
 983
 984 # This routine records matches of shell master keys
 985 sub shmaster {
 986         local($key) = @_;
 987         $shmaster{$key}++;                                      # This symbol is wanted
 988         return unless $opt_t;                           # Continue if trace option on
 989         if ($lastfound{$key} ne $ARGV) {        # Never mentionned for this file ?
 990                 $visited{$ARGV}++ || print $ARGV,":\n";
 991                 print "\t$key\n";
 992                 $lastfound{$key} = $ARGV;
 993         }
 994 }
 995
 996 # Write obsolete symbols into the Wanted file for later perusal by -w.
 997 sub add_obsolete {
 998         local($file);                                           # File where obsolete symbol was found
 999         local($old);                                            # Name of this old symbol
1000         local($new);                                            # Value of the new symbol to be used
1001         foreach $key (sort keys %ofound) {
1002                 ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/);
1003                 if ($new =~ s/^\$//) {                  # We found an obsolete shell symbol
1004                         print WANTED "!$old\n";
1005                 } else {                                                # We found an obsolete C symbol
1006                         print WANTED "!>$old\n";
1007                 }
1008         }
1009 }
1010
1011 # Map obsolete symbols from Wanted file into %Obsolete and call dump_obsolete
1012 # to actually build the Obsol_sh.U and Obsol_h.U files. Those will be needed
1013 # during the Configure building phase to actually do the remaping.
1014 # The obsolete symbols found are entered in the %ofound array, tagged as from
1015 # file 'XXX', which is specially recognized by dump_obsolete.
1016 sub map_obsolete {
1017         open(WANTED, 'Wanted') || die "Can't open Wanted file.\n";
1018         local($new);                            # New symbol to be used instead of obsolete one
1019         while (<WANTED>) {
1020                 chop;
1021                 next unless s/^!//;             # Skip non-obsolete symbols
1022                 if (s/^>//) {                                   # C symbol
1023                         $new = $Obsolete{$_};           # Fetch new symbol
1024                         $ofound{"XXX $_ $new"}++;       # Record obsolete match (XXX = no file)
1025                 } else {                                                # Shell symbol
1026                         $new = $Obsolete{"\$$_"};       # Fetch new symbol
1027                         $ofound{"XXX \$$_ $new"}++;     # Record obsolete match (XXX = no file)
1028                 }
1029         }
1030         close WANTED;
1031 }
1032
1033 # Record obsolete symbols association (new versus old), that is to say for a
1034 # given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended
1035 # for all shell variables
1036 sub record_obsolete {
1037         local($_) = @_;
1038         local(@obsoleted);                                      # List of obsolete symbols
1039         local($symbol);                                         # New symbol which must be used
1040         local($dollar) = s/^\$// ? '$':'';      # The '$' or a null string
1041         # Syntax for obsolete symbols specification is
1042         #    list of symbols (obsolete ones):
1043         if (/^(\w+)\s*\((.*)\)\s*:$/) {
1044                 $symbol = "$dollar$1";
1045                 @obsoleted = split(' ', $2);            # List of obsolete symbols
1046         } else {
1047                 if (/^(\w+)\s*\((.*):$/) {
1048                         warn "\"$file\", line $.: final ')' before ':' missing.\n";
1049                         $symbol = "$dollar$1";
1050                         @obsoleted = split(' ', $2);
1051                 } else {
1052                         warn "\"$file\", line $.: syntax error.\n";
1053                         return;
1054                 }
1055         }
1056         foreach $val (@obsoleted) {
1057                 $_ = $dollar . $val;
1058                 if (defined $Obsolete{$_}) {
1059                 warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n";
1060                 } else {
1061                         $Obsolete{$_} = $symbol;        # Record (old, new) tuple
1062                 }
1063         }
1064 }
1065
1066 # Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and
1067 # Obsol_sh.U to record old versus new mappings if the -o option was used.
1068 sub dump_obsolete {
1069         unless (-f 'Obsolete') {
1070                 open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n";
1071         }
1072         open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n";
1073         open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n";
1074         local($file);                                           # File where obsolete symbol was found
1075         local($old);                                            # Name of this old symbol
1076         local($new);                                            # Value of the new symbol to be used
1077         # Leave a blank line at the top so that anny added ^L will stand on a line
1078         # by itself (the formatting process adds a ^L when a new page is needed).
1079         format OBSOLETE_TOP =
1080
1081               File                 |      Old symbol      |      New symbol
1082 -----------------------------------+----------------------+---------------------
1083 .
1084         format OBSOLETE =
1085 @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<<
1086 $file,                               $old,                  $new
1087 .
1088         local(%seen);
1089         foreach $key (sort keys %ofound) {
1090                 ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/);
1091                 write(OBSOLETE) unless $file eq 'XXX';
1092                 next unless $opt_o;                             # Obsolete mapping done only with -o
1093                 next if $seen{$old}++;                  # Already remapped, thank you
1094                 if ($new =~ s/^\$//) {                  # We found an obsolete shell symbol
1095                         $old =~ s/^\$//;
1096                         print OBSOL_SH "$old=\"\$$new\"\n";
1097                 } else {                                                # We found an obsolete C symbol
1098                         print OBSOL_H "#ifdef $new\n";
1099                         print OBSOL_H "#define $old $new\n";
1100                         print OBSOL_H "#endif\n\n";
1101                 }
1102         }
1103         close OBSOLETE;
1104         close OBSOL_H;
1105         close OBSOL_SH;
1106         if (-s 'Obsolete') {
1107                 print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n";
1108         } else {
1109                 unlink 'Obsolete';
1110         }
1111         undef %ofound;                          # Not needed any more
1112 }
1113
1114 # Build the private makefile we use to compute the transitive closure of the
1115 # previously determined dependencies.
1116 sub build_makefile {
1117     print "XXX0: entering \&build_makefile\n";
1118         print "Computing optimal dependency graph...\n" unless $opt_s;
1119         chdir('.MT') || die "Can't chdir to .MT\n";
1120         local($wanted);                 # Wanted shell symbols
1121         &build_private;                 # Build a first makefile from dependencies
1122         &compute_loadable;              # Compute loadable units
1123         &update_makefile;               # Update makefile using feedback from first pass
1124         chdir($WD) || die "Can't chdir back to $WD\n";
1125         # Free memory by removing useless data structures
1126         undef $dependencies;
1127         undef $saved_dependencies;
1128     print "XXX1: leaving \&build_makefile\n";
1129 }
1130
1131 # First pass: build a private makefile from the extracted dependency, changing
1132 # conditional units to truly wanted ones if the symbol is used, removing the
1133 # dependency otherwise. The original dependencies are saved.
1134 sub build_private {
1135         print "    Building private make file...\n" unless $opt_s;
1136         open(WANTED,"../Wanted") || die "Can't reopen Wanted.\n";
1137         $wanted = ' ' x 2000;   # Pre-extend string
1138         $wanted = '';
1139         while (<WANTED>) {
1140                 chop;
1141                 next if /^!/;           # Skip obsolete symbols
1142                 if (s/^>//) {
1143                         $cmaster{$_}++;
1144                 } else {
1145                         $wanted .= "$_ ";
1146                 }
1147         }
1148         close WANTED;
1149
1150         # The wanted symbols are sorted so that d_* (checking for C library symbol)
1151         # come first and i_* (checking for includes) comes at the end. Grouping the
1152         # d_* symbols together has good chances of improving the locality of the
1153         # other questions and i_* symbols must come last since some depend on h_*
1154         # values which prevent incompatible headers inclusions.
1155         $wanted = join(' ', sort symbols split(' ', $wanted));
1156
1157         # Now generate the first makefile, which will be used to determine which
1158         # symbols we really need, so that conditional dependencies may be solved.
1159         open(MAKEFILE,">Makefile") || die "Can't create .MT/Makefile.\n";
1160         print MAKEFILE "SHELL = /bin/sh\n";
1161         print MAKEFILE "W = $wanted\n";
1162         $saved_dependencies = $dependencies;
1163         foreach $sym (@Cond) {
1164                 if ($symwanted{$sym}) {
1165                         $dependencies =~ s/\+($sym\s)/$1/gm;
1166                 } else {
1167                         $dependencies =~ s/\+$sym(\s)/$1/gm;
1168                 }
1169         }
1170         print MAKEFILE $dependencies;
1171         close MAKEFILE;
1172     print "AAA: leaving \&build_private\n";
1173     system(qq|cp -v 'Makefile' /tmp/first.Makefile|) and die "Unable to copy first Makefile: $!";
1174     # Note: Everything appears okay up to this point on FreeBSD
1175 }
1176
1177 # Ordering for symbols. Give higher priority to d_* ones and lower to i_* ones.
1178 # If any layout priority is defined in %Layout, it is used to order the
1179 # symbols.
1180 sub symbols {
1181         local($r) = $Layout{$a} <=> $Layout{$b};
1182         return $r if $r;
1183         # If we come here, both symbols have the same layout priority.
1184         if ($a =~ /^d_/) {
1185                 return -1 unless $b =~ /^d_/;
1186         } elsif ($b =~ /^d_/) {
1187                 return 1;
1188         } elsif ($a =~ /^i_/) {
1189                 return 1 unless $b =~ /^i_/;
1190         } elsif ($b =~ /^i_/) {
1191                 return -1;
1192         }
1193         $a cmp $b;
1194 }
1195
1196 # Run the makefile produced in the first pass to find the whole set of units we
1197 # have to load, filling in the %symwanted and %condwanted structures.
1198 sub compute_loadable {
1199         print "    Determining loadable units...\n" unless $opt_s;
1200     open(MAKE, "make -n |") || die "Can't run make";
1201     #open(MAKE, "-|", "make -n") || die "Can't run make";
1202         while (<MAKE>) {
1203                 s|^\s+||;                               # Some make print tabs before command
1204                 if (/^pick/) {
1205                         print "\t$_" if $opt_v;
1206                         ($pick,$cmd,$symbol,$unit) = split(' ');
1207                         $symwanted{$symbol}++;
1208                         $symwanted{$unit}++;
1209                 } elsif (/^cond/) {
1210                         print "\t$_" if $opt_v;
1211                         ($pick,@symbol) = split(' ');
1212                         for (@symbol) {
1213                                 $condwanted{$_}++;      # Default value is requested
1214                         }
1215                 }
1216         }
1217         close MAKE;
1218     print "BBB: leaving \&compute_loadable and dumping \%symwanted\n";
1219     dd(\%symwanted);
1220     # perllibs is not found in %symwanted on FreeBSD, though it is on Linux
1221 }
1222
1223 # Now that we know all the desirable symbols, we have to rebuild
1224 # another makefile, in order to have the units in a more optimal
1225 # way.
1226 # Actually, if we have both ?MAKE:a:+b and ?MAKE:d:b and 'd' is
1227 # wanted; then 'b' will be loaded. However, 'b' is a conditional
1228 # dependency for 'a', and it would be better if 'b' were loaded
1229 # before 'a' is, though this is not necessary.
1230 # It is hard to know that 'b' will be loaded *before* the first make.
1231
1232 # Back to the original dependencies, make loadable units truly wanted ones and
1233 # remove optional ones.
1234 sub update_makefile {
1235         print "    Updating make file...\n" unless $opt_s;
1236         open(MAKEFILE,">Makefile") || die "Can't create .MT/Makefile.\n";
1237         print MAKEFILE "SHELL = /bin/sh\n";
1238         print MAKEFILE "W = $wanted\n";
1239         foreach $sym (@Cond) {
1240                 if ($symwanted{$sym}) {
1241                         $saved_dependencies =~ s/\+($sym\s)/$1/gm;
1242                 } else {
1243                         $saved_dependencies =~ s/\+$sym(\s)/$1/gm;
1244                 }
1245         }
1246         print MAKEFILE $saved_dependencies;
1247         close MAKEFILE;
1248     print "CCC: leaving \&update_makefile\n";
1249     system(qq|cp -v 'Makefile' /tmp/second.Makefile|) and die "Unable to copy second Makefile: $!";
1250 }
1251
1252 # Solve dependencies by saving the 'pick' command in @cmdwanted
1253 sub solve_dependencies {
1254         local(%unitseen);                       # Record already picked units (avoid duplicates)
1255         print "Determining the correct order for the units...\n" unless $opt_s;
1256         chdir('.MT') || die "Can't chdir to .MT: $!.\n";
1257     open(MAKE, "make -n |") || die "Can't run make";
1258     #open(MAKE, "-|", "make -n") || die "Can't run make";
1259         while (<MAKE>) {
1260                 s|^\s+||;                               # Some make print tabs before command
1261                 print "\t$_" if $opt_v;
1262 # On FreeBSD-10.3, we're failing to get these 2 lines:
1263 #    pick add perllibs End
1264 #    pick add End End
1265                 if (/^pick/) {
1266                         ($pick,$cmd,$symbol,$unit) = split(' ');
1267                         push(@cmdwanted,"$cmd $symbol $unit")
1268                                 unless $unitseen{"$cmd:$unit"}++;
1269                 } elsif (/^cond/) {
1270                         # Ignore conditional symbol request
1271                 } else {
1272                         chop;
1273                         system $_;
1274                 }
1275         }
1276         chdir($WD) || die "Can't chdir to $WD: $!.\n";
1277         close MAKE;
1278 #    # Although second.Makefile looks okay, we're getting an error message:
1279 #       `All' not remade because of errors.
1280 #   Syntax error: EOF in backquote substitution
1281 #   Syntax error: Error in command substitution
1282     print "DDD: End of solve_dependencies and dumping \@cmdwanted\n";
1283     dd(\@cmdwanted);
1284 }
1285
1286
1287 # Create the Configure script
1288 sub create_configure {
1289         print "Creating Configure...\n" unless $opt_s;
1290         open(CONFIGURE,">Configure") || die "Can't create Configure: $!\n";
1291         open(CONF_H,">config_h.SH") || die "Can't create config_h.SH: $!\n";
1292         if ($opt_M) {
1293                 open(MAGIC_H,">confmagic.h") || die "Can't create confmagic.h: $!\n";
1294         }
1295
1296         chdir('.MT') || die "Can't cd to .MT: $!\n";
1297         for (@cmdwanted) {
1298                 &process_command($_);           # Run the makefile command
1299         }
1300         chdir($WD) || die "Can't cd back to $WD\n";
1301         close CONFIGURE;
1302         print CONF_H "#endif\n";                # Close the opened #ifdef (see Config_h.U)
1303         print CONF_H "!GROK!THIS!\n";
1304         close CONF_H;
1305         if ($opt_M) {
1306                 print MAGIC_H "#endif\n";       # Close the opened #ifdef (see Magic_h.U)
1307                 close MAGIC_H;
1308         }
1309         `chmod +x Configure`;
1310 }
1311
1312 # Process a Makefile 'pick' command
1313 sub process_command {
1314         local($cmd, $target, $unit_name) = split(' ', $_[0]);
1315         local($name) = $unit_name . '.U';       # Restore missing .U
1316         local($file) = $name;                           # Where unit is located
1317         unless ($file =~ m|^\./|) {                     # Unit produced earlier by metaconfig
1318                 $file = $Unit{$unit_name};              # Fetch unit from U directory
1319         }
1320         if (defined $Obsolete{$name}) {         # Signal use of an obsolete unit
1321                 warn "\tObsolete unit $name is used:\n";
1322                 local(@msg) = split(/\n/, $Obsolete{$name});
1323                 foreach $msg (@msg) {
1324                         warn "\t    $msg\n";
1325                 }
1326         }
1327         die "Can't open UNIT (name: $name, target: $target) $file.\n" unless open(UNIT, $file);
1328         print "\t$cmd $file\n" if $opt_v;
1329         &init_interp;                                           # Initializes the interpreter
1330
1331         # The 'add' command adds the unit to Configure.
1332         if ($cmd eq 'add') {
1333                 while (<UNIT>) {
1334                         print CONFIGURE unless &skipped || !&interpret($_);
1335                 }
1336         }
1337
1338         # The 'weed' command adds the unit to Configure, but
1339         # makes some tests for the lines starting with '?' or '%'.
1340         # These lines are kept only if the symbol is wanted.
1341         elsif ($cmd eq 'weed') {
1342                 while (<UNIT>) {
1343                         if (/^\?(\w+):/) {
1344                                 s/^\?\w+:// if $symwanted{$1};
1345                         }
1346                         if (/^%(\w+):/) {
1347                                 s/^%\w+:// if $condwanted{$1};
1348                         }
1349                         print CONFIGURE unless &skipped || !&interpret($_);
1350                 }
1351         }
1352
1353         # The 'wipe' command adds the unit to Configure, but
1354         # also substitues some hardwired macros.
1355         elsif ($cmd eq 'wipe') {
1356                 while (<UNIT>) {
1357                         s/<PACKAGENAME>/$package/g;
1358                         s/<MAINTLOC>/$maintloc/g;
1359                         s/<VERSION>/$version/g;                 # This is metaconfig's version
1360                         s/<PATCHLEVEL>/$patchlevel/g;   # And patchlevel information
1361                         s/<DATE>/$date/g;
1362                         s/<BASEREV>/$baserev/g;
1363                         s/<\$(\w+)>/eval("\$$1")/ge;    # <$var> -> $var substitution
1364                         print CONFIGURE unless &skipped || !&interpret($_);
1365                 }
1366         }
1367
1368         # The 'add.Null' command adds empty initializations
1369         # to Configure for all the shell variable used.
1370         elsif ($cmd eq 'add.Null') {
1371                 for (sort @Master) {
1372                         if (/^\?(\w+):/) {
1373                                 s/^\?\w+:// if $symwanted{$1};
1374                         }
1375                         print CONFIGURE unless &skipped;
1376                 }
1377                 for (sort @Cond) {
1378                         print CONFIGURE "$_=''\n"
1379                                 unless $symwanted{$_} || $hasdefault{$_};
1380                 }
1381                 while (<UNIT>) {
1382                         print CONFIGURE unless &skipped || !&interpret($_);
1383                 }
1384                 print CONFIGURE "CONFIG=''\n\n";
1385         }
1386
1387         # The 'add.Config_sh' command fills in the production of
1388         # the config.sh script within Configure. Only the used
1389         # variable are added, the conditional ones are skipped.
1390         elsif ($cmd eq 'add.Config_sh') {
1391                 while (<UNIT>) {
1392                         print CONFIGURE unless &skipped || !&interpret($_);
1393                 }
1394                 for (sort @Master) {
1395                         if (/^\?(\w+):/) {
1396                                 # Can't use $shmaster, because config.sh must
1397                                 # also contain some internal defaults used by
1398                                 # Configure (e.g. nm_opt, libc, etc...).
1399                                 s/^\?\w+:// if $symwanted{$1};
1400                         }
1401                         s/^(\w+)=''/$1='\$$1'/;
1402                         print CONFIGURE unless &skipped;
1403                 }
1404         }
1405
1406         # The 'close.Config_sh' command adds the final EOT line at
1407         # the end of the here-document construct which produces the
1408         # config.sh file within Configure.
1409         elsif ($cmd eq 'close.Config_sh') {
1410                 print CONFIGURE "EOT\n\n";      # Ends up file
1411         }
1412
1413         # The 'c_h_weed' command produces the config_h.SH file.
1414         # Only the necessary lines are kept. If no conditional line is
1415         # ever printed, then the file is useless and will be removed.
1416         elsif ($cmd eq 'c_h_weed') {
1417                 $printed = 0;
1418                 while (<UNIT>) {
1419                         if (/^\?(\w+):/) {
1420                                 s/^\?\w+:// if $cmaster{$1} || $symwanted{$1};
1421                         }
1422                         unless (&skipped || !&interpret($_)) {
1423                                 if (/^$/) {
1424                                         print CONF_H "\n" if $printed;
1425                                         $printed = 0;
1426                                 } else {
1427                                         print CONF_H;
1428                                         ++$printed;
1429                                 }
1430                         }
1431                 }
1432         }
1433
1434         # The 'cm_h_weed' command produces the confmagic.h file.
1435         # Only the necessary lines are kept. If no conditional line is
1436         # ever printed, then the file is useless and will be removed.
1437         elsif ($cmd eq 'cm_h_weed') {
1438                 if ($opt_M) {
1439                         $printed = 0;
1440                         while (<UNIT>) {
1441                                 if (/^\?(\w+):/) {
1442                                         s/^\?\w+:// if $cmaster{$1} || $symwanted{$1};
1443                                 }
1444                                 unless (&skipped || !&interpret($_)) {
1445                                         if (/^$/) {
1446                                                 print MAGIC_H "\n" if $printed;
1447                                                 $printed = 0;
1448                                         } else {
1449                                                 print MAGIC_H;
1450                                                 ++$printed;
1451                                         }
1452                                 }
1453                         }
1454                 }
1455         }
1456
1457         # The 'prepend' command will add the content of the target to
1458         # the current file (held in $file, the one which UNIT refers to),
1459         # if the file is not empty.
1460         elsif ($cmd eq 'prepend') {
1461                 if (-s $file) {
1462                         open(PREPEND, ">.prepend") ||
1463                                 die "Can't create .MT/.prepend.\n";
1464                         open(TARGET, $Unit{$target}) ||
1465                                 die "Can't open Unit $Unit{$target}.\n";
1466                         while (<TARGET>) {
1467                                 print PREPEND unless &skipped;
1468                         }
1469                         print PREPEND <UNIT>;   # Now add original file contents
1470                         close PREPEND;
1471                         close TARGET;
1472                         rename('.prepend', $file) ||
1473                                 die "Can't rename .prepend into $file.\n";
1474                 }
1475         }
1476
1477         # Command not found
1478         else {
1479                 die "Unrecognized command from Makefile: $cmd\n";
1480         }
1481         &check_state;           # Make sure there are no pending statements
1482         close UNIT;
1483 }
1484
1485 # Skip lines starting with ? or %, including all the following continuation
1486 # lines, if any. Return 0 if the line was not to be skipped, 1 otherwise.
1487 sub skipped {
1488         return 0 unless /^\?|^%/;
1489         &complete_line(UNIT) if /\\\s*$/;       # Swallow continuation lines
1490         1;
1491 }
1492
1493 # Update the MANIFEST.new file if necessary
1494 sub cosmetic_update {
1495         # Check for an "empty" config_h.SH (2 blank lines only). This test relies
1496         # on the actual text held in Config_h.U. If the unit is modified, then the
1497         # following might need adjustments.
1498         local($blank_lines) = 0;
1499         local($spaces) = 0;
1500         open(CONF_H, 'config_h.SH') || die "Can't open config_h.SH\n";
1501         while(<CONF_H>) {
1502                 ++$blank_lines if /^$/;
1503         }
1504         unlink 'config_h.SH' unless $blank_lines > 3;
1505
1506         open(NEWMANI,$NEWMANI);
1507         $_ = <NEWMANI>;
1508         /(\S+\s+)\S+/ && ($spaces = length($1));        # Spaces wanted
1509         close NEWMANI;
1510         $spaces = 29 if ($spaces < 12);                         # Default value
1511         open(NEWMANI,$NEWMANI);
1512         $/ = "\001";                    # Swallow the whole file
1513         $_ = <NEWMANI>;
1514         $/ = "\n";
1515         close NEWMANI;
1516
1517         &mani_add('Configure', 'Portability tool', $spaces) unless /^Configure\b/m;
1518         &mani_add('config_h.SH', 'Produces config.h', $spaces)
1519                 unless /^config_h\.SH\b/m || !-f 'config_h.SH';
1520         &mani_add('confmagic.h', 'Magic symbol remapping', $spaces)
1521                 if $opt_M && !/^confmagic\.h\b/m;
1522
1523         &mani_remove('config_h.SH') if /^config_h\.SH\b/m && !-f 'config_h.SH';
1524         &mani_remove('confmagic.h') if /^confmagic.h\b/m && !$opt_M;
1525
1526         if ($opt_G) {                   # Want a GNU-like configure wrapper
1527                 &add_configure;
1528                 &mani_add('configure', 'GNU configure-like wrapper', $spaces)
1529                         if !/^configure\s/m && -f 'configure';
1530         } else {
1531                 &mani_remove('configure') if /^configure\s/m && !-f 'configure';
1532         }
1533 }
1534
1535 # Add file to MANIFEST.new, with properly indented comment
1536 sub mani_add {
1537         local($file, $comment, $spaces) = @_;
1538         print "Adding $file to your $NEWMANI file...\n" unless $opt_s;
1539         open(NEWMANI, ">>$NEWMANI") || warn "Can't add $file to $NEWMANI: $!\n";
1540         local($blank) = ' ' x ($spaces - length($file));
1541         print NEWMANI "${file}${blank}${comment}\n";
1542         close NEWMANI;
1543 }
1544
1545 # Remove file from MANIFEST.new
1546 sub mani_remove {
1547         local($file) = @_;
1548         print "Removing $file from $NEWMANI...\n" unless $opt_s;
1549         unless (open(NEWMANI, ">$NEWMANI.x")) {
1550                 warn "Can't create backup $NEWMANI copy: $!\n";
1551                 return;
1552         }
1553         unless (open(OLDMANI, $NEWMANI)) {
1554                 warn "Can't open $NEWMANI: $!\n";
1555                 return;
1556         }
1557         local($_);
1558         while (<OLDMANI>) {
1559                 print NEWMANI unless /^$file\b/
1560         }
1561         close OLDMANI;
1562         close NEWMANI;
1563         rename("$NEWMANI.x", $NEWMANI) ||
1564                 warn "Couldn't restore $NEWMANI from $NEWMANI.x\n";
1565 }
1566
1567 # Copy GNU-like configure wrapper to the package root directory
1568 sub add_configure {
1569         if (-f "$MC/configure") {
1570                 print "Copying GNU configure-like front end...\n" unless $opt_s;
1571                 system "cp $MC/configure ./configure";
1572                 `chmod +x configure`;
1573         } else {
1574                 warn "Can't locate $MC/configure: $!\n";
1575         }
1576 }
1577
1578 package interpreter;
1579
1580 # States used by our interpeter -- in sync with @Keep
1581 sub main'init_keep {
1582         # Status in which we keep lines -- $Keep[$status]
1583         @Keep = (0, 1, 1, 0, 1);
1584
1585         # Available status ($status)
1586         $SKIP = 0;
1587         $IF = 1;
1588         $ELSE = 2;
1589         $NOT = 3;
1590         $OUT = 4;
1591 }
1592
1593 # Priorities for operators -- magic numbers :-)
1594 sub main'init_priority {
1595         $Priority{'&&'} = 4;
1596         $Priority{'||'} = 3;
1597 }
1598
1599 # Initializes the state stack of the interpreter
1600 sub main'init_interp {
1601         @state = ();
1602         push(@state, $OUT);
1603 }
1604
1605 # Print error messages -- asssumes $unit and $. correctly set.
1606 sub error {
1607         warn "\"$main'file\", line $.: @_.\n";
1608 }
1609
1610 # If some states are still in the stack, warn the user
1611 sub main'check_state {
1612         &error("one statement pending") if $#state == 1;
1613         &error("$#state statements pending") if $#state > 1;
1614 }
1615
1616 # Add a value on the stack, modified by all the monadic operators.
1617 # We use the locals @val and @mono from eval_expr.
1618 sub push_val {
1619         local($val) = shift(@_);
1620         while ($#mono >= 0) {
1621                 # Cheat... the only monadic operator is '!'.
1622                 pop(@mono);
1623                 $val = !$val;
1624         }
1625         push(@val, $val);
1626 }
1627
1628 # Execute a stacked operation, leave result in stack.
1629 # We use the locals @val and @op from eval_expr.
1630 # If the value stack holds only one operand, do nothing.
1631 sub execute {
1632         return unless $#val > 0;
1633         local($op) = pop(@op);
1634         local($val1) = pop(@val);
1635         local($val2) = pop(@val);
1636         push(@val, eval("$val1 $op $val2") ? 1: 0);
1637 }
1638
1639 # Given an operator, either we add it in the stack @op, because its
1640 # priority is lower than the one on top of the stack, or we first execute
1641 # the stacked operations until we reach the end of stack or an operand
1642 # whose priority is lower than ours.
1643 # We use the locals @val and @op from eval_expr.
1644 sub update_stack {
1645         local($op) = shift(@_);         # Operator
1646         if (!$Priority{$op}) {
1647                 &error("illegal operator $op");
1648                 return;
1649         } else {
1650                 if ($#val < 0) {
1651                         &error("missing first operand for '$op' (diadic operator)");
1652                         return;
1653                 }
1654                 # Because of the special behaviour of do-SUBR with the while modifier,
1655                 # I'm using a while-BLOCK construct. I consider this to be a bug of perl
1656                 # 4.0 PL19, although it is clearly documented in the man page.
1657                 while (
1658                         $Priority{$op[$#op]} > $Priority{$op}   # Higher priority op
1659                         && $#val > 0                                                    # At least 2 values
1660                 ) {
1661                         &execute;               # Execute an higher priority stacked operation
1662                 }
1663                 push(@op, $op);         # Everything at higher priority has been executed
1664         }
1665 }
1666
1667 # This is the heart of our little interpreter. Here, we evaluate
1668 # a logical expression and return its value.
1669 sub eval_expr {
1670         local(*expr) = shift(@_);       # Expression to parse
1671         local(@val) = ();                       # Stack of values
1672         local(@op) = ();                        # Stack of diadic operators
1673         local(@mono) =();                       # Stack of monadic operators
1674         local($tmp);
1675         $_ = $expr;
1676         while (1) {
1677                 s/^\s+//;                               # Remove spaces between words
1678                 # The '(' construct
1679                 if (s/^\(//) {
1680                         &push_val(&eval_expr(*_));
1681                         # A final '\' indicates an end of line
1682                         &error("missing final parenthesis") if !s/^\\//;
1683                 }
1684                 # Found a ')' or end of line
1685                 elsif (/^\)/ || /^$/) {
1686                         s/^\)/\\/;                                              # Signals: left parenthesis found
1687                         $expr = $_;                                             # Remove interpreted stuff
1688                         &execute() while $#val > 0;             # Executed stacked operations
1689                         while ($#op >= 0) {
1690                                 $_ = pop(@op);
1691                                 &error("missing second operand for '$_' (diadic operator)");
1692                         }
1693                         return $val[0];
1694                 }
1695                 # A perl statement '{{'
1696                 elsif (s/^\{\{//) {
1697                         if (s/^(.*)\}\}//) {
1698                                 &push_val((system
1699                                         ('perl','-e', "if ($1) {exit 0;} else {exit 1;}"
1700                                         ))? 0 : 1);
1701                         } else {
1702                                 &error("incomplete perl statement");
1703                         }
1704                 }
1705                 # A shell statement '{'
1706                 elsif (s/^\{//) {
1707                         if (s/^(.*)\}//) {
1708                                 &push_val((system
1709                                         ("if $1 >/dev/null 2>&1; then exit 0; else exit 1; fi"
1710                                         ))? 0 : 1);
1711                         } else {
1712                                 &error("incomplete shell statement");
1713                         }
1714                 }
1715                 # Operator '||' and '&&'
1716                 elsif (s/^(\|\||&&)//) {
1717                         $tmp = $1;                      # Save for perl5 (Dataloaded update_stack)
1718                         &update_stack($tmp);
1719                 }
1720                 # Unary operator '!'
1721                 elsif (s/^!//) {
1722                         push(@mono,'!');
1723                 }
1724                 # Everything else is a test for a defined value
1725                 elsif (s/^([\?%]?\w+)//) {
1726                         $tmp = $1;
1727                         # Test for wanted
1728                         if ($tmp =~ s/^\?//) {
1729                                 &push_val(($main'symwanted{$tmp})? 1 : 0);
1730                         }
1731                         # Test for conditionally wanted
1732                         elsif ($tmp =~ s/^%//) {
1733                                 &push_val(($main'condwanted{$tmp})? 1 : 0);
1734                         }
1735                         # Default: test for definition (see op @define)
1736                         else {
1737                                 &push_val((
1738                                         $main'symwanted{$tmp} ||
1739                                         $main'cmaster{$tmp} ||
1740                                         $main'userdef{$tmp}) ? 1 : 0);
1741                         }
1742                 }
1743                 # An error occured -- we did not recognize the expression
1744                 else {
1745                         s/^([^\s\(\)\{\|&!]+)//;        # Skip until next meaningful char
1746                 }
1747         }
1748 }
1749
1750 # Given an expression in a '@' command, returns a boolean which is
1751 # the result of the evaluation. Evaluate is collecting all the lines
1752 # in the expression into a single string, and then calls eval_expr to
1753 # really evaluate it.
1754 sub evaluate {
1755         local($val);                    # Value returned
1756         local($expr) = "";              # Expression to be parsed
1757         chop;
1758         while (s/\\$//) {               # While end of line escaped
1759                 $expr .= $_;
1760                 $_ = <UNIT>;            # Fetch next line
1761                 unless ($_) {
1762                         &error("EOF in expression");
1763                         last;
1764                 }
1765                 chop;
1766         }
1767         $expr .= $_;
1768         while ($expr ne '') {
1769                 $val = &eval_expr(*expr);               # Expression will be modified
1770                 # We return from eval_expr either when a closing parenthisis
1771                 # is found, or when the expression has been fully analysed.
1772                 &error("extra closing parenthesis ignored") if $expr ne '';
1773         }
1774         $val;
1775 }
1776
1777 # Given a line, we search for commands (lines starting with '@').
1778 # If there is no command in the line, then we return the boolean state.
1779 # Otherwise, the command is analysed and a new state is computed.
1780 # The returned value of interpret is 1 if the line is to be printed.
1781 sub main'interpret {
1782         local($value);
1783         local($status) = $state[$#state];               # Current status
1784         if (s|^\s*@\s*(\w+)\s*(.*)|$2|) {
1785                 local($cmd) = $1;
1786                 $cmd =~ y/A-Z/a-z/;             # Canonicalize to lower case
1787                 # The 'define' command
1788                 if ($cmd eq 'define') {
1789                         chop;
1790                         $userdef{$_}++ if $Keep[$status];
1791                         return 0;
1792                 }
1793                 # The 'if' command
1794                 elsif ($cmd eq 'if') {
1795                         # We always evaluate, in order to find possible errors
1796                         $value = &evaluate($_);
1797                         if (!$Keep[$status]) {
1798                                 # We have to skip until next 'end'
1799                                 push(@state, $SKIP);            # Record structure
1800                                 return 0;
1801                         }
1802                         if ($value) {                   # True
1803                                 push(@state, $IF);
1804                                 return 0;
1805                         } else {                                # False
1806                                 push(@state, $NOT);
1807                                 return 0;
1808                         }
1809                 }
1810                 # The 'else' command
1811                 elsif ($cmd eq 'else') {
1812                         &error("expression after 'else' ignored") if /\S/;
1813                         $state[$#state] = $SKIP if $state[$#state] == $IF;
1814                         return 0 if $state[$#state] == $SKIP;
1815                         if ($state[$#state] == $OUT) {
1816                                 &error("unexpected 'else'");
1817                                 return 0;
1818                         }
1819                         $state[$#state] = $ELSE;
1820                         return 0;
1821                 }
1822                 # The 'elsif' command
1823                 elsif ($cmd eq 'elsif') {
1824                         # We always evaluate, in order to find possible errors
1825                         $value = &evaluate($_);
1826                         $state[$#state] = $SKIP if $state[$#state] == $IF;
1827                         return 0 if $state[$#state] == $SKIP;
1828                         if ($state[$#state] == $OUT) {
1829                                 &error("unexpected 'elsif'");
1830                                 return 0;
1831                         }
1832                         if ($value) {                   # True
1833                                 $state[$#state] = $IF;
1834                                 return 0;
1835                         } else {                                # False
1836                                 $state[$#state] = $NOT;
1837                                 return 0;
1838                         }
1839                 }
1840                 # The 'end' command
1841                 elsif ($cmd eq 'end') {
1842                         &error("expression after 'end' ignored") if /\S/;
1843                         pop(@state);
1844                         &error("unexpected 'end'") if $#state < 0;
1845                         return 0;
1846                 }
1847                 # Unknown command
1848                 else {
1849                         &error("unknown command '$cmd'");
1850                         return 0;
1851                 }
1852         }
1853         $Keep[$status];
1854 }
1855
1856 package main;
1857
1858 sub readpackage {
1859         if (! -f '.package') {
1860                 if (
1861                         -f '../.package' ||
1862                         -f '../../.package' ||
1863                         -f '../../../.package' ||
1864                         -f '../../../../.package'
1865                 ) {
1866                         die "Run in top level directory only.\n";
1867                 } else {
1868                         die "No .package file!  Run packinit.\n";
1869                 }
1870         }
1871         open(PACKAGE,'.package');
1872         while (<PACKAGE>) {
1873                 next if /^:/;
1874                 next if /^#/;
1875                 if (($var,$val) = /^\s*(\w+)=(.*)/) {
1876                         $val = "\"$val\"" unless $val =~ /^['"]/;
1877                         eval "\$$var = $val;";
1878                 }
1879         }
1880         close PACKAGE;
1881 }
1882
1883 sub manifake {
1884     # make MANIFEST and MANIFEST.new say the same thing
1885     if (! -f $NEWMANI) {
1886         if (-f $MANI) {
1887             open(IN,$MANI) || die "Can't open $MANI";
1888             open(OUT,">$NEWMANI") || die "Can't create $NEWMANI";
1889             while (<IN>) {
1890                 if (/---/) {
1891                                         # Everything until now was a header...
1892                                         close OUT;
1893                                         open(OUT,">$NEWMANI") ||
1894                                                 die "Can't recreate $NEWMANI";
1895                                         next;
1896                                 }
1897                 s/^\s*(\S+\s+)[0-9]*\s*(.*)/$1$2/;
1898                                 print OUT;
1899                                 print OUT "\n" unless /\n$/;    # If no description
1900             }
1901             close IN;
1902                         close OUT;
1903         }
1904         else {
1905 die "You need to make a $NEWMANI file, with names and descriptions.\n";
1906         }
1907     }
1908 }
1909
1910 # Perform ~name expansion ala ksh...
1911 # (banish csh from your vocabulary ;-)
1912 sub tilda_expand {
1913         local($path) = @_;
1914         return $path unless $path =~ /^~/;
1915         $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;                    # ~name
1916         $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;   # ~
1917         $path;
1918 }
1919
1920 # Set up profile components into %Profile, add any profile-supplied options
1921 # into @ARGV and return the command invocation name.
1922 sub profile {
1923         local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
1924         local($me) = $0;                # Command name
1925         $me =~ s|.*/(.*)|$1|;   # Keep only base name
1926         return $me unless -s $profile;
1927         local(*PROFILE);                # Local file descriptor
1928         local($options) = '';   # Options we get back from profile
1929         unless (open(PROFILE, $profile)) {
1930                 warn "$me: cannot open $profile: $!\n";
1931                 return;
1932         }
1933         local($_);
1934         local($component);
1935         while (<PROFILE>) {
1936                 next if /^\s*#/;        # Skip comments
1937                 next unless /^$me/o;
1938                 if (s/^$me://o) {       # progname: options
1939                         chop;
1940                         $options .= $_; # Merge options if more than one line
1941                 }
1942                 elsif (s/^$me-([^:]+)://o) {    # progname-component: value
1943                         $component = $1;
1944                         chop;
1945                         s/^\s+//;               # Trim leading and trailing spaces
1946                         s/\s+$//;
1947                         $Profile{$component} = $_;
1948                 }
1949         }
1950         close PROFILE;
1951         return unless $options;
1952         require 'shellwords.pl';
1953         local(@opts);
1954         eval '@opts = &shellwords($options)';   # Protect against mismatched quotes
1955         unshift(@ARGV, @opts);
1956         return $me;                             # Return our invocation name
1957 }
1958