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