#!/usr/bin/perl
	eval "exec perl -S $0 $*"
		if $running_under_some_shell;

use FindBin;

$p5_metaconfig_base = "$FindBin::Bin/../";

#
# This perl program uses dynamic loading [generated by perload]
#

$ENV{LC_ALL} = 'C';

# $Id: mxref.SH 16 2006-11-04 12:11:51Z rmanfredi $
#
#  Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
#  
#  You may redistribute only under the terms of the Artistic Licence,
#  as specified in the README file that comes with the distribution.
#  You may reuse parts of this distribution only within the terms of
#  that same Artistic Licence; a copy of which may be found at the root
#  of the source tree for dist 4.0.
#
# Original Author: Harlan Stenn <harlan@mumps.pfcs.com>
#
# $Log: mxref.SH,v $
# Revision 3.0.1.3  1997/02/28  16:30:49  ram
# patch61: new -L option to match metaconfig and metalint
#
# Revision 3.0.1.2  1994/01/24  14:21:04  ram
# patch16: added ~/.dist_profile awareness
#
# Revision 3.0.1.1  1993/08/19  06:42:27  ram
# patch1: leading config.sh searching was not aborting properly
#
# Revision 3.0  1993/08/18  12:10:18  ram
# Baseline for dist 3.0 netwide release.
#

# Perload ON

$MC = "$p5_metaconfig_base/dist";
$version = '3.5';
$patchlevel = '0';
$grep = '/usr/bin/grep';
&profile;						# Read ~/.dist_profile
require 'getopts.pl';
&usage unless &Getopts("df:hkmsVL:");

chop($date = `date`);
chop($WD = `pwd`);				# Working directory
$MC = $opt_L if $opt_L;			# May override  library path
$MC = &tilda_expand($MC);		# ~name expansion
chdir $MC || die "Can't chdir to $MC: $!\n";
chop($MC = `pwd`);				# Real metaxref lib path (no symbolic links)
chdir $WD || die "Can't chdir back to $WD: $!\n";

if ($opt_V) {
	print STDERR "metaxref $version PL$patchlevel\n";
	exit 0;
} elsif ($opt_h) {
	&usage;
}

$NEWMANI = $opt_f || (-f 'MANIFEST.new' ? 'MANIFEST.new' : 'MANIFEST');

&init;									# Various initializations
`mkdir .MT 2>&1` unless -d '.MT';		# For private temporary files
unlink 'Obsolete';						# Obsolete file rebuilt

&locate_units;				# Fill in @ARGV with a unit list
&extract_dependencies;		# Extract dependencies from units
&extract_filenames;			# Get source files from MANIFEST.new
&build_xref;				# Parse files, build I.* output

if ($opt_k) {
	print "Leaving subdirectory .MT unremoved so you can peruse it.\n"
		unless $opt_s;
} else {
	`rm -rf .MT 2>&1`;
}
print "Done.\n" unless $opt_s;

sub main'init { &auto_main'init; }
sub auto_main'init { &main'dataload; }

sub main'init_except { &auto_main'init_except; }
sub auto_main'init_except { &main'dataload; }

sub main'usage { &auto_main'usage; }
sub auto_main'usage { &main'dataload; }

package locate;

sub main'locate_units { &auto_main'locate_units; }
sub auto_main'locate_units { &main'dataload; }

sub locate'dump_list { &auto_locate'dump_list; }
sub auto_locate'dump_list { &main'dataload; }

sub locate'private_units { &auto_locate'private_units; }
sub auto_locate'private_units { &main'dataload; }

sub locate'public_units { &auto_locate'public_units; }
sub auto_locate'public_units { &main'dataload; }

sub locate'units_path { &auto_locate'units_path; }
sub auto_locate'units_path { &main'dataload; }

package main;

sub main'init_extraction { &auto_main'init_extraction; }
sub auto_main'init_extraction { &main'dataload; }

sub main'end_extraction { &auto_main'end_extraction; }
sub auto_main'end_extraction { &main'dataload; }

sub main'p_make { &auto_main'p_make; }
sub auto_main'p_make { &main'dataload; }

sub main'p_obsolete { &auto_main'p_obsolete; }
sub auto_main'p_obsolete { &main'dataload; }

sub main'p_shell { &auto_main'p_shell; }
sub auto_main'p_shell { &main'dataload; }

sub main'p_c { &auto_main'p_c; }
sub auto_main'p_c { &main'dataload; }

sub main'p_config { &auto_main'p_config; }
sub auto_main'p_config { &main'dataload; }

sub main'p_magic { &auto_main'p_magic; }
sub auto_main'p_magic { &main'dataload; }

sub p_ignore {}		# Ignore comment line
sub p_lint {}		# Ignore lint directives
sub p_visible {}	# No visible checking in metaconfig
sub p_temp {}		# No temporary variable control
sub p_file {}		# Ignore produced file directives (for now)

sub main'p_wanted { &auto_main'p_wanted; }
sub auto_main'p_wanted { &main'dataload; }

# Ingnore the following:
sub p_init {}
sub p_default {}
sub p_library {}
sub p_include {}
sub p_public {}
sub p_layout {}

sub main'extract_filenames { &auto_main'extract_filenames; }
sub auto_main'extract_filenames { &main'dataload; }

sub main'build_filext { &auto_main'build_filext; }
sub auto_main'build_filext { &main'dataload; }

sub main'build_extfun { &auto_main'build_extfun; }
sub auto_main'build_extfun { &main'dataload; }

sub main'q { &auto_main'q; }
sub auto_main'q { &main'dataload; }

sub main'init_depend { &auto_main'init_depend; }
sub auto_main'init_depend { &main'dataload; }

sub main'extract_dependencies { &auto_main'extract_dependencies; }
sub auto_main'extract_dependencies { &main'dataload; }

sub main'complete_line { &auto_main'complete_line; }
sub auto_main'complete_line { &main'dataload; }

sub main'record_obsolete { &auto_main'record_obsolete; }
sub auto_main'record_obsolete { &main'dataload; }

sub main'dump_obsolete { &auto_main'dump_obsolete; }
sub auto_main'dump_obsolete { &main'dataload; }

sub main'build_xref { &auto_main'build_xref; }
sub auto_main'build_xref { &main'dataload; }

sub main'ofound { &auto_main'ofound; }
sub auto_main'ofound { &main'dataload; }

sub main'gensym { &auto_main'gensym; }
sub auto_main'gensym { &main'dataload; }

sub main'manifake { &auto_main'manifake; }
sub auto_main'manifake { &main'dataload; }

sub main'tilda_expand { &auto_main'tilda_expand; }
sub auto_main'tilda_expand { &main'dataload; }

sub main'profile { &auto_main'profile; }
sub auto_main'profile { &main'dataload; }

# Load the calling function from DATA segment and call it. This function is
# called only once per routine to be loaded.
sub main'dataload {
	local($__packname__) = (caller(1))[3];
	$__packname__ =~ s/::/'/;
	local($__rpackname__) = $__packname__;
	local($__at__) = $@;
	$__rpackname__ =~ s/^auto_//;
	&perload'load_from_data($__rpackname__);
	local($__fun__) = "$__rpackname__";
	$__fun__ =~ s/'/'load_/;
	eval "*$__packname__ = *$__fun__;";	# Change symbol table entry
	die $@ if $@;		# Should not happen
	$@ = $__at__;		# Restore value $@ had on entrance
	&$__fun__;			# Call newly loaded function
}

# Load function name given as argument, fatal error if not existent
sub perload'load_from_data {
	package perload;
	local($pos) = $Datapos{$_[0]};			# Offset within DATA
	# Avoid side effects by protecting special variables which will be changed
	# by the dataloading operation.
	local($., $_, $@);
	$pos = &fetch_function_code unless $pos;
	die "Function $_[0] not found in data section.\n" unless $pos;
	die "Cannot seek to $pos into data section.\n"
		unless seek(main'DATA, $pos, 0);
	local($/) = "\n}";
	local($body) = scalar(<main'DATA>);
	die "End of file found while loading $_[0].\n" unless $body =~ /^\}$/m;
	eval $body;		# Load function into perl space
	chop($@) && die "$@, while parsing code of $_[0].\n";
}

# This function is called only once, and fills in the %Datapos array with
# the offset of each of the dataloaded routines held in the data section.
sub perload'fetch_function_code {
	package perload;
	local($start) = 0;
	local($., $_);
	while (<main'DATA>) {			# First move to start of offset table
		next if /^#/;
		last if /^$/ && ++$start > 2;	# Skip two blank line after end token
	}
	$start = tell(main'DATA);		# Offsets in table are relative to here
	local($key, $value);
	while (<main'DATA>) {			# Load the offset table
		last if /^$/;				# Ends with a single blank line
		($key, $value) = split(' ');
		$Datapos{$key} = $value + $start;
	}
	$Datapos{$_[0]};		# All that pain to get this offset...
}

#
# The perl compiler stops here.
#

__END__

#
# Beyond this point lie functions we may never compile.
#

#
# DO NOT CHANGE A IOTA BEYOND THIS COMMENT!
# The following table lists offsets of functions within the data section.
# Should modifications be needed, change original code and rerun perload
# with the -o option to regenerate a proper offset table.
#

	         locate'dump_list       2938
	     locate'private_units       3071
	      locate'public_units       3858
	        locate'units_path       5351
	        main'build_extfun      16719
	        main'build_filext      16368
	          main'build_xref      25627
	       main'complete_line      22216
	       main'dump_obsolete      23859
	      main'end_extraction       7714
	main'extract_dependencies      19358
	   main'extract_filenames      15511
	              main'gensym      29705
	                main'init       1308
	         main'init_depend      18208
	         main'init_except       1534
	     main'init_extraction       6862
	        main'locate_units       2321
	            main'manifake      29793
	              main'ofound      29321
	                 main'p_c      10283
	            main'p_config      11589
	             main'p_magic      13345
	              main'p_make       8066
	          main'p_obsolete       9676
	             main'p_shell       9830
	            main'p_wanted      14245
	             main'profile      30974
	                   main'q      17825
	     main'record_obsolete      22806
	        main'tilda_expand      30619
	               main'usage       1832

#
# End of offset table and beginning of dataloading section.
#

# General initializations
sub main'load_init {
	package main;
	&init_except;			# Token which have upper-cased letters
	&init_depend;			# The %Depend array records control line handling
}

# Record the exceptions -- all symbols but these are lower case
sub main'load_init_except {
	package main;
	$Except{'Author'}++;
	$Except{'Date'}++;
	$Except{'Header'}++;
	$Except{'Id'}++;
	$Except{'Locker'}++;
	$Except{'Log'}++;
	$Except{'RCSfile'}++;
	$Except{'Revision'}++;
	$Except{'Source'}++;
	$Except{'State'}++;
}

# Print out metaxref's usage and exits
sub main'load_usage {
	package main;
	print STDERR <<EOM;
Usage: metaxref [-dhkmsV] [-f manifest] [-L dir]
  -d : debug mode.
  -f : use that file as manifest instead of MANIFEST.new.
  -h : print this help message and exits.
  -k : keep temporary directory.
  -m : assume lots of memory and swap space.
  -s : silent mode.
  -L : specify main units repository.
  -V : print version number and exits.
EOM
	exit 1;
}

# Locate the units and push their path in @ARGV (sorted alphabetically)
sub main'load_locate_units {
	package locate;
	print "Locating units...\n" unless $main'opt_s;
	local(*WD) = *main'WD;			# Current working directory
	local(*MC) = *main'MC;			# Public metaconfig library
	undef %myUlist;					# Records private units paths
	undef %myUseen;					# Records private/public conflicts
	&private_units;					# Locate private units in @myUlist
	&public_units;					# Locate public units in @ARGV
	@ARGV = sort @ARGV;				# Sort it alphabetically
	push(@ARGV, sort @myUlist);		# Append user's units sorted
	&dump_list if $main'opt_v;		# Dump the list of units
}

# Dump the list of units on stdout
sub locate'load_dump_list {
	package locate;
	print "\t";
	$, = "\n\t";
	print @ARGV;
	$, = '';
	print "\n";
}

# Scan private units
sub locate'load_private_units {
	package locate;
	return unless -d 'U';			# Nothing to be done if no 'U' entry
	local(*ARGV) = *myUlist;		# Really fill in @myUlist
	local($MC) = $WD;				# We are really in the working directory
	&units_path("U");				# Locate units in the U directory
	local($unit_name);				# Unit's name (without .U)
	local(@kept);					# Array of kept units
	# Loop over the units and remove duplicates (the first one seen is the one
	# we keep). Also set the %myUseen H table to record private units seen.
	foreach (@ARGV) {
		($unit_name) = m|^.*/(.*)\.U$|;	# Get unit's name from path
		next if $myUseen{$unit_name};	# Already recorded
		$myUseen{$unit_name} = 1;		# Record pirvate unit
		push(@kept, $_);				# Keep this unit
	}
	@ARGV = @kept;
}

# Scan public units
sub locate'load_public_units {
	package locate;
	chdir($MC) || die "Can't find directory $MC.\n";
	&units_path("U");				# Locate units in public U directory
	chdir($WD) || die "Can't go back to directory $WD.\n";
	local($path);					# Relative path from $WD
	local($unit_name);				# Unit's name (without .U)
	local(*Unit) = *main'Unit;		# Unit is a global from main package
	local(@kept);					# Units kept
	local(%warned);					# Units which have already issued a message
	# Loop over all the units and keep only the ones that were not found in
	# the user's U directory. As it is possible two or more units with the same
	# name be found in
	foreach (@ARGV) {
		($unit_name) = m|^.*/(.*)\.U$|;	# Get unit's name from path
		next if $warned{$unit_name};	# We have already seen this unit
		$warned{$unit_name} = 1;		# Remember we have warned the user
		if ($myUseen{$unit_name}) {		# User already has a private unit
			$path = $Unit{$unit_name};	# Extract user's unit path
			next if $path eq $_;		# Same path, we must be in mcon/
			$path =~ s|^$WD/||o;		# Weed out leading working dir path
			print "    Your private $path overrides the public one.\n"
				unless $main'opt_s;
		} else {
			push(@kept, $_);			# We may keep this one
		}
	}
	@ARGV = @kept;
}

# Recursively locate units in the directory. Each file ending with .U has to be
# a unit. Others are stat()'ed, and if they are a directory, they are also
# scanned through. The $MC and @ARGV variable are dynamically set by the caller.
sub locate'load_units_path {
	package locate;
	local($dir) = @_;					# Directory where units are to be found
	local(@contents);					# Contents of the directory
	local($unit_name);					# Unit's name, without final .U
	local($path);						# Full path of a unit
	local(*Unit) = *main'Unit;			# Unit is a global from main package
	unless (opendir(DIR, $dir)) {
		warn("Cannot open directory $dir.\n");
		return;
	}
	print "Locating in $MC/$dir...\n" if $main'opt_v;
	@contents = readdir DIR;			# Slurp the whole thing
	closedir DIR;						# And close dir, ready for recursion
	foreach (@contents) {
		next if $_ eq '.' || $_ eq '..';
		if (/\.U$/) {					# A unit, definitely
			($unit_name) = /^(.*)\.U$/;
			$path = "$MC/$dir/$_";				# Full path of unit
			push(@ARGV, $path);					# Record its path
			if (defined $Unit{$unit_name}) {	# Already seen this unit
				if ($main'opt_v) {
					($path) = $Unit{$unit_name} =~ m|^(.*)/.*|;
					print "    We've already seen $unit_name.U in $path.\n";
				}
			} else {
				$Unit{$unit_name} = $path;		# Map name to path
			}
			next;
		}
		# We have found a file which does not look like a unit. If it is a
		# directory, then scan it. Otherwise skip the file.
		unless (-d "$dir/$_") {
			print "    Skipping file $_ in $dir.\n" if $main'opt_v;
			next;
		}
		&units_path("$dir/$_");
		print "Back to $MC/$dir...\n" if $main'opt_v;
	}
}

# Initialize the extraction process by setting some variables.
# We return a string to be eval to do more customized initializations.
sub main'load_init_extraction {
	package main;
	open(INIT, ">$WD/.MT/Init.U") ||
		die "Can't create .MT/Init.U\n";
	open(CONF_H, ">$WD/.MT/Config_h.U") ||
		die "Can't create .MT/Config_h.U\n";
	open(EXTERN, ">$WD/.MT/Extern.U") ||
		die "Can't create .MT/Extern.U\n";
	open(MAGIC_H, ">$WD/.MT/Magic_h.U") ||
		die "Can't create .MT/Magic_h.U\n";

	$c_symbol = '';				# Current symbol seen in ?C: lines
	$s_symbol = '';				# Current symbol seen in ?S: lines
	$m_symbol = '';				# Current symbol seen in ?M: lines
	$heredoc = '';				# Last "here" document symbol seen
	$heredoc_nosubst = 0;		# True for <<'EOM' here docs
	$condlist = '';				# List of conditional symbols
	$defined = '';				# List of defined symbols in the unit
	$body = '';					# No procedure to handle body
	$ending = '';				# No procedure to clean-up
}

# End the extraction process
sub main'load_end_extraction {
	package main;
	close EXTERN;			# External dependencies (libraries, includes...)
	close CONF_H;			# C symbol definition template
	close INIT;				# Required initializations
	close MAGIC;			# Magic C symbol redefinition templates

	print $dependencies if $opt_v;	# Print extracted dependencies
}

# Process the ?MAKE: line
sub main'load_p_make {
	package main;
	local($_) = @_;
	local(@ary);					# Locally defined symbols
	local(@dep);					# Dependencies
	if (/^[\w+ ]*:/) {				# Main dependency rule
		s|^\s*||;					# Remove leading spaces
		chop;
		s/:(.*)//;
		@dep = split(' ', $1);			# Dependencies
		@ary = split(' ');				# Locally defined symbols
		foreach $sym (@ary) {
			# Symbols starting with a '+' are meant for internal use only.
			next if $sym =~ s/^\+//;
			# Only sumbols starting with a lowercase letter are to
			# appear in config.sh, excepted the ones listed in Except.
			if ($sym =~ /^[_a-z]/ || $Except{$sym}) {
				$shmaster{"\$$sym"} = undef;
				push(@Master,"?$unit:$sym=''\n");	# Initializations
			}
		}
		$condlist = '';				# List of conditional symbols
		local($sym);				# Symbol copy, avoid @dep alteration
		foreach $dep (@dep) {
			if ($dep =~ /^\+[A-Za-z]/) {
				($sym = $dep) =~ s|^\+||;
				$condlist .= "$sym ";
				push(@Cond, $sym) unless $condseen{$sym};
				$condseen{$sym}++;		# Conditionally wanted
			}
		}
		# Append to already existing dependencies. The 'defined' variable
		# is set for &write_out, used to implement ?L: and ?I: canvas. It is
		# reset each time a new unit is parsed.
		# NB: leading '+' for defined symbols (internal use only) have been
		# removed at this point, but conditional dependencies still bear it.
		$defined = join(' ', @ary);		# Symbols defined by this unit
		$dependencies .= $defined . ':' . join(' ', @dep) . "\n";
		$dependencies .= "	-cond $condlist\n" if $condlist;
	} else {
		$dependencies .= $_;		# Building rules
	}
}

# Process the ?O: line
sub main'load_p_obsolete {
	package main;
	local($_) = @_;
	$Obsolete{"$unit.U"} .= $_;		# Message(s) to print if unit is used
}

# Process the ?S: lines
sub main'load_p_shell {
	package main;
	local($_) = @_;
	unless ($s_symbol) {
		if (/^(\w+).*:/) {
			$s_symbol = $1;
			print "  ?S: $s_symbol\n" if $opt_d;
		} else {
			warn "\"$file\", line $.: syntax error in ?S: construct.\n";
			$s_symbol = $unit;
			return;
		}
		# Deal with obsolete symbol list (enclosed between parenthesis)
		&record_obsolete("\$$_") if /\(/;
	}
	m|^\.\s*$| && ($s_symbol = '');		# End of comment
}

# Process the ?C: lines
sub main'load_p_c {
	package main;
	local($_) = @_;
	unless ($c_symbol) {
		if (s/^(\w+)\s*~\s*(\S+)\s*(.*):/$1 $3:/) {
			# The ~ operator aliases the main C symbol to another symbol which
			# is to be used instead for definition in config.h. That is to say,
			# the line '?C:SYM ~ other:' would look for symbol 'other' instead,
			# and the documentation for symbol SYM would only be included in
			# config.h if 'other' were actually wanted.
			$c_symbol = $2;			# Alias for definition in config.h
			print "  ?C: $1 ~ $c_symbol\n" if $opt_d;
		} elsif (/^(\w+).*:/) {
			# Default behaviour. Include in config.h if symbol is needed.
			$c_symbol = $1;
			print "  ?C: $c_symbol\n" if $opt_d;
		} else {
			warn "\"$file\", line $.: syntax error in ?C: construct.\n";
			$c_symbol = $unit;
			return;
		}
		# Deal with obsolete symbol list (enclosed between parenthesis) and
		# make sure that list do not appear in config.h.SH by removing it.
		&record_obsolete("$_") if /\(/;
		s/\s*\(.*\)//;					# Get rid of obsolete symbol list
	}
	s|^(\w+)\s*|?$c_symbol:/* $1| ||						# Start of comment
	(s|^\.\s*$|?$c_symbol: */\n| && ($c_symbol = '', 1)) ||	# End of comment
	s|^(.*)|?$c_symbol: *$1|;								# Middle of comment
	&p_config("$_");					# Add comments to config.h.SH
}

# Process the ?H: lines
sub main'load_p_config {
	package main;
	local($_) = @_;
	local($constraint);					# Constraint to be used for inclusion
	++$old_version if s/^\?%1://;		# Old version
	if (s/^\?(\w+)://) {				# Remove leading '?var:'
		$constraint = $1;				# Constraint is leading '?var'
	} else {
		$constraint = '';				# No constraint
	}
	if (/^#.*\$/) {						# Look only for cpp lines
		if (m|^#\$(\w+)\s+(\w+).*\$(\w+)|) {
			# Case: #$d_var VAR "$var"
			$constraint = $2 unless $constraint;
			print "  ?H: ($constraint) #\$$1 $2 \"\$$3\"\n" if $opt_d;
			$cmaster{$2} = undef;
			$cwanted{$2} = "$1\n$3";
		} elsif (m|^#define\s+(\w+)\((.*)\)\s+\$(\w+)|) {
			# Case: #define VAR(x) $var
			$constraint = $1 unless $constraint;
			print "  ?H: ($constraint) #define $1($2) \$$3\n" if $opt_d;
			$cmaster{$1} = undef;
			$cwanted{$1} = $3;
		} elsif (m|^#\$define\s+(\w+)|) {
			# Case: #$define VAR
			$constraint = $1 unless $constraint;
			print "  ?H: ($constraint) #define $1\n" if $opt_d;
			$cmaster{$1} = undef;
			$cwanted{$1} = "define\n$unit";
		} elsif (m|^#\$(\w+)\s+(\w+)|) {
			# Case: #$d_var VAR
			$constraint = $2 unless $constraint;
			print "  ?H: ($constraint) #\$$1 $2\n" if $opt_d;
			$cmaster{$2} = undef;
			$cwanted{$2} = $1;
		} elsif (m|^#define\s+(\w+).*\$(\w+)|) {
			# Case: #define VAR "$var"
			$constraint = $1 unless $constraint;
			print "  ?H: ($constraint) #define $1 \"\$$2\"\n" if $opt_d;
			$cmaster{$1} = undef;
			$cwanted{$1} = $2;
		} else {
			$constraint = $unit unless $constraint;
			print "  ?H: ($constraint) $_" if $opt_d;
		}
	} else {
		print "  ?H: ($constraint) $_" if $opt_d;
	}
	# If not a single ?H:. line, add the leading constraint
	s/^\.// || s/^/?$constraint:/;
	print CONF_H;
}

# Process the ?M: lines
sub main'load_p_magic {
	package main;
	local($_) = @_;
	unless ($m_symbol) {
		if (/^(\w+):\s*([\w\s]*)\n$/) {
			# A '?M:sym:' line implies a '?W:%<:sym' since we'll need to know
			# about the wantedness of sym later on when building confmagic.h.
			# Buf is sym is wanted, then the C symbol dependencies have to
			# be triggered. That is done by introducing sym in the mwanted
			# array, known by the Wanted file construction process...
			$m_symbol = $1;
			print "  ?M: $m_symbol\n" if $opt_d;
			$mwanted{$m_symbol} = $2;		# Record C dependencies
			&p_wanted("$unit:$m_symbol");	# Build fake ?W: line
		} else {
			warn "\"$file\", line $.: syntax error in ?M: construct.\n";
		}
		return;
	}
	(s/^\.\s*$/?$m_symbol:\n/ && ($m_symbol = '', 1)) ||	# End of block
	s/^/?$m_symbol:/;
	print MAGIC_H;					# Definition goes to confmagic.h
	print "  ?M: $_" if $opt_d;
}

# Process the ?W: lines
sub main'load_p_wanted {
	package main;
	# Syntax is ?W:<shell symbols>:<C symbols>
	local($active) = $_[0] =~ /^([^:]*):/;		# Symbols to activate
	local($look_symbols) = $_[0] =~ /:(.*)/;	# When those are used
	local(@syms) = split(/ /, $look_symbols);	# Keep original spacing info
	$active =~ s/\s+/\n/g;						# One symbol per line

	# Concatenate quoted strings, so saying something like 'two words' will
	# be introduced as one single symbol "two words".
	local(@symbols);				# Concatenated symbols to look for
	local($concat) = '';			# Concatenation buffer
	foreach (@syms) {
		if (s/^\'//) {
			$concat = $_;
		} elsif (s/\'$//) {
			push(@symbols, $concat . ' ' . $_);
			$concat = '';
		} else {
			push(@symbols, $_) unless $concat;
			$concat .= ' ' . $_ if $concat;
		}
	}

	local($fake);		# Fake unique shell symbol to reparent C symbol

	# Now record symbols in master and wanted tables
	foreach (@symbols) {
		$cmaster{$_} = undef;					# Asks for look-up in C files
		# Make a fake C symbol and associate that with the wanted symbol
		# so that later we know were it comes from
		$fake = &gensym;
		$cwanted{$_} = "$fake";					# Attached to this symbol
		push(@Master, "?$unit:$fake=''");		# Fake initialization
	}
}

# Extract filenames from manifest
sub main'load_extract_filenames {
	package main;
	&build_filext;			# Construct &is_cfile and &is_shfile
	print "Extracting filenames (C and SH files) from $NEWMANI...\n"
		unless $opt_s;
	open(NEWMANI,$NEWMANI) || die "Can't open $NEWMANI.\n";
	local($file);
	while (<NEWMANI>) {
		($file) = split(' ');
		next if $file eq 'config_h.SH';			# skip config_h.SH
		next if $file eq 'Configure';			# also skip Configure
		next if $file eq 'confmagic.h' && $opt_M;
		push(@SHlist, $file) if &is_shfile($file);
		push(@clist, $file) if &is_cfile($file);
	}
}

# Construct two file identifiers based on the file suffix: one for C files,
# and one for SH files (using the $cext and $shext variables) defined in
# the .package file.
# The &is_cfile and &is_shfile routine may then be called to known whether
# a given file is a candidate for holding C or SH symbols.
sub main'load_build_filext {
	package main;
	&build_extfun('is_cfile', $cext, '.c .h .y .l');
	&build_extfun('is_shfile', $shext, '.SH');
}

# Build routine $name to identify extensions listed in $exts, ensuring
# that $minimum is at least matched (both to be backward compatible with
# older .package and because it is really the minimum requirred).
sub main'load_build_extfun {
	package main;
	local($name, $exts, $minimum) = @_;
	local(@single);		# Single letter dot extensions (may be grouped)
	local(@others);		# Other extensions
	local(%seen);		# Avoid duplicate extensions
	foreach $ext (split(' ', "$exts $minimum")) {
		next if $seen{$ext}++;
		if ($ext =~ s/^\.(\w)$/$1/) {
			push(@single, $ext);
		} else {
			# Convert into perl's regexp
			$ext =~ s/\./\\./g;		# Escape .
			$ext =~ s/\?/./g;		# ? turns into .
			$ext =~ s/\*/.*/g;		# * turns into .*
			push(@others, $ext);
		}
	}
	local($fn) = &q(<<EOF);		# Function being built
:sub $name {
:	local(\$_) = \@_;
EOF
	local($single);		# Single regexp: .c .h grouped into .[ch]
	$single = '\.[' . join('', @single) . ']' if @single;
	$fn .= &q(<<EOL) if @single;
:	return 1 if /$single\$/;
EOL
	foreach $ext (@others) {
		$fn .= &q(<<EOL);
:	return 1 if /$ext\$/;
EOL
	}
	$fn .= &q(<<EOF);
:	0;	# None of the extensions may be applied to file name
:}
EOF
	print $fn if $opt_d;
	eval $fn;
	chop($@) && die "Can't compile '$name':\n$fn\n$@.\n";
}

# Remove ':' quotations in front of the lines
sub main'load_q {
	package main;
	local($_) = @_;
	local($*) = 1;
	s/^://g;
	$_;
}

# The %Depend array records the functions we use to process the configuration
# lines in the unit, with a special meaning. It is important that all the
# known control symbols be listed below, so that metalint does not complain.
# The %Lcmp array contains valid layouts and their comparaison value.
sub main'load_init_depend {
	package main;
	%Depend = (
		'MAKE', 'p_make',				# The ?MAKE: line records dependencies
		'INIT', 'p_init',				# Initializations printed verbatim
		'LINT', 'p_lint',				# Hints for metalint
		'RCS', 'p_ignore',				# RCS comments are ignored
		'C', 'p_c',						# C symbols
		'D', 'p_default',				# Default value for conditional symbols
		'E', 'p_example',				# Example of usage
		'F', 'p_file',					# Produced files
		'H', 'p_config',				# Process the config.h lines
		'I', 'p_include',				# Added includes
		'L', 'p_library',				# Added libraries
		'M', 'p_magic',					# Process the confmagic.h lines
		'O', 'p_obsolete',				# Unit obsolescence
		'P', 'p_public',				# Location of PD implementation file
		'S', 'p_shell',					# Shell variables
		'T', 'p_temp',					# Shell temporaries used
		'V', 'p_visible',				# Visible symbols like 'rp', 'dflt'
		'W', 'p_wanted',				# Wanted value for interpreter
		'X', 'p_ignore',				# User comment is ignored
		'Y', 'p_layout',				# User-defined layout preference
	);
	%Lcmp = (
		'top',		-1,
		'default',	0,
		'bottom',	1,
	);
}

# Extract dependencies from units held in @ARGV
sub main'load_extract_dependencies {
	package main;
	local($proc);						# Procedure used to handle a ctrl line
	local($file);						# Current file scanned
	local($dir, $unit);					# Directory and unit's name
	local($old_version) = 0;			# True when old-version unit detected
	local($mc) = "$MC/U";				# Public metaconfig directory
	local($line);						# Last processed line for metalint

	printf "Extracting dependency lists from %d units...\n", $#ARGV+1
		unless $opt_s;

	chdir $WD;							# Back to working directory
	&init_extraction;					# Initialize extraction files
	$dependencies = ' ' x (50 * @ARGV);	# Pre-extend
	$dependencies = '';

	# We do not want to use the <> construct here, because we need the
	# name of the opened files (to get the unit's name) and we want to
	# reset the line number for each files, and do some pre-processing.

	file: while ($file = shift(@ARGV)) {
		close FILE;						# Reset line number
		$old_version = 0;				# True if unit is an old version
		if (open(FILE, $file)) {
			($dir, $unit) = ('', $file)
				unless ($dir, $unit) = ($file =~ m|(.*)/(.*)|);
			$unit =~ s|\.U$||;			# Remove extension
		} else {
			warn("Can't open $file.\n");
		}
		# If unit is in the standard public directory, keep only the unit name
		$file = "$unit.U" if $dir eq $mc;
		print "$dir/$unit.U:\n" if $opt_d;
		line: while (<FILE>) {
			$line = $_;					# Save last processed unit line
			if (s/^\?([\w\-]+)://) { 	# We may have found a control line
				$proc = $Depend{$1};	# Look for a procedure to handle it
				unless ($proc) {		# Unknown control line
					$proc = $1;			# p_unknown expects symbol in '$proc'
					eval '&p_unknown';	# Signal error (metalint only)
					next line;			# And go on next line
				}
				# Long lines may be escaped with a final backslash
				$_ .= &complete_line(FILE) if s/\\\s*$//;
				# Run macros substitutions
				s/%</$unit/g;			# %< expands into the unit's name
				if (s/%\*/$unit/) {
					# %* expanded into the entire set of defined symbols
					# in the old version. Now it is only the unit's name.
					++$old_version;
				}
				eval { &$proc($_) };		# Process the line
			} else {
				next file unless $body;		# No procedure to handle body
				do {
					$line = $_;				# Save last processed unit line
					eval { &$body($_) } ;	# From now on, it's the unit body
				} while (defined ($_ = <FILE>));
				next file;
			}
		}
	} continue {
		warn("    Warning: $file is a pre-3.0 version.\n") if $old_version;
		&$ending($line) if $ending;			# Post-processing for metalint
	}

	&end_extraction;		# End the extraction process
}

# The first line was escaped with a final \ character. Every following line
# is to be appended to it (until we found a real \n not escaped). Note that
# the leading spaces of the continuation line are removed, so any space should
# be added before the former \ if needed.
sub main'load_complete_line {
	package main;
	local($file) = @_;		# File where lines come from
	local($_);
	local($read) = '';		# Concatenation of all the continuation lines found
	while (<$file>) {
		s/^\s+//;				# Remove leading spaces
		if (s/\\\s*$//) {		# Still followed by a continuation line
			$read .= $_;	
		} else {				# We've reached the end of the continuation
			return $read . $_;
		}
	}
}

# Record obsolete symbols association (new versus old), that is to say for a
# given old symbol, $Obsolete{'old'} = new symbol to be used. A '$' is prepended
# for all shell variables
sub main'load_record_obsolete {
	package main;
	local($_) = @_;
	local(@obsoleted);					# List of obsolete symbols
	local($symbol);						# New symbol which must be used
	local($dollar) = s/^\$// ? '$':'';	# The '$' or a null string
	# Syntax for obsolete symbols specification is
	#    list of symbols (obsolete ones):
	if (/^(\w+)\s*\((.*)\)\s*:$/) {
		$symbol = "$dollar$1";
		@obsoleted = split(' ', $2);		# List of obsolete symbols
	} else {
		if (/^(\w+)\s*\((.*):$/) {
			warn "\"$file\", line $.: final ')' before ':' missing.\n";
			$symbol = "$dollar$1";
			@obsoleted = split(' ', $2);
		} else {
			warn "\"$file\", line $.: syntax error.\n";
			return;
		}
	}
	foreach $val (@obsoleted) {
		$_ = $dollar . $val;
		if (defined $Obsolete{$_}) {
		warn "\"$file\", line $.: '$_' already obsoleted by '$Obsolete{$_}'.\n";
		} else {
			$Obsolete{$_} = $symbol;	# Record (old, new) tuple
		}
	}
}

# Dump obsolete symbols used in file 'Obsolete'. Also write Obsol_h.U and
# Obsol_sh.U to record old versus new mappings if the -o option was used.
sub main'load_dump_obsolete {
	package main;
	unless (-f 'Obsolete') {
		open(OBSOLETE, ">Obsolete") || die "Can't create Obsolete.\n";
	}
	open(OBSOL_H, ">.MT/Obsol_h.U") || die "Can't create .MT/Obsol_h.U.\n";
	open(OBSOL_SH, ">.MT/Obsol_sh.U") || die "Can't create .MT/Obsol_sh.U.\n";
	local($file);						# File where obsolete symbol was found
	local($old);						# Name of this old symbol
	local($new);						# Value of the new symbol to be used
	# Leave a blank line at the top so that anny added ^L will stand on a line
	# by itself (the formatting process adds a ^L when a new page is needed).
	format OBSOLETE_TOP =

              File                 |      Old symbol      |      New symbol
-----------------------------------+----------------------+---------------------
.
	format OBSOLETE =
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<< | @<<<<<<<<<<<<<<<<<<<
$file,                               $old,                  $new
.
	local(%seen);
	foreach $key (sort keys %ofound) {
		($file, $old, $new) = ($key =~ /^(\S+)\s+(\S+)\s+(\S+)/);
		write(OBSOLETE) unless $file eq 'XXX';
		next unless $opt_o;				# Obsolete mapping done only with -o
		next if $seen{$old}++;			# Already remapped, thank you
		if ($new =~ s/^\$//) {			# We found an obsolete shell symbol
			$old =~ s/^\$//;
			print OBSOL_SH "$old=\"\$$new\"\n";
		} else {						# We found an obsolete C symbol
			print OBSOL_H "#ifdef $new\n";
			print OBSOL_H "#define $old $new\n";
			print OBSOL_H "#endif\n\n";
		}
	}
	close OBSOLETE;
	close OBSOL_H;
	close OBSOL_SH;
	if (-s 'Obsolete') {
		print "*** Obsolete symbols found -- see file 'Obsolete' for a list.\n";
	} else {
		unlink 'Obsolete';
	}
	undef %ofound;				# Not needed any more
}

# Parse files and build cross references
sub main'load_build_xref {
	package main;
	print "Building cross-reference files...\n" unless $opt_s;
	unless (-f $NEWMANI) {
		&manifake;
		die "No $NEWMANI--don't know who to scan.\n" unless -f $NEWMANI;
	}

	open(FUI, "|sort | uniq >I.fui") || die "Can't create I.fui.\n";
	open(UIF, "|sort | uniq >I.uif") || die "Can't create I.uif.\n";

	local($search);							# Where to-be-evaled script is held
	local($_) = ' ' x 50000 if $opt_m;		# Pre-extend pattern search space
	local(%visited);						# Records visited files
	local(%lastfound);						# Where last occurence of key was

	# Map shell symbol names to units by reverse engineering the @Master array
	# which records all the known shell symbols and the units where they
	# are defined.
	foreach $init (@Master) {
		$init =~ /^\?(.*):(.*)=''/ && ($shwanted{"\$$2"} = $1);
	}

	# Now we are a little clever, and build a loop to eval so that we don't
	# have to recompile our patterns on every file.  We also use "study" since
	# we are searching the same string for many different things.  Hauls!

	if (@clist) {
		print "    Scanning .[chyl] files for symbols...\n" unless $opt_s;
		$search = ' ' x (40 * (@cmaster + @ocmaster));	# Pre-extend
		$search = "while (<>) {study;\n";				# Init loop over ARGV
		foreach $key (keys(cmaster)) {
			$search .= "\$cmaster{'$key'} .= \"\$ARGV#\" if /\\b$key\\b/;\n";
		}
		foreach $key (grep(!/^\$/, keys %Obsolete)) {
			$search .= "&ofound('$key') if /\\b$key\\b/;\n";
		}
		$search .= "}\n";			# terminate loop
		print $search if $opt_d;
		@ARGV = @clist;
		# Swallow each file as a whole, if memory is available
		undef $/ if $opt_m;
		eval $search;
		eval '';
		$/ = "\n";
		while (($key,$value) = each(cmaster)) {
			next if $value eq '';
			foreach $file (sort(split(/#/, $value))) {
				next if $file eq '';
				# %cwanted may contain value separated by \n -- take last one
				@sym = split(/\n/, $cwanted{$key});
				$sym = pop(@sym);
				$shell = "\$$sym";
				print FUI
					pack("A35", $file),
					pack("A20", "$shwanted{$shell}.U"),
					$key, "\n";
				print UIF
					pack("A20", "$shwanted{$shell}.U"),
					pack("A25", $key),
					$file, "\n";
			}
		}
	}

	undef @clist;
	undef %cwanted;
	undef %cmaster;		# We're not building Configure, we may delete this
	%visited = ();
	%lastfound = ();

	if (@SHlist) {
		print "    Scanning .SH files for symbols...\n" unless $opt_s;
		$search = ' ' x (40 * (@shmaster + @oshmaster));	# Pre-extend
		$search = "while (<>) {study;\n";
		# All the keys already have a leading '$'
		foreach $key (keys(shmaster)) {
			$search .= "\$shmaster{'$key'} .= \"\$ARGV#\" if /\\$key\\b/;\n";
		}
		foreach $key (grep (/^\$/, keys %Obsolete)) {
			$search .= "&ofound('$key') if /\\$key\\b/;\n";
		}
		$search .= "}\n";
		print $search if $opt_d;
		@ARGV = @SHlist;
		# Swallow each file as a whole, if memory is available
		undef $/ if $opt_m;
		eval $search;
		eval '';
		$/ = "\n";
		while (($key,$value) = each(shmaster)) {
			next if $value eq '';
			foreach $file (sort(split(/#/, $value))) {
				next if $file eq '';
				print FUI
					pack("A35", $file),
					pack("A20", "$shwanted{$key}.U"),
					$key, "\n";
				print UIF
					pack("A20", "$shwanted{$key}.U"),
					pack("A25", $key),
					$file, "\n";
			}
		}
	}

	close FUI;
	close UIF;

	# If obsolete symbols where found, write an Obsolete file which lists where
	# each of them appear and the new symbol to be used. Also write Obsol_h.U
	# and Obsol_sh.U in .MT for later perusal.

	&dump_obsolete;						# Dump obsolete symbols if any

	# Clean-up memory by freeing useless data structures
	undef @SHlist;
	undef %shmaster;
}

# This routine records matches of obsolete keys (C or shell)
sub main'load_ofound {
	package main;
	local($key) = @_;
	local($_) = $Obsolete{$key};		# Value of new symbol
	$ofound{"$ARGV $key $_"}++;			# Record obsolete match
	$cmaster{$_} .= "$ARGV#" unless /^\$/;	# A C hit
	$shmaster{$_} .= "$ARGV#" if /^\$/;		# Or a shell one
}

# Create a new symbol name each time it is invoked. That name is suitable for
# usage as a perl variable name.
sub main'load_gensym {
	package main;
	$Gensym = 'AAAAA' unless $Gensym;
	$Gensym++;
}

sub main'load_manifake {
	package main;
    # make MANIFEST and MANIFEST.new say the same thing
    if (! -f $NEWMANI) {
        if (-f $MANI) {
            open(IN,$MANI) || die "Can't open $MANI";
            open(OUT,">$NEWMANI") || die "Can't create $NEWMANI";
            while (<IN>) {
                if (/---/) {
					# Everything until now was a header...
					close OUT;
					open(OUT,">$NEWMANI") ||
						die "Can't recreate $NEWMANI";
					next;
				}
                s/^\s*(\S+\s+)[0-9]*\s*(.*)/$1$2/;
				print OUT;
				print OUT "\n" unless /\n$/;	# If no description
            }
            close IN;
			close OUT;
        }
        else {
die "You need to make a $NEWMANI file, with names and descriptions.\n";
        }
    }
}

# Perform ~name expansion ala ksh...
# (banish csh from your vocabulary ;-)
sub main'load_tilda_expand {
	package main;
	local($path) = @_;
	return $path unless $path =~ /^~/;
	$path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e;			# ~name
	$path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e;	# ~
	$path;
}

# Set up profile components into %Profile, add any profile-supplied options
# into @ARGV and return the command invocation name.
sub main'load_profile {
	package main;
	local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
	local($me) = $0;		# Command name
	$me =~ s|.*/(.*)|$1|;	# Keep only base name
	return $me unless -s $profile;
	local(*PROFILE);		# Local file descriptor
	local($options) = '';	# Options we get back from profile
	unless (open(PROFILE, $profile)) {
		warn "$me: cannot open $profile: $!\n";
		return;
	}
	local($_);
	local($component);
	while (<PROFILE>) {
		next if /^\s*#/;	# Skip comments
		next unless /^$me/o;
		if (s/^$me://o) {	# progname: options
			chop;
			$options .= $_;	# Merge options if more than one line
		}
		elsif (s/^$me-([^:]+)://o) {	# progname-component: value
			$component = $1;
			chop;
			s/^\s+//;		# Trim leading and trailing spaces
			s/\s+$//;
			$Profile{$component} = $_;
		}
	}
	close PROFILE;
	return unless $options;
	require 'shellwords.pl';
	local(@opts);
	eval '@opts = &shellwords($options)';	# Protect against mismatched quotes
	unshift(@ARGV, @opts);
	return $me;				# Return our invocation name
}

#
# End of dataloading section.
#