pcons-2.3.1

quakeIII源码这个不用我多说吧

    warn("\n$0: killed\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);
};
$SIG{HUP} = $SIG{INT} if !$main::_WIN32;

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

if ($param::depfile)
{
    open(main::DEPFILE, ">" . $param::depfile)
      || die ("$0: couldn't open $param::depfile ($!)\n");
}

# If the supplied top-level Conscript file is not in the
# current directory, then change to that directory.
{
    my ($vol, $dir, $file) =
      File::Spec->splitpath(File::Spec->canonpath($param::topfile));
    if ($vol || $dir)
    {
        my ($cd) = File::Spec->catpath($vol, $dir, undef);
        chdir($cd) || die ("$0: couldn't change to directory $cd ($!)\n");
        $param::topfile = $file;
    }
}

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