/cons-2.2.0/cons.bat
Batch | 5750 lines | 4743 code | 1007 blank | 0 comment | 758 complexity | 666fd88a4b3d17cad6729645bdbd038d MD5 | raw file
Possible License(s): GPL-2.0
Large files files are truncated, but you can click here to view the full file
- @rem = '--*-PERL-*--';
- @rem = '';
- @rem = 'Copyright (C) 1996-2000 Free Software Foundation, Inc.';
- @rem = '';
- @rem = 'This program is free software; you can redistribute it and/or modify';
- @rem = 'it under the terms of the GNU General Public License as published by';
- @rem = 'the Free Software Foundation; either version 2 of the License, or';
- @rem = '(at your option) any later version.';
- @rem = '';
- @rem = 'This program is distributed in the hope that it will be useful,';
- @rem = 'but WITHOUT ANY WARRANTY; without even the implied warranty of';
- @rem = 'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the';
- @rem = 'GNU General Public License for more details.';
- @rem = '';
- @rem = 'You should have received a copy of the GNU General Public License';
- @rem = 'along with this program; see the file COPYING. If not, write to';
- @rem = 'the Free Software Foundation, Inc., 59 Temple Place - Suite 330,';
- @rem = 'Boston, MA 02111-1307, USA.';
- @rem = '
- @echo off
- rem setlocal
- set ARGS=
- :loop
- if .%1==. goto endloop
- set ARGS=%ARGS% %1
- shift
- goto loop
- :endloop
- rem ***** This assumes PERL is in the PATH *****
- rem $Id: cons.bat.proto,v 1.4 2000/06/14 22:33:01 rv Exp $
- perl.exe -S cons.bat %ARGS%
- goto endofperl
- @rem ';
- #!/usr/bin/env perl
- # NOTE: Cons intentionally does not use the "perl -w" option or
- # "use strict." Because Cons "configuration files" are actually
- # Perl scripts, enabling those restrictions here would force them
- # on every user's config files, wanted or not. Would users write
- # "better" Construct and Conscript files if we forced "use strict"
- # on them? Probably. But we want people to use Cons to get work
- # done, not force everyone to become a Perl guru to use it, so we
- # don't insist.
- #
- # That said, Cons' code is both "perl -w" and "use strict" clean.
- # Regression tests keep the code honest by checking for warnings
- # and "use strict" failures.
- # $Id: cons.pl,v 1.129 2000/11/16 12:22:37 knight Exp $
- use vars qw( $ver_num $ver_rev $version );
- $ver_num = "2.2";
- $ver_rev = ".0";
- $version = sprintf "This is Cons %s%s " .
- '($Id: cons.pl,v 1.129 2000/11/16 12:22:37 knight Exp $)'. "\n",
- $ver_num, $ver_rev;
- # Cons: A Software Construction Tool.
- # Copyright (c) 1996-2000 Free Software Foundation, Inc.
- #
- # This program is free software; you can redistribute it and/or modify
- # it under the terms of the GNU General Public License as published by
- # the Free Software Foundation; either version 2 of the License, or
- # (at your option) any later version.
- #
- # This program is distributed in the hope that it will be useful,
- # but WITHOUT ANY WARRANTY; without even the implied warranty of
- # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- # GNU General Public License for more details.
- #
- # You should have received a copy of the GNU General Public License
- # along with this program; see the file COPYING. If not, write to
- # the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
- # Boston, MA 02111-1307, USA.
- require 5.002;
- # See the NOTE above about why Cons doesn't "use strict".
- use integer;
- use Cwd;
- use File::Copy;
- use vars qw( $_WIN32 $_a $_exe $_o $_so );
- #------------------------------------------------------------------
- # Determine if running on win32 platform - either Windows NT or 95
- #------------------------------------------------------------------
- use vars qw( $PATH_SEPARATOR $iswin32 $_WIN32 $usage $indent @targets );
- BEGIN {
- use Config;
- # if the version is 5.003, we can check $^O
- if ($] < 5.003) {
- eval("require Win32");
- $_WIN32 = (!$@);
- } else {
- $_WIN32 = ($^O eq "MSWin32") ? 1 : 0;
- }
- # Fetch the PATH separator from Config;
- # provide our old defaults in case it's not set.
- $PATH_SEPARATOR = $Config{path_sep};
- $PATH_SEPARATOR = $_WIN32 ? ';' : ':' if ! defined $PATH_SEPARATOR;
- # Fetch file suffixes from Config,
- # accomodating differences in the Config variables
- # used by different Perl versions.
- $_exe = $Config{_exe};
- $_exe = $Config{exe_ext} if ! defined $_exe;
- $_exe = $_WIN32 ? '.exe' : '' if ! defined $_exe;
- $_o = $Config{_o};
- $_o = $Config{obj_ext} if ! defined $_o;
- $_o = $_WIN32 ? '.obj' : '.o' if ! defined $_o;
- $_a = $Config{_a};
- $_a = $Config{lib_ext} if ! defined $_a;
- $_a = $_WIN32 ? '.lib' : '.a' if ! defined $_a;
- $_so = ".$Config{so}";
- $_so = $_WIN32 ? '.dll' : '.so' if ! defined $_so;
- }
- # Flush stdout each time.
- $| = 1;
- # Seed random number generator.
- srand(time . $$); # this works better than time ^ $$ in perlfunc manpage.
- $usage = q(
- Usage: cons <arguments> -- <construct-args>
- Arguments can be any of the following, in any order:
- <targets> Build the specified targets. 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.
- -cc Show command that would have been executed, when
- retrieving from cache. No indication that the file
- has been retrieved is given; this is useful for
- generating build logs that can be compared with
- real build logs.
- -cd Disable all caching. Do not retrieve from cache nor
- flush to cache.
- -cr Build dependencies in random order. This is useful when
- building multiple similar trees with caching enabled.
- -cs Synchronize existing build targets that are found to be
- up-to-date with cache. This is useful if caching has
- been disabled with -cc or just recently enabled with
- UseCache.
- -d Enable dependency debugging.
- -f <file> Use the specified file instead of "Construct" (but first
- change to containing directory of <file>).
- -h Show a help message local to the current build if
- one such is defined, and exit.
- -k Keep going as far as possible after errors.
- -o <file> Read override file <file>.
- -p Show construction products in specified trees.
- -pa Show construction products and associated actions.
- -pw Show products and where they are defined.
- -q Be quiet about Installing and Removing targets.
- -r Remove construction products associated with <targets>
- -R <repos> Search for files in <repos>. Multiple -R <repos>
- directories are searched in the order specified.
- -t Traverse up the directory hierarchy looking for a
- Construct file, if none exists in the current directory.
- (Targets will be modified to be relative to the
- Construct file.)
- -v Show cons version and continue processing.
- -V Show cons version and exit.
- -wf <file> Write all filenames considered into <file>.
- -x Show this message and exit.
- Please report any suggestions through the cons-discuss@gnu.org mailing
- list.
- To subscribe, send mail to cons-discuss-request@gnu.org with body
- 'subscribe'.
- If you find a bug, please report it through the bug-cons@gnu.org
- mailing list.
- Information about CONS can be obtained from the official cons web site
- http://www.dsmit.com/cons/ or its mirrors (listed there).
- The cons maintainers can be contacted by email at cons-maintainers@gnu.org
- User documentation of cons is contained in cons and can be obtained
- by doing 'perldoc /path/to/cons'.
- );
- # Simplify program name, if it is a path.
- {
- my ($vol, $dir, $file) = File::Spec->splitpath(File::Spec->canonpath($0));
- $0 = $file;
- }
- # 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::depfile = ''; # Write all deps out to this file
- $param::salt = ''; # Salt derived file signatures with this.
- $param::rep_sig_times_ok = 1; # Repository .consign times are in sync
- # w/files.
- $param::conscript_chdir = 0; # Change dir to Conscript directory
- $param::quiet = 0; # should we show the command being executed.
- #
- $indent = '';
- # Display a command while executing or otherwise. This
- # should be called by command builder action methods.
- sub showcom {
- print($indent . $_[0] . "\n");
- }
- # Default environment.
- # This contains only the completely platform-independent information
- # we can figure out. Platform-specific information (UNIX, Win32)
- # gets added below.
- @param::defaults = (
- 'SUFEXE' => $_exe, # '' on UNIX systems
- 'SUFLIB' => $_a, # '.a' on UNIX systems
- 'SUFLIBS' => "$_so:$_a", # '.so:.a' on UNIX
- 'SUFOBJ' => $_o, # '.o' on UNIX systems
- 'SUFMAP' => {
- '.c' => 'build::command::cc',
- '.s' => 'build::command::cc',
- '.S' => 'build::command::cc',
- '.C' => 'build::command::cxx',
- '.cc' => 'build::command::cxx',
- '.cxx'=> 'build::command::cxx',
- '.cpp'=> 'build::command::cxx',
- '.c++'=> 'build::command::cxx',
- '.C++'=> 'build::command::cxx',
- },
- );
- if ($_WIN32) {
- # Defaults for Win32.
- # Defined for VC++ 6.0 by Greg Spencer <greg_spencer@acm.org>.
- # Your mileage may vary.
- my @win = (
- 'CC' => 'cl',
- 'CFLAGS' => '/nologo',
- 'CCCOM' => '%CC %CFLAGS %_IFLAGS /c %< /Fo%>',
- 'CXX' => '%CC',
- 'CXXFLAGS' => '%CFLAGS',
- 'CXXCOM' => '%CXX %CXXFLAGS %_IFLAGS /c %< /Fo%>',
- 'INCDIRPREFIX' => '/I',
- 'LINK' => 'link',
- 'LINKCOM' => '%LINK %LDFLAGS /out:%> %< %_LDIRS %LIBS',
- 'LINKMODULECOM' => '%LD /r /o %> %<',
- 'LIBDIRPREFIX' => '/LIBPATH:',
- 'AR' => 'lib',
- 'ARFLAGS' => '/nologo ',
- 'ARCOM' => "%AR %ARFLAGS /out:%> %<",
- 'RANLIB' => '',
- 'LD' => 'link',
- 'LDFLAGS' => '/nologo ',
- 'PREFLIB' => '',
- );
- push(@param::defaults, @win);
- } else {
- # Defaults for a typical (?) UNIX platform.
- # Your mileage may vary.
- my @unix = (
- 'CC' => 'cc',
- 'CFLAGS' => '',
- 'CCCOM' => '%CC %CFLAGS %_IFLAGS -c %< -o %>',
- 'CXX' => '%CC',
- 'CXXFLAGS' => '%CFLAGS',
- 'CXXCOM' => '%CXX %CXXFLAGS %_IFLAGS -c %< -o %>',
- 'INCDIRPREFIX' => '-I',
- 'LINK' => '%CXX',
- 'LINKCOM' => '%LINK %LDFLAGS -o %> %< %_LDIRS %LIBS',
- 'LINKMODULECOM' => '%LD -r -o %> %<',
- 'LIBDIRPREFIX' => '-L',
- 'AR' => 'ar',
- 'ARFLAGS' => 'r', # rs?
- 'ARCOM' => "%AR %ARFLAGS %> %<\n%RANLIB %>",
- 'RANLIB' => 'ranlib',
- 'AS' => 'as',
- 'ASFLAGS' => '',
- 'ASCOM' => '%AS %ASFLAGS %< -o %>',
- 'LD' => 'ld',
- 'LDFLAGS' => '',
- 'PREFLIB' => 'lib',
- 'ENV' => { 'PATH' => '/bin:/usr/bin' },
- );
- push(@param::defaults, @unix);
- }
- # Handle command line arguments.
- while (@ARGV) {
- $_ = shift @ARGV;
- last if /^--$/; # Argument passing to Construct.
- &option, next if s/^-//;
- push (@param::include, $_), next if s/^\+//;
- &equate, next if /=/;
- push (@targets, $_), next;
- }
- sub option {
- my %opt = (
- 'cc' => sub { $param::cachecom = 1; },
- 'cd' => sub { $param::cachedisable = 1; },
- 'cr' => sub { $param::random = 1; },
- 'cs' => sub { $param::cachesync = 1; },
- 'd' => sub { $param::depends = 1; },
- 'h' => sub { $param::localhelp = 1; },
- 'k' => sub { $param::kflag = 1; },
- 'p' => sub { $param::pflag = 1;
- $param::build = 0; },
- 'pa' => sub { $param::pflag = 1;
- $param::aflag = 1;
- $indent = "... ";
- $param::build = 0; },
- 'pw' => sub { $param::pflag = 1;
- $param::wflag = 1;
- $param::build = 0; },
- 'q' => sub { $param::quiet = 1; },
- 'r' => sub { $param::rflag = 1;
- $param::build = 0; },
- 't' => sub { $param::traverse = 1; },
- 'v' => sub { print($version); },
- 'V' => sub { print($version), exit(0); },
- 'x' => sub { print($usage), exit 0; },
- );
- my %opt_arg = (
- 'f' => sub { $param::topfile = $_[0]; },
- 'o' => sub { $param::overfile = $_[0]; },
- 'R' => sub { script::Repository($_[0]); },
- 'wf' => sub { $param::depfile = $_[0]; },
- );
- if (defined $opt{$_}) {
- &{$opt{$_}}();
- return;
- }
- $_ =~ m/(.)(.*)/;
- if (defined $opt_arg{$1}) {
- if (! $2) {
- $_ = shift @ARGV;
- die("$0: -$1 option requires an argument.\n") if ! $_;
- }
- &{$opt_arg{$1}}($2 || $_);
- return;
- }
- $_ =~ m/(..)(.*)/;
- if (defined $opt_arg{$1}) {
- if (! $2) {
- $_ = shift @ARGV;
- die("$0: -$1 option requires an argument.\n") if ! $_;
- }
- &{$opt_arg{$1}}($2 || $_);
- return;
- }
- if ($_) {
- die qq($0: unrecognized option "-$_". Use -x for a usage message.\n);
- }
- }
- # 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} = $SIG{QUIT} = $SIG{TERM} = sub {
- $SIG{PIPE} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE';
- $SIG{HUP} = $SIG{INT} if ! $main::_WIN32;
- 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);
- } 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" unless ($param::quiet);
- map(buildtoptarget($_), @linked);
- } else {
- print qq($0: nothing to be built in "$path".\n) if $param::build;
- }
- } 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") unless ($param::quiet);
- } 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.
- # We're careful about stripping our current directory from
- # the list, which we do by comparing the `pwd` results from
- # the current directory and the specified directory. This
- # is cumbersome, but assures that the paths will be reported
- # the same regardless of symbolic links.
- sub Repository {
- my($my_dir) = Cwd::cwd();
- my $dir;
- foreach $dir (@_) {
- my($d) = `$^X -e "use Cwd; chdir('$dir') && print cwd"`;
- 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;
- }
- # 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;
- }
- }
- # 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 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, $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"
- if (!ref($src));
- @sources = @$src;
- @targets = @$tgt;
- } elsif (ref $src) {
- die "InstallAs: Target is a file and source is a list!\n";
- } else {
- push @sources, $src;
- push @targets, $tgt;
- }
- if ($#sources != $#targets) {
- my $tn = $#targets+1;
- my $sn = $#sources+1;
- die "InstallAs: Source file list ($sn) and target file list ($tn) " .
- "are inconsistent in length!\n";
- } else {
- foreach (0..$#sources) {
- my $tfile = $dir::cwd->lookupfile($env->_subst($targets[$_]));
- my $sfile = $dir::cwd->lookupfile($env->_subst($sources[$_]));
- $tfile->bind(find build::install, $sfile);
- }
- }
- }
- # Installation in a local build directory,
- # copying from the repository if it's already built there.
- # Functionally equivalent to:
- # Install $env $dir, $file;
- # Local "$dir/$file";
- sub Install_Local {
- 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, $file);
- $tgt->local(1);
- }
- }
- sub Objects {
- my($env) = shift;
- map($dir::cwd->relpath($_),
- _Objects($env, map($dir::cwd->lookupfile($env->_subst($_)), @_)))
- }
- # 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}->lookupfile($_->base_suf($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;
- my($builder) = $env->{SUFMAP}{$suffix};
- if ($builder) {
- $obj->bind((find $builder($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->lookupfile(file::addsuffix($env->_subst(shift),
- $env->{SUFEXE}));
- my($progenv) = $env->_resolve($tgt);
- $tgt->bind(find build::command::link($progenv, $progenv->{LINKCOM}),
- $env->_Objects(map($dir::cwd->lookupfile($env->_subst($_)), @_)));
- }
- sub Module {
- my($env) = shift;
- my($tgt) = $dir::cwd->lookupfile($env->_subst(shift));
- my($modenv) = $env->_resolve($tgt);
- my($com) = pop(@_);
- $tgt->bind(find build::command::link($modenv, $com),
- $env->_Objects(map($dir::cwd->lookupfile($env->_subst($_)), @_)));
- }
- sub LinkedModule {
- my($env) = shift;
- my($tgt) = $dir::cwd->lookupfile($env->_subst(shift));
- my($progenv) = $env->_resolve($tgt);
- $tgt->bind(find build::command::linkedmodule
- ($progenv, $progenv->{LINKMODULECOM}),
- $env->_Objects(map($dir::cwd->lookupfile($env->_subst($_)), @_)));
- }
- sub Library {
- my($env) = shift;
- my($lib) = $dir::cwd->lookupfile(file::addsuffix($env->_subst(shift),
- $env->{SUFLIB}));
- my($libenv) = $env->_resolve($lib);
- $lib->bind(find build::command::library($libenv),
- $env->_Objects(map($dir::cwd->lookupfile($env->_subst($_)), @_)));
- }
- # 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) = $env->_subst(shift);
- my($com) = pop(@_);
- my(@sources) = map($dir::cwd->lookupfile($env->_subst($_)), @_);
- if (ref($tgt)) {
- # A multi-target command.
- my(@tgts) = map($dir::cwd->lookupfile($_), @$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, 'script');
- my($multi) = build::multiple->new($builder, \@tgts);
- for $tgt (@tgts) {
- $tgt->bind($multi, @sources);
- }
- } else {
- $tgt = $dir::cwd->lookupfile($tgt);
- $env = $env->_resolve($tgt);
- my $builder = find build::command::user($env, $com, 'script');
- $tgt->bind($builder, @sources);
- }
- }
- sub Depends {
- my($env) = shift;
- my($tgt) = $env->_subst(shift);
- my(@deps) = map($dir::cwd->lookup($env->_subst($_)), @_);
- if (! ref($tgt)) {
- $tgt = [ $tgt ];
- }
- my($t);
- foreach $t (map($dir::cwd->lookupfile($_), @$tgt)) {
- push(@{$t->{dep}}, @deps);
- }
- }
- # Setup a quick scanner for the specified input file, for the
- # associated environment. Any use of the input file will cause the
- # scanner to be invoked, once only. The scanner sees just one line at
- # a time of the file, and is expected to return a list of
- # dependencies.
- sub QuickScan {
- my($env, $code, $file, $path) = @_;
- $dir::cwd->lookup($env->_subst($file))->{'srcscan',$env} =
- find scan::quickscan($code, $env, $env->_subst($path));
- }
- # 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.
- 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 }
- # Builder module for the Install command.
- package build::install;
- use vars qw( @ISA $installer );
- BEGIN {
- @ISA = qw(build);
- bless $installer = {} # handle for this class.
- }
- sub find {
- $installer
- }
- # Caching not supported for Install: generally install is trivial anyway,
- # and we don't want to clutter the cache.
- sub cachin { undef }
- sub cachout { }
- # Do the installation.
- sub action {
- my($self, $tgt) = @_;
- my($src) = $tgt->{sources}[0];
- main::showcom("Install ${\$src->rpath} as ${\$tgt->path}")
- if ($param::install && !$param::quiet);
- return unless $param::build;
- futil::install($src->rpath, $tgt);
- return 1;
- }
- # Builder module for generic UNIX commands.
- package build::command;
- use vars qw( @ISA %com );
- BEGIN { @ISA = qw(build) }
- sub find {
- my ($class, $env, $com, $package) = @_;
- $com = $env->_subst($com);
- $package ||= '';
- $com{$env,$com,$package} || do {
- # Remove unwanted bits from signature -- those bracketed by %( ... %)
- my $comsig = $com;
- $comsig =~ s/^\@\s*//mg;
- while ($comsig =~ s/%\(([^%]|%[^\(])*?%\)//g) { }
- my $self = { env => $env, com => $com, 'package' => $package,
- comsig => $comsig };
- $com{$env,$com,$package} = bless $self, $class;
- }
- }
- # Default cache in function.
- sub cachin {
- my($self, $tgt, $sig) = @_;
- if (cache::in($tgt, $sig)) {
- if ($param::cachecom) {
- map { if (! s/^\@\s*//) { main::showcom($_) } } $self->getcoms($tgt);
- } else {
- printf("Retrieved %s from cache\n", $tgt->path)
- unless ($param::quiet);
- }
- return 1;
- }
- return undef;
- }
- # Default cache out function.
- sub cachout {
- my($self, $tgt, $sig) = @_;
- cache::out($tgt, $sig);
- }
- # internal routine to process variable options.
- # f: return file part
- # F: return file part, but strip any suffix
- # d: return directory part
- # 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
- # no option: return full path to file
- sub _variant {
- my($opt, $file) = @_;
- $opt = '' if ! defined $opt;
- if ($opt eq 'f') { return $file->{entry}; }
- elsif ($opt eq 'd') { return $file->{dir}->path; }
- elsif ($opt eq 'F') {
- my $subst = $file->{entry};
- $subst =~ s/\.[^\.]+$//;
- return $subst;
- }
- elsif ($opt eq 'b') {
- my $subst = $file->path;
- $subst =~ s/\.[^\.]+$//;
- return $subst;
- }
- elsif ($opt eq 's') {
- my $subst = $file->{entry};
- $subst =~ m/(\.[^\.]+)$/;
- return $1;
- }
- elsif ($opt eq 'a') {
- my $path = $file->path;
- if (! File::Spec->file_name_is_absolute($path)) {
- $path = File::Spec->catfile(Cwd::cwd(), $path);
- }
- return $path;
- }
- else { return $file->path; }
- }
- # 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, $tgt) = @_;
- my(@coms);
- my $com;
- 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...
- # 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])(:([fdbsFa]?))?/) {
- 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>](:([fdbsFa]?))?/) {
- my($match) = $&;
- my($subst) = _variant($2, $tgt);
- $com =~ s/$match/$subst/;
- }
- # Deal with %< (all sources except %n's already used)
- while ($com =~ /%<(:([fdbsFa]?))?/) {
- 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 ($self->{env}->{$func});
- &{$self->{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 action {
- my($self, $tgt) = @_;
- my($env) = $self->{env};
- 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($tgt)) {
- if ($com !~ s/^\@\s*//) {
- main::showcom($com);
- }
- 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.
- my($package) = $self->{'package'};
- my($pkgvars) = $tgt->{conscript}->{pkgvars};
- NameSpace::restore($package, $pkgvars) if $pkgvars;
- # Actually execute the [perl] command to build the target.
- $status = eval "package $package; $perlcmd";
- # Clean up the namespace by deleting the package variables
- # we just restored.
- 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;
- }
- #---------------------
- # Can't fork on Win32
- #---------------------
- if ($main::_WIN32) {
- system($com);
- if ($?) {
- my ($b0, $b1) = ($? & 0xFF, $? >> 8);
- my $err = $b1 || $?;
- my $path = $tgt->path;
- my $warn = qq($0: *** [$path] Error $err);
- $warn .= " (executable not found in path?)" if $b1 == 0xFF;
- warn "$warn\n";
- return undef;
- }
- } else {
- 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 $path = $tgt->path;
- my $err = "$0: *** \[$path\] $com terminated by signal " .
- "$sig$coremsg\n";
- warn $err;
- return undef;
- }
- if ($b1) {
- my($path) = $tgt->path;
- warn qq($0: *** [$path] Error $b1\n); # trying to be like make.
- return undef;
- }
- last;
- }
- }
- }
- }
- # success.
- return 1;
- }
- # Return script signature.
- sub script {
- $_[0]->{comsig}
- }
- # Create a linked module.
- package build::command::link;
- use vars qw( @ISA );
- 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};
- my($pdirs) = $env->{LIBPATH};
- if (! defined $pdirs) {
- $pdirs = [ ];
- } elsif (ref($pdirs) ne 'ARRAY') {
- $pdirs = [ split(/$main::PATH_SEPARATOR/o, $pdirs) ];
- }
- my $dir;
- for $dir (map($wd->lookupdir($env->_subst($_)), @$pdirs)) {
- my($dpath) = $dir->path;
- $ldirs .= " ".$env->{LIBDIRPREFIX}.$dpath;
- next if File::Spec->file_name_is_absolute($dpath);
- if (@param::rpath) {
- my $d;
- if ($dpath eq $dir::CURDIR) {
- foreach $d (map($_->path, @param::rpath)) {
- $ldirs .= " ".$env->{LIBDIRPREFIX}.$d;
- }
- } else {
- foreach $d (map($_->path, @param::rpath)) {
- $ldirs .= " ".$env->{LIBDIRPREFIX}.File::Spec->catfile($d, $dpath);
- }
- }
- }
- }
- $env->{_LDIRS} = "%($ldirs%)";
- }
- # Introduce a new magic _LIBS symbol which allows to use the
- # Unix-style -lNAME syntax for Win32 only. -lNAME will be replaced
- # with %{PREFLIB}NAME%{SUFLIB}. <schwarze@isa.de> 1998-06-18
- if ($main::_WIN32 && !exists $env->{_LIBS}) {
- my $libs;
- my $name;
- for $name (split(' ', $env->_subst($env->{LIBS} || ''))) {
- if ($name =~ /^-l(.*)/) {
- $name = "$env->{PREFLIB}$1$env->{SUFLIB}";
- }
- $libs .= ' ' . $name;
- }
- $env->{_LIBS} = $libs ? "%($libs%)" : '';
- }
- 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 $ldirs = $env->{LIBPATH};
- if (! defined $ldirs) {
- $ldirs = [ ];
- } elsif (ref($ldirs) ne 'ARRAY') {
- $ldirs = [ split(/$main::PATH_SEPARATOR/o, $ldirs) ];
- }
- my @lpath = map($ewd->lookupdir($_), @$ldirs);
- my(@sigs);
- my(@names);
- if ($main::_WIN32) {
- # Pass %LIBS symbol through %-substituition
- # <schwarze@isa.de> 1998-06-18
- @names = split(' ', $env->_subst($env->{LIBS} || ''));
- } else {
- @names = split(' ', $env->{LIBS} || '');
- }
- my $name;
- for $name (@names…
Large files files are truncated, but you can click here to view the full file