#!/usr/swlocal/bin/perl

# TODO: make multi stuff work correctly with new jobs
#       make -pa work correctly. Right now it won't work at all.

# Cons: A Software Construction Tool.
# Bob Sidebotham (rns@fore.com), FORE Systems, 1996.

$version = "This is Cons internal version //depot/us/rns/cons/export/cons#2\n";

# Copyright (c) 1996 FORE Systems, Inc.	 All rights reserved.

# Permission to use, copy, modify and distribute this software and
# its documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and
# that both that copyright notice and this permission notice appear
# in supporting documentation, and that the name of FORE Systems, Inc.
# ("FORE Systems") not be used in advertising or publicity pertaining to
# distribution of the software without specific, written prior permission.

# FORE SYSTEMS DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
# INCLUDING ANY WARRANTIES REGARDING INTELLECTUAL PROPERTY RIGHTS AND
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
# PURPOSE.  IN NO EVENT SHALL FORE SYSTEMS BE LIABLE FOR ANY SPECIAL,
# INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING
# FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
# NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
# WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

require 5.002;
# Could optimize this out.
require 'pwd.pl'; &initpwd; # Must use &chdir, not chdir.
use integer;

# Flush stdout each time.
$| = 1;

$usage = q(
Usage: cons <arguments>

Arguments can be any of the following, in any order:

  <target >	Build the specified target. If <target> is a directory
		recursively build everything within that directory.

  +<pattern>	Limit the cons scripts considered to just those that
		match <pattern>. Multiple + arguments are accepted.

  <name>=<val>	Sets <name> to value <val> in the ARG hash passed to the
		top-level Construct file.

  -f <file>	Use the specified file instead of "Construct" (but first
		change to containing directory of <file>). 

  -o <file>	Read override file <file>.
		
  -k		Keep going as far as possible after errors.

  -p		Show construction products in specified trees.
  -pa		Show construction products and associated actions.
  -pw		Show products and where they are defined.

  -r		Remove construction products associated with <targets>

  -v		Show cons version and continue processing.
  -V            Show cons version nd exit.
  -x		Show this message and exit.

  -j <n>        Do <n> things in parallel by forking, all on this host.
  -z            Parallel build on multiple hosts (if you have .rhosts)

);

# Simplify program name, if it is a path.
$0 =~ s#.*/##;

# Default parameters.
$param::topfile = 'Construct'; # Top-level construction file.
$param::install = 1;	       # Show installations
$param::build = 1;	       # Build targets
$param::show = 1;	       # Show building of targets.
$param::sigpro = 'md5';        # Signature protocol.
$param::jobclass='job::serial';# Which package to use for job handling, by default.

# Display a command while executing or otherwise. This
# should be called by command builder action methods.
sub showcom {
    print($indent . $_[0] . "\n");
}

# Default environment.
@param::defaults = (
     'CC'	    => 'cc',
     'CFLAGS'	    => '',
     'CCCOM'	    => '%CC %CFLAGS %_IFLAGS -c %< -o %>',
     'LINK'	    => '%CC',		    
     'LINKCOM'	    => '%LINK %LDFLAGS -o %> %< %_LDIRS %LIBS',
     'AR'	    => 'ar',
     'ARCOM'	    => "%AR %ARFLAGS %> %<\n%RANLIB %>",
     'ARFLAGS'	    => 'r', # rs?		    
     'RANLIB'	    => 'ranlib',		    
     'AS'	    => 'as',
     'ASFLAGS'	    => '',
     'ASCOM'	    => '%AS %ASFLAGS %< -o %>',
     'LD'	    => 'ld',	    
     'LDFLAGS'	    => '',
     'SUFLIB'	    => '.a',
     'SUFOBJ'	    => '.o',
     'ENV'	    => { 'PATH' => '/bin:/usr/bin' },
);

# Handle command line arguments.
while (@ARGV) {
    $_ = shift(@ARGV);
    &option, next			if s/^-//;
    push (@param::include, $_), next	if s/^\+//;
    &equate, next			if /=/;
    push (@targets, $_), next;
}

sub option {
    if ($_ eq 'v') {
	print($version);
    } elsif ($_ eq 'V') {
	print($version), exit(0);
    } elsif ($_ eq 'o') {
	$param::overfile = shift(@ARGV);
	die("$0: -o option requires a filename argument.\n") if !$param::overfile;
    } elsif ($_ eq 'f') {
	$param::topfile = shift(@ARGV);
	die("$0: -f option requires a filename argument.\n") if !$param::topfile;
    } elsif ($_ eq 'k') {
	$param::kflag = 1;
    } elsif ($_ eq 'p') {
	$param::pflag = 1;
	$param::build = 0;
    } elsif ($_ eq 'pa') {
	$param::pflag = $param::aflag = 1;
	$param::build = 0;
	$indent = "... ";
    } elsif ($_ eq 'pw') {
	$param::pflag = $param::wflag = 1;
	$param::build = 0;
    } elsif ($_ eq 'r') {
	$param::rflag = 1;
	$param::build = 0;
    } elsif ($_ eq 'x') {
	print($usage);
	exit 0;
    } elsif ($_ eq 'j') {
	$param::maxjobs = shift(@ARGV);
	$param::jobclass = 'job::async';
	die("$0: -j option requires an argument specifying the maximum number of jobs in parallel.\n") if !$param::maxjobs;
    } elsif ($_ eq 'z') {
	$param::jobclass = 'job::rmx';
    } else {
	die qq($0: unrecognized option "-$_". Use -x for a usage message.\n) if $_;
    }
}	

# Process an equate argument (var=val).
sub equate {
    my($var, $val) = /([^=]*)=(.*)/;
    $script::ARG{$var} = $val;
}

# Define file signature protocol.
sig->select($param::sigpro);

# Cleanup after an interrupt.
$SIG{INT} = sub { 
    $SIG{PIPE} = $SIG{INT} = 'IGNORE';
    warn("\n$0: interrupted\n");
    # Call this first, to make sure that this processing
    # occurs even if a child process does not die (and we
    # hang on the wait).
    sig::hash::END();
    wait();
    exit(1);
};

# Cleanup after a broken pipe (someone piped our stdout?)
$SIG{PIPE} = sub { 
    $SIG{PIPE} = $SIG{INT} = 'IGNORE';
    warn("\n$0: broken pipe\n");
    sig::hash::END();
    wait();
    exit(1);
};

# If the supplied top-level Conscript file is not in the
# current directory, then change to that directory.
if ($param::topfile =~ s#(.*)/##) {
    &chdir($1) || die("$0: couldn't change to directory $1 ($!)\n");
}

# Now handle override file.
package override;
if ($param::overfile) {
    my($ov) = $param::overfile;
    die qq($0: can't read override file "$ov" ($!)\n) if ! -f $ov; #'
    do $ov;
    if ($@) {
	chop($@);
	die qq($0: errors in override file "$ov" ($@)\n);
    }
}

# Provide this to user to setup override patterns.
sub Override {
    my($re, @env) = @_;
    return if $overrides{$re}; # if identical, first will win.
    $param::overrides = 1;
    $param::overrides{$re} = \@env;
    push(@param::overrides, $re);
}

package main;
# Check script inclusion regexps
for $re (@param::include) {
    if (! defined eval {"" =~ /$re/}) {
	my($err) = $@;
	$err =~ s/in regexp at .*$//;
	die("$0: error in regexp $err");
    }
}

# Read the top-level construct file and its included scripts.
doscripts($param::topfile);

# Status priorities. This let's us aggregate status for directories and print
# an appropriate message (at the top-level).
%priority =
    ('none' => 1, 'handled' => 2, 'built' => 3, 'unknown' => 4, 'errors' => 5);

# Build the supplied target patterns.
for $tgt (map($dir::top->lookup($_), @targets)) {
    my(@tgts);
    enumerate(\@tgts, $tgt);
    my($status);
    if ($param::build) {
	for $subtgt(@tgts) {
	    fstart $subtgt;
	}
	my($status) = 'none';
	for $subtgt(@tgts) {
	    fwait $subtgt;
	    if ($subtgt->{status} ne $status) {
		$status = $subtgt->{status}
		    if $priority{$subtgt->{status}} > $priority{$result};
	    }
	}
	if ($status ne 'built') {
	    my($path) = $tgt->path;
	    if ($status eq "errors") {
		print qq($0: "$path" not remade because of errors.\n);
		$errors++;
	    } elsif ($status eq "handled") {
		print qq($0: "$path" is up-to-date.\n);
	    } elsif ($status eq "unknown") {
		# cons error already reported.
		$errors++;
	    } elsif ($status eq "none") {
		#???
	    } else {
		print qq($0: don't know how to construct "$path".\n);
		$errors++;
            }
	}
    } elsif ($param::depends) {
# all this is wrong right now.
	my($path) = $tgt->path;
	if ($tgt->{builder}) {
	    my(@dep) = (@{$tgt->{dep}}, @{$tgt->{sources}});
	    for $dep (@dep) {
		print("dep: $dep\n");}
	    my($dep) = join(' ',map($_->path, @dep));
	    print("$path: $dep\n");
	} else {
	    print("$path: not a derived file\n");
	}
    } elsif ($param::pflag || $param::wflag || $param::aflag) {
	if ($tgt->{builder}) {
	    if ($param::wflag) {
		print qq(${\$tgt->path}: $tgt->{script}\n);
	    } elsif ($param::pflag) {
		print qq(${\$tgt->path}:\n) if $param::aflag;
		print qq(${\$tgt->path}\n) if !$param::aflag;
	    }
	    if ($param::aflag) {
		$tgt->{builder}->action($tgt);
	    }
	}
    } elsif ($param::rflag && $tgt->{builder}) {
	my($path) = $tgt->path;
	if (-f $path) {
	    if (unlink($path)) {
		print("Removed $path\n");
	    } else {
		warn("$0: couldn't remove $path\n");
	    }
	}
    }
}

exit 0 + ($errors != 0);

# Recursively enumerate the supplied directory or file, and return all
# the buildable targets contained within.
sub enumerate {
    my($list, $tgt) = @_;
    if (ref($tgt) eq "file" && exists($tgt->{builder})) {
	push(@$list, $tgt);
    } elsif (ref($tgt) eq "dir") {
	if (exists $tgt->{member}) {
	    my($members) = $tgt->{member};
	    for $entry (sort keys %$members) {
		next if $entry =~ /^\./; # ignore hidden files
		my($tgt) = $members->{$entry};
		enumerate($list, $tgt);
	    }
	}
    }
}

# Support for "building" scripts, importing and exporting variables.
# With the expection of the top-level routine here (invoked from the
# main package by cons), these are all invoked by user scripts.
package script;

# This is called from main to interpret/run the top-level Construct
# file, passed in as the single argument.
sub main::doscripts {
    my($script) = @_;
    Build($script);
    # Now set up the includes/excludes (after the Construct file is read).
    $param::include = join('|', @param::include);

    my(@scripts) = pop(@priv::scripts);
    while ($priv::self = shift(@scripts)) {
	my($path) = $priv::self->{script}->srcpath;
	$dir::cwd = $priv::self->{script}->{dir};
	if (-f $path) {
	    do $path;
	    if ($@) {
		chop($@);
		print qq($0: error in file "$path" ($@)\n);
		$run::errors++;
	    } else {
		# Only process subsidiary scripts if no errors in parent.
		unshift(@scripts, @priv::scripts);
	    }
	    undef @priv::scripts;
	} else {
	    warn qq(Ignoring missing script "$path".\n);
	}

# reset "a-zA-Z";# Reset here, to give Construct chance at globals (i.e. %ARG).
# RESET causes a memory corruption problem, with all sorts of bad side effects
# so we've replaced it with the following code.
	my($key,$val);
	while (($key,$val) = each %script::) {
	    local(*priv::script) = $val;
	    undef $priv::script;
	    undef @priv::script;
	    undef %priv::script;
	}
    }
    die("$0: script errors encountered: construction aborted\n") if $run::errors;
}

# Link a directory to another. This simply means set up the *source*
# for the directory to be the other directory.
sub Link {
    my(@paths) = @_;
    my($srcdir) = $dir::cwd->lookupdir(pop @paths)->srcdir;
    map($dir::cwd->lookupdir($_)->{srcdir} = $srcdir, @paths);
}

# Export variables to any scripts invoked from this one.
sub Export {
    @{$priv::self->{exports}} = @_;
}

# Import variables from the export list of the caller
# of the current script.
sub Import {
    my($parent) = $priv::self->{parent};
    my($imports) = $priv::self->{imports};
    @{$priv::self->{exports}} = keys %$imports;
    my($var);
    while ($var = shift) {
	if (!exists $imports->{$var}) {
	    my($path) = $parent->{script}->path;
	    die qq($0: variable "$var" not exported by file "$path"\n);
	}
	if (!defined $imports->{$var}) {
	    my($path) = $parent->{script}->path;
	    die qq($0: variable "$var" exported but not defined by file "$path"\n);
	}
	${"script::$var"} = $imports->{$var};
    }
}

# Build an inferior script. That is, arrange to read and execute
# the specified script, passing to it any exported variables from
# the current script.
sub Build {
    my(@files) = map($dir::cwd->lookup($_), @_);
    my(%imports);
    map($imports{$_} = ${"script::$_"}, @{$priv::self->{exports}});
    for $file (@files) {
	next if $param::include && $file->path !~ /$param::include/o;
	my($self) = {'script' => $file,
		     'parent' => $priv::self,
		     'imports' => \%imports};
	bless $self;  # may want to bless into class of parent in future 
	push(@priv::scripts, $self);
    }
}

# Set up regexps dependencies to ignore. Should only be called once.
sub Ignore {
    die("Ignore called more than once\n") if $param::ignore;
    $param::ignore = join("|", map("($_)", @_)) if @_;
}

# Return the build name(s) of a file or file list.
sub FilePath {
    wantarray
	? map($dir::cwd->lookup($_)->path, @_)
	: $dir::cwd->lookup($_[0])->path;
}

# Return the build name(s) of a directory or directory list.
sub DirPath {
    wantarray
	? map($dir::cwd->lookupdir($_)->path, @_)
	: $dir::cwd->lookupdir($_[0])->path;
}


# These methods are callable from Conscript files, via a cons
# object. Procs beginning with _ are intended for internal use.
package cons;

# This is passed the name of the base environment to instantiate.
# Overrides to the base environment may also be passed in
# as key/value pairs. 
sub new {
    my($package) = shift;
    my ($env) = {@param::defaults, @_};
    @{$env->{_envcopy}} = %$env; # Note: we never change PATH
    $env->{_cwd} = $dir::cwd; # Save directory of environment for
    bless $env, $package;	# any deferred name interpretation.
}

# Clone an environment.
# Note that the working directory will be the initial directory
# of the original environment.
sub clone {
    my($env) = shift;
    my $clone = {@{$env->{_envcopy}}, @_};
    @{$clone->{_envcopy}} = %$clone; # Note: we never change PATH
    $clone->{_cwd} = $env->{_cwd};
    bless $clone, ref $env;
}

# Create a flattened hash representing the environment.
# It also contains a copy of the PATH, so that the path
# may be modified if it is converted back to a hash.
sub copy {
    my($env) = shift;
    (@{$env->{_envcopy}}, 'ENV' => {%{$env->{ENV}}}, @_)
}

# Resolve which environment to actually use for a given
# target. This is just used for simple overrides.
sub _resolve {
    return $_[0] if !$param::overrides;
    my($env, $tgt) = @_;
    my($path) = $tgt->path;
    for $re (@param::overrides) {
	next if $path !~ /$re/;
	# Found one. Return a combination of the original environment
	# and the override.
	my($ovr) = $param::overrides{$re};
	return $envcache{$env,$re} if $envcache{$env,$re};
	my($newenv) = {@{$env->{_envcopy}}, @$ovr};
	@{$newenv->{_envcopy}} = %$env;
	$newenv->{_cwd} = $env->{_cwd};
	return $envcache{$env,$re} = bless $newenv, ref $env;
    }
    return $env;
}

# Substitute construction environment variables into a string.
# Internal function/method.
sub _subst {
    my($env, $str) = @_;
    while ($str =~ s/\%([_a-zA-Z]\w*)/$env->{$1}/ge) {}
    $str;
}

sub Install {
    my($env) = shift;
    my($tgtdir) = $dir::cwd->lookupdir(shift);
    for $file (map($dir::cwd->lookup($_), @_)) {
	my($tgt) = $tgtdir->lookup($file->{entry});
	$tgt->bind(find build::install, $file);
    }
}

sub Objects {
    my($env) = shift;
    map($_->{entry}, _Objects($env, map($dir::cwd->lookup($_), @_)))
}

# Called with multiple source file references (or object files).
# Returns corresponding object files references.
sub _Objects {
    my($env) = shift;
    my($suffix) = $env->{SUFOBJ};
    map(_Object($env, $_, $_->{dir}->lookup($_->base . $suffix)), @_)
}

# Called with an object and source reference.  If no object reference
# is supplied, then the object file is determined implicitly from the
# source file's extension. Sets up the appropriate rules for creating
# the object from the source.  Returns the object reference.
sub _Object {
    my($env, $src, $obj) = @_;
    return $obj if $src eq $obj; # don't need to build self from self.
    my($objenv) = $env->_resolve($obj);
    my($suffix) = $src->suffix;
    if ($suffix eq '.c' || $suffix eq '.s' || $suffix eq '.S') {
	$obj->bind(find build::command::cc($objenv), $src);
    } else {
	die("don't know how to construct ${\$obj->path} from ${\$src->path}.\n");
    }
    $obj
}

sub Program {
    my($env) = shift;
    my($tgt) = $dir::cwd->lookup(shift);
    my($progenv) = $env->_resolve($tgt);
    $tgt->bind(find build::command::link($progenv, $progenv->{LINKCOM}),
	       $env->_Objects(map($dir::cwd->lookup($_), @_)));
}

sub Module {
    my($env) = shift;
    my($tgt) = $dir::cwd->lookup(shift);
    my($modenv) = $env->_resolve($tgt);
    my($com) = pop(@_);
    $tgt->bind(find build::command::link($modenv, $com),
	       $env->_Objects(map($dir::cwd->lookup($_), @_)));
}

sub Library {
    my($env) = shift;
    my($lib) = $dir::cwd->lookup(file::addsuffix(shift, $env->{SUFLIB}));
    my($libenv) = $env->_resolve($lib);
    $lib->bind(find build::command::library($libenv),
	       $env->_Objects(map($dir::cwd->lookup($_), @_)));
}

# Simple derivation: you provide target, source(s), command.
# Special variables substitute into the rule.
# Target may be a reference, in which case it is taken
# to be a multiple target (all targets built at once).
sub Command {
    my($env) = shift;
    my($tgt) = shift;
    my($com) = pop(@_);
    my(@sources) = map($dir::cwd->lookup($_), @_);
    if (ref($tgt)) {
	# A multi-target command.
	my(@tgts) = map($dir::cwd->lookup($_), @$tgt);
	die("empty target list in multi-target command\n") if !@tgts;
	$env = $env->_resolve($tgts[0]);
	my($builder) = find build::command::user($env, $com);
	my($multi) = build::multiple->new($builder, \@tgts);
	for $tgt (@tgts) {
	    $tgt->bind($multi, @sources);
	}
    } else {
	$tgt = $dir::cwd->lookup($tgt);
	$env = $env->_resolve($tgt);
	my($builder) = find build::command::user($env, $com);
	$tgt->bind($builder, @sources);
    }
}

sub Depends {
    my($env) = shift;
    my($tgt) = $dir::cwd->lookup(shift);
    push(@{$tgt->{dep}}, map($dir::cwd->lookup($_), @_));
}

# Generic builder module. Just a few default methods.  Every derivable
# file must have a builder object of some sort attached.  Usually
# builder objects are shared. Each subclass must provide start and
# wait methods. Start arranges to start building the target, and
# wait awaits completion of the build. If the action fails, the
# status attribute of the target must be set to 'errors', otherwise
# nothing is updated . The file package takes care of
# making sure that only one attempt to build the target ever
# occurs.
package build;

# Null signature for dynamic includes.
sub includes { () }

# Null signature for build script.
sub script { () }

# Not compatible with any other builder, by default.
sub compatible { 0 }

# Combined start/wait action method
sub action {
    my($self, $tgt) = @_;
    $self->bstart($tgt);
    $self->bwait($tgt);
}


# Builder module for the Install command.
package build::install;
BEGIN {
    @ISA = qw(build);
    bless $installer = {}    # handle for this class.
} 

sub find {
    $installer
}

# Do the installation.
sub bstart {
    my($self, $tgt) = @_;
    my($src) = $tgt->{sources}[0];
    main::showcom("Install ${\$src->path} as ${\$tgt->path}") if $param::install;
    return unless $param::build;
    if (! futil::install($src->srcpath, $tgt)) {
	$tgt->{status} = 'errors';
    }
}

# Optimized versions of these routines for install.
sub bwait {$_[0]->{status}}
sub action {&bstart}


# Builder module for generic UNIX commands.
package build::command;
BEGIN { @ISA = qw(build) }

sub find {
    my($class, $env, $com, $includes) = @_;
    $com = $env->_subst($com);
    $com{$env,$com,$includes} || do {
	my($self) = {'env' => $env, 'com' => $com, 'includes' => $includes};
	$com{$env,$com,$includes} = bless $self, $class;
    }
}

# For the signature of a basic command, we don't bother
# including the command itself. This is not strictly correct,
# and if we wanted to be rigorous, we might want to insist
# that the command was checked for all the basic commands
# like gcc, etc. For this reason we don't have an includes
# method.

# Arrange to start building the target
sub bstart {
    my($self, $tgt) = @_;
    my($path) = $tgt->path;
    my($job);

    if ($param::build) {
	futil::mkdir($tgt->{dir});
	unlink($path); # is this done already?
	$job = new job($tgt, $self->{env}->{ENV});
    }

    # Handle multi-line commands.
    for $com (split(/\n/, $self->{com})) {
	my(@src) = (undef, @{$tgt->{sources}});
	my(@src1) = @src;

	next if $com =~ /^\s*$/;

	# NOTE: we used to have a more elegant s//.../e solution
	# for the items below, but this caused a bus error...

	# Deal with %n, n=1,9 and variants.
	while ($com =~ /%([1-9])(:([fd]?))?/) {
	    my($match) = $&;
	    my($src) = $src1[$1];
	    my($subst) =
		!$src? '' :
		    $3 eq 'f' ? $src1[$1]->{entry} :
			$3 eq 'd'? $src1[$1]->{dir}->path :
			    $src1[$1]->path;
	    undef $src[$1];	    
	    $com =~ s/$match/$subst/;
	}

	# Deal with %0 aka %> and variants.
	while ($com =~ /%[0>](:([fd]?))?/) {
	    my($match) = $&;
	    my($subst) =
		$2 eq 'f' ? $tgt->{entry} :
		    $2 eq 'd'? $tgt->{dir}->path :
			$path;
	    $com =~ s/$match/$subst/;
	}

	# Deal with %< (all sources except %n's already used)
	while ($com =~ /%<(:([fd]?))?/) {
	    my($match) = $&;
	    my($subst) =
		join(' ',
		     $2 eq 'f' ? map($_ && $_->{entry} || (), @src) :
		     $2 eq 'd' ? map($_ && $_->{dir}->path || (), @src) :
		     map($_ && $_->path || (), @src));
	    $com =~ s/$match/$subst/;
	}
	
	# White space cleanup. XXX NO WAY FOR USER TO HAVE QUOTED SPACES
	$com = join(' ', split(' ', $com));
	next if $com =~ /^:/ && $com !~ /^:\S/;

	$job->command($com) if $param::build;
    }

    if ($param::build) {
	$tgt->{job} = $job;
	jstart $job;
    }
}

sub bwait {
    my($self, $tgt) = @_;
    $tgt->{status} = $tgt->{job}->jwait;
    delete $self->{job};
}

# Return generic build script (without $<, $>, etc. bound), for
# dependency calculation. $<, etc. are depended on explicitly.
sub script {
    $_[0]->{com}
}

# Link a program.
package build::command::link;

BEGIN { @ISA = qw(build::command) }

# Find an appropriate linker.
sub find {
    my($class, $env, $command) = @_;
    if (!exists $env->{_LDIRS}) {
	my($ldirs);
	my($wd) = $env->{_cwd};
	for $dir (map($wd->lookupdir($_), split(/:/, $env->{LIBPATH}))) {
	    $ldirs .= ' -L' . $dir->path;
	}
	$env->{_LDIRS} = $ldirs;
    }
    bless find build::command($env, $command);
}

# Called from file::build. Make sure any libraries needed by the
# environment are built, and return the collected signatures
# of the libraries in the path.
sub includes {
    return $_[0]->{sig} if exists $_[0]->{sig};
    my($self, $tgt) = @_;
    my($env) = $self->{env};
    my($ewd) = $env->{_cwd};
    my(@lpath) = map($ewd->lookupdir($_), split(/:/, $env->{LIBPATH}));
    my(@sigs);
    for $name (split(' ', $env->{LIBS})) {
	my($lpath);
	if ($name =~ /^-l(.*)/) {
	    # -l style names are looked up on LIBPATH
	    $name = "lib$1$env->{SUFLIB}";
	    $lpath = \@lpath;
	} else {
	    $lpath = [$dir::top];
	}
	for $dir (@$lpath) {
	    my($lib) = $dir->lookup($name);
	    if ($lib->accessible) {
		last if $lib->ignore;
		if ((build $lib $tgt) eq 'errors') {
		    $tgt->{status} = 'errors';
		    return undef;
		}
		push(@sigs, sig->signature($lib));
		last;
	    }
	}
    }
    $self->{sig} = sig->collect(@sigs);
}    

# Builder for a C module
package build::command::cc;

BEGIN { @ISA = qw(build::command) }

sub find {
    $_[1]->{_cc} || do {
	my($class, $env) = @_;
	my($cscanner) = find scan::cpp($env->{_cwd}, $env->{CPPPATH});
	$env->{_IFLAGS} = $cscanner->iflags;
	my($self) = find build::command($env, $env->{CCCOM});
	$self->{scanner} = $cscanner;
	bless $env->{_cc} = $self;
    }
}

# Invoke the associated	 C scanner to get signature of included files.
sub includes {
    my($self, $tgt) = @_;
    $self->{scanner}->includes($tgt, $tgt->{sources}[0]);
}

# Builder for a user command (cons::Command).  We assume that a user
# command might be built and implement the appropriate dependencies on
# the command itself (actually, just on the first word of the command
# line).
package build::command::user;

BEGIN { @ISA = qw(build::command) }

# XXX Optimize this to not use ignored paths.
sub includes {
    return $_[0]->{comsig} if exists $_[0]->{comsig};
    my($self, $tgt) = @_;
    my($env) = $self->{env};
  com:
    for $com (split(/\n/, $self->script)) {
	# Isolate command word.
	$com =~ s/^\s*//;
	$com =~ s/\s.*//;
	next if !$com; # blank line
	for $dir (map($dir::top->lookupdir($_), split(/:/, $env->{ENV}->{PATH}))) {
	    my($prog) = $dir->lookup($com);
	    next com if $prog->ignore;
	    if ($prog->accessible) { # XXX Not checking execute permission.
		if ((build $prog $tgt) eq 'errors') {
		    $tgt->{status} = 'errors';
		    return undef;
		}
		$self->{comsig} .= sig->signature($prog);
		next com;
	    }
	}
	# Not found: let shell give an error.
    }
    return $self->{comsig};
}


# Builder for a library module (archive).
# We assume that a user command might be built and implement the
# appropriate dependencies on the command itself.
package build::command::library;

BEGIN { @ISA = qw(build::command) }

sub find {
    my($class, $env) = @_;
    bless find build::command($env, $env->{ARCOM})
}

# Always compatible with other library builders, so the user
# can define a single library from multiple places.
sub compatible {
    my($self, $other) = @_;
    ref($other) eq "build::command::library";
}

# A multi-target builder.
# This allows multiple targets to be associated with a single build
# script, without forcing all the code to be aware of multiple targets.
package build::multiple;

sub new {
    my($class, $builder, $tgts) = @_;
    bless { 'builder' => $builder, 'tgts' => $tgts };
}

sub script {
    my($self) = pop(@_);
    $self->{builder}->script(@_);
}

sub includes {
    my($self) = pop(@_);
    $self->{builder}->includes(@_);
}

sub compatible {
    my($self) = pop(@_);
    $self->{builder}->compatible(@_);
}

sub bstart {
    my($self, $invoked_tgt) = @_;
    return $self->{built} if exists $self->{built};

    # Make sure all targets in the group are unlinked before building any.
    my($tgts) = $self->{tgts};
    for $tgt (@$tgts) {
	futil::mkdir($tgt->{dir});
	unlink($tgt->path);
    }

    # Now do the action to build all the targets. For consistency
    # we always call the action on the first target, just so that
    # $> is deterministic.
    $self->{built} = $self->{builder}->action($tgts->[0]);

    # Now "build" all the other targets (except for the one
    # we were called with). This guarantees that the signature
    # of each target is updated appropriately. We force the
    # targets to be built even if they have been previously
    # considered and found to be OK; the only effect this
    # has is to make sure that signature files are updated
    # correctly.
    for $tgt (@$tgts) {
	if ($tgt ne $invoked_tgt) {
	    delete $tgt->{status};
	    sig->invalidate($tgt);
	    build $tgt;
	}
    }

    # Status of action.
    $self->{built};
}

sub bwait {
    $_[1]
}


# Generic scanning module.
package scan;

# Returns the signature of files included by the specified files on
# behalf of the associated target. Any errors in handling the included
# files are propagated to the target on whose behalf this processing
# is being done. Signatures are cached for each unique file/scanner
# pair.
sub includes {
    my($self, $tgt, @files) = @_;
    my(%files, $file);
    my($inc) = $self->{includes} || ($self->{includes} = {});
    while ($file = pop @files) {
	next if exists $files{$file};
	if ($inc->{$file}) {
	    push(@files, @{$inc->{$file}});
	    $files{$file} = sig->signature($file);
	} else {
	    if ((build $file $tgt) eq 'errors') {
		$tgt->{status} = 'errors'; # tgt inherits build status
		return ();
	    }
	    $files{$file} = sig->signature($file);
	    my(@includes) = $self->scan($file);
	    $inc->{$file} = \@includes;
	    push(@files, @includes);
	}
    }
    sig->collect(sort values %files);
}


# CPP (C preprocessor) scanning module
package scan::cpp;

BEGIN { @ISA = qw(scan) }

# For this constructor, provide the include path argument (colon
# separated). Each path is taken relative to the provided directory.

# Note: a particular scanning object is assumed to always return the
# same result for the same input. This is why the search path is a
# parameter to the constructor for a CPP scanning object. We go to
# some pains to make sure that we return the same scanner object
# for the same path: otherwise we will unecessarily scan files.
sub find {
    my($class, $dir, $path) = @_;
    my(@path) = (map($dir->lookupdir($_), split(/:/,$path)));
    my($spath) = "@path";
    $scanner{$spath} || do {
	my($self) = {'path' => \@path};
	$scanner{$spath} = bless $self;
    }
}

# Scan the specified file for include lines.
sub scan {
    my($self, $file) = @_;
    my($angles, $quotes);

    if (exists $file->{angles}) {
	$angles = $file->{angles};
	$quotes = $file->{quotes};
    } else {
	my(@anglenames, @quotenames);
	return () unless open(SCAN, $file->path);
	# Inexplicably, using $_ here implicitly (as <SCAN>) causes
	# various types of corruption to perl. Right now, it causes
	# output to be blocked (no output is printed form the script).
	# So this is temporarily hacked around.
	while (<SCAN>) {
	    next unless /^\s*#/;
	    if (/^\s*#\s*include\s*([<"])(.*)[>"]/) {
		if ($1 eq "<") {
		    push(@anglenames, $2);
		} else {
		    push(@quotenames, $2);
		}
	    }
	}
	close(SCAN);
	$angles = $file->{angles} = \@anglenames;
	$quotes = $file->{quotes} = \@quotenames;
    }

    my(@shortpath) = @{$self->{path}};	  # path for <> style includes
    my(@longpath) = ($file->{dir}, @shortpath); # path for "" style includes

    my(@includes);

    for $name (@$angles) {
	for $dir (@shortpath) {
	    my($include) = $dir->lookup($name);
	    if ($include->accessible) {
		push(@includes, $include) unless $include->ignore;
		last;
	    }
	}
    }

    for $name (@$quotes) {
	for $dir(@longpath) {
	    my($include) = $dir->lookup($name);
	    if ($include->accessible) {
		push(@includes, $include) unless $include->ignore;
		last;
	    }
	}
    }	    

    return @includes
}

# Return the include flags that would be used for a C Compile.
sub iflags {
    my($self) = @_;
    my($path);
    for $dpath (map($_->path, @{$self->{path}})) {
	$path .= " -I$dpath";
    }
    $path
}

# Job package. This handles the scheduling of actual construction
# activity. Different job classes exist, only one of which is active
# for any given cons invocation. The job class is also reponsible
# for handling all job-related output. Note that only the serial
# class allows handling of stdin: if you have an application such
# as metaconfig that requires interaction, then this must be invoked
# with the serial class.
package job;

sub new {
    my($class, $tgt, $execenv) = @_;
    bless {tgt => $tgt, ENV => $execenv}, $param::jobclass;
}

# Add a command to a job. All commands will be executed
# sequentially. If any command fails, the rest must be
# ignored.
sub command {
    my($self, $com) = @_;
    push(@{$self->{commands}}, $com);
}

# Serial jobs: all commands are executed serially, by this process.
package job::serial;

BEGIN { @ISA = qw(job) }

sub jstart {
    my($job) = @_;
    my($tgt) = $job->{tgt};

    # Set environment.
    map(delete $ENV{$_}, keys %ENV);
    %ENV = %{$job->{ENV}};

    for $com (@{$job->{commands}}) {
	main::showcom($com);
	if ($param::build) {
	    my($pid) = fork();
	    die("$0: unable to fork child process ($!)\n") if !defined $pid;
	    if (!$pid) {
		# This is the child.
		exec($com);
		$com =~ s/\s.*//;
		die qq($0: failed to execute "$com" ($!). )
		    . qq(Is this an executable on path "$ENV{PATH}"?\n);
	    }
	    do {} until wait() == $pid;
	    my($err) = $? >> 8;
	    if ($err) {
		warn qq($0: *** [$path] Error $err\n); # trying to be like make.
		$job->{status} = 'errors';
	    }
	}
    }
}

sub jwait {
    $_[0]->{status}
}

# Parallel jobs: up to n jobs forked off at once, as controlled by the -j
# parameter.
package job::async;

BEGIN { @ISA = qw(job) }

sub jstart {
    my($job) = @_;
    my($tgt) = $job->{tgt};
    my($pid);

    # Set environment.
    map(delete $ENV{$_}, keys %ENV);
    %ENV = %{$job->{ENV}};

    if ($param::build) {
	while ($njobs >= $param::maxjobs) {
	    $pid = wait();
	    die("$0: wait returned an error ($!)\n") if $pid == -1;
	    if ($?) {
		$job{$pid}->{status} = 'errors';
	    } else { # XXX this is ugly. Couldn't we use one status?
		$job{$pid}->{done} = 1;
	    }
	    $njobs--;
	}
	$pid = fork();
	die("$0: unable to fork child process ($!)\n") if !defined $pid;
    }

    if ($pid) {
	# This is the parent
	$njobs++;
	$job->{pid} = $pid;
	$job{$pid} = $job;
    } else {
	# This is the child.
	my(@commands) = @{$job->{commands}};
	while ($com = shift(@commands)) {
	    main::showcom($com);
	    if ($param::build) {
		my($pid);
		$pid = fork() if @commands;
		if (!$pid) {
		    # This is the child of the child.
		    exec($com);
		    $com =~ s/\s.*//;
		    die qq($0: failed to execute "$com" ($!). )
		    . qq(Is this an executable on path "$ENV{PATH}"?\n);
		}
		do {} until wait() == $pid;
		my($err) = $? >> 8;
		if ($err) {
		    warn qq($0: *** [$path] Error $err\n); # trying to be like make.
		    exit($err);
		}
	    }
	}
	exit(0);
    }
}

sub jwait {
    my($job) = @_;
    if (! $job->{status} && !$job->{done}) {
	my($waitpid) = $job->{pid};
	do {
	    $pid = wait();
	    if ($?) {
		$job{$pid}->{status} = 'errors';
	    } else { # XXX this is ugly. Couldn't we use one status?
		$job{$pid}->{done} = 1;
	    }
	    die("$0: wait returned an error ($!)\n") if $pid == -1;
	    $njobs--;
	} until $pid == $waitpid;
    }
    $_[0]->{status}
}

package job::rmx;

BEGIN { @ISA = qw(job) }

sub notify {
    my($job, $exitstatus) = @_;
    unlink($job->{script});
    open(LOG, $job->{log});
    while (<LOG>) {
	print $_;
    }
    if ($exitstatus) {
	my($path) = $job->{tgt}->path;
	warn qq($0: *** [$path] Error $exitstatus\n);	
    }
}

sub jstart {
    my($job) = @_;
    my($tgt) = $job->{tgt};
    my($env) = $job->{ENV};
    my($path) = $tgt->path;
    my($script) = $job->{script} = "$path#sh";
    my($log) = $job->{log} = "$path#log";
    open(SCRIPT, ">$script") || die("couldn't create $script ($!)\n");
    print SCRIPT "set -e\n" . "cd $env->{PWD}\n";
    while (($key, $val) = each %$env) {
        print SCRIPT "$key=$val; export $key\n";
    }
    for $com (@{$job->{commands}}) {
	($echo = $com) =~ s/'/'\\''/;
	print SCRIPT "echo '$echo'\n" . "($com)\n";
    }
    $rmxcom = $rmx->startproc("sh $script > $log 2>&1", \notify, $job);
    die("couldn't start remote job") if !$rmxcom; # XXX
    $job->{rmxcom} = $rmxcom;
}

sub jwait {
    my($job) = @_;
    return 'errors' if $job->{rmxcom}->wait();
    return undef;
}

# XXX rmx shutdown processing should be initiated somewhere when
# an error is detected.


# Directory and file handling. Files/dirs are represented by objects.
# Other packages are welcome to add component-specific attributes.
package dir;

BEGIN {
    $root = {path => '/', prefix => '/', srcpath => '/', exists => 1 };
    $root->{srcdir} = $root;
    bless $root;

    $top = {path => '.', prefix => '', srcpath => '.', exists => 1 };
    $top->{srcdir} = $top;
    $top->{member}->{'.'} = $top;
    bless $top;

    $cwd = $top;
}

# Look up a file (but not a directory) in a directory. 
# The file may be specified as relative, absolute (starts
# with /), or top-relative (starts with #).
sub lookup {
    my($dir, $entry) = @_;

    if ($entry !~ m#/#) {
	# Fast path: simple entry name in a known directory.
	if ($entry =~ s/^#//) {
	    # Top-relative names begin with #.
	    $dir = $dir::top;
	}
    } else {
	# Path has a / in it somewhere. Separate into
	# stem and entry, and find the new directory
	# to look the entry up in.
	my($stem);
	if ($entry =~ s#^/##) {
	    # Absolute path
	    if ($entry =~ m#/#) {
		($stem, $entry) = $entry =~ m#(.*)/(.*)#;
		$dir = $root->lookupdir($stem)
	    } else {
		return $root if !$entry;
		$dir = $root;
	    }
	} else {
  	    ($stem, $entry) = $entry =~ m#(.*)/(.*)#;
	    if ($entry =~ s/^#//) {
		# Top-relative names begin with #.
		$dir = $dir::top->lookupdir($stem)
	    } else {
		$dir = $dir->lookupdir($stem)
	    }
	}
    }
    $dir->{member}->{$entry} ||
	bless $dir->{member}->{$entry} =
	    {'entry' => $entry, 'dir' => $dir}, file
}

sub lookupdir {
    $dir::cache{$_[0],$_[1]} || do {
	my($dir) = $dir::cache{$_[0],$_[1]} = &dir::lookup;
	$dir->{member}->{'..'} = $dir->{dir};
	$dir->{member}->{'.'} = $dir;
	bless $dir;
    }	    
}

# Return the path of the directory (file paths implemented
# separately, below).
sub path {
    $_[0]->{path} ||
	($_[0]->{path} = $_[0]->{dir}->prefix . $_[0]->{entry});
}

# Return the pathname as a prefix to be concatenated with an entry.
sub prefix {
    return $_[0]->{prefix} if exists $_[0]->{prefix};
    $_[0]->{prefix} = $_[0]->path . '/'
}

# Return the related source path prefix.
sub srcprefix {
    return $_[0]->{srcprefix} if exists $_[0]->{srcprefix};
    my($srcdir) = $_[0]->srcdir;
    $srcdir->{srcprefix} = $srcdir eq $_[0] ? $srcdir->prefix : $srcdir->srcprefix;
}

# Return the related source directory.
sub srcdir {
    $_[0]->{srcdir} ||
	($_[0]->{srcdir} = $_[0]->{dir}->srcdir->lookupdir($_[0]->{entry}))
}


package file;

BEGIN { @ISA = qw(dir) }

# Return the pathname of the file.
# Define this separately from dir::path because we don't want to
# cache all file pathnames (just directory pathnames).
sub path {
    $_[0]->{dir}->prefix . $_[0]->{entry}
}

# Return the related source file path.
# XXX This is a hack to make sig->signature work. We need
# to revisit this (should sig->signature be called 
# with a derived file?). In any event, it's expensive this
# way, since sig->signature goes and converts to source path
# and object path, then compares the paths, all for no particular
# reason.
sub srcpath {
    if ($_[0]->{builder}) {
	$_[0]->{dir}->prefix . $_[0]->{entry}
    } else {
	$_[0]->{dir}->srcprefix . $_[0]->{entry}
    }
}

# Return the entry name of the specified file
# without the suffix 
sub base {
    my($entry) = $_[0]->{entry};
    $entry =~ s/\.[^\.]*$//;
    $entry
}

# Return the suffix of the file, for up to a 3 character
# suffix. Anything less returns nothing.
sub suffix {
    $_[0]->{entry} =~ /\.[^\.\/]{0,3}$/;
    $&
}

# Called as a simple function file::addsuffix(name, suffix)
sub addsuffix {
    my($name, $suffix) = @_;

    if ($suffix && substr($name, -length($suffix)) ne $suffix) {
	return $name .= $suffix;
    }
    $name
}

# Return true if the file is (or will be) accessible.
# That is, if we can build it, or if it is already present.
sub accessible {
    (exists $_[0]->{builder}) || sig->signature($_[0])
}

# Return true if the file should be ignored for the purpose
# of computing dependency information (should not be considered
# as a dependency and, further, should not be scanned for 
# dependencies). 
sub ignore {
    return 0 if !$param::ignore;
    return $_[0]->{ignore} if exists $_[0]->{ignore};
    $_[0]->{ignore} = $_[0]->path =~ /$param::ignore/o
}

# Build the file, if necessary.
sub build {
    $_[0]->{status} || (&fstart, &fwait)
}

# Start build, asynchronously if possible.
# Parent object may be passed in optionally for better diagnostics.
sub fstart {
    my($self, $parent) = @_;
    return if $self->{started};
    if (!exists $self->{builder}) {
	# We don't know how to build the file. This is OK, if
	# the file is present in the tree.
	if (sig->signature($self)) {
	    # This may read the signature (if externally provided)
	    # or fabricate it (either from the file's name and timestamp)
	    # or from the file's contents.
	    $self->{status} = 'handled';
	} else {
	    my($name) = $self->path;
	    my $warn = qq($0: don't know how to construct "$name");
            $warn .= qq( needed by "${\$parent->path}") if $parent;
            warn("$warn\n");
            if (!$param::kflag) {
                sig::hash::END();
	        exit(1) unless $param::kflag; ##### need better shutdown for parallel build
            }
	    $self->{status} = 'errors';
	}
	return;
    }

    # An associated build object exists, so we know how to build
    # the file. We first compute the signature of the file, based
    # on its dependendencies, then only rebuild the file if the
    # signature has changed.
    my($builder) = $self->{builder};

    # Will contain signatures of dependents
    my (@dsig);
    my (@deps) = (@{$self->{dep}}, @{$self->{sources}});

    # Start any asynchronous builds we can.
    for $dep (@deps) {
	$dep->fstart($self);
    }

    # Get signatures of statically defined dependents.
    # XXXXX Some question here about -k vs. not -k semantics.
    for $dep (@deps) {
	if ((fwait $dep) eq 'errors') {
	    # Propagate dependent errors to target.
	    $self->{status} = 'errors';
	} else {
	    push(@dsig, sig->signature($dep));
	}
    }

    # Add dynamic dependent signature, if appropriate.
    push(@dsig, $builder->includes($self));

    # If dependents have errors, cannot proceed with build of target.
    return if $self->{status};

    # Compute the final signature of the file.
    my($sig) = sig->collect(@dsig, $builder->script);

    # Then check for currency.
    if (! sig->current($self, $sig)) {
	# We have to build/derive the file.
	$builder->bstart($self);
	$self->{started} = $sig;
    } else {
	$self->{status} = 'handled';
    }
}

# Wait for build already started.
sub fwait {
    $_[0]->{status} || do {
	my($self) = @_;
	$self->{builder}->bwait($self);
	if ($self->{status}) {
	    die("$0: errors constructing ${\$self->path}\n") unless $param::kflag;
	    return 'errors';
	} else {
	    # We only ever set status to "built" if it was really built
	    # by us (not just because it exists).
	    sig->set($self, $self->{started});
	    return $self->{status} = 'built';
	}
    }
}

# Bind an action to a file, with the specified sources. No return value.
sub bind {
    my($self, $builder, @sources) = @_;
    if ($self->{builder} && !$self->{builder}->compatible($builder)) {
	# Even if not "compatible", we can still check to see if the
	# derivation is identical. It should be identical if the builder is
	# the same and the sources are the same.
	if ("$self->{builder} @{$self->{sources}}" ne "$builder @sources") {
	    $main::errors++;
	    my($path) = $self->path;
	    die("$0: attempt to build ${\$self->path} twice, in different ways!\n");
	}
	return;
    }
    if ($param::wflag) {
	my($lev) = 1;
	my(@frame);
	do {@frame = caller ++$lev} while $frame[3] ne '(eval)';
	@frame = caller --$lev;
	$self->{script} .= "; " if $self->{script};
	$self->{script} .= qq($frame[3] in "$frame[1]", line $frame[2]);
    }
    $self->{builder} = $builder;
    push(@{$self->{sources}}, @sources);
}

# File utilities
package futil;

# Install one file as another.
# Links them if possible (hard link), otherwise copies.
# Don't ask why, but the source is a path, the tgt is a file obj.
sub install {
    my($sp, $tgt) = @_;
    my($tp) = $tgt->path;
    return 1 if $tp eq $sp;
    return 1 if link($sp, $tp);
    unlink($tp);
    futil::mkdir($tgt->{dir});
    return 1 if link($sp, $tp);
    futil::copy($sp, $tp);
}

# Copy one file to another. Arguments are actual file names.
# Returns undef on failure. Preserves mtime and mode.
sub copy {
    my ($sp, $tp) = @_;
    my($mode, $length, $atime, $mtime) = (stat($sp))[2,7,8,9];
    if (!open(SRC, $sp)) {
	die("$0: unable to read file $sp ($!)\n");
	return undef;
    }
    if (!open(TGT, ">$tp")) {
	die("$0: unable to write file $tp ($!)\n");
	close(SRC);
	return undef;
    }

    my($len, $total);
    while ($len = sysread(SRC, $buf, 4096)) {
	if (syswrite(TGT, $buf, $len) != $len) {
	    die("$0: error writing object file $tp ($!)\n");
	}
	$total += $len;
    }
    die("$0: error copying file $sp (incorrect length!)\n") if $total != $length;
    close(SRC);
    close(TGT);
    utime $atime, $mtime, $tp
	|| die qq($0: can't set modification time for file "$tp" ($!)\n); #'
    chmod $mode, $tp
	|| die qq($0: can't set mode on file "$tp" ($!)\n); #'
    return 1;
}

# Ensure that the specified directory exists.
# Aborts on failure.
sub mkdir {
    return if $_[0]->{exists};
    futil::mkdir($_[0]->{dir}); # Recursively make parent.
    my($path) = $_[0]->path;
    if (!-d $path && !mkdir($path, 0777)) {
	die("$0: can't create directory $path ($!).\n");
    }
    $dir->{exists} = 1;
}


# Signature package.
package sig::hash;

sub init {
    my($dir) = @_;
    my($consign) = $dir->prefix . ".consign";
    my($dhash) = $dir->{consign} = {};
    if (-f $consign) {
	open(CONSIGN, $consign) || die("$0: can't open $consign ($!)\n");
	while(<CONSIGN>) {
	    chop;
	    ($file,$sig) = split(/:/,$_);
	    $dhash->{$file} = $sig;
	}
	close(HASH);
    }
    $dhash
}

# Read the hash entry for a particular file.
sub in {
    my($dir) = $_[0]->{dir};
    ($dir->{consign} || init($dir))->{$_[0]->{entry}}
}

# Write the hash entry for a particular file.
sub out {
    my($file, $sig) = @_;
    my($dir) = $file->{dir};
    ($dir->{consign} || init($dir))->{$file->{entry}} = $sig;
    $sig::hash::dirty{$dir} = $dir;
}

# Flush hash entries. Called at end or via ^C interrupt.
sub END {
    return if $called++; # May be called twice.
    close(CONSIGN); # in case this came in via ^C.
    for $dir (values %sig::hash::dirty) {
	$consign = $dir->prefix . ".consign";
	open(CONSIGN, ">$consign") || die("$0: can't create $consign ($!)\n");
	my($entry, $sig);
	while(($entry,$sig) = each %{$dir->{consign}}) {
	    print CONSIGN ("$entry:$sig\n");
	}
	close(CONSIGN);
    }
}


# Generic signature handling
package sig;

sub select {
    my($package, $subclass) = @_;
    @ISA = ("sig::$subclass");
};


# MD5-based signature package.
package sig::md5;

use MD5 1.6;

BEGIN {
    $md5 = new MD5;
}

# Invalidate a cache entry.
sub invalidate {
    delete $_[1]->{sig}
}

# Determine the current signature of an already-existing or
# non-existant file As a side-effect, this will also link source files
# into the shadow object directory.
# XXXX Should optimize case where srcpath = path, and remove hack
# in srcpath to look at 'builder'.
sub signature {
    if (defined $_[1]->{sig}) {
	return $_[1]->{sig};
    }
    my ($self, $file) = @_;
    my($path) = $file->path;
    my($src) = $file->srcpath;
    my($time);
    if ($path ne $src) {
	if (-f $src) {
	    $time = (stat(_))[9];
	    if (-f $path) {
		my($ptime) = (stat(_))[9];
		if ($time != $ptime) {
		  futil::install($src, $file);
		}
	    } else {
	      futil::install($src, $file);
	    }
	} else {
	    if (-f $path) {
		unlink($path) || die("$0: couldn't unlink $path ($!)\n");
	    }
	}
    } else {
	if (-f $src) {
	    $time = (stat(_))[9];
	}
    }
    if ($time) {
	my($sigtime) = sig::hash::in($file);
	if ($sigtime) {
	    my($htime, $hsig) = split(' ',$sigtime);
	    if ($htime == $time) {
		return $file->{sig} = $hsig;
	    }
	}
	return $file->{sig} = $file->{entry} . $time;
    }
    $file->{sig} = '';
}

# Is the provided signature equal to the signature of the current
# instantiation of the target (and does the target exist)?
sub current {
    my($self, $file, $sig) = @_;
    $self->signature($file) eq $sig
}

# Store the signature for a file.
sub set {
    my($self, $file, $sig) = @_;
    my($time) = (stat($file->path))[9];
    sig::hash::out($file, "$time $sig");
    $file->{sig} = $sig
}

# Return an aggregate signature
sub collect {
    my($self, @sigs) = @_;
    # The following sequence is faster than calling the hex interface.
    $md5->reset();
    $md5->add(join('', @sigs));
    unpack("H*", $md5->digest());
}

# Support for remote build.
package remote;