pcons-2.3.1

quakeIII源码这个不用我多说吧

# 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;
        }
        ${"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->lookupfile($_), @_);
    my (%imports) = map { $_ => ${"script::$_"} } @{$priv::self->{exports}};
    my $file;
    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 @_;
}

# Specification of default targets.
sub Default
{
    push (@param::default_targets, map($dir::cwd->lookup($_)->path, @_));
}

# Local Help.  Should only be called once.
sub Help
{
    if ($param::localhelp)
    {
        print "@_\n";
        exit 2;
    }
}

# For windows platforms which use unix tool sets, the msvc defaults may
# not be useful. Also, in the future, other platforms (Mac?) may have the
# same problem.
sub RuleSet
{
    my $style    = shift;
    my @rulesets = sort keys %param::rulesets;
    die "Unknown style for rules: $style.\n"
      . "Supported rules are: ("
      . join (" ", @rulesets) . ")"
      unless eval(join ("||", map("\$style eq '$_'", @rulesets)));
    return @param::base, @{$param::rulesets{$style}};
}

sub DefaultRules
{
    @param::defaults = ();
    push @param::defaults, @_;
}

# Return the build name(s) of a file or file list.
sub FilePath
{
    wantarray 
      ? map($dir::cwd->lookupfile($_)->path, @_)
      : $dir::cwd->lookupfile($_[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;
}

# Split the search path provided into components. Look each up
# relative to the current directory.
# The usual path separator problems abound; for now we'll use :
sub SplitPath
{
    my ($dirs) = @_;
    if (ref($dirs) ne "ARRAY")
    {
        $dirs = [split (/$main::PATH_SEPARATOR/o, $dirs)];
    }
    map { DirPath($_) } @$dirs;
}

# Return true if the supplied path is available as a source file
# or is buildable (by rules seen to-date in the build).
sub ConsPath
{
    my ($path) = @_;
    my ($file) = $dir::cwd->lookup($path);
    return $file->accessible;
}

# Return the source path of the supplied path.
sub SourcePath
{
    wantarray 
      ? map($dir::cwd->lookupfile($_)->rsrcpath, @_)
      : $dir::cwd->lookupfile($_[0])->rsrcpath;
}

# Search up the tree for the specified cache directory, starting with
# the current directory. Returns undef if not found, 1 otherwise.
# If the directory is found, then caching is enabled. The directory
# must be readable and writable. If the argument "mixtargets" is provided,
# then targets may be mixed in the cache (two targets may share the same
# cache file--not recommended).
sub UseCache($@)
{
    my ($dir, @args) = @_;

    # NOTE: it's important to process arguments here regardless of whether
    # the cache is disabled temporarily, since the mixtargets option affects
    # the salt for derived signatures.
    for (@args)
    {
        if ($_ eq "mixtargets")
        {

            # When mixtargets is enabled, we salt the target signatures.
            # This is done purely to avoid a scenario whereby if
            # mixtargets is turned on or off after doing builds, and
            # if cache synchronization with -cs is used, then
            # cache files may be shared in the cache itself (linked
            # under more than one name in the cache). This is not bad,
            # per se, but simply would mean that a cache cleaning algorithm
            # that looked for a link count of 1 would never find those
            # particular files; they would always appear to be in use.
            $param::salt       = 'M' . $param::salt;
            $param::mixtargets = 1;
        }
        else
        {
            die qq($0: UseCache unrecognized option "$_"\n);
        }
    }
    if ($param::cachedisable)
    {
        warn("Note: caching disabled by -cd flag\n");
        return 1;
    }
    my ($depth) = 15;
    while ($depth-- && !-d $dir)
    {
        $dir = File::Spec->catdir($dir::UPDIR, $dir);
    }
    if (-d $dir)
    {
        $param::cache = $dir;
        return 1;
    }
    return undef;
}

# Salt the signature generator. The salt (a number of string) is added
# into the signature of each derived file. Changing the salt will
# force recompilation of all derived files.
sub Salt($)
{

    # We append the value, so that UseCache and Salt may be used
    # in either order without changing the signature calculation.
    $param::salt .= $_[0];
}

# Mark files (or directories) to not be removed before building.
sub Precious
{
    map($_->{precious} = 1, map($dir::cwd->lookup($_), @_));
}

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

use vars qw( %envcache );

# 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;
    my $re;
    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) = @_;
    if (!defined $str)
    {
        return undef;
    }
    elsif (ref($str) eq "ARRAY")
    {
        return [map($env->_subst($_), @$str)];
    }
    else
    {

        # % expansion.  %% gets converted to % later, so expand any
        # %keyword construction that doesn't have a % in front of it,
        # modulo multiple %% pairs in between.
        # In Perl 5.005 and later, we could actually do this in one regex
        # using a conditional expression as follows,
        #	while ($str =~ s/($pre)\%(\{)?([_a-zA-Z]\w*)(?(2)\})/"$1".
        #                      $env->{$3}/ge) {}
        # The following two-step approach is backwards-compatible
        # to (at least) Perl5.003.
        my $pre = '^|[^\%](?:\%\%)*';
        while (($str =~ s/($pre)\%([_a-zA-Z]\w*)/$1.($env->{$2}||'')/ge)
               || ($str =~ s/($pre)\%\{([_a-zA-Z]\w*)\}/$1.($env->{$2}||'')/ge))
        {
        }
        return $str;
    }
}

sub AfterBuild
{
    my ($env)           = shift;
    my ($perl_eval_str) = pop (@_);
    my $file;
    for $file (map($dir::cwd->lookup($_), @_))
    {
        $file->{after_build_func} = $perl_eval_str;

    }
}

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

sub InstallAs
{
    my $env     = shift;
    my $tgt     = shift;
    my $src     = shift;
    my @sources = ();
    my @targets = ();

    if (ref $tgt)
    {
        die "InstallAs: Source is a file and target is a list!\n"