*** /usr/local/bin/cons-2.3.0 Tue May 29 23:30:34 2001 --- pcons-2.3.0 Thu Nov 8 11:00:40 2001 *************** *** 1,5 **** --- 1,18 ---- #!/usr/bin/env perl + + # + # Revision history: + # ----------------- + # July 2001, Thomas Gleerup + # 1) pcons-1.6 (John Erickson, August 1999) merged into cons-2.3.0. + # 2) Added automatic insertion of && for multi-line commands. + # + # September 2001, Thomas Gleerup + # 1) Updated with Kevin Nolish's multi-line improvement. + # 2) Improved this so that single [perl] commands can still be used. + # + # NOTE: Cons intentionally does not use the "perl -w" option or # "use strict." Because Cons "configuration files" are actually # Perl scripts, enabling those restrictions here would force them *************** *** 21,27 **** $ver_num = "2.3"; $ver_rev = ".0"; ! $version = "This is Cons $ver_num$ver_rev ($CVS_id)\n"; # Cons: A Software Construction Tool. # Copyright (c) 1996-2001 Free Software Foundation, Inc. --- 34,41 ---- $ver_num = "2.3"; $ver_rev = ".0"; ! #$version = "This is Cons $ver_num$ver_rev ($CVS_id)\n"; ! $version = "This is parallel Cons (pcons) $ver_num$ver_rev ($CVS_id)\n"; # Cons: A Software Construction Tool. # Copyright (c) 1996-2001 Free Software Foundation, Inc. *************** *** 185,191 **** by doing 'perldoc /path/to/cons'. ); ! # Simplify program name, if it is a path. { my ($vol, $dir, $file) = File::Spec->splitpath(File::Spec->canonpath($0)); --- 199,205 ---- by doing 'perldoc /path/to/cons'. ); ! my $pcons = 1; # Simplify program name, if it is a path. { my ($vol, $dir, $file) = File::Spec->splitpath(File::Spec->canonpath($0)); *************** *** 205,210 **** --- 219,225 ---- # w/files. $param::conscript_chdir = 0; # Change dir to Conscript directory $param::quiet = 0; # should we show the command being executed. + $param::max_jobs = 1; # pcons @param::defaults = (); *************** *** 241,246 **** --- 256,266 ---- 'PERL' => $^X, ); + # pcons does not allow multi-line commands + my $ar_command = ($param::max_jobs<=1) ? # pcons + ['%AR %ARFLAGS %> %<', '%RANLIB %>'] : # cons + '%AR %ARFLAGS %> %< && %RANLIB %>'; # pcons + %param::rulesets = ( # Defaults for Win32. *************** *** 268,273 **** --- 288,294 ---- 'LDFLAGS' => '/nologo ', 'PREFLIB' => '', ], + # Defaults for a typical (?) UNIX platform. # Your mileage may vary. 'unix' => [ *************** *** 286,292 **** 'LIBDIRSUFFIX' => '', 'AR' => 'ar', 'ARFLAGS' => 'r', # rs? ! 'ARCOM' => ['%AR %ARFLAGS %> %<', '%RANLIB %>'], 'RANLIB' => 'ranlib', 'AS' => 'as', 'ASFLAGS' => '', --- 307,313 ---- 'LIBDIRSUFFIX' => '', 'AR' => 'ar', 'ARFLAGS' => 'r', # rs? ! 'ARCOM' => $ar_command, # pcons 'RANLIB' => 'ranlib', 'AS' => 'as', 'ASFLAGS' => '', *************** *** 344,349 **** --- 365,371 ---- 'R' => sub { script::Repository($_[0]); }, 'S' => sub { $param::sigpro = $_[0]; }, 'wf' => sub { $param::depfile = $_[0]; }, + 'j' => sub { $param::max_jobs = $_[0]; }, # pcons ); if (defined $opt{$_}) { *************** *** 1104,1109 **** --- 1126,1132 ---- my $file; for $file (map($dir::cwd->lookup($_), @_)) { $file->{after_build_func} = $perl_eval_str; + } } *************** *** 1329,1335 **** return 1; } ! # Builder module for generic UNIX commands. package build::command; --- 1352,1358 ---- return 1; } ! # Builder module for generic UNIX commands. package build::command; *************** *** 1709,1716 **** # Now do the action to build all the targets. For consistency # we always call the action on the first target, just so that # $> is deterministic. ! $self->{built} = $self->{builder}->action($tgts->[0]); ! # Now "build" all the other targets (except for the one # we were called with). This guarantees that the signature # of each target is updated appropriately. We force the --- 1732,1748 ---- # Now do the action to build all the targets. For consistency # we always call the action on the first target, just so that # $> is deterministic. ! if ($param::max_jobs<=1) { # pcons ! $self->{built} = $self->{builder}->action($tgts->[0]); ! } else { ! { ! # action now is non-blocking, so we must kludge blocking for this ! # explicit call ! local( $file::child_queue ) = { parent => $tgts->[0] }; # pcons ! $self->{built} = $self->{builder}->action($tgts->[0]); # pcons ! &file::wait_on_all_children(); # pcons ! } ! } # Now "build" all the other targets (except for the one # we were called with). This guarantees that the signature # of each target is updated appropriately. We force the *************** *** 1767,1775 **** } my $self = { cmd => $cmd, cmdsig => 'sig'->cmdsig($sig) }; $cmd{$env,$cmd} = bless $self, $class; ! } } sub _strip { my $sig = shift; $sig =~ s/^\@\s*//mg; --- 1799,1810 ---- } my $self = { cmd => $cmd, cmdsig => 'sig'->cmdsig($sig) }; $cmd{$env,$cmd} = bless $self, $class; ! }; } + + + sub _strip { my $sig = shift; $sig =~ s/^\@\s*//mg; *************** *** 1926,1933 **** %ENV = %{$env->{ENV}}; # Handle multi-line commands. ! my $com; ! for $com ($self->getcoms($env, $tgt)) { if ($com !~ s/^\@\s*//) { main::showcom($com); } --- 1961,1979 ---- %ENV = %{$env->{ENV}}; # Handle multi-line commands. ! ! my @cmds = $self->getcoms($env, $tgt); # pcons ! if ($param::max_jobs>1) { # pcons ! if ($#cmds>0) { ! for( $i = 0; $i < @cmds; $i++ ) { #pcons -kn ! $cmds[$i] = "( " . $cmds[$i] . " )"; #pcons -kn ! } #pcons -kn ! @cmds = join(" && ", @cmds) ; # pcons ! } # pcons ! } # pcons ! ! my $com; # pcons ! for $com (@cmds) { # pcons if ($com !~ s/^\@\s*//) { main::showcom($com); } *************** *** 1958,1964 **** } next; } ! if (! $self->do_command($com, $tgt->path)) { return undef; } } --- 2004,2010 ---- } next; } ! if (! $self->do_command($com, $tgt->path, $tgt)) { return undef; } } *************** *** 1980,1986 **** package action::command::unix; sub do_command { ! my($class, $com, $path) = @_; my($pid) = fork(); die("$0: unable to fork child process ($!)\n") if !defined $pid; if (!$pid) { --- 2026,2037 ---- package action::command::unix; sub do_command { ! my($class, $com, $path) = @_; # cons ! my($class, $com, $path, $tgt) = @_; # pcons ! ! if ($param::max_jobs>1) { # pcons ! &file::wait_on_max_jobs(); # pcons ! } # pcons my($pid) = fork(); die("$0: unable to fork child process ($!)\n") if !defined $pid; if (!$pid) { *************** *** 1991,2023 **** die qq($0: failed to execute "$com" ($!). ) . qq(Is this an executable on path "$ENV{PATH}"?\n); } ! for (;;) { ! do {} until wait() == $pid; ! my ($b0, $b1) = ($? & 0xFF, $? >> 8); ! # Don't actually see 0177 on stopped process; is this necessary? ! next if $b0 == 0177; # process stopped; we can wait. ! if ($b0) { ! my($core, $sig) = ($b0 & 0200, $b0 & 0177); ! my($coremsg) = $core ? "; core dumped" : ""; ! $com =~ s/\s.*//; ! my $err = "$0: *** \[$path\] $com terminated by signal " . ! "$sig$coremsg\n"; ! warn $err; ! return undef; ! } ! if ($b1) { ! warn qq($0: *** [$path] Error $b1\n); # trying to be like make. ! return undef; } ! last; ! } return 1; } package action::command::win32; sub do_command { ! my($class, $com, $path) = @_; system($com); if ($?) { my ($b0, $b1) = ($? & 0xFF, $? >> 8); --- 2042,2081 ---- die qq($0: failed to execute "$com" ($!). ) . qq(Is this an executable on path "$ENV{PATH}"?\n); } ! if ($param::max_jobs<=1) { # pcons ! for (;;) { ! do {} until wait() == $pid; ! my ($b0, $b1) = ($? & 0xFF, $? >> 8); ! # Don't actually see 0177 on stopped process; is this necessary? ! next if $b0 == 0177; # process stopped; we can wait. ! if ($b0) { ! my($core, $sig) = ($b0 & 0200, $b0 & 0177); ! my($coremsg) = $core ? "; core dumped" : ""; ! $com =~ s/\s.*//; ! my $err = "$0: *** \[$path\] $com terminated by signal " . ! "$sig$coremsg\n"; ! warn $err; ! return undef; ! } ! if ($b1) { ! warn qq($0: *** [$path] Error $b1\n); # trying to be like make. ! return undef; ! } ! last; } ! } else { # pcons ! $file::child_queue->{$pid}->{com} = $com; # pcons ! $file::child_queue->{$pid}->{tgt} = $tgt; # pcons ! ! } # pcons ! return 1; } package action::command::win32; sub do_command { ! my($class, $com, $path, $tgt) = @_; system($com); if ($?) { my ($b0, $b1) = ($? & 0xFF, $? >> 8); *************** *** 3051,3056 **** --- 3109,3115 ---- return $_[0]->{status} if $_[0]->{status}; my($status) = &file::_build; if ($_[0]->{after_build_func}) { + #print STDERR "DEBUG: after_build_func=$_[0]->{after_build_func}\n"; my($pkgvars) = $_[0]->{conscript}->{pkgvars}; NameSpace::restore('script', $pkgvars) if $pkgvars; eval("package script; " . $_[0]->{after_build_func}); *************** *** 3061,3069 **** } sub _build { my($self) = @_; ! print main::DEPFILE $self->path, "\n" if $param::depfile; ! print((' ' x $level), "Checking ", $self->path, "\n") if $param::depends; if (!exists $self->{builder}) { # We don't know how to build the file. This is OK, if # the file is present as a source file, under either the --- 3120,3270 ---- } sub _build { + my @args = @_; + + if ($param::max_jobs<=1) { # pcons + my($self) = @args; + print main::DEPFILE $self->path, "\n" if $param::depfile; + print((' ' x $level), "Checking ", $self->path, "\n") if $param::depends; + if (!exists $self->{builder}) { + # We don't know how to build the file. This is OK, if + # the file is present as a source file, under either the + # local tree or a Repository. + if ($self->source_exists) { + return $self->{status} = 'handled'; + } else { + my($name) = $self->path; + print("$0: don't know how to construct \"$name\"\n"); + exit(1) unless $param::kflag; + return $self->{status} = 'errors'; # xxx used to be 'unknown' + } + } + # An associated build object exists, so we know how to build + # the file. We first compute the signature of the file, based + # on its dependendencies, then only rebuild the file if the + # signature has changed. + my($builder) = $self->{builder}; + $level += 2; + + my(@deps) = (@{$self->{dep}}, @{$self->{sources}}); + my($rdeps) = \@deps; + + if ($param::random) { + # If requested, build in a random order, instead of the + # order that the dependencies were listed. + my(%rdeps); + map { $rdeps{$_,'*' x int(rand 10)} = $_ } @deps; + $rdeps = [values(%rdeps)]; + } + + $self->{status} = ''; + + my $dep; + for $dep (@$rdeps) { + if ((build $dep) eq 'errors') { + # Propagate dependent errors to target. + # but try to build all dependents regardless of errors. + $self->{status} = 'errors'; + } + } + + # If any dependents had errors, then we abort. + if ($self->{status} eq 'errors') { + $level -= 2; + return 'errors'; + } + + # Compute the final signature of the file, based on + # the static dependencies (in order), dynamic dependencies, + # output path name, and (non-substituted) build script. + my($sig) = 'sig'->collect(map('sig'->signature($_->rfile), @deps), + $builder->includes($self), + $builder->scriptsig); + + # May have gotten errors during computation of dynamic + # dependency signature, above. + $level -= 2; + return 'errors' if $self->{status} eq 'errors'; + + if (@param::rpath && $self->derived_exists) { + # There is no local file of this name, but there is one + # under a Repository directory. + + if ('sig'->current($self->rfile, $sig)) { + # The Repository copy is current (its signature matches + # our calculated signature). + if ($self->local) { + # ...but they want a local copy, so provide it. + main::showcom("Local copy of ${\$self->path} from " . + "${\$self->rpath}"); + futil::install($self->rpath, $self); + 'sig'->bsig($self, $sig); + } + return $self->{status} = 'handled'; + } + + # The signatures don't match, implicitly because something + # on which we depend exists locally. Get rid of the reference + # to the Repository file; we'll build this (and anything that + # depends on it) locally. + $self->no_rfile; + } + + # Then check for currency. + if (! 'sig'->current($self, $sig)) { + # We have to build/derive the file. + print((' ' x $level), "Rebuilding ", $self->path, ": out of date.\n") + if $param::depends; + # First check to see if the built file is cached. + if ($builder->cachin($self, $sig)) { + 'sig'->bsig($self, $sig); + return $self->{status} = 'built'; + } elsif ($builder->action($self)) { + $builder->cachout($self, $sig); + 'sig'->bsig($self, $sig); + return $self->{status} = 'built'; + } else { + die("$0: errors constructing ${\$self->path}\n") + unless $param::kflag; + return $self->{status} = 'errors'; + } + } else { + # Push this out to the cache if we've been asked to (-C option). + # Don't normally do this because it slows us down. + # In a fully built system, no accesses to the cache directory + # are required to check any files. This is a win if cache is + # heavily shared. Enabling this option puts the directory in the + # loop. Useful only when you wish to recreate a cache from a build. + if ($param::cachesync) { + $builder->cachout($self, $sig); + 'sig'->bsig($self, $sig); + } + return $self->{status} = 'handled'; + } + } else { # pcons + my($tgt) = @args; # pcons + local( $file::child_queue ) = { parent => $tgt }; # pcons + _pbuild( $tgt ); # pcons + wait_on_all_children(); # pcons + return $tgt->{status}; # pcons + } + } + + + + ######################################## + # pcons only BEGIN + # + + sub pbuild { + $_[0]->{status} || &file::_pbuild; + } + + sub _pbuild { my($self) = @_; ! $self->{status} = ''; # tgl ! print main::DEPFILE $self->path, "\n" if param::depfile; ! print((' ' x $level), $self->path, "\n") if $param::depends; if (!exists $self->{builder}) { # We don't know how to build the file. This is OK, if # the file is present as a source file, under either the *************** *** 3082,3088 **** # the file. We first compute the signature of the file, based # on its dependendencies, then only rebuild the file if the # signature has changed. ! my($builder) = $self->{builder}; $level += 2; my(@deps) = (@{$self->{dep}}, @{$self->{sources}}); --- 3283,3289 ---- # the file. We first compute the signature of the file, based # on its dependendencies, then only rebuild the file if the # signature has changed. ! my($builder) = $self->{'builder'}; $level += 2; my(@deps) = (@{$self->{dep}}, @{$self->{sources}}); *************** *** 3092,3114 **** # If requested, build in a random order, instead of the # order that the dependencies were listed. my(%rdeps); ! map { $rdeps{$_,'*' x int(rand 10)} = $_ } @deps; $rdeps = [values(%rdeps)]; } $self->{status} = ''; ! my $dep; ! for $dep (@$rdeps) { ! if ((build $dep) eq 'errors') { ! # Propagate dependent errors to target. ! # but try to build all dependents regardless of errors. ! $self->{status} = 'errors'; } ! } # If any dependents had errors, then we abort. ! if ($self->{status} eq 'errors') { $level -= 2; return 'errors'; } --- 3293,3321 ---- # If requested, build in a random order, instead of the # order that the dependencies were listed. my(%rdeps); ! # FIX map { $rdeps{$_,'*' x int(rand(0,10))} = $_ } @deps; ! map { $rdeps{$_,'*' x int(rand(10))} = $_ } @deps; $rdeps = [values(%rdeps)]; } $self->{status} = ''; ! my $sig; ! { ! # print "in ", $self->path, "\n"; ! local( $file::child_queue ) = { parent => $self }; ! for my $dep (@$rdeps) { ! if ((pbuild $dep) eq 'errors') { ! # Propagate dependent errors to target. ! # but try to build all dependents regardless of errors. ! $self->{status} = 'errors'; ! } } ! wait_on_all_children(); + } # If any dependents had errors, then we abort. ! if ($self->{'status'} eq 'errors') { $level -= 2; return 'errors'; } *************** *** 3116,3124 **** # Compute the final signature of the file, based on # the static dependencies (in order), dynamic dependencies, # output path name, and (non-substituted) build script. ! my($sig) = 'sig'->collect(map('sig'->signature($_->rfile), @deps), ! $builder->includes($self), ! $builder->scriptsig); # May have gotten errors during computation of dynamic # dependency signature, above. --- 3323,3338 ---- # Compute the final signature of the file, based on # the static dependencies (in order), dynamic dependencies, # output path name, and (non-substituted) build script. ! ! # my($sig) = $self->{'sign'} = sig->collect(map(sig->signature($_->rfile), @deps), ! # $builder->includes($self), ! ## FIX $builder->script); ! # $builder->scriptsig); ! ! my($sig) = 'sig'->collect(map('sig'->signature($_->rfile), @deps), # from cons-2.3.0 ! $builder->includes($self), # from cons-2.3.0 ! $builder->scriptsig); # from cons-2.3.0 ! $self->{sign} = $sig; # May have gotten errors during computation of dynamic # dependency signature, above. *************** *** 3134,3143 **** # our calculated signature). if ($self->local) { # ...but they want a local copy, so provide it. ! main::showcom("Local copy of ${\$self->path} from " . ! "${\$self->rpath}"); futil::install($self->rpath, $self); ! 'sig'->bsig($self, $sig); } return $self->{status} = 'handled'; } --- 3348,3357 ---- # our calculated signature). if ($self->local) { # ...but they want a local copy, so provide it. ! main::showcom("Local copy of ${\$self->path} from ${\$self->rpath}"); futil::install($self->rpath, $self); ! #'sig'->set($self, $sig); ! 'sig'->bsig($self, $sig); # pcons } return $self->{status} = 'handled'; } *************** *** 3152,3170 **** # Then check for currency. if (! 'sig'->current($self, $sig)) { # We have to build/derive the file. - print((' ' x $level), "Rebuilding ", $self->path, ": out of date.\n") - if $param::depends; # First check to see if the built file is cached. if ($builder->cachin($self, $sig)) { ! 'sig'->bsig($self, $sig); ! return $self->{status} = 'built'; } elsif ($builder->action($self)) { $builder->cachout($self, $sig); ! 'sig'->bsig($self, $sig); return $self->{status} = 'built'; } else { ! die("$0: errors constructing ${\$self->path}\n") ! unless $param::kflag; return $self->{status} = 'errors'; } } else { --- 3366,3389 ---- # Then check for currency. if (! 'sig'->current($self, $sig)) { # We have to build/derive the file. # First check to see if the built file is cached. if ($builder->cachin($self, $sig)) { ! #'sig'->set($self, $sig); ! 'sig'->bsig($self, $sig); # pcons ! return $self->{status} = 'built'; ! ! # action no longer blocks (for most actions), so this returns ! # immediately, before any commands are actually run. The ! # signature and return status should be overridden later in ! # wait_on_child if a process was forked, but they are still set ! # here in case a non-spawning action was called } elsif ($builder->action($self)) { $builder->cachout($self, $sig); ! #'sig'->set($self, $sig); ! 'sig'->bsig($self, $sig); # pcons return $self->{status} = 'built'; } else { ! die("$0: errors constructing ${\$self->path}\n") unless $param::kflag; return $self->{status} = 'errors'; } } else { *************** *** 3176,3187 **** --- 3395,3495 ---- # loop. Useful only when you wish to recreate a cache from a build. if ($param::cachesync) { $builder->cachout($self, $sig); + #'sig'->set($self, $sig); 'sig'->bsig($self, $sig); } return $self->{status} = 'handled'; } } + my @finished; # pcons //fix -Mstrict + + sub wait_on_max_jobs { + while( grep( /\d+/, keys %{$file::child_queue} ) >= $param::max_jobs ) { + wait_on_child(); + } + } + + sub wait_on_all_children { + + while( grep( /\d+/, keys %{$file::child_queue} ) != 0 ) { + wait_on_child(); + } + } + + sub wait_on_child { + my( $queue ) = $file::child_queue; + my( $parent ) = $queue->{parent}; + + my $n=grep( /\d+/, keys %{$file::child_queue} ); + # printf "Waiting to build (%s): %s\n", $n, $parent->path if ref($parent) eq 'file'; + my $pid = undef; + + # first check for jobs that have already been collected from child + # targets + for my $p ( @finished ) { + if( $queue->{$p} ) { + $pid = $p; + last; + } + } + + while( !$queue->{$pid} ) { + $pid = wait(); + if( $pid < 1 ) { + die "wait returned invalid pid $pid"; + } else { + # this job was meant for a parent, save it so that it can be + # found later + if( !$queue->{$pid} ) { + push @finished, $pid; + } + } + } + + + + my $child = $queue->{$pid}; + my $tgt = $queue->{$pid}->{'tgt'}; + my $com = $child->{'com'}; + $tgt->{status} = 'built'; + #print "waited: ", $tgt->path; + #print "on: ", keys %{$queue}, "\n"; + + my($b0, $b1 ) = ($? & 0xFF, $? >> 8); + # Don't actually see 0177 on stopped process; is this necessary? + # next if $b0 == 0177; # process stopped; we can wait. + if ($b0) { + my($core, $sig) = ($b0 & 0200, $b0 & 0177); + my($coremsg) = $core ? "; core dumped" : ""; + $com =~ s/\s.*//; + my($path) = $tgt->path; + warn qq($0: *** [$path] $com terminated by signal $sig$coremsg\n); + $parent->{status} = $tgt->{status} = 'errors'; + } + if ($b1) { + my($path) = $tgt->path; + warn qq($0: *** [$path] Error $b1\n); # trying to be like make. + $parent->{status} = $tgt->{status} = 'errors'; + } + if( $tgt->{status} eq 'built' ) { + $tgt->{builder}->cachout($tgt, $tgt->{sign}); + #'sig'->set($tgt, $tgt->{sign}); + 'sig'->bsig($tgt, $tgt->{sign}); + } else { + die("$0: errors constructing ${\$tgt->path}\n") unless $param::kflag; + } + delete $queue->{$pid}; + + } + + # + # pcons END + ######################################## + + + + # Bind an action to a file, with the specified sources. No return value. sub bind { my($self, $builder, @sources) = @_; *************** *** 3296,3302 **** } return $_[0]->{stored}; } ! # Generic entry (file or directory) handling. # This is an empty subclass for nodes that haven't # quite decided whether they're files or dirs. --- 3604,3610 ---- } return $_[0]->{stored}; } ! # Generic entry (file or directory) handling. # This is an empty subclass for nodes that haven't # quite decided whether they're files or dirs. *************** *** 3306,3312 **** use vars qw( @ISA ); BEGIN { @ISA = qw(file) } ! # File utilities package futil; --- 3614,3620 ---- use vars qw( @ISA ); BEGIN { @ISA = qw(file) } ! # File utilities package futil;