PageRenderTime 839ms CodeModel.GetById 81ms app.highlight 618ms RepoModel.GetById 46ms app.codeStats 1ms

/quake3/trunk/code/unix/cons

#
Perl | 2233 lines | 1627 code | 230 blank | 376 comment | 248 complexity | df595a1e2f7398f2271e10cde70603d4 MD5 | raw file

Large files files are truncated, but you can click here to view the full file

   1#!/usr/bin/env perl
   2
   3# NOTE:  Cons intentionally does not use the "perl -w" option or
   4# "use strict."  Because Cons "configuration files" are actually
   5# Perl scripts, enabling those restrictions here would force them
   6# on every user's config files, wanted or not.  Would users write
   7# "better" Construct and Conscript files if we forced "use strict"
   8# on them?  Probably.  But we want people to use Cons to get work
   9# done, not force everyone to become a Perl guru to use it, so we
  10# don't insist.
  11#
  12# That said, Cons' code is both "perl -w" and "use strict" clean.
  13# Regression tests keep the code honest by checking for warnings
  14# and "use strict" failures.
  15
  16use vars qw( $CVS_id $CVS_ver $ver_num $ver_rev $version );
  17
  18$CVS_id = 'Id';
  19$CVS_ver = (split(/\s+/, $CVS_id))[2];
  20
  21$ver_num = "2.3";
  22$ver_rev = ".1";
  23
  24$version = "This is Cons $ver_num$ver_rev ($CVS_id)\n";
  25
  26# Cons: A Software Construction Tool.
  27# Copyright (c) 1996-2001 Free Software Foundation, Inc.
  28#
  29# This program is free software; you can redistribute it and/or modify
  30# it under the terms of the GNU General Public License as published by
  31# the Free Software Foundation; either version 2 of the License, or
  32# (at your option) any later version.
  33#
  34# This program is distributed in the hope that it will be useful,
  35# but WITHOUT ANY WARRANTY; without even the implied warranty of
  36# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37# GNU General Public License for more details.
  38#
  39# You should have received a copy of the GNU General Public License
  40# along with this program; see the file COPYING.  If not, write to
  41# the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  42# Boston, MA 02111-1307, USA.
  43
  44require 5.003;
  45# See the NOTE above about why Cons doesn't "use strict".
  46use integer;
  47use Cwd;
  48use File::Copy;
  49
  50use vars qw( $_WIN32 $_a $_exe $_o $_so );
  51
  52#------------------------------------------------------------------
  53# Determine if running on win32 platform - either Windows NT or 95
  54#------------------------------------------------------------------
  55
  56use vars qw( $PATH_SEPARATOR $iswin32 $_WIN32 $usage $indent @targets );
  57
  58BEGIN {
  59    use Config;
  60
  61    # if the version is 5.003, we can check $^O
  62    if ($] <  5.003) {
  63	eval("require Win32");
  64	$_WIN32 = (!$@);
  65    } else {
  66	$_WIN32 = ($^O eq "MSWin32") ? 1 : 0;
  67    }
  68
  69    # Fetch the PATH separator from Config;
  70    # provide our old defaults in case it's not set.
  71    $PATH_SEPARATOR = $Config{path_sep};
  72    $PATH_SEPARATOR = $_WIN32 ? ';' : ':' if ! defined $PATH_SEPARATOR;
  73
  74    # Fetch file suffixes from Config,
  75    # accomodating differences in the Config variables
  76    # used by different Perl versions.
  77    $_exe = $Config{_exe};
  78    $_exe = $Config{exe_ext} if ! defined $_exe;
  79    $_exe = $_WIN32 ? '.exe' : '' if ! defined $_exe;
  80    $_o = $Config{_o};
  81    $_o = $Config{obj_ext}  if ! defined $_o;
  82    $_o = $_WIN32 ? '.obj' : '.o' if ! defined $_o;
  83    $_a = $Config{_a};
  84    $_a = $Config{lib_ext} if ! defined $_a;
  85    $_a = $_WIN32 ? '.lib' : '.a' if ! defined $_a;
  86    $_so = ".$Config{so}";
  87    $_so = $_WIN32 ? '.dll' : '.so' if ! defined $_so;
  88}
  89
  90# Flush stdout each time.
  91$| = 1;
  92
  93# Seed random number generator.
  94srand(time . $$); # this works better than time ^ $$ in perlfunc manpage.
  95
  96$usage = q(
  97Usage: cons <arguments> -- <construct-args>
  98
  99Arguments can be any of the following, in any order:
 100
 101  <targets>	Build the specified targets. If <target> is a directory
 102		recursively build everything within that directory.
 103
 104  +<pattern>	Limit the cons scripts considered to just those that
 105		match <pattern>. Multiple + arguments are accepted.
 106
 107  <name>=<val>	Sets <name> to value <val> in the ARG hash passed to the
 108		top-level Construct file.
 109
 110  -cc           Show command that would have been executed, when
 111		retrieving from cache. No indication that the file
 112		has been retrieved is given; this is useful for
 113		generating build logs that can be compared with
 114		real build logs.
 115
 116  -cd           Disable all caching. Do not retrieve from cache nor
 117		flush to cache.
 118
 119  -cr           Build dependencies in random order. This is useful when
 120		building multiple similar trees with caching enabled.
 121
 122  -cs           Synchronize existing build targets that are found to be
 123		up-to-date with cache. This is useful if caching has
 124		been disabled with -cc or just recently enabled with
 125		UseCache.
 126
 127  -d            Enable dependency debugging.
 128
 129  -f <file>	Use the specified file instead of "Construct" (but first
 130		change to containing directory of <file>).
 131
 132  -h            Show a help message local to the current build if
 133		one such is defined,  and exit.
 134
 135  -k		Keep going as far as possible after errors.
 136
 137  -o <file>	Read override file <file>.
 138
 139  -p		Show construction products in specified trees.
 140  -pa		Show construction products and associated actions.
 141  -pw		Show products and where they are defined.
 142
 143  -q		Be quiet; multiple -q flags increase quietness level:
 144		1: quiet about Installing and Removing targets
 145		2: quiet about build commands, up-to-date targets
 146
 147  -r		Remove construction products associated with <targets>
 148
 149  -R <repos>	Search for files in <repos>.  Multiple -R <repos>
 150		directories are searched in the order specified.
 151
 152  -S <pkg>	Use package sig::<pkg> to calculate file signatures.
 153		Currently supported values are "md5" for MD5
 154		signatures (the default) and "md5::debug" for MD5
 155		signature debug information.
 156
 157  -t            Traverse up the directory hierarchy looking for a
 158		Construct file, if none exists in the current directory.
 159		(Targets will be modified to be relative to the
 160		Construct file.)
 161
 162  -v		Show cons version and continue processing.
 163  -V            Show cons version and exit.
 164
 165  -wf <file>    Write all filenames considered into <file>.
 166
 167  -x		Show this message and exit.
 168
 169
 170   Please report any suggestions through the cons-discuss@gnu.org mailing
 171   list.
 172
 173   To subscribe, send mail to cons-discuss-request@gnu.org with body
 174   'subscribe'.
 175
 176   If you find a bug, please report it through the bug-cons@gnu.org
 177   mailing list.
 178
 179   Information about CONS can be obtained from the official cons web site
 180   http://www.dsmit.com/cons/ or its mirrors (listed there).
 181
 182   The cons maintainers can be contacted by email at cons-maintainers@gnu.org
 183
 184   User documentation of cons is contained in cons and can be obtained
 185   by doing 'perldoc /path/to/cons'.
 186
 187);
 188
 189# Simplify program name, if it is a path.
 190{
 191    my ($vol, $dir, $file) = File::Spec->splitpath(File::Spec->canonpath($0));
 192    $0 = $file;
 193}
 194
 195# Default parameters.
 196$param::topfile = 'Construct';	# Top-level construction file.
 197$param::install = 1;		# Show installations
 198$param::build = 1;		# Build targets
 199### $param::show = 1;		# Show building of targets.
 200$param::sigpro = 'md5';		# Signature protocol.
 201$param::depfile = '';		# Write all deps out to this file
 202$param::salt = '';		# Salt derived file signatures with this.
 203$param::sourcesig = ['*' => 'content'];# Source file signature calculation
 204$param::rep_sig_times_ok = 1;	# Repository .consign times are in sync
 205				#   w/files.
 206$param::conscript_chdir = 0;	# Change dir to Conscript directory
 207$param::quiet = 0;		# should we show the command being executed.
 208
 209@param::defaults = ();
 210
 211#
 212$indent = '';
 213
 214# Display a command while executing or otherwise. This
 215# should be called by command builder action methods.
 216sub showcom {
 217    print($indent . $_[0] . "\n") if ($param::quiet < 2);
 218}
 219
 220# Default environment.
 221# This contains only the completely platform-independent information
 222# we can figure out.  Platform-specific information (UNIX, Win32)
 223# gets added below.
 224@param::base = (
 225     'SIGNATURE'    => [ '*' => 'build' ],
 226     'SUFEXE'	    => $_exe,				# '' on UNIX systems
 227     'SUFLIB'	    => $_a,				# '.a' on UNIX systems
 228     'SUFLIBS'      => "$_so:$_a",			# '.so:.a' on UNIX
 229     'SUFOBJ'	    => $_o,				# '.o' on UNIX systems
 230     'SUFMAP'       => {
 231	 '.c'  => 'build::command::cc',
 232	 '.s'  => 'build::command::cc',
 233	 '.S'  => 'build::command::cc',
 234	 '.C'  => 'build::command::cxx',
 235	 '.cc' => 'build::command::cxx',
 236	 '.cxx'=> 'build::command::cxx',
 237	 '.cpp'=> 'build::command::cxx',
 238	 '.c++'=> 'build::command::cxx',
 239	 '.C++'=> 'build::command::cxx',
 240     },
 241     'PERL'	    => $^X,
 242);
 243
 244%param::rulesets =
 245    (
 246     # Defaults for Win32.
 247     # Defined for VC++ 6.0 by Greg Spencer <greg_spencer@acm.org>
 248     # Your mileage may vary.
 249     'msvc' => [
 250		'CC'             => 'cl',
 251		'CFLAGS'         => '/nologo',
 252		'CCCOM'          => '%CC %CFLAGS %_IFLAGS /c %< /Fo%>',
 253		'CXX'            => '%CC',
 254		'CXXFLAGS'       => '%CFLAGS',
 255		'CXXCOM'         => '%CXX %CXXFLAGS %_IFLAGS /c %< /Fo%>',
 256		'INCDIRPREFIX'   => '/I',
 257		'INCDIRSUFFIX'   => '',
 258		'LINK'           => 'link',
 259		'LINKCOM'        => '%LINK %LDFLAGS /out:%> %< %_LDIRS %LIBS',
 260		'LINKMODULECOM'  => '%LD /r /o %> %<',
 261		'LIBDIRPREFIX'   => '/LIBPATH:',
 262		'LIBDIRSUFFIX'   => '',
 263		'AR'             => 'lib',
 264		'ARFLAGS'        => '/nologo ',
 265		'ARCOM'          => "%AR %ARFLAGS /out:%> %<",
 266		'RANLIB'         => '',
 267		'LD'             => 'link',
 268		'LDFLAGS'        => '/nologo ',
 269		'PREFLIB'        => '',
 270		],
 271     # Defaults for a typical (?) UNIX platform.
 272     # Your mileage may vary.
 273     'unix' => [
 274		'CC'             => 'cc',
 275		'CFLAGS'         => '',
 276		'CCCOM'          => '%CC %CFLAGS %_IFLAGS -c %< -o %>',
 277		'CXX'            => '%CC',
 278		'CXXFLAGS'       => '%CFLAGS',
 279		'CXXCOM'         => '%CXX %CXXFLAGS %_IFLAGS -c %< -o %>',
 280		'INCDIRPREFIX'   => '-I',
 281		'INCDIRSUFFIX'   => '',
 282		'LINK'           => '%CXX',
 283		'LINKCOM'        => '%LINK %LDFLAGS -o %> %< %_LDIRS %LIBS',
 284		'LINKMODULECOM'  => '%LD -r -o %> %<',
 285		'LIBDIRPREFIX'   => '-L',
 286		'LIBDIRSUFFIX'   => '',
 287		'AR'             => 'ar',
 288		'ARFLAGS'        => 'r', # rs?
 289		'ARCOM'          => ['%AR %ARFLAGS %> %<', '%RANLIB %>'],
 290		'RANLIB'         => 'ranlib',
 291		'AS'             => 'as',
 292		'ASFLAGS'        => '',
 293		'ASCOM'          => '%AS %ASFLAGS %< -o %>',
 294		'LD'             => 'ld',
 295		'LDFLAGS'        => '',
 296		'PREFLIB'        => 'lib',
 297		'ENV'            => { 'PATH' => '/bin:/usr/bin' },
 298		],
 299     );
 300
 301# Set the rules based on the platform.
 302script::DefaultRules(script::RuleSet($_WIN32 ? 'msvc' : 'unix'));
 303
 304# Handle command line arguments.
 305while (@ARGV) {
 306    $_ = shift @ARGV;
 307    last if /^--$/;		# Argument passing to Construct.
 308    &option, next			if s/^-//;
 309    push (@param::include, $_), next	if s/^\+//;
 310    &equate, next			if /=/;
 311    push (@targets, $_), next;
 312}
 313
 314sub option {
 315    my %opt = (
 316		    'cc' =>   sub { $param::cachecom = 1; },
 317		    'cd' =>   sub { $param::cachedisable = 1; },
 318		    'cr' =>   sub { $param::random = 1; },
 319		    'cs' =>   sub { $param::cachesync = 1; },
 320		    'd' =>    sub { $param::depends = 1; },
 321		    'h' =>    sub { $param::localhelp = 1; },
 322		    'k' =>    sub { $param::kflag = 1; },
 323		    'p' =>    sub { $param::pflag = 1;
 324				    $param::build = 0; },
 325		    'pa' =>   sub { $param::pflag = 1;
 326				    $param::aflag = 1;
 327				    $indent = "... ";
 328				    $param::build = 0; },
 329		    'pw' =>   sub { $param::pflag = 1;
 330				    $param::wflag = 1;
 331				    $param::build = 0; },
 332		    'q' =>    sub { $param::quiet++; },
 333		    'r' =>    sub { $param::rflag = 1;
 334				    $param::build = 0; },
 335		    't' =>    sub { $param::traverse = 1; },
 336		    'v' =>    sub { print($version); },
 337		    'V' =>    sub { print($version), exit(0); },
 338		    'x' =>    sub { print($usage), exit 0; },
 339		);
 340
 341    my %opt_arg = (
 342		    'f' =>    sub { $param::topfile = $_[0]; },
 343		    'o' =>    sub { $param::overfile = $_[0]; },
 344		    'R' =>    sub { script::Repository($_[0]); },
 345		    'S' =>    sub { $param::sigpro = $_[0]; },
 346		    'wf' =>   sub { $param::depfile = $_[0]; },
 347		);
 348
 349    if (defined $opt{$_}) {
 350	&{$opt{$_}}();
 351	return;
 352    }
 353    while ($_) {
 354	$_  =~ m/(.)(.*)/;
 355	if (defined $opt{$1}) {
 356	    &{$opt{$1}}();
 357	    $_ = $2;
 358	    next;
 359	}
 360	if (defined $opt_arg{$1}) {
 361	    if (! $2) {
 362		$_ = shift @ARGV;
 363		die("$0: -$1 option requires an argument.\n") if ! $_;
 364	    }
 365	    &{$opt_arg{$1}}($2 || $_);
 366	    return;
 367	}
 368	$_  =~ m/(..)(.*)/;
 369	if (defined $opt_arg{$1}) {
 370	    if (! $2) {
 371		$_ = shift @ARGV;
 372		die("$0: -$1 option requires an argument.\n") if ! $_;
 373	    }
 374	    &{$opt_arg{$1}}($2 || $_);
 375	    return;
 376	}
 377	if ($_) {
 378	    die qq($0: unrecognized option "-$_".  Use -x for a usage message.\n);
 379	}
 380    }
 381}
 382
 383# Process an equate argument (var=val).
 384sub equate {
 385    my($var, $val) = /([^=]*)=(.*)/;
 386    $script::ARG{$var} = $val;
 387}
 388
 389# Define file signature protocol.
 390'sig'->select($param::sigpro);
 391
 392# Cleanup after an interrupt.
 393$SIG{INT} = $SIG{QUIT} = $SIG{TERM} = sub {
 394    $SIG{PIPE} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE';
 395    $SIG{HUP} = $SIG{INT} if ! $main::_WIN32;
 396    warn("\n$0: killed\n");
 397    # Call this first, to make sure that this processing
 398    # occurs even if a child process does not die (and we
 399    # hang on the wait).
 400    sig::hash::END();
 401    wait();
 402    exit(1);
 403};
 404$SIG{HUP} = $SIG{INT} if ! $main::_WIN32;
 405
 406# Cleanup after a broken pipe (someone piped our stdout?)
 407$SIG{PIPE} = sub {
 408    $SIG{PIPE} = $SIG{HUP} = $SIG{INT} = $SIG{QUIT} = $SIG{TERM} = 'IGNORE';
 409    warn("\n$0: broken pipe\n");
 410    sig::hash::END();
 411    wait();
 412    exit(1);
 413};
 414
 415if ($param::depfile) {
 416  open (main::DEPFILE, ">".$param::depfile) ||
 417    die ("$0: couldn't open $param::depfile ($!)\n");
 418}
 419
 420# If the supplied top-level Conscript file is not in the
 421# current directory, then change to that directory.
 422{
 423    my ($vol, $dir, $file) =
 424      File::Spec->splitpath(File::Spec->canonpath($param::topfile));
 425    if ($vol || $dir) {
 426	my($cd) = File::Spec->catpath($vol, $dir, undef);
 427	chdir($cd) || die("$0: couldn't change to directory $cd ($!)\n");
 428	$param::topfile = $file;
 429    }
 430}
 431
 432# Walk up the directory hierarchy looking for a Conscript file (if -t set).
 433my($target_top);
 434my(@targetdir) = ();
 435if ($param::traverse && ! -f $param::topfile) {
 436    my($vol, $dirs, $file) = File::Spec->splitpath(cwd());
 437    my(@dirs) = (File::Spec->splitdir($dirs), $file);
 438    while (! -f File::Spec->catpath($vol, File::Spec->catdir(@dirs),
 439				    $param::topfile)) {
 440	die("$0: unable to find $param::topfile.\n") if ! @dirs;
 441	unshift(@targetdir, pop(@dirs));
 442    }
 443    my($cwd) = File::Spec->catpath($vol, File::Spec->catdir(@dirs), '');
 444    print "$0: Entering directory `$cwd'\n";
 445    chdir($cwd);
 446    @targets = map {File::Spec->catdir(@targetdir, $_)} @targets;
 447}
 448
 449# Set up $dir::top and $dir::cwd, now that we are in the right directory.
 450dir::init();
 451
 452#
 453if (@targetdir) {
 454    $target_top = $dir::top->lookupdir(File::Spec->catdir(@targetdir));
 455}
 456
 457# Now handle override file.
 458package override;
 459if ($param::overfile) {
 460    my($ov) = $param::overfile;
 461    die qq($0: can\'t read override file "$ov" ($!)\n) if ! -f $ov; #'
 462    do $ov;
 463    if ($@) {
 464	chop($@);
 465	die qq($0: errors in override file "$ov" ($@)\n);
 466    }
 467}
 468
 469# Provide this to user to setup override patterns.
 470sub Override {
 471    my($re, @env) = @_;
 472    return if $param::overrides{$re}; # if identical, first will win.
 473    $param::overrides = 1;
 474    $param::overrides{$re} = \@env;
 475    push(@param::overrides, $re);
 476}
 477
 478package main;
 479
 480use vars qw( %priority $errors );
 481
 482# Check script inclusion regexps
 483my $re;
 484for $re (@param::include) {
 485    if (! defined eval {"" =~ /$re/}) {
 486	my($err) = $@;
 487	$err =~ s/in regexp at .*$//;
 488	die("$0: error in regexp $err");
 489    }
 490}
 491
 492# Read the top-level construct file and its included scripts.
 493doscripts($param::topfile);
 494
 495# Status priorities. This lets us aggregate status for directories
 496# and print an appropriate message (at the top-level).
 497%priority =
 498    ('none' => 1, 'handled' => 2, 'built' => 3, 'unknown' => 4, 'errors' => 5);
 499
 500# If no targets were specified, supply default targets (if any).
 501@targets = @param::default_targets if ! @targets;
 502
 503$errors = 0;
 504
 505# Build the supplied target patterns.
 506my $tgt;
 507for $tgt (map($dir::top->lookup($_), @targets)) {
 508    if ($target_top && ! $tgt->is_under($target_top)) {
 509	# A -t option was used, and this target is not underneath
 510	# the directory where we were invoked via -t.
 511	# If the target is a directory and the -t directory
 512	# is underneath it, then build the -t directory.
 513	if (ref $tgt ne "dir" || ! $target_top->is_under($tgt)) {
 514	    next;
 515	}
 516	$tgt = $target_top;
 517    }
 518    buildtoptarget($tgt);
 519}
 520
 521exit 0 + ($errors != 0);
 522
 523sub buildtoptarget {
 524    my($tgt) = @_;
 525    return if ! $tgt;
 526    my($status) = buildtarget($tgt);
 527    if ($status ne 'built') {
 528	my($path) = $tgt->path;
 529	if ($status eq "errors") {
 530	    print qq($0: "$path" not remade because of errors.\n);
 531	    $errors++;
 532	} elsif ($status eq "handled") {
 533	    print qq($0: "$path" is up-to-date.\n) if ($param::quiet < 2);
 534	} elsif ($status eq "unknown") {
 535	    # cons error already reported.
 536	    $errors++;
 537	} elsif ($status eq "none") {
 538	    # search for targets that may be linked to the given path.
 539	    my @linked = dir::linked_targets($tgt) if $target_top;
 540	    if (@linked) {
 541		my @names = map($_->path, @linked);
 542		print "Linked targets: @names\n" if ($param::quiet < 1);
 543		map(buildtoptarget($_), @linked);
 544	    } else {
 545		print qq($0: nothing to be built in "$path".\n)
 546		      if $param::build && ($param::quiet < 2);
 547	    }
 548	} else {
 549	    print qq($0: don\'t know how to construct "$path".\n); #'
 550	    $errors++;
 551	}
 552    }
 553}
 554
 555# Build the supplied target directory or files. Return aggregated status.
 556sub buildtarget {
 557    my($tgt) = @_;
 558    if (ref($tgt) eq "dir") {
 559	my($result) = "none";
 560	my($priority) = $priority{$result};
 561	if (exists $tgt->{member}) {
 562	    my($members) = $tgt->{member};
 563	    my $entry;
 564	    for $entry (sort keys %$members) {
 565		next if $entry eq $dir::CURDIR || $entry eq $dir::UPDIR;
 566		my($tgt) = $members->{$entry};
 567		next if ref($tgt) ne "dir" && !exists($tgt->{builder});
 568		my($stat) = buildtarget($members->{$entry});
 569		my($pri) = $priority{$stat};
 570		if ($pri > $priority) {
 571		    $priority = $pri;
 572		    $result = $stat;
 573		}
 574	    }
 575	}
 576	return $result;
 577    }
 578    if ($param::depends) {
 579	my($path) = $tgt->path;
 580	if ($tgt->{builder}) {
 581	    my(@dep) = (@{$tgt->{dep}}, @{$tgt->{sources}});
 582	    my($dep) = join(' ',map($_->path, @dep));
 583	    print("Target $path: $dep\n");
 584	} else {
 585	    print("Target $path: not a derived file\n");
 586	}
 587    }
 588    if ($param::build) {
 589	return build $tgt;
 590    } elsif ($param::pflag || $param::wflag || $param::aflag) {
 591	if ($tgt->{builder}) {
 592	    if ($param::wflag) {
 593		print qq(${\$tgt->path}: $tgt->{script}\n);
 594	    } elsif ($param::pflag) {
 595		print qq(${\$tgt->path}:\n) if $param::aflag;
 596		print qq(${\$tgt->path}\n) if !$param::aflag;
 597	    }
 598	    if ($param::aflag) {
 599		$tgt->{builder}->action($tgt);
 600	    }
 601	}
 602    } elsif ($param::rflag && $tgt->{builder}) {
 603	my($path) = $tgt->path;
 604	if (-f $path) {
 605	    if (unlink($path)) {
 606		print("Removed $path\n") if ($param::quiet < 1);
 607	    } else {
 608		warn("$0: couldn't remove $path\n");
 609	    }
 610	}
 611    }
 612
 613    return "none";
 614}
 615
 616package NameSpace;
 617
 618# Return a hash that maps the name of symbols in a namespace to an
 619# array of refs for all types for which the name has a defined value.
 620# A list of symbols may be specified; default is all symbols in the
 621# name space.
 622sub save {
 623    my $package = shift;
 624    my(%namerefs, $var, $type);
 625    no strict 'refs';
 626    @_ = keys %{$package."::"} if ! @_;
 627    foreach $var (@_) {
 628	$namerefs{$var} = [];
 629	my $fqvar = $package."::".$var;
 630	# If the scalar for this variable name doesn't already
 631	# exist, *foo{SCALAR} will autovivify the reference
 632	# instead of returning undef, so unlike the other types,
 633	# we have to dereference to find out if it exists.
 634	push(@{$namerefs{$var}}, *{$fqvar}{SCALAR})
 635		    if defined ${*{$fqvar}{SCALAR}};
 636	foreach $type (qw(ARRAY HASH CODE IO)) {
 637	    push(@{$namerefs{$var}}, *{$fqvar}{$type})
 638			  if defined *{$fqvar}{$type};
 639	}
 640    }
 641    return \%namerefs;
 642}
 643
 644# Remove the specified symbols from the namespace.
 645# Default is to remove all.
 646sub remove {
 647    my $package = shift;
 648    my(%namerefs, $var);
 649    no strict 'refs';
 650    @_ = keys %{$package."::"} if ! @_;
 651    foreach $var (@_) {
 652	delete ${$package."::"}{$var};
 653    }
 654}
 655
 656# Restore values to symbols specified in a hash as returned
 657# by NameSpace::save.
 658sub restore {
 659    my($package, $namerefs) = @_;
 660    my($var, $ref);
 661    no strict 'refs';
 662    foreach $var (keys %$namerefs) {
 663	my $fqvar = $package."::".$var;
 664	foreach $ref (@{$namerefs->{$var}}) {
 665	    *{$fqvar} = $ref;
 666	}
 667    }
 668}
 669
 670# Support for "building" scripts, importing and exporting variables.
 671# With the exception of the top-level routine here (invoked from the
 672# main package by cons), these are all invoked by user scripts.
 673package script;
 674
 675use vars qw( $ARG $caller_dir_path %special_var );
 676
 677BEGIN {
 678    # We can't Export or Import the following variables because Perl always
 679    # treats them as part of the "main::" package (see perlvar(1)).
 680    %special_var = map {$_ => 1} qw(ENV INC ARGV ARGVOUT SIG
 681				    STDIN STDOUT STDERR);
 682}
 683
 684# This is called from main to interpret/run the top-level Construct
 685# file, passed in as the single argument.
 686sub main::doscripts {
 687    my($script) = @_;
 688    Build($script);
 689    # Now set up the includes/excludes (after the Construct file is read).
 690    $param::include = join('|', @param::include);
 691
 692    # Save the original variable names from the script package.
 693    # These will stay intact, but any other "script::" variables
 694    # defined in a Conscript file will get saved, deleted,
 695    # and (when necessary) restored.
 696    my(%orig_script_var) = map {$_ => 1} keys %script::;
 697    $caller_dir_path = undef;
 698    my $cwd = Cwd::cwd();
 699    my(@scripts) = pop(@priv::scripts);
 700    while ($priv::self = shift(@scripts)) {
 701	my($path) = $priv::self->{script}->rsrcpath;
 702	if (-f $path) {
 703	    $dir::cwd = $priv::self->{script}->{dir};
 704	    # Handle chdir to the Conscript file directory, if necessary.
 705	    my ($vol, $dir, $file);
 706	    if ($param::conscript_chdir) {
 707		($vol, $dir, $file) =
 708		  File::Spec->splitpath(File::Spec->canonpath($path));
 709		if ($vol ne '' || $dir ne '') {
 710		    $caller_dir_path = File::Spec->catpath($vol, $dir, undef);
 711		    chdir($caller_dir_path) ||
 712			die "Could not chdir to $caller_dir_path: $!\n";
 713		}
 714	    } else {
 715		$file = $path;
 716	    }
 717	    # Actually process the Conscript file.
 718	    do $file;
 719	    # Save any variables defined by the Conscript file
 720	    # so we can restore them later, if needed;
 721	    # then delete them from the script:: namespace.
 722	    my(@del) = grep(! $orig_script_var{$_}, keys %script::);
 723	    if (@del) {
 724		$priv::self->{script}->{pkgvars} = NameSpace::save('script',
 725								   @del);
 726		NameSpace::remove('script', @del);
 727	    }
 728	    if ($caller_dir_path) {
 729		chdir($cwd);
 730		$caller_dir_path = undef;
 731	    }
 732	    if ($@) {
 733		chomp($@);
 734		my $err = ($@ =~ /\n/ms) ? ":\n$@" : " ($@)";
 735		print qq($0: error in file "$path"$err\n);
 736		$run::errors++;
 737	    } else {
 738		# Only process subsidiary scripts if no errors in parent.
 739		unshift(@scripts, @priv::scripts);
 740	    }
 741	    undef @priv::scripts;
 742	} else {
 743	    my $where = '';
 744	    my $cref = $priv::self->{script}->creator;
 745	    if (defined $cref) {
 746		my($_foo, $script, $line, $sub) = @$cref;
 747		$where = " ($sub in $script, line $line)";
 748	    }
 749	    warn qq(Ignoring missing script "$path"$where);
 750	}
 751    }
 752    die("$0: script errors encountered: construction aborted\n")
 753	if $run::errors;
 754}
 755
 756# Return caller info about the method being invoked.
 757# This is everything from the Perl "caller" builtin function,
 758# including which Construct/Conscript file, line number,
 759# subroutine name, etc.
 760sub caller_info {
 761    my($lev) = 1;
 762    my(@frame);
 763    do {
 764	@frame = caller ++$lev;
 765	if (defined($frame[3]) && $frame[3] eq '(eval)') {
 766	    @frame = caller --$lev;
 767	    if ($caller_dir_path) {
 768		$frame[1] = File::Spec->catfile($caller_dir_path, $frame[1]);
 769	    }
 770	    return @frame;
 771	}
 772    } while ($frame[3]);
 773    return;
 774}
 775
 776# Link a directory to another. This simply means set up the *source*
 777# for the directory to be the other directory.
 778sub Link {
 779    dir::link(@_);
 780}
 781
 782# Add directories to the repository search path for files.
 783# Strip our current directory from the list so Repository
 784# (or -R options) can be used from within the repository.
 785sub Repository {
 786    my($my_dir) = Cwd::cwd();
 787    my $dir;
 788    foreach $dir (@_) {
 789	# The following more direct call isn't available in
 790	# Cwd.pm until some time after 5.003...
 791	#	my($d) = Cwd::abs_path($dir);
 792	chdir($dir);
 793	my($d) = Cwd::cwd();
 794	chdir($my_dir);
 795	#
 796	next if ! $d || ! -d $d || $d eq $my_dir;
 797	# We know we can get away with passing undef to lookupdir
 798	# as the directory because $dir is an absolute path.
 799	push(@param::rpath, dir::lookupdir(undef, $dir));
 800	push @INC, $d;
 801    }
 802}
 803
 804# Return the list of Repository directories specified.
 805sub Repository_List {
 806    map($_->path, @param::rpath);
 807}
 808
 809# Specify whether the .consign signature times in repository files are,
 810# in fact, consistent with the times on the files themselves.
 811sub Repository_Sig_Times_OK {
 812    $param::rep_sig_times_ok = shift;
 813}
 814
 815sub SourceSignature {
 816    $param::sourcesig = [@_];
 817}
 818
 819# Specify whether we should chdir to the containing directories
 820# of Conscript files.
 821sub Conscript_chdir {
 822    $param::conscript_chdir = shift;
 823}
 824
 825# Specify files/targets that must be present and built locally,
 826# even if they exist already-built in a Repository.
 827sub Local {
 828    my(@files) = map($dir::cwd->lookupfile($_), @_);
 829    map($_->local(1), @files);
 830}
 831
 832# Export variables to any scripts invoked from this one.
 833sub Export {
 834    my(@illegal) = grep($special_var{$_}, @_);
 835    if (@illegal) {
 836	die qq($0: cannot Export special Perl variables: @illegal\n);
 837    }
 838    @{$priv::self->{exports}} = grep(! defined $special_var{$_}, @_);
 839}
 840
 841# Import variables from the export list of the caller
 842# of the current script.
 843sub Import {
 844    my(@illegal) = grep($special_var{$_}, @_);
 845    if (@illegal) {
 846	die qq($0: cannot Import special Perl variables: @illegal\n);
 847    }
 848    my($parent) = $priv::self->{parent};
 849    my($imports) = $priv::self->{imports};
 850    @{$priv::self->{exports}} = keys %$imports;
 851    my($var);
 852    foreach $var (grep(! defined $special_var{$_}, @_)) {
 853	if (!exists $imports->{$var}) {
 854	    my($path) = $parent->{script}->path;
 855	    die qq($0: variable "$var" not exported by file "$path"\n);
 856	}
 857	if (!defined $imports->{$var}) {
 858	    my $path = $parent->{script}->path;
 859	    my $err = "$0: variable \"$var\" exported but not " .
 860		      "defined by file \"$path\"\n";
 861	    die $err;
 862	}
 863	${"script::$var"} = $imports->{$var};
 864    }
 865}
 866
 867# Build an inferior script. That is, arrange to read and execute
 868# the specified script, passing to it any exported variables from
 869# the current script.
 870sub Build {
 871    my(@files) = map($dir::cwd->lookupfile($_), @_);
 872    my(%imports) = map {$_ => ${"script::$_"}} @{$priv::self->{exports}};
 873    my $file;
 874    for $file (@files) {
 875	next if $param::include && $file->path !~ /$param::include/o;
 876	my($self) = {'script' => $file,
 877		     'parent' => $priv::self,
 878		     'imports' => \%imports};
 879	bless $self;  # may want to bless into class of parent in future
 880	push(@priv::scripts, $self);
 881    }
 882}
 883
 884# Set up regexps dependencies to ignore. Should only be called once.
 885sub Ignore {
 886    die("Ignore called more than once\n") if $param::ignore;
 887    $param::ignore = join("|", map("($_)", @_)) if @_;
 888}
 889
 890# Specification of default targets.
 891sub Default {
 892    push(@param::default_targets, map($dir::cwd->lookup($_)->path, @_));
 893}
 894
 895# Local Help.  Should only be called once.
 896sub Help {
 897    if ($param::localhelp) {
 898	print "@_\n";
 899	exit 2;
 900    }
 901}
 902
 903# For windows platforms which use unix tool sets, the msvc defaults may
 904# not be useful. Also, in the future, other platforms (Mac?) may have the
 905# same problem.
 906sub RuleSet {
 907    my $style = shift;
 908    my @rulesets = sort keys %param::rulesets;
 909    die "Unknown style for rules: $style.\n" .
 910	"Supported rules are: (" . join(" ", @rulesets) . ")"
 911	    unless eval(join("||", map("\$style eq '$_'", @rulesets)));
 912    return @param::base, @{$param::rulesets{$style}};
 913}
 914
 915sub DefaultRules {
 916    @param::defaults = ();
 917    push @param::defaults, @_;
 918}
 919
 920# Return the build name(s) of a file or file list.
 921sub FilePath {
 922    wantarray
 923	? map($dir::cwd->lookupfile($_)->path, @_)
 924	: $dir::cwd->lookupfile($_[0])->path;
 925}
 926
 927# Return the build name(s) of a directory or directory list.
 928sub DirPath {
 929    wantarray
 930	? map($dir::cwd->lookupdir($_)->path, @_)
 931	: $dir::cwd->lookupdir($_[0])->path;
 932}
 933
 934# Split the search path provided into components. Look each up
 935# relative to the current directory.
 936# The usual path separator problems abound; for now we'll use :
 937sub SplitPath {
 938    my($dirs) = @_;
 939    if (ref($dirs) ne "ARRAY") {
 940	$dirs = [ split(/$main::PATH_SEPARATOR/o, $dirs) ];
 941    }
 942    map { DirPath($_) } @$dirs;
 943}
 944
 945# Return true if the supplied path is available as a source file
 946# or is buildable (by rules seen to-date in the build).
 947sub ConsPath {
 948    my($path) = @_;
 949    my($file) = $dir::cwd->lookup($path);
 950    return $file->accessible;
 951}
 952
 953# Return the source path of the supplied path.
 954sub SourcePath {
 955    wantarray
 956	? map($dir::cwd->lookupfile($_)->rsrcpath, @_)
 957	: $dir::cwd->lookupfile($_[0])->rsrcpath;
 958}
 959
 960# Search up the tree for the specified cache directory, starting with
 961# the current directory. Returns undef if not found, 1 otherwise.
 962# If the directory is found, then caching is enabled. The directory
 963# must be readable and writable. If the argument "mixtargets" is provided,
 964# then targets may be mixed in the cache (two targets may share the same
 965# cache file--not recommended).
 966sub UseCache($@) {
 967    my($dir, @args) = @_;
 968    # NOTE: it's important to process arguments here regardless of whether
 969    # the cache is disabled temporarily, since the mixtargets option affects
 970    # the salt for derived signatures.
 971    for (@args) {
 972	if ($_ eq "mixtargets") {
 973	    # When mixtargets is enabled, we salt the target signatures.
 974	    # This is done purely to avoid a scenario whereby if
 975	    # mixtargets is turned on or off after doing builds, and
 976	    # if cache synchronization with -cs is used, then
 977	    # cache files may be shared in the cache itself (linked
 978	    # under more than one name in the cache). This is not bad,
 979	    # per se, but simply would mean that a cache cleaning algorithm
 980	    # that looked for a link count of 1 would never find those
 981	    # particular files; they would always appear to be in use.
 982	    $param::salt = 'M' . $param::salt;
 983	    $param::mixtargets = 1;
 984	} else {
 985	    die qq($0: UseCache unrecognized option "$_"\n);
 986	}
 987    }
 988    if ($param::cachedisable) {
 989	warn("Note: caching disabled by -cd flag\n");
 990	return 1;
 991    }
 992    my($depth) = 15;
 993    while ($depth-- && ! -d $dir) {
 994	$dir = File::Spec->catdir($dir::UPDIR, $dir);
 995    }
 996    if (-d $dir) {
 997	$param::cache = $dir;
 998	return 1;
 999    }
1000    return undef;
1001}
1002
1003# Salt the signature generator. The salt (a number of string) is added
1004# into the signature of each derived file. Changing the salt will
1005# force recompilation of all derived files.
1006sub Salt($) {
1007    # We append the value, so that UseCache and Salt may be used
1008    # in either order without changing the signature calculation.
1009    $param::salt .= $_[0];
1010}
1011
1012# Mark files (or directories) to not be removed before building.
1013sub Precious {
1014    map($_->{precious} = 1, map($dir::cwd->lookup($_), @_));
1015}
1016
1017
1018# These methods are callable from Conscript files, via a cons
1019# object. Procs beginning with _ are intended for internal use.
1020package cons;
1021
1022use vars qw( %envcache );
1023
1024# This is passed the name of the base environment to instantiate.
1025# Overrides to the base environment may also be passed in
1026# as key/value pairs.
1027sub new {
1028    my($package) = shift;
1029    my ($env) = {@param::defaults, @_};
1030    @{$env->{_envcopy}} = %$env; # Note: we never change PATH
1031    $env->{_cwd} = $dir::cwd; # Save directory of environment for
1032    bless $env, $package;	# any deferred name interpretation.
1033}
1034
1035# Clone an environment.
1036# Note that the working directory will be the initial directory
1037# of the original environment.
1038sub clone {
1039    my($env) = shift;
1040    my $clone = {@{$env->{_envcopy}}, @_};
1041    @{$clone->{_envcopy}} = %$clone; # Note: we never change PATH
1042    $clone->{_cwd} = $env->{_cwd};
1043    bless $clone, ref $env;
1044}
1045
1046# Create a flattened hash representing the environment.
1047# It also contains a copy of the PATH, so that the path
1048# may be modified if it is converted back to a hash.
1049sub copy {
1050    my($env) = shift;
1051    (@{$env->{_envcopy}}, 'ENV' => {%{$env->{ENV}}}, @_)
1052}
1053
1054# Resolve which environment to actually use for a given
1055# target. This is just used for simple overrides.
1056sub _resolve {
1057    return $_[0] if !$param::overrides;
1058    my($env, $tgt) = @_;
1059    my($path) = $tgt->path;
1060    my $re;
1061    for $re (@param::overrides) {
1062	next if $path !~ /$re/;
1063	# Found one. Return a combination of the original environment
1064	# and the override.
1065	my($ovr) = $param::overrides{$re};
1066	return $envcache{$env,$re} if $envcache{$env,$re};
1067	my($newenv) = {@{$env->{_envcopy}}, @$ovr};
1068	@{$newenv->{_envcopy}} = %$env;
1069	$newenv->{_cwd} = $env->{_cwd};
1070	return $envcache{$env,$re} = bless $newenv, ref $env;
1071    }
1072    return $env;
1073}
1074
1075# Substitute construction environment variables into a string.
1076# Internal function/method.
1077sub _subst {
1078    my($env, $str) = @_;
1079    if (! defined $str) {
1080	return undef;
1081    } elsif (ref($str) eq "ARRAY") {
1082	return [ map($env->_subst($_), @$str) ];
1083    } else {
1084	# % expansion.  %% gets converted to % later, so expand any
1085	# %keyword construction that doesn't have a % in front of it,
1086	# modulo multiple %% pairs in between.
1087	# In Perl 5.005 and later, we could actually do this in one regex
1088	# using a conditional expression as follows,
1089	#	while ($str =~ s/($pre)\%(\{)?([_a-zA-Z]\w*)(?(2)\})/"$1".
1090	#                      $env->{$3}/ge) {}
1091	# The following two-step approach is backwards-compatible
1092	# to (at least) Perl5.003.
1093	my $pre = '^|[^\%](?:\%\%)*';
1094	while (($str =~ s/($pre)\%([_a-zA-Z]\w*)/$1.($env->{$2}||'')/ge) ||
1095	       ($str =~ s/($pre)\%\{([_a-zA-Z]\w*)\}/$1.($env->{$2}||'')/ge)) {
1096	}
1097	return $str;
1098    }
1099}
1100
1101sub AfterBuild {
1102    my($env) = shift;
1103    my($perl_eval_str) = pop(@_);
1104    my $file;
1105    for $file (map($dir::cwd->lookup($_), @_)) {
1106	$file->{after_build_func} = $perl_eval_str;
1107    }
1108}
1109
1110sub Install {
1111    my($env) = shift;
1112    my($tgtdir) = $dir::cwd->lookupdir($env->_subst(shift));
1113    my $file;
1114    for $file (map($dir::cwd->lookupfile($env->_subst($_)), @_)) {
1115	my($tgt) = $tgtdir->lookupfile($file->{entry});
1116	$tgt->bind(find build::install($env), $file);
1117    }
1118}
1119
1120sub InstallAs {
1121    my $env = shift;
1122    my $tgt = shift;
1123    my $src = shift;
1124    my @sources = ();
1125    my @targets = ();
1126
1127    if (ref $tgt) {
1128	die "InstallAs: Source is a file and target is a list!\n"
1129	    if (!ref($src));
1130	@sources = @$src;
1131	@targets = @$tgt;
1132    } elsif (ref $src) {
1133	die "InstallAs: Target is a file and source is a list!\n";
1134    } else {
1135	push @sources, $src;
1136	push @targets, $tgt;
1137    }
1138
1139    if ($#sources != $#targets) {
1140	my $tn = $#targets+1;
1141	my $sn = $#sources+1;
1142	die "InstallAs: Source file list ($sn) and target file list ($tn) " .
1143	    "are inconsistent in length!\n";
1144    } else {
1145	foreach (0..$#sources) {
1146	    my $tfile = $dir::cwd->lookupfile($env->_subst($targets[$_]));
1147	    my $sfile = $dir::cwd->lookupfile($env->_subst($sources[$_]));
1148	    $tfile->bind(find build::install($env), $sfile);
1149	}
1150    }
1151}
1152
1153# Installation in a local build directory,
1154# copying from the repository if it's already built there.
1155# Functionally equivalent to:
1156#	Install $env $dir, $file;
1157#	Local "$dir/$file";
1158sub Install_Local {
1159    my($env) = shift;
1160    my($tgtdir) = $dir::cwd->lookupdir($env->_subst(shift));
1161    my $file;
1162    for $file (map($dir::cwd->lookupfile($env->_subst($_)), @_)) {
1163	my($tgt) = $tgtdir->lookupfile($file->{entry});
1164	$tgt->bind(find build::install($env), $file);
1165	$tgt->local(1);
1166    }
1167}
1168
1169sub Objects {
1170    my($env) = shift;
1171    map($dir::cwd->relpath($_), $env->_Objects(@_));
1172}
1173
1174# Called with multiple source file references (or object files).
1175# Returns corresponding object files references.
1176sub _Objects {
1177    my($env) = shift;
1178    my($suffix) = $env->{SUFOBJ};
1179    map($env->_Object($_, $_->{dir}->lookupfile($_->base_suf($suffix))),
1180	map { ref $_ ? $_ : $dir::cwd->lookupfile($env->_subst($_)) }
1181		grep(defined $_, @_));
1182}
1183
1184# Called with an object and source reference.  If no object reference
1185# is supplied, then the object file is determined implicitly from the
1186# source file's extension. Sets up the appropriate rules for creating
1187# the object from the source.  Returns the object reference.
1188sub _Object {
1189    my($env, $src, $obj) = @_;
1190    return $obj if $src eq $obj; # don't need to build self from self.
1191    my($objenv) = $env->_resolve($obj);
1192    my($suffix) = $src->suffix;
1193
1194    my($builder) = $env->{SUFMAP}{$suffix};
1195
1196    if ($builder) {
1197	$obj->bind((find $builder($objenv)), $src);
1198    } else {
1199	die("don't know how to construct ${\$obj->path} from " .
1200	    "${\$src->path}.\n");
1201    }
1202    $obj
1203}
1204
1205sub Program {
1206    my($env) = shift;
1207    my($tgt) = $dir::cwd->lookupfile(file::addsuffix($env->_subst(shift),
1208						 $env->{SUFEXE}));
1209    my($progenv) = $env->_resolve($tgt);
1210    $tgt->bind(find build::command::link($progenv, $progenv->{LINKCOM}),
1211	       $env->_Objects(@_));
1212}
1213
1214sub Module {
1215    my($env) = shift;
1216    my($tgt) = $dir::cwd->lookupfile($env->_subst(shift));
1217    my($modenv) = $env->_resolve($tgt);
1218    my($com) = pop(@_);
1219    $tgt->bind(find build::command::link($modenv, $com), $env->_Objects(@_));
1220}
1221
1222sub LinkedModule {
1223    my($env) = shift;
1224    my($tgt) = $dir::cwd->lookupfile($env->_subst(shift));
1225    my($progenv) = $env->_resolve($tgt);
1226    $tgt->bind(find build::command::linkedmodule
1227	       ($progenv, $progenv->{LINKMODULECOM}),
1228	       $env->_Objects(@_));
1229}
1230
1231sub Library {
1232    my($env) = shift;
1233    my($lib) = $dir::cwd->lookupfile(file::addsuffix($env->_subst(shift),
1234						 $env->{SUFLIB}));
1235    my($libenv) = $env->_resolve($lib);
1236    $lib->bind(find build::command::library($libenv), $env->_Objects(@_));
1237}
1238
1239# Simple derivation: you provide target, source(s), command.
1240# Special variables substitute into the rule.
1241# Target may be a reference, in which case it is taken
1242# to be a multiple target (all targets built at once).
1243sub Command {
1244    my($env) = shift;
1245    my($tgt) = $env->_subst(shift);
1246    my($builder) = find build::command::user($env, pop(@_), 'script');
1247    my(@sources) = map($dir::cwd->lookupfile($env->_subst($_)), @_);
1248    if (ref($tgt)) {
1249	# A multi-target command.
1250	my(@tgts) = map($dir::cwd->lookupfile($_), @$tgt);
1251	die("empty target list in multi-target command\n") if !@tgts;
1252	$env = $env->_resolve($tgts[0]);
1253	my($multi) = build::multiple->new($builder, \@tgts);
1254	for $tgt (@tgts) {
1255	    $tgt->bind($multi, @sources);
1256	}
1257    } else {
1258	$tgt = $dir::cwd->lookupfile($tgt);
1259	$env = $env->_resolve($tgt);
1260	$tgt->bind($builder, @sources);
1261    }
1262}
1263
1264sub Depends {
1265    my($env) = shift;
1266    my($tgt) = $env->_subst(shift);
1267    my(@deps) = map($dir::cwd->lookup($env->_subst($_)), @_);
1268    if (! ref($tgt)) {
1269	$tgt = [ $tgt ];
1270    }
1271    my($t);
1272    foreach $t (map($dir::cwd->lookupfile($_), @$tgt)) {
1273	push(@{$t->{dep}}, @deps);
1274    }
1275}
1276
1277# Setup a quick scanner for the specified input file, for the
1278# associated environment. Any use of the input file will cause the
1279# scanner to be invoked, once only. The scanner sees just one line at
1280# a time of the file, and is expected to return a list of
1281# dependencies.
1282sub QuickScan {
1283    my($env, $code, $file, $path) = @_;
1284    $dir::cwd->lookup($env->_subst($file))->{'srcscan',$env} =
1285	find scan::quickscan($code, $env, $env->_subst($path));
1286}
1287
1288# Generic builder module. Just a few default methods.  Every derivable
1289# file must have a builder object of some sort attached.  Usually
1290# builder objects are shared.
1291package build;
1292
1293use vars qw( %builder );
1294
1295# Every builder must now have at least an associated environment,
1296# so we can find its sigarray and calculate the proper signature.
1297sub find {
1298    my($class, $env) = @_;
1299    $builder{$env} || do {
1300	my $self = { env => $env };
1301	$builder{$env} = bless $self, $class;
1302    }
1303}
1304
1305# Null signature for dynamic includes.
1306sub includes { () }
1307
1308# Null signature for build script.
1309sub scriptsig { () }
1310
1311# Not compatible with any other builder, by default.
1312sub compatible { 0 }
1313
1314
1315# Builder module for the Install command.
1316package build::install;
1317
1318use vars qw( @ISA );
1319
1320BEGIN { @ISA = qw(build) }
1321
1322# Caching not supported for Install: generally install is trivial anyway,
1323# and we don't want to clutter the cache.
1324sub cachin { undef }
1325sub cachout { }
1326
1327# Do the installation.
1328sub action {
1329    my($self, $tgt) = @_;
1330    my($src) = $tgt->{sources}[0];
1331    main::showcom("Install ${\$src->rpath} as ${\$tgt->path}")
1332	if ($param::install && $param::quiet < 1);
1333    return unless $param::build;
1334    futil::install($src->rpath, $tgt);
1335    return 1;
1336}
1337
1338
1339# Builder module for generic UNIX commands.
1340package build::command;
1341
1342use vars qw( @ISA %com );
1343
1344BEGIN { @ISA = qw(build) }
1345
1346sub find {
1347    my($class, $env, $cmd, $package) = @_;
1348    my($act) = action::new($env, $cmd);
1349    $package ||= '';
1350    $com{$env,$act,$package} || do {
1351	my $self = { env => $env, act => $act, 'package' => $package };
1352	$com{$env,$act,$package} = bless $self, $class;
1353    }
1354}
1355
1356# Default cache in function.
1357sub cachin {
1358    my($self, $tgt, $sig) = @_;
1359    if (cache::in($tgt, $sig)) {
1360	if ($param::cachecom) {
1361	    $self->{act}->show($self->{env}, $tgt);
1362	} else {
1363	    printf("Retrieved %s from cache\n", $tgt->path)
1364		if ($param::quiet < 1);
1365	}
1366	return 1;
1367    }
1368    return undef;
1369}
1370
1371# Default cache out function.
1372sub cachout {
1373    my($self, $tgt, $sig) = @_;
1374    cache::out($tgt, $sig);
1375}
1376
1377# Build the target using the previously specified commands.
1378sub action {
1379    my($self, $tgt) = @_;
1380    $self->{act}->execute($self->{env}, $tgt, $self->{'package'});
1381}
1382
1383# Return script signature.
1384sub scriptsig {
1385    $_[0]->{act}->scriptsig
1386}
1387
1388
1389# Create a linked module.
1390package build::command::link;
1391
1392use vars qw( @ISA );
1393
1394BEGIN { @ISA = qw(build::command) }
1395
1396# Find an appropriate linker.
1397sub find {
1398    my($class, $env, $command) = @_;
1399    if (!exists $env->{_LDIRS}) {
1400	my($ldirs) = '';
1401	my($wd) = $env->{_cwd};
1402	my($pdirs) = $env->{LIBPATH};
1403	if (! defined $pdirs) {
1404	    $pdirs = [ ];
1405	} elsif (ref($pdirs) ne 'ARRAY') {
1406	    $pdirs = [ split(/$main::PATH_SEPARATOR/o, $pdirs) ];
1407	}
1408	my($dir, $dpath);
1409	for $dir (map($wd->lookupdir($env->_subst($_)), @$pdirs)) {
1410	    $dpath = $dir->path;
1411	    # Add the (presumably local) directory to the -L flags
1412	    # if we're not using repositories, the directory exists,
1413	    # or it's Linked to a source directory (that is, it *will*
1414	    # exist by the time the link occurs).
1415	    $ldirs .= " ".$env->{LIBDIRPREFIX}.$dpath.$env->{LIBDIRSUFFIX}
1416			if ! @param::rpath || -d $dpath || $dir->is_linked;
1417	    next if File::Spec->file_name_is_absolute($dpath);
1418	    if (@param::rpath) {
1419		my $d;
1420		if ($dpath eq $dir::CURDIR) {
1421		    foreach $d (map($_->path, @param::rpath)) {
1422			$ldirs .= " " . $env->{LIBDIRPREFIX} .
1423				  $d . $env->{LIBDIRSUFFIX};
1424		    }
1425		} else {
1426		    my($rpath);
1427		    foreach $d (map($_->path, @param::rpath)) {
1428			$rpath = File::Spec->catfile($d, $dpath);
1429			$ldirs .= " ". $env->{LIBDIRPREFIX} .
1430				  $rpath . $env->{LIBDIRSUFFIX} if -d $rpath;
1431		    }
1432		}
1433	    }
1434	}
1435	$env->{_LDIRS} = "%($ldirs%)";
1436    }
1437
1438    # Introduce a new magic _LIBS symbol which allows to use the
1439    # Unix-style -lNAME syntax for Win32 only. -lNAME will be replaced
1440    # with %{PREFLIB}NAME%{SUFLIB}. <schwarze@isa.de> 1998-06-18
1441
1442    if ($main::_WIN32 && !exists $env->{_LIBS}) {
1443	my $libs;
1444	my $name;
1445	for $name (split(' ', $env->_subst($env->{LIBS} || ''))) {
1446	    if ($name =~ /^-l(.*)/) {
1447		$name = "$env->{PREFLIB}$1$env->{SUFLIB}";
1448	    }
1449	    $libs .= ' ' . $name;
1450	}
1451	$env->{_LIBS} = $libs ? "%($libs%)" : '';
1452    }
1453    bless find build::command($env, $command);
1454}
1455
1456# Called from file::build. Make sure any libraries needed by the
1457# environment are built, and return the collected signatures
1458# of the libraries in the path.
1459sub includes {
1460    return $_[0]->{'bsig'} if exists $_[0]->{'bsig'};
1461    my($self, $tgt) = @_;
1462    my($env) = $self->{env};
1463    my($ewd) = $env->{_cwd};
1464    my $ldirs = $env->{LIBPATH};
1465    if (! defined $ldirs) {
1466	$ldirs = [ ];
1467    } elsif (ref($ldirs) ne 'ARRAY') {
1468	$ldirs = [ split(/$main::PATH_SEPARATOR/o, $ldirs) ];
1469    }
1470    my @lpath = map($ewd->lookupdir($_), @$ldirs);
1471    my(@sigs);
1472    my(@names);
1473
1474    # Pass %LIBS symbol through %-substituition
1475    # <schwarze@isa.de> 1998-06-18
1476    @names = split(' ', $env->_subst($env->{LIBS} || ''));
1477    my $name;
1478    for $name (@names) {
1479	my ($lpath, @allnames);
1480	if ($name =~ /^-l(.*)/) {
1481	    # -l style names are looked up on LIBPATH, using all
1482	    # possible lib suffixes in the same search order the
1483	    # linker uses (according to SUFLIBS).
1484	    # Recognize new PREFLIB symbol, which should be 'lib' on
1485	    # Unix, and empty on Win32. TODO: What about shared
1486	    # library suffixes?  <schwarze@isa.de> 1998-05-13
1487	   @allnames = map("$env->{PREFLIB}$1$_",
1488			   split(/:/, $env->{SUFLIBS}));
1489	    $lpath = \@lpath;
1490	} else {
1491	    @allnames = ($name);
1492	    # On Win32, all library names are looked up in LIBPATH
1493	    # <schwarze@isa.de> 1998-05-13
1494	    if ($main::_WIN32) {
1495		$lpath = [$dir::top, @lpath];
1496	    }
1497	    else {
1498		$lpath = [$dir::top];
1499	    }
1500	}
1501	my $dir;
1502	DIR: for $dir (@$lpath) {
1503	    my $n;
1504	    for $n (@allnames) {
1505		my($lib) = $dir->lookup_accessible($n);
1506		if ($lib) {
1507		    last DIR if $lib->ignore;
1508		    if ((build $lib) eq 'errors') {
1509			$tgt->{status} = 'errors';
1510			return undef;
1511		    }
1512		    push(@sigs, 'sig'->signature($lib));
1513		    last DIR;
1514		}
1515	    }
1516	}
1517    }
1518    $self->{'bsig'} = 'sig'->collect(@sigs);
1519}
1520
1521# Always compatible with other such builders, so the user
1522# can define a single program or module from multiple places.
1523sub compatible {
1524    my($self, $other) = @_;
1525    ref($other) eq "build::command::link";
1526}
1527
1528# Link a program.
1529package build::command::linkedmodule;
1530
1531use vars qw( @ISA );
1532
1533BEGIN { @ISA = qw(build::command) }
1534
1535# Always compatible with other such builders, so the user
1536# can define a single linked module from multiple places.
1537sub compatible {
1538    my($self, $other) = @_;
1539    ref($other) eq "build::command::linkedmodule";
1540}
1541
1542# Builder for a C module
1543package build::command::cc;
1544
1545use vars qw( @ISA );
1546
1547BEGIN { @ISA = qw(build::command) }
1548
1549sub find {
1550    $_[1]->{_cc} || do {
1551	my($class, $env) = @_;
1552	my($cpppath) = $env->_subst($env->{CPPPATH});
1553	my($cscanner) = find scan::cpp($env->{_cwd}, $cpppath);
1554	$env->{_IFLAGS} = "%(" . $cscanner->iflags($env) . "%)";
1555	my($self) = find build::command($env, $env->{CCCOM});
1556	$self->{scanner} = $cscanner;
1557	bless $env->{_cc} = $self;
1558    }
1559}
1560
1561# Invoke the associated	 C scanner to get signature of included files.
1562sub includes {
1563    my($self, $tgt) = @_;
1564    $self->{scanner}->includes($tgt, $tgt->{sources}[0]);
1565}
1566
1567# Builder for a C++ module
1568package build::command::cxx;
1569
1570use vars qw( @ISA );
1571
1572BEGIN { @ISA = qw(build::command) }
1573
1574sub find {
1575    $_[1]->{_cxx} || do {
1576	my($class, $env) = @_;
1577	my($cpppath) = $env->_subst($env->{CPPPATH});
1578	my($cscanner) = find scan::cpp($env->{_cwd}, $cpppath);
1579	$env->{_IFLAGS} = "%(" . $cscanner->iflags($env) . "%)";
1580	my($self) = find build::command($env, $env->{CXXCOM});
1581	$self->{scanner} = $cscanner;
1582	bless $env->{_cxx} = $self;
1583    }
1584}
1585
1586# Invoke the associated	 C scanner to get signature of included files.
1587sub includes {
1588    my($self, $tgt) = @_;
1589    $self->{scanner}->includes($tgt, $tgt->{sources}[0]);
1590}
1591
1592# Builder for a user command (cons::Command).  We assume that a user
1593# command might be built and implement the appropriate dependencies on
1594# the command itself (actually, just on the first word of the command
1595# line).
1596package build::command::user;
1597
1598use vars qw( @ISA );
1599
1600BEGIN { @ISA = qw(build::command) }
1601
1602sub includes {
1603    my($self, $tgt) = @_;
1604    my($sig) = '';
1605
1606    # Check for any quick scanners attached to source files.
1607    my $dep;
1608    for $dep (@{$tgt->{dep}}, @{$tgt->{sources}}) {
1609	my($scanner) = $dep->{'srcscan',$self->{env}};
1610	if ($scanner) {
1611	    $sig .= $scanner->includes($tgt, $dep);
1612	}
1613    }
1614
1615    # XXX Optimize this to not use ignored paths.
1616    if (! exists $self->{_comsig}) {
1617	my($env) = $self->{env};
1618	$self->{_comsig} = '';
1619	my($com, $dir);
1620      com:
1621	for $com ($self->{act}->commands) {
1622	    my($pdirs) = $env->{ENV}->{PATH};
1623	    if (! defined $pdirs) {
1624		$pdirs = [ ];
1625	    } elsif (ref($pdirs) ne 'ARRAY') {
1626		$pdirs = [ split(/$main::PATH_SEPARATOR/o, $pdirs) ];
1627	    }
1628	    for $dir (map($dir::top->lookupdir($_), @$pdirs)) {
1629		my($prog) = $dir->lookup_accessible($com);
1630		if ($prog) { # XXX Not checking execute permission.
1631		    if ((build $prog) eq 'errors') {
1632			$tgt->{status} = 'errors';
1633			return $sig;
1634		    }
1635		    next com if $prog->ignore;
1636		    $self->{_comsig} .= 'sig'->signature($prog);
1637		    next com;
1638		}
1639	    }
1640	}
1641    }
1642
1643    return $self->{_comsig} . $sig
1644}
1645
1646
1647# Builder for a library module (archive).
1648# We assume that a user command might be built and implement the
1649# appropriate dependencies on the command itself.
1650package build::command::library;
1651
1652use vars qw( @ISA );
1653
1654BEGIN { @ISA = qw(build::command) }
1655
1656sub find {
1657    my($class, $env) = @_;
1658    bless find build::command($env, $env->{ARCOM})
1659}
1660
1661# Always compatible with other library builders, so the user
1662# can define a single library from multiple places.
1663sub compatible {
1664    my($self, $other) = @_;
1665    ref($other) eq "build::command::library";
1666}
1667
1668# A multi-target builder.
1669# This allows multiple targets to be associated with a single build
1670# script, without forcing all the code to be aware of multiple targets.
1671package build::multiple;
1672
1673sub new {
1674    my($class, $builder, $tgts) = @_;
1675    bless { 'builder' => $builder, 'env' => $builder->{env}, 'tgts' => $tgts };
1676}
1677
1678sub scriptsig {
1679    my($self, $tgt) = @_;
1680    $self->{builder}->scriptsig($tgt);
1681}
1682
1683sub includ

Large files files are truncated, but you can click here to view the full file