Rev 217 | Blame | Compare with Previous | Last modification | View Log | RSS feed
package WorkspaceCreator;
# ************************************************************
# Description : Base class for all workspace creators
# Author : Chad Elliott
# Create Date : 5/13/2002
# ************************************************************
# ************************************************************
# Pragmas
# ************************************************************
use strict;
use FileHandle;
use File::Path;
use File::Compare;
use Creator;
use Options;
use vars qw(@ISA);
@ISA = qw(Creator Options);
# ************************************************************
# Data Section
# ************************************************************
my($wsext) = 'mwc';
my($wsbase) = 'mwb';
## Valid names for assignments within a workspace
my(%validNames) = ('cmdline' => 1,
'implicit' => 1,
);
## Singleton hash maps of project information
my(%allprinfo) = ();
my(%allprojects) = ();
my(%allliblocs) = ();
## Global previous workspace names
my(%previous_workspace_name) = ();
## Constant aggregated workspace type name
my($aggregated) = 'aggregated_workspace';
# ************************************************************
# Subroutine Section
# ************************************************************
sub new {
my($class) = shift;
my($global) = shift;
my($inc) = shift;
my($template) = shift;
my($ti) = shift;
my($dynamic) = shift;
my($static) = shift;
my($relative) = shift;
my($addtemp) = shift;
my($addproj) = shift;
my($progress) = shift;
my($toplevel) = shift;
my($baseprojs) = shift;
my($gfeature) = shift;
my($feature) = shift;
my($features) = shift;
my($hierarchy) = shift;
my($exclude) = shift;
my($makeco) = shift;
my($nmod) = shift;
my($applypj) = shift;
my($genins) = shift;
my($into) = shift;
my($language) = shift;
my($use_env) = shift;
my($expandvars) = shift;
my($self) = Creator::new($class, $global, $inc,
$template, $ti, $dynamic, $static,
$relative, $addtemp, $addproj,
$progress, $toplevel, $baseprojs,
$feature, $features,
$hierarchy, $nmod, $applypj,
$into, $language, $use_env, $expandvars,
'workspace');
$self->{'workspace_name'} = undef;
$self->{$self->{'type_check'}} = 0;
$self->{'projects'} = [];
$self->{'project_info'} = {};
$self->{'lib_locations'} = {};
$self->{'reading_parent'} = [];
$self->{'project_files'} = [];
$self->{'scoped_assign'} = {};
$self->{'cacheok'} = 1;
$self->{'exclude'} = {};
$self->{'wctype'} = $self->extractType("$self");
$self->{'modified_count'} = 0;
$self->{'global_feature_file'} = $gfeature;
$self->{'coexistence'} = $makeco;
$self->{'project_file_list'} = {};
$self->{'ordering_cache'} = {};
$self->{'handled_scopes'} = {};
$self->{'generate_ins'} = $genins;
$self->{'scoped_basedir'} = undef;
if (defined $$exclude[0]) {
my($type) = $self->{'wctype'};
if (!defined $self->{'exclude'}->{$type}) {
$self->{'exclude'}->{$type} = [];
}
push(@{$self->{'exclude'}->{$type}}, @$exclude);
}
## Add a hash reference for our workspace type
if (!defined $previous_workspace_name{$self->{'wctype'}}) {
$previous_workspace_name{$self->{'wctype'}} = {};
}
## Warn users about unnecessary options
if ($self->get_hierarchy() && $self->workspace_per_project()) {
$self->warning("The -hierarchy option is unnecessary " .
"for the " . $self->{'wctype'} . " type.");
}
if ($self->make_coexistence() && !$self->supports_make_coexistence()) {
$self->warning("Using the -make_coexistence option has " .
"no effect on the " . $self->{'wctype'} . " type.");
}
return $self;
}
sub modify_assignment_value {
my($self) = shift;
my($name) = shift;
my($value) = shift;
## Workspace assignments do not need modification.
return $value;
}
sub parse_line {
my($self) = shift;
my($ih) = shift;
my($line) = shift;
my($status, $error, @values) = $self->parse_known($line);
## Was the line recognized?
if ($status && defined $values[0]) {
if ($values[0] eq $self->{'grammar_type'}) {
my($name) = $values[1];
if (defined $name && $name eq '}') {
if (!defined $self->{'reading_parent'}->[0]) {
## Fill in all the default values
$self->generate_defaults();
## End of workspace; Have subclass write out the file
## Generate the project files
my($gstat, $creator, $err) = $self->generate_project_files();
if ($gstat) {
($status, $error) = $self->write_workspace($creator, 1);
$self->{'assign'} = {};
}
else {
$error = $err;
$status = 0;
}
$self->{'modified_count'} = 0;
$self->{'workspace_name'} = undef;
$self->{'projects'} = [];
$self->{'project_info'} = {};
$self->{'project_files'} = [];
}
$self->{$self->{'type_check'}} = 0;
}
else {
## Workspace Beginning
## Deal with the inheritance hiearchy first
if (defined $values[2]) {
foreach my $parent (@{$values[2]}) {
## Read in the parent onto ourself
my($file) = $self->search_include_path("$parent.$wsbase");
if (!defined $file) {
$file = $self->search_include_path("$parent.$wsext");
}
if (defined $file) {
push(@{$self->{'reading_parent'}}, 1);
$status = $self->parse_file($file);
pop(@{$self->{'reading_parent'}});
if (!$status) {
$error = "Invalid parent: $parent";
}
}
else {
$status = 0;
$error = "Unable to locate parent: $parent";
}
}
}
## Set up some initial values
if (defined $name) {
if ($name =~ /[\/\\]/) {
$status = 0;
$error = 'Workspaces can not have a slash ' .
'or a back slash in the name';
}
else {
$name =~ s/^\(\s*//;
$name =~ s/\s*\)$//;
## Replace any *'s with the default name
if (index($name, '*') >= 0) {
$name = $self->fill_type_name(
$name,
$self->get_default_workspace_name());
}
$self->{'workspace_name'} = $name;
}
}
$self->{$self->{'type_check'}} = 1;
}
}
elsif ($values[0] eq '=') {
if (defined $validNames{$values[1]}) {
$self->process_assignment($values[1], $values[2]);
}
else {
$error = "Invalid assignment name: $values[1]";
$status = 0;
}
}
elsif ($values[0] eq '+=') {
if (defined $validNames{$values[1]}) {
$self->process_assignment_add($values[1], $values[2]);
}
else {
$error = "Invalid addition name: $values[1]";
$status = 0;
}
}
elsif ($values[0] eq '-=') {
if (defined $validNames{$values[1]}) {
$self->process_assignment_sub($values[1], $values[2]);
}
else {
$error = "Invalid subtraction name: $values[1]";
$status = 0;
}
}
elsif ($values[0] eq 'component') {
($status, $error) = $self->parse_scope($ih,
$values[1],
$values[2],
\%validNames);
}
else {
$error = "Unrecognized line: $line";
$status = 0;
}
}
elsif ($status == -1) {
foreach my $expfile ($line =~ /[\?\*\[\]]/ ? $self->mpc_glob($line) :
$line) {
if ($expfile =~ /\.$wsext$/) {
($status, $error) = $self->aggregated_workspace($expfile);
last if (!$status);
}
else {
push(@{$self->{'project_files'}}, $expfile);
$status = 1;
}
}
}
return $status, $error;
}
sub aggregated_workspace {
my($self) = shift;
my($file) = shift;
my($fh) = new FileHandle();
if (open($fh, $file)) {
my($oline) = $self->get_line_number();
my($tc) = $self->{$self->{'type_check'}};
my($ag) = $self->{'handled_scopes'}->{$aggregated};
my($psbd) = $self->{'scoped_basedir'};
my($status, $error, @values) = (0, 'No recognizable lines');
$self->{'handled_scopes'}->{$aggregated} = undef;
$self->set_line_number(0);
$self->{$self->{'type_check'}} = 0;
$self->{'scoped_basedir'} = $self->mpc_dirname($file);
while(<$fh>) {
my($line) = $self->preprocess_line($fh, $_);
($status, $error, @values) = $self->parse_known($line);
## Was the line recognized?
if ($status) {
if (defined $values[0]) {
if ($values[0] eq $self->{'grammar_type'}) {
if (defined $values[2]) {
my($name) = $self->mpc_basename($file);
$name =~ s/\.[^\.]+$//;
$status = 0;
$error = 'Aggregated workspace (' . $name .
') can not inherit from another workspace';
}
else {
($status, $error) = $self->parse_scope($fh,
'',
$aggregated,
\%validNames);
}
}
else {
$status = 0;
$error = 'Unable to aggregate ' . $file;
}
last;
}
}
else {
last;
}
}
close($fh);
$self->{'scoped_basedir'} = $psbd;
$self->{'handled_scopes'}->{$aggregated} = $ag;
$self->{$self->{'type_check'}} = $tc;
$self->set_line_number($oline);
return $status, $error;
}
return 0, 'Unable to open ' . $file;
}
sub parse_scope {
my($self) = shift;
my($fh) = shift;
my($name) = shift;
my($type) = shift;
my($validNames) = shift;
my($flags) = shift;
my($elseflags) = shift;
if ($name eq 'exclude') {
return $self->parse_exclude($fh, $type);
}
else {
## We need to make a copy of the current assignment hash
## to ensure that multiply scoped assignments/additions/subtractions
## work and contain the non-scoped assignments/additions/subtractions
if (!defined $flags) {
my(%copy) = %{$self->get_assignment_hash()};
$flags = \%copy;
}
return $self->SUPER::parse_scope($fh, $name, $type,
$validNames, $flags, $elseflags);
}
}
sub parse_exclude {
my($self) = shift;
my($fh) = shift;
my($typestr) = shift;
my($status) = 0;
my($errorString) = 'Unable to process exclude';
my($negated) = undef;
if ($typestr eq $self->get_default_component_name()) {
$typestr = $self->{'wctype'};
}
my(@exclude) = ();
my(%types) = ();
@types{split(/\s*,\s*/, $typestr)} = ();
## If there is a negation at all, add our
## current type, it may be removed below
if (index($typestr, '!') >= 0) {
$negated = 1;
$types{$self->{wctype}} = 1;
## Process negated exclusions
foreach my $key (keys %types) {
if ($key =~ /^!\s*(\w+)/) {
## Remove the negated key
delete $types{$key};
## Then delete the key that was negated in the exclusion.
delete $types{$1};
}
}
}
if (exists $types{$self->{wctype}}) {
while(<$fh>) {
my($line) = $self->preprocess_line($fh, $_);
if ($line eq '') {
}
elsif ($line =~ /^}(.*)$/) {
if (defined $1 && $1 ne '') {
$status = 0;
$errorString = "Trailing characters found: '$1'";
}
else {
$status = 1;
$errorString = undef;
}
last;
}
else {
if ($line =~ /^"([^"]+)"$/) {
$line = $1;
}
if (defined $self->{'scoped_basedir'}) {
$line = $self->{'scoped_basedir'} . '/' . $line;
}
if ($line =~ /[\?\*\[\]]/) {
push(@exclude, $self->mpc_glob($line));
}
else {
push(@exclude, $line);
}
}
}
foreach my $type (keys %types) {
if (!defined $self->{'exclude'}->{$type}) {
$self->{'exclude'}->{$type} = [];
}
push(@{$self->{'exclude'}->{$type}}, @exclude);
}
}
else {
if ($negated) {
($status, $errorString) = $self->SUPER::parse_scope($fh,
'exclude',
$typestr,
\%validNames);
}
else {
## If this exclude block didn't match the current type and the
## exclude wasn't negated, we need to eat the exclude block so that
## these lines don't get included into the workspace.
while(<$fh>) {
my($line) = $self->preprocess_line($fh, $_);
if ($line =~ /^}(.*)$/) {
if (defined $1 && $1 ne '') {
$status = 0;
$errorString = "Trailing characters found: '$1'";
}
else {
$status = 1;
$errorString = undef;
}
last;
}
}
}
}
return $status, $errorString;
}
sub excluded {
my($self) = shift;
my($file) = shift;
foreach my $excluded (@{$self->{'exclude'}->{$self->{'wctype'}}}) {
if ($excluded eq $file || index($file, "$excluded/") == 0) {
return 1;
}
}
return 0;
}
sub handle_scoped_end {
my($self) = shift;
my($type) = shift;
my($flags) = shift;
my($status) = 1;
my($error) = undef;
if ($type eq $aggregated &&
!defined $self->{'handled_scopes'}->{$type}) {
## Replace instances of $PWD with the current directory plus the
## scoped_basedir. We have to do it now otherwise, $PWD will be the
## wrong directory if it's done later.
if (defined $$flags{'cmdline'}) {
my($dir) = $self->getcwd() . '/' . $self->{'scoped_basedir'};
$$flags{'cmdline'} =~ s/\$PWD(\W)/$dir$1/g;
$$flags{'cmdline'} =~ s/\$PWD$/$dir/;
}
## Go back to the previous directory and add the directory contents
($status, $error) = $self->handle_scoped_unknown(undef, $type, $flags, '.');
}
$self->{'handled_scopes'}->{$type} = undef;
return $status, $error;
}
sub handle_scoped_unknown {
my($self) = shift;
my($fh) = shift;
my($type) = shift;
my($flags) = shift;
my($line) = shift;
my($status) = 1;
my($error) = undef;
my($dupchk) = undef;
if ($line =~ /^\w+.*{/) {
if (defined $fh) {
my(@values) = ();
my($tc) = $self->{$self->{'type_check'}};
$self->{$self->{'type_check'}} = 1;
($status, $error, @values) = $self->parse_line($fh, $line);
$self->{$self->{'type_check'}} = $tc;
}
else {
$status = 0;
$error = 'Unhandled line: ' . $line;
}
return $status, $error;
}
if ($type eq $aggregated) {
$line = $self->{'scoped_basedir'} . ($line ne '.' ? "/$line" : '');
my(%dup) = ();
@dup{@{$self->{'project_files'}}} = ();
$dupchk = \%dup;
}
if (-d $line) {
my(@files) = ();
$self->search_for_files([ $line ], \@files, $$flags{'implicit'});
## If we are generating implicit projects within a scope, then
## we need to remove directories and the parent directories for which
## there is an mpc file. Otherwise, the projects will be added
## twice.
if ($$flags{'implicit'}) {
my(%remove) = ();
foreach my $file (@files) {
if ($file =~ /\.mpc$/) {
my($exc) = $file;
do {
$exc = $self->mpc_dirname($exc);
$remove{$exc} = 1;
} while($exc ne '.' && $exc !~ /[a-z]:[\/\\]/i);
}
}
my(@acceptable) = ();
foreach my $file (@files) {
if (!defined $remove{$file}) {
push(@acceptable, $file);
}
}
@files = @acceptable;
}
foreach my $file (@files) {
if (!$self->excluded($file)) {
if (defined $dupchk && exists $$dupchk{$file}) {
$self->warning("Duplicate mpc file ($file) added by an " .
'aggregate workspace. It will be ignored.');
}
else {
$self->{'scoped_assign'}->{$file} = $flags;
push(@{$self->{'project_files'}}, $file);
}
}
}
}
else {
foreach my $expfile ($line =~ /[\?\*\[\]]/ ? $self->mpc_glob($line) :
$line) {
if ($expfile =~ /\.$wsext$/) {
## An aggregated workspace within an aggregated workspace.
($status, $error) = $self->aggregated_workspace($expfile);
last if (!$status);
}
else {
if (!$self->excluded($expfile)) {
if (defined $dupchk && exists $$dupchk{$expfile}) {
$self->warning("Duplicate mpc file ($expfile) added by an " .
'aggregate workspace. It will be ignored.');
}
else {
$self->{'scoped_assign'}->{$expfile} = $flags;
push(@{$self->{'project_files'}}, $expfile);
}
}
}
}
}
$self->{'handled_scopes'}->{$type} = 1;
return $status, $error;
}
sub search_for_files {
my($self) = shift;
my($files) = shift;
my($array) = shift;
my($impl) = shift;
my($excluded) = 0;
foreach my $file (@$files) {
if (-d $file) {
my(@f) = $self->generate_default_file_list(
$file,
$self->{'exclude'}->{$self->{'wctype'}},
\$excluded);
$self->search_for_files(\@f, $array, $impl);
if ($impl) {
$file =~ s/^\.\///;
unshift(@$array, $file);
}
}
else {
if ($file =~ /\.mpc$/) {
$file =~ s/^\.\///;
unshift(@$array, $file);
}
}
}
return $excluded;
}
sub remove_duplicate_projects {
my($self) = shift;
my($list) = shift;
my($count) = scalar(@$list);
for(my $i = 0; $i < $count; ++$i) {
my($file) = $$list[$i];
foreach my $inner (@$list) {
if ($file ne $inner &&
$file eq $self->mpc_dirname($inner) && ! -d $inner) {
splice(@$list, $i, 1);
--$count;
--$i;
last;
}
}
}
}
sub generate_default_components {
my($self) = shift;
my($files) = shift;
my($impl) = shift;
my($excluded) = shift;
my($pjf) = $self->{'project_files'};
if (defined $$pjf[0]) {
## If we have files, then process directories
my(@built) = ();
foreach my $file (@$pjf) {
if (!$self->excluded($file)) {
if (-d $file) {
my(@found) = ();
my(@gen) = $self->generate_default_file_list(
$file,
$self->{'exclude'}->{$self->{'wctype'}});
$self->search_for_files(\@gen, \@found, $impl);
push(@built, @found);
if ($impl || $self->{'scoped_assign'}->{$file}->{'implicit'}) {
push(@built, $file);
}
}
else {
push(@built, $file);
}
}
}
## If the workspace is set to implicit
if ($impl) {
## Remove duplicates from this list
$self->remove_duplicate_projects(\@built);
}
## Set the project files
$self->{'project_files'} = \@built;
}
else {
## Add all of the wanted files in this directory
## and in the subdirectories.
$excluded |= $self->search_for_files($files, $pjf, $impl);
## If the workspace is set to implicit
if ($impl) {
## Remove duplicates from this list
$self->remove_duplicate_projects($pjf);
}
## If no files were found, then we push the empty
## string, so the Project Creator will generate
## the default project file.
if (!defined $$pjf[0] && !$excluded) {
push(@$pjf, '');
}
}
}
sub get_default_workspace_name {
my($self) = shift;
my($name) = $self->{'current_input'};
if ($name eq '') {
$name = $self->base_directory();
}
else {
## Since files on UNIX can have back slashes, we transform them
## into underscores.
$name =~ s/\\/_/g;
## Take off the extension
$name =~ s/\.[^\.]+$//;
}
return $name;
}
sub generate_defaults {
my($self) = shift;
## Generate default workspace name
if (!defined $self->{'workspace_name'}) {
$self->{'workspace_name'} = $self->get_default_workspace_name();
}
## Modify the exclude list if we have changed directory from the original
## starting directory. Just take off the difference from the front.
my(@original) = ();
my($top) = $self->getcwd() . '/';
my($start) = $self->getstartdir() . '/';
if ($start ne $top && $top =~ s/^$start//) {
foreach my $exclude (@{$self->{'exclude'}->{$self->{'wctype'}}}) {
push(@original, $exclude);
$exclude =~ s/^$top//;
}
}
my($excluded) = 0;
my(@files) = $self->generate_default_file_list(
'.',
$self->{'exclude'}->{$self->{'wctype'}},
\$excluded);
## Generate default components
$self->generate_default_components(\@files,
$self->get_assignment('implicit'),
$excluded);
## Return the actual exclude list of we modified it
if (defined $original[0]) {
$self->{'exclude'}->{$self->{'wctype'}} = \@original;
}
}
sub get_workspace_name {
my($self) = shift;
return $self->{'workspace_name'};
}
sub get_current_output_name {
my($self) = shift;
return $self->{'current_output'};
}
sub write_workspace {
my($self) = shift;
my($creator) = shift;
my($addfile) = shift;
my($status) = 1;
my($error) = undef;
my($duplicates) = 0;
if ($self->get_toplevel()) {
my($progress) = $self->get_progress_callback();
if (defined $progress) {
&$progress();
}
if ($addfile) {
## To be consistent across multiple project types, we disallow
## duplicate project names for all types, not just VC6.
## Note that these name are handled case-insensitive by VC6
my(%names) = ();
foreach my $project (@{$self->{'projects'}}) {
my($name) = lc($self->{'project_info'}->{$project}->[0]);
if (defined $names{$name}) {
++$duplicates;
$self->error("Duplicate case-insensitive project '$name'. " .
"Look in " . $self->mpc_dirname($project) .
" and " . $self->mpc_dirname($names{$name}) .
" for project name conflicts.");
}
else {
$names{$name} = $project;
}
}
}
else {
$self->{'per_project_workspace_name'} = 1;
}
my($name) = $self->transform_file_name($self->workspace_file_name());
my($outdir) = $self->get_outdir();
my($oname) = $name;
$name = "$outdir/$name";
my($abort_creation) = 0;
if ($duplicates > 0) {
$abort_creation = 1;
$error = "Duplicate case-insensitive project names are " .
"not allowed within a workspace.";
$status = 0;
}
else {
if (!defined $self->{'projects'}->[0]) {
$self->information('No projects were created.');
$abort_creation = 1;
}
}
if (!$abort_creation) {
my($fh) = new FileHandle();
my($dir) = $self->mpc_dirname($name);
## Verify and possibly modify the dependencies
if ($addfile) {
$self->verify_build_ordering();
}
if ($dir ne '.') {
mkpath($dir, 0, 0777);
}
if ($addfile || !$self->file_written($name)) {
$self->{'current_output'} = $name;
if ($self->compare_output()) {
## First write the output to a temporary file
my($tmp) = "$outdir/MWC$>.$$";
my($different) = 1;
if (open($fh, ">$tmp")) {
$self->pre_workspace($fh);
$self->write_comps($fh, $creator, $addfile);
$self->post_workspace($fh);
close($fh);
if (-r $name &&
-s $tmp == -s $name && compare($tmp, $name) == 0) {
$different = 0;
}
}
else {
$error = "Unable to open $tmp for output.";
$status = 0;
}
if ($status) {
if ($different) {
unlink($name);
if (rename($tmp, $name)) {
if ($addfile) {
$self->add_file_written($oname);
}
}
else {
$error = 'Unable to open ' . $self->getcwd() .
"/$name for output";
$status = 0;
}
}
else {
## We will pretend that we wrote the file
unlink($tmp);
if ($addfile) {
$self->add_file_written($oname);
}
}
}
}
else {
if (open($fh, ">$name")) {
$self->pre_workspace($fh);
$self->write_comps($fh, $creator, $addfile);
$self->post_workspace($fh);
close($fh);
if ($addfile) {
$self->add_file_written($oname);
}
}
else {
$error = "Unable to open $name for output.";
$status = 0;
}
}
}
}
if (!$addfile) {
$self->{'per_project_workspace_name'} = undef;
}
}
return $status, $error;
}
sub save_project_info {
my($self) = shift;
my($gen) = shift;
my($gpi) = shift;
my($gll) = shift;
my($dir) = shift;
my($projects) = shift;
my($pi) = shift;
my($ll) = shift;
my($c) = 0;
## For each file written
foreach my $pj (@$gen) {
## Save the full path to the project file in the array
my($full) = ($dir ne '.' ? "$dir/" : '') . $pj;
push(@$projects, $full);
## Get the corresponding generated project info and save it
## in the hash map keyed on the full project file name
$$pi{$full} = $$gpi[$c];
$c++;
}
foreach my $key (keys %$gll) {
$$ll{$key} = $$gll{$key};
}
}
sub topname {
my($self) = shift;
my($file) = shift;
my($dir) = '.';
my($rest) = $file;
if ($file =~ /^([^\/\\]+)[\/\\](.*)/) {
$dir = $1;
$rest = $2;
}
return $dir, $rest;
}
sub generate_hierarchy {
my($self) = shift;
my($creator) = shift;
my($origproj) = shift;
my($originfo) = shift;
my($current) = undef;
my(@saved) = ();
my(%sinfo) = ();
my($cwd) = $self->getcwd();
## Make a copy of these. We will be modifying them.
## It is necessary to sort the projects to get the correct ordering.
## Projects in the current directory must come before projects in
## other directories.
my(@projects) = sort { return $self->sort_projects_by_directory($a, $b) + 0;
} @{$origproj};
my(%projinfo) = %{$originfo};
foreach my $prj (@projects) {
my($top, $rest) = $self->topname($prj);
if (!defined $current) {
$current = $top;
push(@saved, $rest);
$sinfo{$rest} = $projinfo{$prj};
}
elsif ($top ne $current) {
if ($current ne '.') {
## Write out the hierachical workspace
$self->cd($current);
$self->generate_hierarchy($creator, \@saved, \%sinfo);
$self->{'projects'} = \@saved;
$self->{'project_info'} = \%sinfo;
$self->{'workspace_name'} = $self->base_directory();
my($status, $error) = $self->write_workspace($creator);
if (!$status) {
$self->error($error);
}
$self->cd($cwd);
}
## Start the next one
$current = $top;
@saved = ($rest);
%sinfo = ();
$sinfo{$rest} = $projinfo{$prj};
}
else {
push(@saved, $rest);
$sinfo{$rest} = $projinfo{$prj};
}
}
if (defined $current && $current ne '.') {
$self->cd($current);
$self->generate_hierarchy($creator, \@saved, \%sinfo);
$self->{'projects'} = \@saved;
$self->{'project_info'} = \%sinfo;
$self->{'workspace_name'} = $self->base_directory();
my($status, $error) = $self->write_workspace($creator);
if (!$status) {
$self->error($error);
}
$self->cd($cwd);
}
}
sub generate_project_files {
my($self) = shift;
my($status) = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
my(@projects) = ();
my(%pi) = ();
my(%liblocs) = ();
my($creator) = $self->project_creator();
my($cwd) = $self->getcwd();
my($impl) = $self->get_assignment('implicit');
my($postkey) = $creator->get_dynamic() .
$creator->get_static() . "-$self";
my($previmpl) = $impl;
my($prevcache) = $self->{'cacheok'};
my(%gstate) = $creator->save_state();
my($genimpdep) = $self->generate_implicit_project_dependencies();
## Remove the address portion of the $self string
$postkey =~ s/=.*//;
## Set the source file callback on our project creator
$creator->set_source_listing_callback([\&source_listing_callback, $self]);
foreach my $ofile (@{$self->{'project_files'}}) {
if (!$self->excluded($ofile)) {
my($file) = $ofile;
my($dir) = $self->mpc_dirname($file);
my($restore) = 0;
if (defined $self->{'scoped_assign'}->{$ofile}) {
## Handle the implicit assignment
my($oi) = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
if (defined $oi) {
$previmpl = $impl;
$impl = $oi;
}
## Handle the cmdline assignment
my($cmdline) = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
if (defined $cmdline && $cmdline ne '') {
## Save the cacheok value
$prevcache = $self->{'cacheok'};
## Get the current parameters and process the command line
my(%parameters) = $self->current_parameters();
$self->process_cmdline($cmdline, \%parameters);
## Set the parameters on the creator
$creator->restore_state(\%parameters);
$restore = 1;
}
}
## If we are generating implicit projects and the file is a
## directory, then we set the dir to the file and empty the file
if ($impl && -d $file) {
$dir = $file;
$file = '';
## If the implicit assignment value was not a number, then
## we will add this value to our base projects.
if ($impl !~ /^\d+$/) {
my($bps) = $creator->get_baseprojs();
push(@$bps, split(/\s+/, $impl));
$restore = 1;
$self->{'cacheok'} = 0;
}
}
## Generate the key for this project file
my($prkey) = $self->getcwd() . '/' .
($file eq '' ? $dir : $file) . "-$postkey";
## We must change to the subdirectory for
## which this project file is intended
if ($self->cd($dir)) {
my($files_written) = [];
my($gen_proj_info) = [];
my($gen_lib_locs) = {};
if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
$files_written = $allprojects{$prkey};
$gen_proj_info = $allprinfo{$prkey};
$gen_lib_locs = $allliblocs{$prkey};
$status = 1;
}
else {
$status = $creator->generate($self->mpc_basename($file));
## If any one project file fails, then stop
## processing altogether.
if (!$status) {
## We don't restore the state before we leave,
## but that's ok since we will be exiting right now.
return $status, $creator,
"Unable to process " . ($file eq '' ? " in $dir" : $file);
}
## Get the individual project information and
## generated file name(s)
$files_written = $creator->get_files_written();
$gen_proj_info = $creator->get_project_info();
$gen_lib_locs = $creator->get_lib_locations();
if ($self->{'cacheok'}) {
$allprojects{$prkey} = $files_written;
$allprinfo{$prkey} = $gen_proj_info;
$allliblocs{$prkey} = $gen_lib_locs;
}
}
$self->cd($cwd);
$self->save_project_info($files_written, $gen_proj_info,
$gen_lib_locs, $dir,
\@projects, \%pi, \%liblocs);
}
else {
## Unable to change to the directory.
## We don't restore the state before we leave,
## but that's ok since we will be exiting soon.
return 0, $creator, "Unable to change directory to $dir";
}
## Return things to the way they were
if (defined $self->{'scoped_assign'}->{$ofile}) {
$impl = $previmpl;
}
if ($restore) {
$self->{'cacheok'} = $prevcache;
$creator->restore_state(\%gstate);
}
}
else {
## This one was excluded, so status is ok
$status = 1;
}
}
## Add implict project dependencies based on source files
## that have been used by multiple projects. If we do it here
## before we call generate_hierarchy(), we don't have to call it
## in generate_hierarchy() for each workspace.
$self->{'projects'} = \@projects;
$self->{'project_info'} = \%pi;
if ($status && $genimpdep) {
$self->add_implicit_project_dependencies($creator, $cwd);
}
## If we are generating the hierarchical workspaces, then do so
$self->{'lib_locations'} = \%liblocs;
if ($self->get_hierarchy() || $self->workspace_per_project()) {
my($orig) = $self->{'workspace_name'};
$self->generate_hierarchy($creator, \@projects, \%pi);
$self->{'workspace_name'} = $orig;
}
## Reset the projects and project_info
$self->{'projects'} = \@projects;
$self->{'project_info'} = \%pi;
return $status, $creator;
}
sub array_contains {
my($self) = shift;
my($left) = shift;
my($right) = shift;
my(%check) = ();
## Initialize the hash keys with the left side array
@check{@$left} = ();
## Check each element on the right against the left.
foreach my $r (@$right) {
if (exists $check{$r}) {
return 1;
}
}
return 0;
}
sub non_intersection {
my($self) = shift;
my($left) = shift;
my($right) = shift;
my($over) = shift;
my($status) = 0;
my(%check) = ();
## Initialize the hash keys with the left side array
@check{@$left} = ();
## Check each element on the right against the left.
## Store anything that isn't in the left side in the over array.
foreach my $r (@$right) {
if (exists $check{$r}) {
$status = 1;
}
else {
push(@$over, $r);
}
}
return $status;
}
sub indirect_depdency {
my($self) = shift;
my($dir) = shift;
my($ccheck) = shift;
my($cfile) = shift;
if (index($self->{'project_info'}->{$ccheck}->[1], $cfile) >= 0) {
return 1;
}
else {
my($deps) = $self->create_array(
$self->{'project_info'}->{$ccheck}->[1]);
foreach my $dep (@$deps) {
if (defined $self->{'project_info'}->{"$dir$dep"} &&
$self->indirect_depdency($dir, "$dir$dep", $cfile)) {
return 1;
}
}
}
return 0;
}
sub add_implicit_project_dependencies {
my($self) = shift;
my($creator) = shift;
my($cwd) = shift;
my(%bidir) = ();
my(%save) = ();
## Take the current working directory and regular expression'ize it.
$cwd = $self->escape_regex_special($cwd);
## Look at each projects file list and check it against all of the
## others. If any of the other projects file lists contains anothers
## file, then they are dependent (due to build parallelism). So, we
## append the dependency and remove the file in question from the
## project so that the next time around the foreach, we don't find it
## as a dependent on the one that we just modified.
my(@pflkeys) = keys %{$self->{'project_file_list'}};
foreach my $key (@pflkeys) {
foreach my $ikey (@pflkeys) {
## Not the same project and
## The same directory and
## We've not already added a dependency to this project
if ($key ne $ikey &&
($self->{'project_file_list'}->{$key}->[1] eq
$self->{'project_file_list'}->{$ikey}->[1]) &&
(!defined $bidir{$ikey} ||
!$self->array_contains($bidir{$ikey}, [$key]))) {
my(@over) = ();
if ($self->non_intersection(
$self->{'project_file_list'}->{$key}->[2],
$self->{'project_file_list'}->{$ikey}->[2],
\@over)) {
## The project contains shared source files, so we need to
## look into adding an implicit inter-project dependency.
$save{$ikey} = $self->{'project_file_list'}->{$ikey}->[2];
$self->{'project_file_list'}->{$ikey}->[2] = \@over;
if (defined $bidir{$key}) {
push(@{$bidir{$key}}, $ikey);
}
else {
$bidir{$key} = [$ikey];
}
my($append) = $creator->translate_value('after', $key);
my($file) = $self->{'project_file_list'}->{$ikey}->[0];
my($dir) = $self->{'project_file_list'}->{$ikey}->[1];
my($cfile) = $creator->translate_value('after', $ikey);
## Remove our starting directory from the projects directory
## to get the right part of the directory to prepend.
$dir =~ s/^$cwd[\/\\]*//;
## Turn the append value into a key for 'project_info' and
## prepend the directory to the file.
my($ccheck) = $append;
$ccheck =~ s/"//g;
if ($dir ne '') {
$dir .= '/';
$ccheck = "$dir$ccheck";
$file = "$dir$file";
}
## If the append value key contains a reference to the project
## that we were going to append the dependency value, then
## ignore the generated dependency. It is redundant and
## quite possibly wrong.
if (!defined $self->{'project_info'}->{$ccheck} ||
!$self->indirect_depdency($dir, $ccheck, $cfile)) {
## Append the dependency
$self->{'project_info'}->{$file}->[1] .= " $append";
}
}
}
}
}
## Restore the modified values in case this method is called again
## which is the case when using the -hierarchy option.
foreach my $skey (keys %save) {
$self->{'project_file_list'}->{$skey}->[2] = $save{$skey};
}
}
sub get_projects {
my($self) = shift;
return $self->{'projects'};
}
sub get_project_info {
my($self) = shift;
return $self->{'project_info'};
}
sub get_lib_locations {
my($self) = shift;
return $self->{'lib_locations'};
}
sub get_first_level_directory {
my($self) = shift;
my($file) = shift;
my($dir) = undef;
if (($file =~ tr/\///) > 0) {
$dir = $file;
$dir =~ s/^([^\/]+\/).*/$1/;
$dir =~ s/\/+$//;
}
else {
$dir = '.';
}
return $dir;
}
sub sort_within_group {
my($self) = shift;
my($list) = shift;
my($start) = shift;
my($end) = shift;
my($deps) = undef;
my($ccount) = 0;
my($cmax) = ($end - $start) + 1;
my($previ) = -1;
my($prevpjs) = [];
my($movepjs) = [];
## Put the projects in the order specified
## by the project dpendencies.
for(my $i = $start; $i <= $end; ++$i) {
## If our moved project equals our previously moved project then
## we count this as a possible circular dependency.
if (defined $$movepjs[0] && defined $$prevpjs[0] &&
$$movepjs[0] == $$prevpjs[0] && $$movepjs[1] == $$prevpjs[1]) {
++$ccount;
}
else {
$ccount = 0;
}
## Detect circular dependencies
if ($ccount > $cmax) {
my(@prjs) = ();
foreach my $mvgr (@$movepjs) {
push(@prjs, $$list[$mvgr]);
}
my($other) = $$movepjs[0] - 1;
if ($other < $start || $other == $$movepjs[1] || !defined $$list[$other]) {
$other = undef;
}
$self->warning('Circular dependency detected while processing the ' .
($self->{'current_input'} eq '' ?
'default' : $self->{'current_input'}) .
' workspace. ' .
'The following projects are involved: ' .
(defined $other ? "$$list[$other], " : '') .
join(' and ', @prjs));
return;
}
## Keep track of the previous project movement
$prevpjs = $movepjs;
if ($previ < $i) {
$movepjs = [];
}
$previ = $i;
$deps = $self->get_validated_ordering($$list[$i]);
if (defined $$deps[0]) {
my($baseproj) = $self->mpc_basename($$list[$i]);
my($moved) = 0;
foreach my $dep (@$deps) {
if ($baseproj ne $dep) {
## See if the dependency is listed after this project
for(my $j = $i + 1; $j <= $end; ++$j) {
if ($self->mpc_basename($$list[$j]) eq $dep) {
$movepjs = [$i, $j];
## If so, move it in front of the current project.
## The original code, which had splices, didn't always
## work correctly (especially on AIX for some reason).
my($save) = $$list[$j];
for(my $k = $j; $k > $i; --$k) {
$$list[$k] = $$list[$k - 1];
}
$$list[$i] = $save;
## Mark that an entry has been moved
$moved = 1;
$j--;
}
}
}
}
if ($moved) {
$i--;
}
}
}
}
sub build_dependency_chain {
my($self) = shift;
my($name) = shift;
my($len) = shift;
my($list) = shift;
my($ni) = shift;
my($glen) = shift;
my($groups) = shift;
my($map) = shift;
my($gdeps) = shift;
my($deps) = $self->get_validated_ordering($name);
if (defined $$deps[0]) {
foreach my $dep (@$deps) {
## Find the item in the list that matches our current dependency
my($mapped) = $$map{$dep};
for(my $i = 0; $i < $len; $i++) {
if ($$list[$i] eq $mapped) {
## Locate the group number to which the dependency belongs
for(my $j = 0; $j < $glen; $j++) {
if ($i >= $$groups[$j]->[0] && $i <= $$groups[$j]->[1]) {
if ($j != $ni) {
## Add every project in the group to the dependency chain
for(my $k = $$groups[$j]->[0]; $k <= $$groups[$j]->[1]; $k++) {
my($ldep) = $self->mpc_basename($$list[$k]);
if (!exists $$gdeps{$ldep}) {
$$gdeps{$ldep} = 1;
$self->build_dependency_chain($$list[$k],
$len, $list, $j,
$glen, $groups,
$map, $gdeps);
}
}
}
last;
}
}
last;
}
}
$$gdeps{$dep} = 1;
}
}
}
sub sort_by_groups {
my($self) = shift;
my($list) = shift;
my($grindex) = shift;
my(@groups) = @$grindex;
my($llen) = scalar(@$list);
## Check for duplicates first before we attempt to sort the groups.
## If there is a duplicate, we quietly return immediately. The
## duplicates will be flagged as an error when creating the main
## workspace.
my(%dupcheck) = ();
foreach my $proj (@$list) {
my($base) = $self->mpc_basename($proj);
if (defined $dupcheck{$base}) {
return;
}
$dupcheck{$base} = $proj;
}
my(%circular_checked) = ();
for(my $gi = 0; $gi <= $#groups; ++$gi) {
## Detect circular dependencies
if (!$circular_checked{$gi}) {
$circular_checked{$gi} = 1;
for(my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
my(%gdeps) = ();
$self->build_dependency_chain($$list[$i], $llen, $list, $gi,
$#groups + 1, \@groups,
\%dupcheck, \%gdeps);
if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
## There was a cirular dependency, get all of the directories
## involved.
my(%dirs) = ();
foreach my $gdep (keys %gdeps) {
$dirs{$self->mpc_dirname($dupcheck{$gdep})} = 1;
}
## If the current directory was involved, translate that into
## a directory relative to the start directory.
if (defined $dirs{'.'}) {
my($cwd) = $self->getcwd();
my($start) = $self->getstartdir();
if ($cwd ne $start) {
my($startre) = $self->escape_regex_special($start);
delete $dirs{'.'};
$cwd =~ s/^$startre[\\\/]//;
$dirs{$cwd} = 1;
}
}
## Display a warining to the user
my(@keys) = sort keys %dirs;
$self->warning('Circular directory dependency detected in the ' .
($self->{'current_input'} eq '' ?
'default' : $self->{'current_input'}) .
' workspace. ' .
'The following director' .
($#keys == 0 ? 'y is' : 'ies are') .
' involved: ' . join(', ', @keys));
return;
}
}
}
## Build up the group dependencies
my(%gdeps) = ();
for(my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
my($deps) = $self->get_validated_ordering($$list[$i]);
if (defined $$deps[0]) {
@gdeps{@$deps} = ();
}
}
## Search the rest of the groups for any of the group dependencies
for(my $gj = $gi + 1; $gj <= $#groups; ++$gj) {
for(my $i = $groups[$gj]->[0]; $i <= $groups[$gj]->[1]; ++$i) {
if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
## Move this group ($gj) in front of the current group ($gi)
my(@save) = ();
for(my $j = $groups[$gi]->[1] + 1; $j <= $groups[$gj]->[1]; ++$j) {
push(@save, $$list[$j]);
}
my($offset) = $groups[$gj]->[1] - $groups[$gi]->[1];
for(my $j = $groups[$gi]->[1]; $j >= $groups[$gi]->[0]; --$j) {
$$list[$j + $offset] = $$list[$j];
}
for(my $j = 0; $j <= $#save; ++$j) {
$$list[$groups[$gi]->[0] + $j] = $save[$j];
}
## Update the group indices
my($shiftamt) = ($groups[$gi]->[1] - $groups[$gi]->[0]) + 1;
for(my $j = $gi + 1; $j <= $gj; ++$j) {
$groups[$j]->[0] -= $shiftamt;
$groups[$j]->[1] -= $shiftamt;
}
my(@grsave) = @{$groups[$gi]};
$grsave[0] += $offset;
$grsave[1] += $offset;
for(my $j = $gi; $j < $gj; ++$j) {
$groups[$j] = $groups[$j + 1];
}
$groups[$gj] = \@grsave;
## Start over from the first group
$gi = -1;
## Exit from the outter ($gj) loop
$gj = $#groups;
last;
}
}
}
}
}
sub sort_dependencies {
my($self) = shift;
my($projects) = shift;
my($groups) = shift;
my(@list) = sort { return $self->sort_projects_by_directory($a, $b) + 0;
} @$projects;
## The list above is sorted by directory in order to keep projects
## within the same directory together. Otherwise, when groups are
## created we may get multiple groups for the same directory.
## Put the projects in the order specified
## by the project dpendencies. We only need to do
## this if there is more than one element in the array.
if ($#list > 0) {
## If the parameter wasn't passed in or it was passed in
## and was true, sort with directory groups in mind
if (!defined $groups || $groups) {
## First determine the individual groups
my(@grindex) = ();
my($previous) = [0, undef];
for(my $li = 0; $li <= $#list; ++$li) {
my($dir) = $self->get_first_level_directory($list[$li]);
if (!defined $previous->[1]) {
$previous = [$li, $dir];
}
elsif ($previous->[1] ne $dir) {
push(@grindex, [$previous->[0], $li - 1]);
$previous = [$li, $dir];
}
}
push(@grindex, [$previous->[0], $#list]);
## Next, sort the individual groups
foreach my $gr (@grindex) {
if ($$gr[0] != $$gr[1]) {
$self->sort_within_group(\@list, @$gr);
}
}
## Now sort the groups as single entities
if ($#grindex > 0) {
$self->sort_by_groups(\@list, \@grindex);
}
}
else {
$self->sort_within_group(\@list, 0, $#list);
}
}
return @list;
}
sub number_target_deps {
my($self) = shift;
my($projects) = shift;
my($pjs) = shift;
my($targets) = shift;
my($groups) = shift;
my(@list) = $self->sort_dependencies($projects, $groups);
## This block of code must be done after the list of dependencies
## has been sorted in order to get the correct project numbers.
for(my $i = 0; $i <= $#list; ++$i) {
my($project) = $list[$i];
if (defined $$pjs{$project}) {
my($name, $deps) = @{$$pjs{$project}};
if (defined $deps && $deps ne '') {
my(@numbers) = ();
my(%dhash) = ();
@dhash{@{$self->create_array($deps)}} = ();
## For each dependency, search in the sorted list
## up to the point of this project for the projects
## that this one depends on. When the project is
## found, we put the target number in the numbers array.
for(my $j = 0; $j < $i; ++$j) {
if (exists $dhash{$self->mpc_basename($list[$j])}) {
push(@numbers, $j);
}
}
## Store the array in the hash keyed on the project file.
if (defined $numbers[0]) {
$$targets{$project} = \@numbers;
}
}
}
}
return @list;
}
sub project_target_translation {
my($self) = shift;
my($case) = shift;
my(%map) = ();
## Translate project names to avoid target collision with
## some versions of make.
foreach my $key (keys %{$self->{'project_info'}}) {
my($dir) = $self->mpc_dirname($key);
my($name) = $self->{'project_info'}->{$key}->[0];
## We want to compare to the upper most directory. This will be the
## one that may conflict with the project name.
$dir =~ s/[\/\\].*//;
if (($case && $dir eq $name) || (!$case && lc($dir) eq lc($name))) {
$map{$key} = "$name-target";
}
else {
$map{$key} = $name;
}
}
return \%map;
}
sub optionError {
my($self) = shift;
my($str) = shift;
$self->warning("$self->{'current_input'}: $str.");
}
sub process_cmdline {
my($self) = shift;
my($cmdline) = shift;
my($parameters) = shift;
## It's ok to use the cache
$self->{'cacheok'} = 1;
if (defined $cmdline && $cmdline ne '') {
my($args) = $self->create_array($cmdline);
## Look for environment variables
foreach my $arg (@$args) {
while($arg =~ /\$(\w+)/) {
my($name) = $1;
my($val) = '';
if ($name eq 'PWD') {
$val = $self->getcwd();
}
elsif (defined $ENV{$name}) {
$val = $ENV{$name};
}
$arg =~ s/\$\w+/$val/;
}
}
my($options) = $self->options('MWC', {}, 0, @$args);
if (defined $options) {
foreach my $key (keys %$options) {
my($type) = $self->is_set($key, $options);
if (!defined $type) {
## This option was not used, so we ignore it
}
elsif ($type eq 'ARRAY') {
push(@{$parameters->{$key}}, @{$options->{$key}});
}
elsif ($type eq 'HASH') {
foreach my $hk (keys %{$options->{$key}}) {
$parameters->{$key}->{$hk} = $options->{$key}->{$hk};
}
}
elsif ($type eq 'SCALAR') {
$parameters->{$key} = $options->{$key};
}
}
## Issue warnings for these options
if (defined $options->{'recurse'}) {
$self->optionError('-recurse is ignored');
}
if (defined $options->{'reldefs'}) {
$self->optionError('-noreldefs is ignored');
}
if (defined $options->{'coexistence'}) {
$self->optionError('-make_coexistence is ignored');
}
if (defined $options->{'into'}) {
$self->optionError('-into is ignored');
}
if (defined $options->{'input'}->[0]) {
$self->optionError('Command line files ' .
'specified in a workspace are ignored');
}
## Determine if it's ok to use the cache
my(@cacheInvalidating) = ('global', 'include', 'baseprojs',
'template', 'ti', 'relative', 'language',
'addtemp', 'addproj', 'feature_file',
'features', 'use_env', 'expand_vars');
foreach my $key (@cacheInvalidating) {
if ($self->is_set($key, $options)) {
$self->{'cacheok'} = 0;
last;
}
}
}
}
}
sub current_parameters {
my($self) = shift;
my(%parameters) = $self->save_state();
## We always want the project creator to generate a toplevel
$parameters{'toplevel'} = 1;
return %parameters;
}
sub project_creator {
my($self) = shift;
my($str) = "$self";
## NOTE: If the subclassed WorkspaceCreator name prefix does not
## match the name prefix of the ProjectCreator, this code
## will not work and the subclassed WorkspaceCreator will
## need to override this method.
$str =~ s/Workspace/Project/;
$str =~ s/=HASH.*//;
## Set up values for each project creator
## If we have command line arguments in the workspace, then
## we process them before creating the project creator
my($cmdline) = $self->get_assignment('cmdline');
my(%parameters) = $self->current_parameters();
$self->process_cmdline($cmdline, \%parameters);
## Create the new project creator with the updated parameters
return $str->new($parameters{'global'},
$parameters{'include'},
$parameters{'template'},
$parameters{'ti'},
$parameters{'dynamic'},
$parameters{'static'},
$parameters{'relative'},
$parameters{'addtemp'},
$parameters{'addproj'},
$parameters{'progress'},
$parameters{'toplevel'},
$parameters{'baseprojs'},
$self->{'global_feature_file'},
$parameters{'feature_file'},
$parameters{'features'},
$parameters{'hierarchy'},
$self->{'exclude'}->{$self->{'wctype'}},
$self->make_coexistence(),
$parameters{'name_modifier'},
$parameters{'apply_project'},
$self->{'generate_ins'} || $parameters{'genins'},
$parameters{'into'},
$parameters{'language'},
$parameters{'use_env'},
$parameters{'expand_vars'});
}
sub sort_files {
#my($self) = shift;
return 0;
}
sub make_coexistence {
my($self) = shift;
return $self->{'coexistence'};
}
sub get_modified_workspace_name {
my($self) = shift;
my($name) = shift;
my($ext) = shift;
my($nows) = shift;
my($nmod) = $self->get_name_modifier();
if (defined $nmod) {
$nmod =~ s/\*/$name/g;
$name = $nmod;
}
## If this is a per project workspace, then we should not
## modify the workspace name. It may overwrite another workspace
## but that's ok, it will only be a per project workspace.
## Also, if we don't want the workspace name attached ($nows) then
## we just return the name plus the extension.
if ($nows || $self->{'per_project_workspace_name'}) {
return "$name$ext";
}
my($pwd) = $self->getcwd();
my($type) = $self->{'wctype'};
my($wsname) = $self->get_workspace_name();
if (!defined $previous_workspace_name{$type}->{$pwd}) {
$previous_workspace_name{$type}->{$pwd} = $wsname;
$self->{'current_workspace_name'} = undef;
}
else {
my($prefix) = ($name eq $wsname ? $name : "$name.$wsname");
$previous_workspace_name{$type}->{$pwd} = $wsname;
while($self->file_written("$prefix" .
($self->{'modified_count'} > 0 ?
".$self->{'modified_count'}" : '') .
"$ext")) {
++$self->{'modified_count'};
}
$self->{'current_workspace_name'} =
"$prefix" . ($self->{'modified_count'} > 0 ?
".$self->{'modified_count'}" : '') . "$ext";
}
return (defined $self->{'current_workspace_name'} ?
$self->{'current_workspace_name'} : "$name$ext");
}
sub generate_recursive_input_list {
my($self) = shift;
my($dir) = shift;
my($exclude) = shift;
return $self->extension_recursive_input_list($dir, $exclude, $wsext);
}
sub verify_build_ordering {
my($self) = shift;
foreach my $project (@{$self->{'projects'}}) {
$self->get_validated_ordering($project);
}
}
sub get_validated_ordering {
my($self) = shift;
my($project) = shift;
my($deps) = undef;
if (defined $self->{'ordering_cache'}->{$project}) {
$deps = $self->{'ordering_cache'}->{$project};
}
else {
$deps = [];
if (defined $self->{'project_info'}->{$project}) {
my($name, $dstr) = @{$self->{'project_info'}->{$project}};
if (defined $dstr && $dstr ne '') {
$deps = $self->create_array($dstr);
my($dlen) = scalar(@$deps);
for(my $i = 0; $i < $dlen; $i++) {
my($dep) = $$deps[$i];
my($found) = 0;
## Avoid circular dependencies
if ($dep ne $name && $dep ne $self->mpc_basename($project)) {
foreach my $p (@{$self->{'projects'}}) {
if ($dep eq $self->{'project_info'}->{$p}->[0] ||
$dep eq $self->mpc_basename($p)) {
$found = 1;
last;
}
}
if (!$found) {
if (defined $ENV{MPC_VERBOSE_ORDERING}) {
$self->warning("'$name' references '$dep' which has " .
"not been processed.");
}
splice(@$deps, $i, 1);
--$dlen;
--$i;
}
}
else {
## If a project references itself, we must remove it
## from the list of dependencies.
splice(@$deps, $i, 1);
--$dlen;
--$i;
}
}
}
$self->{'ordering_cache'}->{$project} = $deps;
}
}
return $deps;
}
sub source_listing_callback {
my($self) = shift;
my($project_file) = shift;
my($project_name) = shift;
my($cwd) = $self->getcwd();
$self->{'project_file_list'}->{$project_name} = [ $project_file,
$cwd, \@_ ];
}
sub sort_projects_by_directory {
my($self) = shift;
my($left) = shift;
my($right) = shift;
my($sa) = index($left, '/');
my($sb) = index($right, '/');
if ($sa >= 0 && $sb == -1) {
return 1;
}
elsif ($sb >= 0 && $sa == -1) {
return -1;
}
return $left cmp $right;
}
# ************************************************************
# Virtual Methods To Be Overridden
# ************************************************************
sub supports_make_coexistence {
#my($self) = shift;
return 0;
}
sub generate_implicit_project_dependencies {
#my($self) = shift;
return 0;
}
sub workspace_file_name {
#my($self) = shift;
return '';
}
sub workspace_per_project {
#my($self) = shift;
return 0;
}
sub pre_workspace {
#my($self) = shift;
#my($fh) = shift;
}
sub write_comps {
#my($self) = shift;
#my($fh) = shift;
#my($gens) = shift;
#my($top) = shift;
}
sub post_workspace {
#my($self) = shift;
#my($fh) = shift;
}
1;