cons

quakeIII源码这个不用我多说吧

# Walk up the directory hierarchy looking for a Conscript file (if -t set).
my($target_top);
my(@targetdir) = ();
if ($param::traverse && ! -f $param::topfile) {
    my($vol, $dirs, $file) = File::Spec->splitpath(cwd());
    my(@dirs) = (File::Spec->splitdir($dirs), $file);
    while (! -f File::Spec->catpath($vol, File::Spec->catdir(@dirs),
				    $param::topfile)) {
	die("$0: unable to find $param::topfile.\n") if ! @dirs;
	unshift(@targetdir, pop(@dirs));
    }
    my($cwd) = File::Spec->catpath($vol, File::Spec->catdir(@dirs), '');
    print "$0: Entering directory `$cwd'\n";
    chdir($cwd);
    @targets = map {File::Spec->catdir(@targetdir, $_)} @targets;
}

# Set up $dir::top and $dir::cwd, now that we are in the right directory.
dir::init();

#
if (@targetdir) {
    $target_top = $dir::top->lookupdir(File::Spec->catdir(@targetdir));
}

# 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 $param::overrides{$re}; # if identical, first will win.
    $param::overrides = 1;
    $param::overrides{$re} = \@env;
    push(@param::overrides, $re);
}

package main;

use vars qw( %priority $errors );

# Check script inclusion regexps
my $re;
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 lets 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);

# If no targets were specified, supply default targets (if any).
@targets = @param::default_targets if ! @targets;

$errors = 0;

# Build the supplied target patterns.
my $tgt;
for $tgt (map($dir::top->lookup($_), @targets)) {
    if ($target_top && ! $tgt->is_under($target_top)) {
	# A -t option was used, and this target is not underneath
	# the directory where we were invoked via -t.
	# If the target is a directory and the -t directory
	# is underneath it, then build the -t directory.
	if (ref $tgt ne "dir" || ! $target_top->is_under($tgt)) {
	    next;
	}
	$tgt = $target_top;
    }
    buildtoptarget($tgt);
}

exit 0 + ($errors != 0);

sub buildtoptarget {
    my($tgt) = @_;
    return if ! $tgt;
    my($status) = buildtarget($tgt);
    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) if ($param::quiet < 2);
	} elsif ($status eq "unknown") {
	    # cons error already reported.
	    $errors++;
	} elsif ($status eq "none") {
	    # search for targets that may be linked to the given path.
	    my @linked = dir::linked_targets($tgt) if $target_top;
	    if (@linked) {
		my @names = map($_->path, @linked);
		print "Linked targets: @names\n" if ($param::quiet < 1);
		map(buildtoptarget($_), @linked);
	    } else {
		print qq($0: nothing to be built in "$path".\n)
		      if $param::build && ($param::quiet < 2);
	    }
	} else {
	    print qq($0: don\'t know how to construct "$path".\n); #'
	    $errors++;
	}
    }
}

# Build the supplied target directory or files. Return aggregated status.
sub buildtarget {
    my($tgt) = @_;
    if (ref($tgt) eq "dir") {
	my($result) = "none";
	my($priority) = $priority{$result};
	if (exists $tgt->{member}) {
	    my($members) = $tgt->{member};
	    my $entry;
	    for $entry (sort keys %$members) {
		next if $entry eq $dir::CURDIR || $entry eq $dir::UPDIR;
		my($tgt) = $members->{$entry};
		next if ref($tgt) ne "dir" && !exists($tgt->{builder});
		my($stat) = buildtarget($members->{$entry});
		my($pri) = $priority{$stat};
		if ($pri > $priority) {
		    $priority = $pri;
		    $result = $stat;
		}
	    }
	}
	return $result;
    }
    if ($param::depends) {
	my($path) = $tgt->path;
	if ($tgt->{builder}) {
	    my(@dep) = (@{$tgt->{dep}}, @{$tgt->{sources}});
	    my($dep) = join(' ',map($_->path, @dep));
	    print("Target $path: $dep\n");
	} else {
	    print("Target $path: not a derived file\n");
	}
    }
    if ($param::build) {
	return build $tgt;
    } 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") if ($param::quiet < 1);
	    } else {
		warn("$0: couldn't remove $path\n");
	    }
	}
    }

    return "none";
}

package NameSpace;

# Return a hash that maps the name of symbols in a namespace to an
# array of refs for all types for which the name has a defined value.
# A list of symbols may be specified; default is all symbols in the
# name space.
sub save {
    my $package = shift;
    my(%namerefs, $var, $type);
    no strict 'refs';
    @_ = keys %{$package."::"} if ! @_;
    foreach $var (@_) {
	$namerefs{$var} = [];
	my $fqvar = $package."::".$var;
	# If the scalar for this variable name doesn't already
	# exist, *foo{SCALAR} will autovivify the reference
	# instead of returning undef, so unlike the other types,
	# we have to dereference to find out if it exists.
	push(@{$namerefs{$var}}, *{$fqvar}{SCALAR})
		    if defined ${*{$fqvar}{SCALAR}};
	foreach $type (qw(ARRAY HASH CODE IO)) {
	    push(@{$namerefs{$var}}, *{$fqvar}{$type})
			  if defined *{$fqvar}{$type};
	}
    }
    return \%namerefs;
}

# Remove the specified symbols from the namespace.
# Default is to remove all.
sub remove {
    my $package = shift;
    my(%namerefs, $var);
    no strict 'refs';
    @_ = keys %{$package."::"} if ! @_;
    foreach $var (@_) {
	delete ${$package."::"}{$var};
    }
}

# Restore values to symbols specified in a hash as returned
# by NameSpace::save.
sub restore {
    my($package, $namerefs) = @_;
    my($var, $ref);
    no strict 'refs';
    foreach $var (keys %$namerefs) {
	my $fqvar = $package."::".$var;
	foreach $ref (@{$namerefs->{$var}}) {
	    *{$fqvar} = $ref;
	}
    }
}

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

use vars qw( $ARG $caller_dir_path %special_var );

BEGIN {
    # We can't Export or Import the following variables because Perl always
    # treats them as part of the "main::" package (see perlvar(1)).
    %special_var = map {$_ => 1} qw(ENV INC ARGV ARGVOUT SIG
				    STDIN STDOUT STDERR);
}

# 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);

    # Save the original variable names from the script package.
    # These will stay intact, but any other "script::" variables
    # defined in a Conscript file will get saved, deleted,
    # and (when necessary) restored.
    my(%orig_script_var) = map {$_ => 1} keys %script::;
    $caller_dir_path = undef;
    my $cwd = Cwd::cwd();
    my(@scripts) = pop(@priv::scripts);
    while ($priv::self = shift(@scripts)) {
	my($path) = $priv::self->{script}->rsrcpath;
	if (-f $path) {
	    $dir::cwd = $priv::self->{script}->{dir};
	    # Handle chdir to the Conscript file directory, if necessary.
	    my ($vol, $dir, $file);
	    if ($param::conscript_chdir) {
		($vol, $dir, $file) =
		  File::Spec->splitpath(File::Spec->canonpath($path));
		if ($vol ne '' || $dir ne '') {
		    $caller_dir_path = File::Spec->catpath($vol, $dir, undef);
		    chdir($caller_dir_path) ||
			die "Could not chdir to $caller_dir_path: $!\n";
		}
	    } else {
		$file = $path;
	    }
	    # Actually process the Conscript file.
	    do $file;
	    # Save any variables defined by the Conscript file
	    # so we can restore them later, if needed;
	    # then delete them from the script:: namespace.
	    my(@del) = grep(! $orig_script_var{$_}, keys %script::);
	    if (@del) {
		$priv::self->{script}->{pkgvars} = NameSpace::save('script',
								   @del);
		NameSpace::remove('script', @del);
	    }
	    if ($caller_dir_path) {
		chdir($cwd);
		$caller_dir_path = undef;
	    }
	    if ($@) {
		chomp($@);
		my $err = ($@ =~ /\n/ms) ? ":\n$@" : " ($@)";
		print qq($0: error in file "$path"$err\n);
		$run::errors++;
	    } else {
		# Only process subsidiary scripts if no errors in parent.
		unshift(@scripts, @priv::scripts);
	    }
	    undef @priv::scripts;
	} else {
	    my $where = '';
	    my $cref = $priv::self->{script}->creator;
	    if (defined $cref) {
		my($_foo, $script, $line, $sub) = @$cref;
		$where = " ($sub in $script, line $line)";
	    }
	    warn qq(Ignoring missing script "$path"$where);
	}
    }
    die("$0: script errors encountered: construction aborted\n")
	if $run::errors;
}

# Return caller info about the method being invoked.
# This is everything from the Perl "caller" builtin function,
# including which Construct/Conscript file, line number,
# subroutine name, etc.
sub caller_info {
    my($lev) = 1;
    my(@frame);
    do {
	@frame = caller ++$lev;
	if (defined($frame[3]) && $frame[3] eq '(eval)') {
	    @frame = caller --$lev;
	    if ($caller_dir_path) {
		$frame[1] = File::Spec->catfile($caller_dir_path, $frame[1]);
	    }
	    return @frame;
	}
    } while ($frame[3]);
    return;
}

# Link a directory to another. This simply means set up the *source*
# for the directory to be the other directory.
sub Link {
    dir::link(@_);
}

# Add directories to the repository search path for files.
# Strip our current directory from the list so Repository
# (or -R options) can be used from within the repository.
sub Repository {
    my($my_dir) = Cwd::cwd();
    my $dir;
    foreach $dir (@_) {
	# The following more direct call isn't available in
	# Cwd.pm until some time after 5.003...
	#	my($d) = Cwd::abs_path($dir);
	chdir($dir);
	my($d) = Cwd::cwd();
	chdir($my_dir);
	#
	next if ! $d || ! -d $d || $d eq $my_dir;
	# We know we can get away with passing undef to lookupdir
	# as the directory because $dir is an absolute path.
	push(@param::rpath, dir::lookupdir(undef, $dir));
	push @INC, $d;
    }
}

# Return the list of Repository directories specified.
sub Repository_List {
    map($_->path, @param::rpath);
}

# Specify whether the .consign signature times in repository files are,
# in fact, consistent with the times on the files themselves.
sub Repository_Sig_Times_OK {
    $param::rep_sig_times_ok = shift;
}

sub SourceSignature {
    $param::sourcesig = [@_];
}

# Specify whether we should chdir to the containing directories
# of Conscript files.
sub Conscript_chdir {
    $param::conscript_chdir = shift;
}

# Specify files/targets that must be present and built locally,
# even if they exist already-built in a Repository.
sub Local {
    my(@files) = map($dir::cwd->lookupfile($_), @_);
    map($_->local(1), @files);
}

# Export variables to any scripts invoked from this one.
sub Export {
    my(@illegal) = grep($special_var{$_}, @_);
    if (@illegal) {
	die qq($0: cannot Export special Perl variables: @illegal\n);
    }
    @{$priv::self->{exports}} = grep(! defined $special_var{$_}, @_);
}

# Import variables from the export list of the caller
# of the current script.
sub Import {
    my(@illegal) = grep($special_var{$_}, @_);
    if (@illegal) {
	die qq($0: cannot Import special Perl variables: @illegal\n);
    }
    my($parent) = $priv::self->{parent};
    my($imports) = $priv::self->{imports};
    @{$priv::self->{exports}} = keys %$imports;
    my($var);
    foreach $var (grep(! defined $special_var{$_}, @_)) {
	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;
	    my $err = "$0: variable \"$var\" exported but not " .
		      "defined by file \"$path\"\n";
	    die $err;
	}