cons

quakeIII源码这个不用我多说吧

    # 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};
}

package action;

sub new {
    my($env, $act) = @_;
    if (ref($act) eq 'CODE') {
	return action::perl->new($act);
    } else {
	return action::command->new($env, $act);
    }
}

package action::command;

use vars qw( @ISA %cmd %_varopts $_varletters );

BEGIN {
    @ISA = $main::_WIN32 ? 'action::command::win32' : 'action::command::unix';

    # Internal hash for processing variable options.
    # f: return file part
    # d: return directory part
    # F: return file part, but strip any suffix
    # b: return full path, but strip any suffix (a.k.a. return basename)
    # s: return only the suffix (or an empty string, if no suffix is there)
    # a: return the absolute path to the file
    # S: return the absolute path to a Linked source file
    %_varopts = (
	'f' => sub { return $_[0]->{entry}; },
	'd' => sub { return $_[0]->{dir}->path; },
	'F' => sub { my $subst = $_[0]->{entry};
		     $subst =~ s/\.[^\.]+$//;
		     return $subst; },
	'b' => sub { my $subst =  $_[0]->path;
		     $subst =~ s/\.[^\.]+$//;
		     return $subst; },
	's' => sub { my $subst = $_[0]->{entry};
		     $subst =~ m/(\.[^\.]+)$/;
		     return $1; },
	'a' => sub { my $path = $_[0]->path;
		     if (! File::Spec->file_name_is_absolute($path)) {
			$path = File::Spec->catfile(Cwd::cwd(), $path);
		     }
		     return $path; },
	'S' => sub { my $path = $_[0]->srcpath;
		     if (! File::Spec->file_name_is_absolute($path)) {
			my $cwd = File::Spec->canonpath(Cwd::cwd());
			$path = File::Spec->catfile($cwd, $path);
		     }
		     return $path; },
    );

    $_varletters = join('', keys %_varopts);
}

# Internal routine for processing variable options.
# Options are specified in hash in the BEGIN block above.
# no option: return path to file (relative to top,
# or absolute if it's outside)
sub _variant {
    my($opt, $file) = @_;
    $opt = '' if ! defined $opt;
    if (defined $_varopts{$opt}) {
	return &{$_varopts{$opt}}($file);
    }
    return $file->path;
}

sub new {
    my($class, $env, $cmd) = @_;
    $cmd = $env->_subst($cmd);
    $cmd{$env,$cmd} || do {
	# Remove unwanted bits from signature -- those bracketed by %( ... %)
	my $sigs = $cmd;
	my $sig = '';
	if (ref($sigs) eq 'ARRAY') {
	    # This is an array of commands..
	    my $f;
	    foreach $f (@$sigs) {
		$sig .= _strip($f);
	    }
	} else {
	    $sig = _strip($sigs);
	}
	my $self = { cmd => $cmd, cmdsig => 'sig'->cmdsig($sig) };
	$cmd{$env,$cmd} = bless $self, $class;
    }
}

sub _strip {
    my $sig = shift;
    $sig =~ s/^\@\s*//mg;
    while ($sig =~ s/%\(([^%]|%[^\(])*?%\)//g) { }
    $sig;
}

sub scriptsig {
    $_[0]->{cmdsig};
}

# Return an array of all the commands (first word on each line).
sub commands {
    my($self) = @_;
    my(@cmds) = ();
    my $com;
    my $cmd = $self->{'cmd'};
    my @allcoms;

    push @allcoms, ref $cmd ? @{$cmd} : split(/\n/, $cmd);

    for $com (@allcoms) {
	$com =~ s/^\s*//;
	$com =~ s/\s.*//;
	next if ! $com; # blank line
	push @cmds, $com;
    }
    @cmds;
}

# 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.

# Call this to get the command line script: an array of
# fully substituted commands.
sub getcoms {
    my($self, $env, $tgt) = @_;
    my(@coms);
    my $com;
    my @allcoms = ();
    my $cmd = $self->{'cmd'};

    push @allcoms, ref $cmd ? @{$cmd} : split(/\n/, $cmd);

    for $com (@allcoms) {
	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...

	# Remove %( and %) -- those are only used to bracket parts
	# of the command that we don't depend on.
	$com =~ s/%[()]//g;

	# Deal with %n, n=1,9 and variants.
	while ($com =~ /%([1-9])(:([$_varletters]?))?/o) {
	    my($match) = $&;
	    my($src) = $src1[$1];
	    my($subst) = _variant($3, $src1[$1]->rfile);
	    undef $src[$1];
	    $com =~ s/$match/$subst/;
	}

	# Deal with %0 aka %> and variants.
	while ($com =~ /%[0>](:([$_varletters]?))?/o) {
	    my($match) = $&;
	    my($subst) = _variant($2, $tgt);
	    $com =~ s/$match/$subst/;
	}

	# Deal with %< (all sources except %n's already used)
	while ($com =~ /%<(:([$_varletters]?))?/o) {
	    my($match) = $&;
	    my @list = ();
	    foreach (@src) {
		push(@list, _variant($2, $_->rfile)) if $_;
	    }
	    my($subst) = join(' ', @list);
	    $com =~ s/$match/$subst/;
	}

	# Deal with %[ %].
	$com =~ s{%\[(.*?)%\]}{
	    my($func, @args) = grep { $_ ne '' } split(/\s+/, $1);
	    die("$0: \"$func\" is not defined.\n")
		unless ($env->{$func});
	    &{$env->{$func}}(@args);
	}gex;

	# Convert left-over %% into %.
	$com =~ s/%%/%/g;

	# White space cleanup. XXX NO WAY FOR USER TO HAVE QUOTED SPACES
	$com = join(' ', split(' ', $com));
	next if $com =~ /^:/ && $com !~ /^:\S/;
	push(@coms, $com);
    }
    @coms
}

# Build the target using the previously specified commands.
sub execute {
    my($self, $env, $tgt, $package) = @_;

    if ($param::build) {
	futil::mkdir($tgt->{dir});
	unlink($tgt->path) if ! $tgt->precious;
    }

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

    # Handle multi-line commands.
    my $com;
    for $com ($self->getcoms($env, $tgt)) {
	if ($com !~ s/^\@\s*//) {
	    main::showcom($com);
	}
	next if ! $param::build;

	if ($com =~ /^\[perl\]\s*/) {
	    my $perlcmd = $';
	    my $status;
	    {
		# Restore the script package variables that were defined
		# in the Conscript file that defined this [perl] build,
		# so the code executes with the expected variables.
		# Then actually execute (eval) the [perl] command to build
		# the target, followed by cleaning up the name space
		# by deleting the package variables we just restored.
		my($pkgvars) = $tgt->{conscript}->{pkgvars};
		NameSpace::restore($package, $pkgvars) if $pkgvars;
		$status = eval "package $package; $perlcmd";
		NameSpace::remove($package, keys %$pkgvars) if $pkgvars;
	    }
	    if (!defined($status)) {
		warn "$0: *** Error during perl command eval: $@.\n";
		return undef;
	    } elsif ($status == 0) {
		warn "$0: *** Perl command returned $status "
		   . "(this indicates an error).\n";
		return undef;
	    }
	    next;
	}
	if (! $self->do_command($com, $tgt->path)) {
		return undef;
	}
    }

    # success.
    return 1;
}

sub show {
    my($self, $env, $tgt) = @_;
    my $com;
    for $com ($self->getcoms($env, $tgt)) {
	if ($com !~ /^\@\s*/) {
	    main::showcom($com);
	}
    }
}

package action::command::unix;

sub do_command {
    my($class, $com, $path) = @_;
    my($pid) = fork();
    die("$0: unable to fork child process ($!)\n") if !defined $pid;
    if (!$pid) {
	# This is the child.  We eval the command to suppress -w
	# warnings about not reaching the statements afterwards.
	eval 'exec($com)';
	$com =~ s/\s.*//;
	die qq($0: failed to execute "$com" ($!). )
	  . qq(Is this an executable on path "$ENV{PATH}"?\n);
    }
    for (;;) {
	do {} until wait() == $pid;
	my ($b0, $b1) = ($? & 0xFF, $? >> 8);
	# Don't actually see 0177 on stopped process; is this necessary?
	next if $b0 == 0177; # process stopped; we can wait.
	if ($b0) {
	    my($core, $sig) = ($b0 & 0200, $b0 & 0177);
	    my($coremsg) = $core ? "; core dumped" : "";
	    $com =~ s/\s.*//;
	    my $err = "$0: *** \[$path\] $com terminated by signal " .
		  "$sig$coremsg\n";
	    warn $err;
	    return undef;
	}
	if ($b1) {
	    warn qq($0: *** [$path] Error $b1\n); # trying to be like make.
	    return undef;
	}
	last;
    }
    return 1;
}

package action::command::win32;

sub do_command {
    my($class, $com, $path) = @_;
    system($com);
    if ($?) {
	my ($b0, $b1) = ($? & 0xFF, $? >> 8);
	my $err = $b1 || $?;
	my $warn = qq($0: *** [$path] Error $err);
	$warn .= " (executable not found in path?)" if $b1 == 0xFF;
	warn "$warn\n";
	return undef;
    }
    return 1;
}

package action::perl;

# THIS IS AN EXPERIMENTAL PACKAGE.  It's entirely possible that the
# interface may change as this gets completed, so use at your own risk.
#
# There are (at least) two issues that need to be solved before blessing
# this as a real, fully-supported feature:
#
#   --	We need to calculate a signature value for a Perl code ref, in
#	order to rebuild the target if there's a change to the Perl code
#	used to generate it.
#
#	This is not straightforward.  A B::Deparse package exists that
#	decompiles a coderef into text.  It's reportedly not completely
#	reliable for closures; it misses which variables are global, and
#	the values of private lexicals.  Nevertheless, it'd probably
#	be perfect for our purposes, except that it wasn't added until
#	some time between Perl 5.00502 and 5.00554, and doesn't seem to
#	really work until Perl 5.6.0, so by relying on it, we'd lose
#	support for Perl versions back to 5.003*.
#
#   --	Ideally, a code ref should be able to use something like
#	$env->_subst to fetch values from the construction environment
#	to modify its behavior without having to cut-and-paste code.
#	(Actually, since we pass the environment to the executed code
#	ref, there's no reason you can't do this with the code as it
#	stands today.)  But this REALLY complicates the signature
#	calculation, because now the actual signature would depend not
#	just on the code contents, but on the construction variables (or
#	maybe just the environment).
#
# A potentially valid workaround would be to use the contents of the
# Conscript file in which the code reference is defined as the code
# ref's signature.  This has the drawback of causing a recompilation of
# the target file even in response to unrelated changes in the Conscript
# file, but it would ensure correct builds without having to solve the
# messy issues of generating a signature directly from a code ref.
#
# Nevertheless, this seemed a useful enough skeleton of a feature that
# it made sense to release it in hopes that some practical experience
# will encourage someone to figure out how to solve the signature
# issues.  Or maybe we'll discover these aren't big issues in practice
# and end up blessing it as is.

use vars qw( %code );

sub new {
    my($class, $cref) = @_;
    $code{$cref} || do {
	my $sig = '';
	# Generating a code signature using B::Deparse doesn't really
	# work for us until Perl 5.6.0.  Here's the code in case
	# someone wants to use it.
	#use B::Deparse;
	#my $deparse = B::Deparse->new();
	#my $body = $deparse->coderef2text($cref);
	#$sig = $body;	# should be an MD5 sig
	my($self) = { cref => $cref, crefsig => $sig };
	$code{$cref} = bless $self, $class;
    }
}

sub scriptsig {
    $_[0]->{crefsig}
}

sub execute {
    my($self, $env, $tgt) = @_;
    if ($param::build) {
	futil::mkdir($tgt->{dir});
	unlink($tgt->path) if ! $tgt->precious;
	my($cref) = $self->{cref};
	&$cref($env, $tgt->path, map($_->rpath, @{$tgt->{sources}}));
    }
}

sub commands {
    return ();
}


# 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->rfile);
	} else {
	    if ((build $file) eq 'errors') {
		$tgt->{status} = 'errors'; # tgt inherits build status
		return ();
	    }
	    $files{$file} = 'sig'->signature(