bin/metaxref

   1 #!/usr/bin/perl
   2         eval "exec perl -S $0 $*"
   3                 if $running_under_some_shell;
   4
   5 use FindBin;
   6
   7 $p5_metaconfig_base = "$FindBin::Bin/../";
   8
   9 #
  10 # This perl program uses dynamic loading [generated by perload]
  11 #
  12
  13 $ENV{LC_ALL} = 'C';
  14
  15 # $Id: mxref.SH 16 2006-11-04 12:11:51Z rmanfredi $
  16 #
  17 #  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
  18 #
  19 #  You may redistribute only under the terms of the Artistic Licence,
  20 #  as specified in the README file that comes with the distribution.
  21 #  You may reuse parts of this distribution only within the terms of
  22 #  that same Artistic Licence; a copy of which may be found at the root
  23 #  of the source tree for dist 4.0.
  24 #
  25 # Original Author: Harlan Stenn <harlan@mumps.pfcs.com>
  26 #
  27 # $Log: mxref.SH,v $
  28 # Revision 3.0.1.3  1997/02/28  16:30:49  ram
  29 # patch61: new -L option to match metaconfig and metalint
  30 #
  31 # Revision 3.0.1.2  1994/01/24  14:21:04  ram
  32 # patch16: added ~/.dist_profile awareness
  33 #
  34 # Revision 3.0.1.1  1993/08/19  06:42:27  ram
  35 # patch1: leading config.sh searching was not aborting properly
  36 #
  37 # Revision 3.0  1993/08/18  12:10:18  ram
  38 # Baseline for dist 3.0 netwide release.
  39 #
  40
  41 # Perload ON
  42
  43 $MC = "$p5_metaconfig_base/dist";
  44 $version = '3.5';
  45 $patchlevel = '0';
  46 $grep = '/usr/bin/grep';
  47 &profile;                                               # Read ~/.dist_profile
  48 require 'getopts.pl';
  49 &usage unless &Getopts("df:hkmsVL:");
  50
  51 chop($date = `date`);
  52 chop($WD = `pwd`);                              # Working directory
  53 $MC = $opt_L if $opt_L;                 # May override  library path
  54 $MC = &tilda_expand($MC);               # ~name expansion
  55 chdir $MC || die "Can't chdir to $MC: $!\n";
  56 chop($MC = `pwd`);                              # Real metaxref lib path (no symbolic links)
  57 chdir $WD || die "Can't chdir back to $WD: $!\n";
  58
  59 if ($opt_V) {
  60         print STDERR "metaxref $version PL$patchlevel\n";
  61         exit 0;
  62 } elsif ($opt_h) {
  63         &usage;
  64 }
  65
  66 $NEWMANI = $opt_f || (-f 'MANIFEST.new' ? 'MANIFEST.new' : 'MANIFEST');
  67
  68 &init;                                                                  # Various initializations
  69 `mkdir .MT 2>&1` unless -d '.MT';               # For private temporary files
  70 unlink 'Obsolete';                                              # Obsolete file rebuilt
  71
  72 &locate_units;                          # Fill in @ARGV with a unit list
  73 &extract_dependencies;          # Extract dependencies from units
  74 &extract_filenames;                     # Get source files from MANIFEST.new
  75 &build_xref;                            # Parse files, build I.* output
  76
  77 if ($opt_k) {
  78         print "Leaving subdirectory .MT unremoved so you can peruse it.\n"
  79                 unless $opt_s;
  80 } else {
  81         `rm -rf .MT 2>&1`;
  82 }
  83 print "Done.\n" unless $opt_s;
  84
  85 sub main'init { &auto_main'init; }
  86 sub auto_main'init { &main'dataload; }
  87
  88 sub main'init_except { &auto_main'init_except; }
  89 sub auto_main'init_except { &main'dataload; }
  90
  91 sub main'usage { &auto_main'usage; }
  92 sub auto_main'usage { &main'dataload; }
  93
  94 package locate;
  95
  96 sub main'locate_units { &auto_main'locate_units; }
  97 sub auto_main'locate_units { &main'dataload; }
  98
  99 sub locate'dump_list { &auto_locate'dump_list; }
 100 sub auto_locate'dump_list { &main'dataload; }
 101
 102 sub locate'private_units { &auto_locate'private_units; }
 103 sub auto_locate'private_units { &main'dataload; }
 104
 105 sub locate'public_units { &auto_locate'public_units; }
 106 sub auto_locate'public_units { &main'dataload; }
 107
 108 sub locate'units_path { &auto_locate'units_path; }
 109 sub auto_locate'units_path { &main'dataload; }
 110
 111 package main;
 112
 113 sub main'init_extraction { &auto_main'init_extraction; }
 114 sub auto_main'init_extraction { &main'dataload; }
 115
 116 sub main'end_extraction { &auto_main'end_extraction; }
 117 sub auto_main'end_extraction { &main'dataload; }
 118
 119 sub main'p_make { &auto_main'p_make; }
 120 sub auto_main'p_make { &main'dataload; }
 121
 122 sub main'p_obsolete { &auto_main'p_obsolete; }
 123 sub auto_main'p_obsolete { &main'dataload; }
 124
 125 sub main'p_shell { &auto_main'p_shell; }
 126 sub auto_main'p_shell { &main'dataload; }
 127
 128 sub main'p_c { &auto_main'p_c; }
 129 sub auto_main'p_c { &main'dataload; }
 130
 131 sub main'p_config { &auto_main'p_config; }
 132 sub auto_main'p_config { &main'dataload; }
 133
 134 sub main'p_magic { &auto_main'p_magic; }
 135 sub auto_main'p_magic { &main'dataload; }
 136
 137 sub p_ignore {}         # Ignore comment line
 138 sub p_lint {}           # Ignore lint directives
 139 sub p_visible {}        # No visible checking in metaconfig
 140 sub p_temp {}           # No temporary variable control
 141 sub p_file {}           # Ignore produced file directives (for now)
 142
 143 sub main'p_wanted { &auto_main'p_wanted; }
 144 sub auto_main'p_wanted { &main'dataload; }
 145
 146 # Ingnore the following:
 147 sub p_init {}
 148 sub p_default {}
 149 sub p_library {}
 150 sub p_include {}
 151 sub p_public {}
 152 sub p_layout {}
 153
 154 sub main'extract_filenames { &auto_main'extract_filenames; }
 155 sub auto_main'extract_filenames { &main'dataload; }
 156
 157 sub main'build_filext { &auto_main'build_filext; }
 158 sub auto_main'build_filext { &main'dataload; }
 159
 160 sub main'build_extfun { &auto_main'build_extfun; }
 161 sub auto_main'build_extfun { &main'dataload; }
 162
 163 sub main'q { &auto_main'q; }
 164 sub auto_main'q { &main'dataload; }
 165
 166 sub main'init_depend { &auto_main'init_depend; }
 167 sub auto_main'init_depend { &main'dataload; }
 168
 169 sub main'extract_dependencies { &auto_main'extract_dependencies; }
 170 sub auto_main'extract_dependencies { &main'dataload; }
 171
 172 sub main'complete_line { &auto_main'complete_line; }
 173 sub auto_main'complete_line { &main'dataload; }
 174
 175 sub main'record_obsolete { &auto_main'record_obsolete; }
 176 sub auto_main'record_obsolete { &main'dataload; }
 177
 178 sub main'dump_obsolete { &auto_main'dump_obsolete; }
 179 sub auto_main'dump_obsolete { &main'dataload; }
 180
 181 sub main'build_xref { &auto_main'build_xref; }
 182 sub auto_main'build_xref { &main'dataload; }
 183
 184 sub main'ofound { &auto_main'ofound; }
 185 sub auto_main'ofound { &main'dataload; }
 186
 187 sub main'gensym { &auto_main'gensym; }
 188 sub auto_main'gensym { &main'dataload; }
 189
 190 sub main'manifake { &auto_main'manifake; }
 191 sub auto_main'manifake { &main'dataload; }
 192
 193 sub main'tilda_expand { &auto_main'tilda_expand; }
 194 sub auto_main'tilda_expand { &main'dataload; }
 195
 196 sub main'profile { &auto_main'profile; }
 197 sub auto_main'profile { &main'dataload; }
 198
 199 # Load the calling function from DATA segment and call it. This function is
 200 # called only once per routine to be loaded.
 201 sub main'dataload {
 202         local($__packname__) = (caller(1))[3];
 203         $__packname__ =~ s/::/'/;
 204         local($__rpackname__) = $__packname__;
 205         local($__at__) = $@;
 206         $__rpackname__ =~ s/^auto_//;
 207         &perload'load_from_data($__rpackname__);
 208         local($__fun__) = "$__rpackname__";
 209         $__fun__ =~ s/'/'load_/;
 210         eval "*$__packname__ = *$__fun__;";     # Change symbol table entry
 211         die $@ if $@;           # Should not happen
 212         $@ = $__at__;           # Restore value $@ had on entrance
 213         &$__fun__;                      # Call newly loaded function
 214 }
 215
 216 # Load function name given as argument, fatal error if not existent
 217 sub perload'load_from_data {
 218         package perload;
 219         local($pos) = $Datapos{$_[0]};                  # Offset within DATA
 220         # Avoid side effects by protecting special variables which will be changed
 221         # by the dataloading operation.
 222         local($., $_, $@);
 223         $pos = &fetch_function_code unless $pos;
 224         die "Function $_[0] not found in data section.\n" unless $pos;
 225         die "Cannot seek to $pos into data section.\n"
 226                 unless seek(main'DATA, $pos, 0);
 227         local($/) = "\n}";
 228         local($body) = scalar(<main'DATA>);
 229         die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/m;
 230         eval $body;             # Load function into perl space
 231         chop($@) && die "$@, while parsing code of $_[0].\n";
 232 }
 233
 234 # This function is called only once, and fills in the %Datapos array with
 235 # the offset of each of the dataloaded routines held in the data section.
 236 sub perload'fetch_function_code {
 237         package perload;
 238         local($start) = 0;
 239         local($., $_);
 240         while (<main'DATA>) {                   # First move to start of offset table
 241                 next if /^#/;
 242                 last if /^$/ && ++$start > 2;   # Skip two blank line after end token
 243         }
 244         $start = tell(main'DATA);               # Offsets in table are relative to here
 245         local($key, $value);
 246         while (<main'DATA>) {                   # Load the offset table
 247                 last if /^$/;                           # Ends with a single blank line
 248                 ($key, $value) = split(' ');
 249                 $Datapos{$key} = $value + $start;
 250         }
 251         $Datapos{$_[0]};                # All that pain to get this offset...
 252 }
 253
 254 #
 255 # The perl compiler stops here.
 256 #
 257
 258 __END__
 259
 260 #
 261 # Beyond this point lie functions we may never compile.
 262 #
 263
 264 #
 265 # DO NOT CHANGE A IOTA BEYOND THIS COMMENT!
 266 # The following table lists offsets of functions within the data section.
 267 # Should modifications be needed, change original code and rerun perload
 268 # with the -o option to regenerate a proper offset table.
 269 #
 270
 271                  locate'dump_list       2938
 272              locate'private_units       3071
 273               locate'public_units       3858
 274                 locate'units_path       5351
 275                 main'build_extfun      16719
 276                 main'build_filext      16368
 277                   main'build_xref      25627
 278                main'complete_line      22216
 279                main'dump_obsolete      23859
 280               main'end_extraction       7714
 281         main'extract_dependencies      19358
 282            main'extract_filenames      15511
 283                       main'gensym      29705
 284                         main'init       1308
 285                  main'init_depend      18208
 286                  main'init_except       1534
 287              main'init_extraction       6862
 288                 main'locate_units       2321
 289                     main'manifake      29793
 290                       main'ofound      29321
 291                          main'p_c      10283
 292                     main'p_config      11589
 293                      main'p_magic      13345
 294                       main'p_make       8066
 295                   main'p_obsolete       9676
 296                      main'p_shell       9830
 297                     main'p_wanted      14245
 298                      main'profile      30974
 299                            main'q      17825
 300              main'record_obsolete      22806
 301                 main'tilda_expand      30619
 302                        main'usage       1832
 303
 304 #
 305 # End of offset table and beginning of dataloading section.
 306 #
 307
 308 # General initializations
 309 sub main'load_init {
 310         package main;
 311         &init_except;                   # Token which have upper-cased letters
 312         &init_depend;                   # The %Depend array records control line handling
 313 }
 314
 315 # Record the exceptions -- all symbols but these are lower case
 316 sub main'load_init_except {
 317         package main;
 318         $Except{'Author'}++;
 319         $Except{'Date'}++;
 320         $Except{'Header'}++;
 321         $Except{'Id'}++;
 322         $Except{'Locker'}++;
 323         $Except{'Log'}++;
 324         $Except{'RCSfile'}++;
 325         $Except{'Revision'}++;
 326         $Except{'Source'}++;
 327         $Except{'State'}++;
 328 }
 329
 330 # Print out metaxref's usage and exits
 331 sub main'load_usage {
 332         package main;
 333         print STDERR <<EOM;
 334 Usage: metaxref [-dhkmsV] [-f manifest] [-L dir]
 335   -d : debug mode.
 336   -f : use that file as manifest instead of MANIFEST.new.
 337   -h : print this help message and exits.
 338   -k : keep temporary directory.
 339   -m : assume lots of memory and swap space.
 340   -s : silent mode.
 341   -L : specify main units repository.
 342   -V : print version number and exits.
 343 EOM
 344         exit 1;
 345 }
 346
 347 # Locate the units and push their path in @ARGV (sorted alphabetically)
 348 sub main'load_locate_units {
 349         package locate;
 350         print "Locating units...\n" unless $main'opt_s;
 351         local(*WD) = *main'WD;                  # Current working directory
 352         local(*MC) = *main'MC;                  # Public metaconfig library
 353         undef %myUlist;                                 # Records private units paths
 354         undef %myUseen;                                 # Records private/public conflicts
 355         &private_units;                                 # Locate private units in @myUlist
 356         &public_units;                                  # Locate public units in @ARGV
 357         @ARGV = sort @ARGV;                             # Sort it alphabetically
 358         push(@ARGV, sort @myUlist);             # Append user's units sorted
 359         &dump_list if $main'opt_v;              # Dump the list of units
 360 }
 361
 362 # Dump the list of units on stdout
 363 sub locate'load_dump_list {
 364         package locate;
 365         print "\t";
 366         $, = "\n\t";
 367         print @ARGV;
 368         $, = '';
 369         print "\n";
 370 }
 371
 372 # Scan private units
 373 sub locate'load_private_units {
 374         package locate;
 375         return unless -d 'U';                   # Nothing to be done if no 'U' entry
 376         local(*ARGV) = *myUlist;                # Really fill in @myUlist
 377         local($MC) = $WD;                               # We are really in the working directory
 378         &units_path("U");                               # Locate units in the U directory
 379         local($unit_name);                              # Unit's name (without .U)
 380         local(@kept);                                   # Array of kept units
 381         # Loop over the units and remove duplicates (the first one seen is the one
 382         # we keep). Also set the %myUseen H table to record private units seen.
 383         foreach (@ARGV) {
 384                 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
 385                 next if $myUseen{$unit_name};   # Already recorded
 386                 $myUseen{$unit_name} = 1;               # Record pirvate unit
 387                 push(@kept, $_);                                # Keep this unit
 388         }
 389         @ARGV = @kept;
 390 }
 391
 392 # Scan public units
 393 sub locate'load_public_units {
 394         package locate;
 395         chdir($MC) || die "Can't find directory $MC.\n";
 396         &units_path("U");                               # Locate units in public U directory
 397         chdir($WD) || die "Can't go back to directory $WD.\n";
 398         local($path);                                   # Relative path from $WD
 399         local($unit_name);                              # Unit's name (without .U)
 400         local(*Unit) = *main'Unit;              # Unit is a global from main package
 401         local(@kept);                                   # Units kept
 402         local(%warned);                                 # Units which have already issued a message
 403         # Loop over all the units and keep only the ones that were not found in
 404         # the user's U directory. As it is possible two or more units with the same
 405         # name be found in
 406         foreach (@ARGV) {
 407                 ($unit_name) = m|^.*/(.*)\.U$|; # Get unit's name from path
 408                 next if $warned{$unit_name};    # We have already seen this unit
 409                 $warned{$unit_name} = 1;                # Remember we have warned the user
 410                 if ($myUseen{$unit_name}) {             # User already has a private unit
 411                         $path = $Unit{$unit_name};      # Extract user's unit path
 412                         next if $path eq $_;            # Same path, we must be in mcon/
 413                         $path =~ s|^$WD/||o;            # Weed out leading working dir path
 414                         print "    Your private $path overrides the public one.\n"
 415                                 unless $main'opt_s;
 416                 } else {
 417                         push(@kept, $_);                        # We may keep this one
 418                 }
 419         }
 420         @ARGV = @kept;
 421 }
 422
 423 # Recursively locate units in the directory. Each file ending with .U has to be
 424 # a unit. Others are stat()'ed, and if they are a directory, they are also
 425 # scanned through. The $MC and @ARGV variable are dynamically set by the caller.
 426 sub locate'load_units_path {
 427         package locate;
 428         local($dir) = @_;                                       # Directory where units are to be found
 429         local(@contents);                                       # Contents of the directory
 430         local($unit_name);                                      # Unit's name, without final .U
 431         local($path);                                           # Full path of a unit
 432         local(*Unit) = *main'Unit;                      # Unit is a global from main package
 433         unless (opendir(DIR, $dir)) {
 434                 warn("Cannot open directory $dir.\n");
 435                 return;
 436         }
 437         print "Locating in $MC/$dir...\n" if $main'opt_v;
 438         @contents = readdir DIR;                        # Slurp the whole thing
 439         closedir DIR;                                           # And close dir, ready for recursion
 440         foreach (@contents) {
 441                 next if $_ eq '.' || $_ eq '..';
 442                 if (/\.U$/) {                                   # A unit, definitely
 443                         ($unit_name) = /^(.*)\.U$/;
 444                         $path = "$MC/$dir/$_";                          # Full path of unit
 445                         push(@ARGV, $path);                                     # Record its path
 446                         if (defined $Unit{$unit_name}) {        # Already seen this unit
 447                                 if ($main'opt_v) {
 448                                         ($path) = $Unit{$unit_name} =~ m|^(.*)/.*|;
 449                                         print "    We've already seen $unit_name.U in $path.\n";
 450                                 }
 451                         } else {
 452                                 $Unit{$unit_name} = $path;              # Map name to path
 453                         }
 454                         next;
 455                 }
 456                 # We have found a file which does not look like a unit. If it is a
 457                 # directory, then scan it. Otherwise skip the file.
 458                 unless (-d "$dir/$_") {
 459                         print "    Skipping file $_ in $dir.\n" if $main'opt_v;
 460                         next;
 461                 }
 462                 &units_path("$dir/$_");
 463                 print "Back to $MC/$dir...\n" if $main'opt_v;
 464         }
 465 }
 466
 467 # Initialize the extraction process by setting some variables.
 468 # We return a string to be eval to do more customized initializations.
 469 sub main'load_init_extraction {
 470         package main;
 471         open(INIT, ">$WD/.MT/Init.U") ||
 472                 die "Can't create .MT/Init.U\n";
 473         open(CONF_H, ">$WD/.MT/Config_h.U") ||
 474                 die "Can't create .MT/Config_h.U\n";
 475         open(EXTERN, ">$WD/.MT/Extern.U") ||
 476                 die "Can't create .MT/Extern.U\n";
 477         open(MAGIC_H, ">$WD/.MT/Magic_h.U") ||
 478                 die "Can't create .MT/Magic_h.U\n";
 479
 480         $c_symbol = '';                         # Current symbol seen in ?C: lines
 481         $s_symbol = '';                         # Current symbol seen in ?S: lines
 482         $m_symbol = '';                         # Current symbol seen in ?M: lines
 483         $heredoc = '';                          # Last "here" document symbol seen
 484         $heredoc_nosubst = 0;           # True for <<'EOM' here docs
 485         $condlist = '';                         # List of conditional symbols
 486         $defined = '';                          # List of defined symbols in the unit
 487         $body = '';                                     # No procedure to handle body
 488         $ending = '';                           # No procedure to clean-up
 489 }
 490
 491 # End the extraction process
 492 sub main'load_end_extraction {
 493         package main;
 494         close EXTERN;                   # External dependencies (libraries, includes...)
 495         close CONF_H;                   # C symbol definition template
 496         close INIT;                             # Required initializations
 497         close MAGIC;                    # Magic C symbol redefinition templates
 498
 499         print $dependencies if $opt_v;  # Print extracted dependencies
 500 }
 501
 502 # Process the ?MAKE: line
 503 sub main'load_p_make {
 504         package main;
 505         local($_) = @_;
 506         local(@ary);                                    # Locally defined symbols
 507         local(@dep);                                    # Dependencies
 508         if (/^[\w+ ]*:/) {                              # Main dependency rule
 509                 s|^\s*||;                                       # Remove leading spaces
 510                 chop;
 511                 s/:(.*)//;
 512                 @dep = split(' ', $1);                  # Dependencies
 513                 @ary = split(' ');                              # Locally defined symbols
 514                 foreach $sym (@ary) {
 515                         # Symbols starting with a '+' are meant for internal use only.
 516                         next if $sym =~ s/^\+//;
 517                         # Only sumbols starting with a lowercase letter are to
 518                         # appear in config.sh, excepted the ones listed in Except.
 519                         if ($sym =~ /^[_a-z]/ || $Except{$sym}) {
 520                                 $shmaster{"\$$sym"} = undef;
 521                                 push(@Master,"?$unit:$sym=''\n");       # Initializations
 522                         }
 523                 }
 524                 $condlist = '';                         # List of conditional symbols
 525                 local($sym);                            # Symbol copy, avoid @dep alteration
 526                 foreach $dep (@dep) {
 527                         if ($dep =~ /^\+[A-Za-z]/) {
 528                                 ($sym = $dep) =~ s|^\+||;
 529                                 $condlist .= "$sym ";
 530                                 push(@Cond, $sym) unless $condseen{$sym};
 531                                 $condseen{$sym}++;              # Conditionally wanted
 532                         }
 533                 }
 534                 # Append to already existing dependencies. The 'defined' variable
 535                 # is set for &write_out, used to implement ?L: and ?I: canvas. It is
 536                 # reset each time a new unit is parsed.
 537                 # NB: leading '+' for defined symbols (internal use only) have been
 538                 # removed at this point, but conditional dependencies still bear it.
 539                 $defined = join(' ', @ary);             # Symbols defined by this unit
 540                 $dependencies .= $defined . ':' . join(' ', @dep) . "\n";
 541                 $dependencies .= "      -cond $condlist\n" if $condlist;
 542         } else {
 543                 $dependencies .= $_;            # Building rules
 544         }
 545 }
 546
 547 # Process the ?O: line
 548 sub main'load_p_obsolete {
 549         package main;
 550         local($_) = @_;
 551         $Obsolete{"$unit.U"} .= $_;             # Message(s) to print if unit is used
 552 }
 553
 554 # Process the ?S: lines
 555 sub main'load_p_shell {
 556         package main;
 557         local($_) = @_;
 558         unless ($s_symbol) {
 559                 if (/^(\w+).*:/) {
 560                         $s_symbol = $1;
 561                         print "  ?S: $s_symbol\n" if $opt_d;
 562                 } else {
 563                         warn "\"$file\", line $.: syntax error in ?S: construct.\n";
 564                         $s_symbol = $unit;
 565                         return;
 566                 }
 567                 # Deal with obsolete symbol list (enclosed between parenthesis)
 568                 &record_obsolete("\$$_") if /\(/;
 569         }
 570         m|^\.\s*$| && ($s_symbol = '');         # End of comment
 571 }
 572
 573 # Process the ?C: lines
 574 sub main'load_p_c {
 575         package main;
 576         local($_) = @_;
 577         unless ($c_symbol) {
 578                 if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) {
 579                         # The ~ operator aliases the main C symbol to another symbol which
 580                         # is to be used instead for definition in config.h. That is to say,
 581                         # the line '?C:SYM ~ other:' would look for symbol 'other' instead,
 582                         # and the documentation for symbol SYM would only be included in
 583                         # config.h if 'other' were actually wanted.
 584                         $c_symbol = $2;                 # Alias for definition in config.h
 585                         print "  ?C: $1 ~ $c_symbol\n" if $opt_d;
 586                 } elsif (/^(\w+).*:/) {
 587                         # Default behaviour. Include in config.h if symbol is needed.
 588                         $c_symbol = $1;
 589                         print "  ?C: $c_symbol\n" if $opt_d;
 590                 } else {
 591                         warn "\"$file\", line $.: syntax error in ?C: construct.\n";
 592                         $c_symbol = $unit;
 593                         return;
 594                 }
 595                 # Deal with obsolete symbol list (enclosed between parenthesis) and
 596                 # make sure that list do not appear in config.h.SH by removing it.
 597                 &record_obsolete("$_") if /\(/;
 598                 s/\s*\(.*\)//;                                  # Get rid of obsolete symbol list
 599         }
 600         s|^(\w+)\s*|?$c_symbol:/* $1| ||                                                # Start of comment
 601         (s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) || # End of comment
 602         s|^(.*)|?$c_symbol: *$1|;                                                               # Middle of comment
 603         &p_config("$_");                                        # Add comments to config.h.SH
 604 }
 605
 606 # Process the ?H: lines
 607 sub main'load_p_config {
 608         package main;
 609         local($_) = @_;
 610         local($constraint);                                     # Constraint to be used for inclusion
 611         ++$old_version if s/^\?%1://;           # Old version
 612         if (s/^\?(\w+)://) {                            # Remove leading '?var:'
 613                 $constraint = $1;                               # Constraint is leading '?var'
 614         } else {
 615                 $constraint = '';                               # No constraint
 616         }
 617         if (/^#.*\$/) {                                         # Look only for cpp lines
 618                 if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) {
 619                         # Case: #$d_var VAR "$var"
 620                         $constraint = $2 unless $constraint;
 621                         print "  ?H: ($constraint) #\$$1 $2 \"\$$3\"\n" if $opt_d;
 622                         $cmaster{$2} = undef;
 623                         $cwanted{$2} = "$1\n$3";
 624                 } elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) {
 625                         # Case: #define VAR(x) $var
 626                         $constraint = $1 unless $constraint;
 627                         print "  ?H: ($constraint) #define $1($2) \$$3\n" if $opt_d;
 628                         $cmaster{$1} = undef;
 629                         $cwanted{$1} = $3;
 630                 } elsif (m|^#\$define\s+(\w+)|) {
 631                         # Case: #$define VAR
 632                         $constraint = $1 unless $constraint;
 633                         print "  ?H: ($constraint) #define $1\n" if $opt_d;
 634                         $cmaster{$1} = undef;
 635                         $cwanted{$1} = "define\n$unit";
 636                 } elsif (m|^#\$(\w+)\s+(\w+)|) {
 637                         # Case: #$d_var VAR
 638                         $constraint = $2 unless $constraint;
 639                         print "  ?H: ($constraint) #\$$1 $2\n" if $opt_d;
 640                         $cmaster{$2} = undef;
 641                         $cwanted{$2} = $1;
 642                 } elsif (m|^#define\s+(\w+).*\$(\w+)|) {
 643                         # Case: #define VAR "$var"
 644                         $constraint = $1 unless $constraint;
 645                         print "  ?H: ($constraint) #define $1 \"\$$2\"\n" if $opt_d;
 646                         $cmaster{$1} = undef;
 647                         $cwanted{$1} = $2;
 648                 } else {
 649                         $constraint = $unit unless $constraint;
 650                         print "  ?H: ($constraint) $_" if $opt_d;
 651                 }
 652         } else {
 653                 print "  ?H: ($constraint) $_" if $opt_d;
 654         }
 655         # If not a single ?H:. line, add the leading constraint
 656         s/^\.// || s/^/?$constraint:/;
 657         print CONF_H;
 658 }
 659
 660 # Process the ?M: lines
 661 sub main'load_p_magic {
 662         package main;
 663         local($_) = @_;
 664         unless ($m_symbol) {
 665                 if (/^(\w+):\s*([\w\s]*)\n$/) {
 666                         # A '?M:sym:' line implies a '?W:%<:sym' since we'll need to know
 667                         # about the wantedness of sym later on when building confmagic.h.
 668                         # Buf is sym is wanted, then the C symbol dependencies have to
 669                         # be triggered. That is done by introducing sym in the mwanted
 670                         # array, known by the Wanted file construction process...
 671                         $m_symbol = $1;
 672                         print "  ?M: $m_symbol\n" if $opt_d;
 673                         $mwanted{$m_symbol} = $2;               # Record C dependencies
 674                         &p_wanted("$unit:$m_symbol");   # Build fake ?W: line
 675                 } else {
 676                         warn "\"$file\", line $.: syntax error in ?M: construct.\n";
 677                 }
 678                 return;
 679         }
 680         (s/^\.\s*$/?$m_symbol:\n/ && ($m_symbol = '', 1)) ||    # End of block
 681         s/^/?$m_symbol:/;
 682         print MAGIC_H;                                  # Definition goes to confmagic.h
 683         print "  ?M: $_" if $opt_d;
 684 }
 685
 686 # Process the ?W: lines
 687 sub main'load_p_wanted {
 688         package main;
 689         # Syntax is ?W:<shell symbols>:<C symbols>
 690         local($active) = $_[0] =~ /^([^:]*):/;          # Symbols to activate
 691         local($look_symbols) = $_[0] =~ /:(.*)/;        # When those are used
 692         local(@syms) = split(/ /, $look_symbols);       # Keep original spacing info
 693         $active =~ s/\s+/\n/g;                                          # One symbol per line
 694
 695         # Concatenate quoted strings, so saying something like 'two words' will
 696         # be introduced as one single symbol "two words".
 697         local(@symbols);                                # Concatenated symbols to look for
 698         local($concat) = '';                    # Concatenation buffer
 699         foreach (@syms) {
 700                 if (s/^\'//) {
 701                         $concat = $_;
 702                 } elsif (s/\'$//) {
 703                         push(@symbols, $concat . ' ' . $_);
 704                         $concat = '';
 705                 } else {
 706                         push(@symbols, $_) unless $concat;
 707                         $concat .= ' ' . $_ if $concat;
 708                 }
 709         }
 710
 711         local($fake);           # Fake unique shell symbol to reparent C symbol
 712
 713         # Now record symbols in master and wanted tables
 714         foreach (@symbols) {
 715                 $cmaster{$_} = undef;                                   # Asks for look-up in C files
 716                 # Make a fake C symbol and associate that with the wanted symbol
 717                 # so that later we know were it comes from
 718                 $fake = &gensym;
 719                 $cwanted{$_} = "$fake";                                 # Attached to this symbol
 720                 push(@Master, "?$unit:$fake=''");               # Fake initialization
 721         }
 722 }
 723
 724 # Extract filenames from manifest
 725 sub main'load_extract_filenames {
 726         package main;
 727         &build_filext;                  # Construct &is_cfile and &is_shfile
 728         print "Extracting filenames (C and SH files) from $NEWMANI...\n"
 729                 unless $opt_s;
 730         open(NEWMANI,$NEWMANI) || die "Can't open $NEWMANI.\n";
 731         local($file);
 732         while (<NEWMANI>) {
 733                 ($file) = split(' ');
 734                 next if $file eq 'config_h.SH';                 # skip config_h.SH
 735                 next if $file eq 'Configure';                   # also skip Configure
 736                 next if $file eq 'confmagic.h' && $opt_M;
 737                 push(@SHlist, $file) if &is_shfile($file);
 738                 push(@clist, $file) if &is_cfile($file);
 739         }
 740 }
 741
 742 # Construct two file identifiers based on the file suffix: one for C files,
 743 # and one for SH files (using the $cext and $shext variables) defined in
 744 # the .package file.
 745 # The &is_cfile and &is_shfile routine may then be called to known whether
 746 # a given file is a candidate for holding C or SH symbols.
 747 sub main'load_build_filext {
 748         package main;
 749         &build_extfun('is_cfile', $cext, '.c .h .y .l');
 750         &build_extfun('is_shfile', $shext, '.SH');
 751 }
 752
 753 # Build routine $name to identify extensions listed in $exts, ensuring
 754 # that $minimum is at least matched (both to be backward compatible with
 755 # older .package and because it is really the minimum requirred).
 756 sub main'load_build_extfun {
 757         package main;
 758         local($name, $exts, $minimum) = @_;
 759         local(@single);         # Single letter dot extensions (may be grouped)
 760         local(@others);         # Other extensions
 761         local(%seen);           # Avoid duplicate extensions
 762         foreach $ext (split(' ', "$exts $minimum")) {
 763                 next if $seen{$ext}++;
 764                 if ($ext =~ s/^\.(\w)$/$1/) {
 765                         push(@single, $ext);
 766                 } else {
 767                         # Convert into perl's regexp
 768                         $ext =~ s/\./\\./g;             # Escape .
 769                         $ext =~ s/\?/./g;               # ? turns into .
 770                         $ext =~ s/\*/.*/g;              # * turns into .*
 771                         push(@others, $ext);
 772                 }
 773         }
 774         local($fn) = &q(<<EOF);         # Function being built
 775 :sub $name {
 776 :       local(\$_) = \@_;
 777 EOF
 778         local($single);         # Single regexp: .c .h grouped into .[ch]
 779         $single = '\.[' . join('', @single) . ']' if @single;
 780         $fn .= &q(<<EOL) if @single;
 781 :       return 1 if /$single\$/;
 782 EOL
 783         foreach $ext (@others) {
 784                 $fn .= &q(<<EOL);
 785 :       return 1 if /$ext\$/;
 786 EOL
 787         }
 788         $fn .= &q(<<EOF);
 789 :       0;      # None of the extensions may be applied to file name
 790 :}
 791 EOF
 792         print $fn if $opt_d;
 793         eval $fn;
 794         chop($@) && die "Can't compile '$name':\n$fn\n$@.\n";
 795 }
 796
 797 # Remove ':' quotations in front of the lines
 798 sub main'load_q {
 799         package main;
 800         local($_) = @_;
 801         local($*) = 1;
 802         s/^://g;
 803         $_;
 804 }
 805
 806 # The %Depend array records the functions we use to process the configuration
 807 # lines in the unit, with a special meaning. It is important that all the
 808 # known control symbols be listed below, so that metalint does not complain.
 809 # The %Lcmp array contains valid layouts and their comparaison value.
 810 sub main'load_init_depend {
 811         package main;
 812         %Depend = (
 813                 'MAKE', 'p_make',                               # The ?MAKE: line records dependencies
 814                 'INIT', 'p_init',                               # Initializations printed verbatim
 815                 'LINT', 'p_lint',                               # Hints for metalint
 816                 'RCS', 'p_ignore',                              # RCS comments are ignored
 817                 'C', 'p_c',                                             # C symbols
 818                 'D', 'p_default',                               # Default value for conditional symbols
 819                 'E', 'p_example',                               # Example of usage
 820                 'F', 'p_file',                                  # Produced files
 821                 'H', 'p_config',                                # Process the config.h lines
 822                 'I', 'p_include',                               # Added includes
 823                 'L', 'p_library',                               # Added libraries
 824                 'M', 'p_magic',                                 # Process the confmagic.h lines
 825                 'O', 'p_obsolete',                              # Unit obsolescence
 826                 'P', 'p_public',                                # Location of PD implementation file
 827                 'S', 'p_shell',                                 # Shell variables
 828                 'T', 'p_temp',                                  # Shell temporaries used
 829                 'V', 'p_visible',                               # Visible symbols like 'rp', 'dflt'
 830                 'W', 'p_wanted',                                # Wanted value for interpreter
 831                 'X', 'p_ignore',                                # User comment is ignored
 832                 'Y', 'p_layout',                                # User-defined layout preference
 833         );
 834         %Lcmp = (
 835                 'top',          -1,
 836                 'default',      0,
 837                 'bottom',       1,
 838         );
 839 }
 840
 841 # Extract dependencies from units held in @ARGV
 842 sub main'load_extract_dependencies {
 843         package main;
 844         local($proc);                                           # Procedure used to handle a ctrl line
 845         local($file);                                           # Current file scanned
 846         local($dir, $unit);                                     # Directory and unit's name
 847         local($old_version) = 0;                        # True when old-version unit detected
 848         local($mc) = "$MC/U";                           # Public metaconfig directory
 849         local($line);                                           # Last processed line for metalint
 850
 851         printf "Extracting dependency lists from %d units...\n", $#ARGV+1
 852                 unless $opt_s;
 853
 854         chdir $WD;                                                      # Back to working directory
 855         &init_extraction;                                       # Initialize extraction files
 856         $dependencies = ' ' x (50 * @ARGV);     # Pre-extend
 857         $dependencies = '';
 858
 859         # We do not want to use the <> construct here, because we need the
 860         # name of the opened files (to get the unit's name) and we want to
 861         # reset the line number for each files, and do some pre-processing.
 862
 863         file: while ($file = shift(@ARGV)) {
 864                 close FILE;                                             # Reset line number
 865                 $old_version = 0;                               # True if unit is an old version
 866                 if (open(FILE, $file)) {
 867                         ($dir, $unit) = ('', $file)
 868                                 unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|);
 869                         $unit =~ s|\.U$||;                      # Remove extension
 870                 } else {
 871                         warn("Can't open $file.\n");
 872                 }
 873                 # If unit is in the standard public directory, keep only the unit name
 874                 $file = "$unit.U" if $dir eq $mc;
 875                 print "$dir/$unit.U:\n" if $opt_d;
 876                 line: while (<FILE>) {
 877                         $line = $_;                                     # Save last processed unit line
 878                         if (s/^\?([\w\-]+)://) {        # We may have found a control line
 879                                 $proc = $Depend{$1};    # Look for a procedure to handle it
 880                                 unless ($proc) {                # Unknown control line
 881                                         $proc = $1;                     # p_unknown expects symbol in '$proc'
 882                                         eval '&p_unknown';      # Signal error (metalint only)
 883                                         next line;                      # And go on next line
 884                                 }
 885                                 # Long lines may be escaped with a final backslash
 886                                 $_ .= &complete_line(FILE) if s/\\\s*$//;
 887                                 # Run macros substitutions
 888                                 s/%</$unit/g;                   # %< expands into the unit's name
 889                                 if (s/%\*/$unit/) {
 890                                         # %* expanded into the entire set of defined symbols
 891                                         # in the old version. Now it is only the unit's name.
 892                                         ++$old_version;
 893                                 }
 894                                 eval { &$proc($_) };            # Process the line
 895                         } else {
 896                                 next file unless $body;         # No procedure to handle body
 897                                 do {
 898                                         $line = $_;                             # Save last processed unit line
 899                                         eval { &$body($_) } ;   # From now on, it's the unit body
 900                                 } while (defined ($_ = <FILE>));
 901                                 next file;
 902                         }
 903                 }
 904         } continue {
 905                 warn("    Warning: $file is a pre-3.0 version.\n") if $old_version;
 906                 &$ending($line) if $ending;                     # Post-processing for metalint
 907         }
 908
 909         &end_extraction;                # End the extraction process
 910 }
 911
 912 # The first line was escaped with a final \ character. Every following line
 913 # is to be appended to it (until we found a real \n not escaped). Note that
 914 # the leading spaces of the continuation line are removed, so any space should
 915 # be added before the former \ if needed.
 916 sub main'load_complete_line {
 917         package main;
 918         local($file) = @_;              # File where lines come from
 919         local($_);
 920         local($read) = '';              # Concatenation of all the continuation lines found
 921         while (<$file>) {
 922                 s/^\s+//;                               # Remove leading spaces
 923                 if (s/\\\s*$//) {               # Still followed by a continuation line
 924                         $read .= $_;
 925                 } else {                                # We've reached the end of the continuation
 926                         return $read . $_;
 927                 }
 928         }
 929 }
 930
 931 # Record obsolete symbols association (new versus old), that is to say for a
 932 # given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended
 933 # for all shell variables
 934 sub main'load_record_obsolete {
 935         package main;
 936         local($_) = @_;
 937         local(@obsoleted);                                      # List of obsolete symbols
 938         local($symbol);                                         # New symbol which must be used
 939         local($dollar) = s/^\$// ? '$':'';      # The '$' or a null string
 940         # Syntax for obsolete symbols specification is
 941         #    list of symbols (obsolete ones):
 942         if (/^(\w+)\s*\((.*)\)\s*:$/) {
 943                 $symbol = "$dollar$1";
 944                 @obsoleted = split(' ', $2);            # List of obsolete symbols
 945         } else {
 946                 if (/^(\w+)\s*\((.*):$/) {
 947                         warn "\"$file\", line $.: final ')' before ':' missing.\n";
 948                         $symbol = "$dollar$1";
 949                         @obsoleted = split(' ', $2);
 950                 } else {
 951                         warn "\"$file\", line $.: syntax error.\n";
 952                         return;
 953                 }
 954         }
 955         foreach $val (@obsoleted) {
 956                 $_ = $dollar . $val;
 957                 if (defined $Obsolete{$_}) {
 958                 warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n";
 959                 } else {
 960                         $Obsolete{$_} = $symbol;        # Record (old, new) tuple
 961                 }
 962         }
 963 }
 964
 965 # Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and
 966 # Obsol_sh.U to record old versus new mappings if the -o option was used.
 967 sub main'load_dump_obsolete {
 968         package main;
 969         unless (-f 'Obsolete') {
 970                 open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n";
 971         }
 972         open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n";
 973         open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n";
 974         local($file);                                           # File where obsolete symbol was found
 975         local($old);                                            # Name of this old symbol
 976         local($new);                                            # Value of the new symbol to be used
 977         # Leave a blank line at the top so that anny added ^L will stand on a line
 978         # by itself (the formatting process adds a ^L when a new page is needed).
 979         format OBSOLETE_TOP =
 980
 981               File                 |      Old symbol      |      New symbol
 982 -----------------------------------+----------------------+---------------------
 983 .
 984         format OBSOLETE =
 985 @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<<
 986 $file,                               $old,                  $new
 987 .
 988         local(%seen);
 989         foreach $key (sort keys %ofound) {
 990                 ($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/);
 991                 write(OBSOLETE) unless $file eq 'XXX';
 992                 next unless $opt_o;                             # Obsolete mapping done only with -o
 993                 next if $seen{$old}++;                  # Already remapped, thank you
 994                 if ($new =~ s/^\$//) {                  # We found an obsolete shell symbol
 995                         $old =~ s/^\$//;
 996                         print OBSOL_SH "$old=\"\$$new\"\n";
 997                 } else {                                                # We found an obsolete C symbol
 998                         print OBSOL_H "#ifdef $new\n";
 999                         print OBSOL_H "#define $old $new\n";
1000                         print OBSOL_H "#endif\n\n";
1001                 }
1002         }
1003         close OBSOLETE;
1004         close OBSOL_H;
1005         close OBSOL_SH;
1006         if (-s 'Obsolete') {
1007                 print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n";
1008         } else {
1009                 unlink 'Obsolete';
1010         }
1011         undef %ofound;                          # Not needed any more
1012 }
1013
1014 # Parse files and build cross references
1015 sub main'load_build_xref {
1016         package main;
1017         print "Building cross-reference files...\n" unless $opt_s;
1018         unless (-f $NEWMANI) {
1019                 &manifake;
1020                 die "No $NEWMANI--don't know who to scan.\n" unless -f $NEWMANI;
1021         }
1022
1023         open(FUI, "|sort | uniq >I.fui") || die "Can't create I.fui.\n";
1024         open(UIF, "|sort | uniq >I.uif") || die "Can't create I.uif.\n";
1025
1026         local($search);                                                 # Where to-be-evaled script is held
1027         local($_) = ' ' x 50000 if $opt_m;              # Pre-extend pattern search space
1028         local(%visited);                                                # Records visited files
1029         local(%lastfound);                                              # Where last occurence of key was
1030
1031         # Map shell symbol names to units by reverse engineering the @Master array
1032         # which records all the known shell symbols and the units where they
1033         # are defined.
1034         foreach $init (@Master) {
1035                 $init =~ /^\?(.*):(.*)=''/ && ($shwanted{"\$$2"} = $1);
1036         }
1037
1038         # Now we are a little clever, and build a loop to eval so that we don't
1039         # have to recompile our patterns on every file.  We also use "study" since
1040         # we are searching the same string for many different things.  Hauls!
1041
1042         if (@clist) {
1043                 print "    Scanning .[chyl] files for symbols...\n" unless $opt_s;
1044                 $search = ' ' x (40 * (@cmaster + @ocmaster));  # Pre-extend
1045                 $search = "while (<>) {study;\n";                               # Init loop over ARGV
1046                 foreach $key (keys(cmaster)) {
1047                         $search .= "\$cmaster{'$key'} .= \"\$ARGV#\" if /\\b$key\\b/;\n";
1048                 }
1049                 foreach $key (grep(!/^\$/, keys %Obsolete)) {
1050                         $search .= "&ofound('$key') if /\\b$key\\b/;\n";
1051                 }
1052                 $search .= "}\n";                       # terminate loop
1053                 print $search if $opt_d;
1054                 @ARGV = @clist;
1055                 # Swallow each file as a whole, if memory is available
1056                 undef $/ if $opt_m;
1057                 eval $search;
1058                 eval '';
1059                 $/ = "\n";
1060                 while (($key,$value) = each(cmaster)) {
1061                         next if $value eq '';
1062                         foreach $file (sort(split(/#/, $value))) {
1063                                 next if $file eq '';
1064                                 # %cwanted may contain value separated by \n -- take last one
1065                                 @sym = split(/\n/, $cwanted{$key});
1066                                 $sym = pop(@sym);
1067                                 $shell = "\$$sym";
1068                                 print FUI
1069                                         pack("A35", $file),
1070                                         pack("A20", "$shwanted{$shell}.U"),
1071                                         $key, "\n";
1072                                 print UIF
1073                                         pack("A20", "$shwanted{$shell}.U"),
1074                                         pack("A25", $key),
1075                                         $file, "\n";
1076                         }
1077                 }
1078         }
1079
1080         undef @clist;
1081         undef %cwanted;
1082         undef %cmaster;         # We're not building Configure, we may delete this
1083         %visited = ();
1084         %lastfound = ();
1085
1086         if (@SHlist) {
1087                 print "    Scanning .SH files for symbols...\n" unless $opt_s;
1088                 $search = ' ' x (40 * (@shmaster + @oshmaster));        # Pre-extend
1089                 $search = "while (<>) {study;\n";
1090                 # All the keys already have a leading '$'
1091                 foreach $key (keys(shmaster)) {
1092                         $search .= "\$shmaster{'$key'} .= \"\$ARGV#\" if /\\$key\\b/;\n";
1093                 }
1094                 foreach $key (grep (/^\$/, keys %Obsolete)) {
1095                         $search .= "&ofound('$key') if /\\$key\\b/;\n";
1096                 }
1097                 $search .= "}\n";
1098                 print $search if $opt_d;
1099                 @ARGV = @SHlist;
1100                 # Swallow each file as a whole, if memory is available
1101                 undef $/ if $opt_m;
1102                 eval $search;
1103                 eval '';
1104                 $/ = "\n";
1105                 while (($key,$value) = each(shmaster)) {
1106                         next if $value eq '';
1107                         foreach $file (sort(split(/#/, $value))) {
1108                                 next if $file eq '';
1109                                 print FUI
1110                                         pack("A35", $file),
1111                                         pack("A20", "$shwanted{$key}.U"),
1112                                         $key, "\n";
1113                                 print UIF
1114                                         pack("A20", "$shwanted{$key}.U"),
1115                                         pack("A25", $key),
1116                                         $file, "\n";
1117                         }
1118                 }
1119         }
1120
1121         close FUI;
1122         close UIF;
1123
1124         # If obsolete symbols where found, write an Obsolete file which lists where
1125         # each of them appear and the new symbol to be used. Also write Obsol_h.U
1126         # and Obsol_sh.U in .MT for later perusal.
1127
1128         &dump_obsolete;                                         # Dump obsolete symbols if any
1129
1130         # Clean-up memory by freeing useless data structures
1131         undef @SHlist;
1132         undef %shmaster;
1133 }
1134
1135 # This routine records matches of obsolete keys (C or shell)
1136 sub main'load_ofound {
1137         package main;
1138         local($key) = @_;
1139         local($_) = $Obsolete{$key};            # Value of new symbol
1140         $ofound{"$ARGV $key $_"}++;                     # Record obsolete match
1141         $cmaster{$_} .= "$ARGV#" unless /^\$/;  # A C hit
1142         $shmaster{$_} .= "$ARGV#" if /^\$/;             # Or a shell one
1143 }
1144
1145 # Create a new symbol name each time it is invoked. That name is suitable for
1146 # usage as a perl variable name.
1147 sub main'load_gensym {
1148         package main;
1149         $Gensym = 'AAAAA' unless $Gensym;
1150         $Gensym++;
1151 }
1152
1153 sub main'load_manifake {
1154         package main;
1155     # make MANIFEST and MANIFEST.new say the same thing
1156     if (! -f $NEWMANI) {
1157         if (-f $MANI) {
1158             open(IN,$MANI) || die "Can't open $MANI";
1159             open(OUT,">$NEWMANI") || die "Can't create $NEWMANI";
1160             while (<IN>) {
1161                 if (/---/) {
1162                                         # Everything until now was a header...
1163                                         close OUT;
1164                                         open(OUT,">$NEWMANI") ||
1165                                                 die "Can't recreate $NEWMANI";
1166                                         next;
1167                                 }
1168                 s/^\s*(\S+\s+)[0-9]*\s*(.*)/$1$2/;
1169                                 print OUT;
1170                                 print OUT "\n" unless /\n$/;    # If no description
1171             }
1172             close IN;
1173                         close OUT;
1174         }
1175         else {
1176 die "You need to make a $NEWMANI file, with names and descriptions.\n";
1177         }
1178     }
1179 }
1180
1181 # Perform ~name expansion ala ksh...
1182 # (banish csh from your vocabulary ;-)
1183 sub main'load_tilda_expand {
1184         package main;
1185         local($path) = @_;
1186         return $path unless $path =~ /^~/;
1187         $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;                    # ~name
1188         $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;   # ~
1189         $path;
1190 }
1191
1192 # Set up profile components into %Profile, add any profile-supplied options
1193 # into @ARGV and return the command invocation name.
1194 sub main'load_profile {
1195         package main;
1196         local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
1197         local($me) = $0;                # Command name
1198         $me =~ s|.*/(.*)|$1|;   # Keep only base name
1199         return $me unless -s $profile;
1200         local(*PROFILE);                # Local file descriptor
1201         local($options) = '';   # Options we get back from profile
1202         unless (open(PROFILE, $profile)) {
1203                 warn "$me: cannot open $profile: $!\n";
1204                 return;
1205         }
1206         local($_);
1207         local($component);
1208         while (<PROFILE>) {
1209                 next if /^\s*#/;        # Skip comments
1210                 next unless /^$me/o;
1211                 if (s/^$me://o) {       # progname: options
1212                         chop;
1213                         $options .= $_; # Merge options if more than one line
1214                 }
1215                 elsif (s/^$me-([^:]+)://o) {    # progname-component: value
1216                         $component = $1;
1217                         chop;
1218                         s/^\s+//;               # Trim leading and trailing spaces
1219                         s/\s+$//;
1220                         $Profile{$component} = $_;
1221                 }
1222         }
1223         close PROFILE;
1224         return unless $options;
1225         require 'shellwords.pl';
1226         local(@opts);
1227         eval '@opts = &shellwords($options)';   # Protect against mismatched quotes
1228         unshift(@ARGV, @opts);
1229         return $me;                             # Return our invocation name
1230 }
1231
1232 #
1233 # End of dataloading section.
1234 #
1235