PageRenderTime 75ms CodeModel.GetById 29ms RepoModel.GetById 1ms app.codeStats 0ms

/quake3/trunk/code/unix/cons

#
Perl | 2233 lines | 1627 code | 230 blank | 376 comment | 248 complexity | df595a1e2f7398f2271e10cde70603d4 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.1, AGPL-3.0, AGPL-1.0, Unlicense

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

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

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