modules/WorkspaceCreator.pm

   1 package WorkspaceCreator;
   2
   3 # ************************************************************
   4 # Description   : Base class for all workspace creators
   5 # Author        : Chad Elliott
   6 # Create Date   : 5/13/2002
   7 # ************************************************************
   8
   9 # ************************************************************
  10 # Pragmas
  11 # ************************************************************
  12
  13 use strict;
  14 use FileHandle;
  15 use File::Path;
  16
  17 use Creator;
  18 use Options;
  19 use WorkspaceHelper;
  20
  21 use IO::Socket;
  22 use Data::Dumper;
  23
  24 use vars qw(@ISA);
  25 @ISA = qw(Creator Options);
  26
  27 # ************************************************************
  28 # Data Section
  29 # ************************************************************
  30
  31 ## process stuff
  32 our $num_workers = 0;           # single-process
  33 our $wdir;                      # tmp directory
  34 our $wport;
  35
  36 my $wsext  = 'mwc';
  37 my $wsbase = 'mwb';
  38
  39 ## Valid names for assignments within a workspace
  40 my %validNames = ('cmdline'  => 1,
  41                   'implicit' => 1,
  42                  );
  43
  44 ## Singleton hash maps of project information
  45 my %allprinfo;
  46 my %allprojects;
  47 my %allliblocs;
  48
  49 ## Global previous workspace names
  50 my %previous_workspace_name;
  51
  52 ## Constant aggregated workspace type name
  53 my $aggregated = 'aggregated_workspace';
  54
  55 my $onVMS = DirectoryManager::onVMS();
  56
  57 # ************************************************************
  58 # Subroutine Section
  59 # ************************************************************
  60
  61 sub new {
  62   my($class, $global, $inc, $template, $ti, $dynamic,
  63      $static, $relative, $addtemp, $addproj, $progress,
  64      $toplevel, $baseprojs, $gfeature, $relative_f, $feature,
  65      $features, $hierarchy, $exclude, $makeco, $nmod, $applypj,
  66      $genins, $into, $language, $use_env, $expandvars, $gendot,
  67      $comments, $foreclipse, $workers, $workers_dir,
  68      $workers_port) = @_;
  69
  70   my $self = Creator::new($class, $global, $inc,
  71                           $template, $ti, $dynamic, $static,
  72                           $relative, $addtemp, $addproj,
  73                           $progress, $toplevel, $baseprojs,
  74                           $feature, $features,
  75                           $hierarchy, $nmod, $applypj,
  76                           $into, $language, $use_env, $expandvars,
  77                           'workspace');
  78
  79   $self->{'pid'} = 'parent';
  80
  81   # implicit dependency order counter. this is
  82   # incremented in the children.
  83   $self->{'imp_dep_ctr'} = 0;
  84
  85   ## These need to be reset at the end of each
  86   ## workspace processed within a .mwc file
  87   $self->{'workspace_name'}      = undef;
  88   $self->{'projects'}            = [];
  89   $self->{'project_info'}        = {};
  90   $self->{'project_files'}       = [];
  91   $self->{'modified_count'}      = 0;
  92   $self->{'exclude'}             = {};
  93   $self->{'associated'}          = {};
  94   $self->{'scoped_assign'}       = {};
  95   $self->{'aggregated_mpc'}      = {};
  96   $self->{'aggregated_assign'}   = {};
  97   $self->{'mpc_to_output'}       = {};
  98
  99   ## These are maintained/modified throughout processing
 100   $self->{$self->{'type_check'}} = 0;
 101   $self->{'cacheok'}             = $self->default_cacheok();
 102   $self->{'lib_locations'}       = {};
 103   $self->{'reading_parent'}      = [];
 104   $self->{'global_feature_file'} = $gfeature;
 105   $self->{'relative_file'}       = $relative_f;
 106   $self->{'project_file_list'}   = {};
 107   $self->{'ordering_cache'}      = {};
 108   $self->{'handled_scopes'}      = {};
 109   $self->{'scoped_basedir'}      = undef;
 110   $self->{'current_aggregated'}  = undef;
 111
 112   ## These are static throughout processing
 113   $self->{'coexistence'}         = $self->requires_make_coexistence() ? 1 : $makeco;
 114   $self->{'for_eclipse'}         = $foreclipse;
 115   $self->{'workers'}             = $workers;
 116   $self->{'generate_dot'}        = $gendot;
 117   $self->{'generate_ins'}        = $genins;
 118   $self->{'verbose_ordering'}    = $self->default_verbose_ordering();
 119   $self->{'wctype'}              = $self->extractType("$self");
 120   $self->{'workspace_comments'}  = $comments;
 121
 122   if (defined $$exclude[0]) {
 123     my $type = $self->{'wctype'};
 124     if (!defined $self->{'exclude'}->{$type}) {
 125       $self->{'exclude'}->{$type} = [];
 126     }
 127     push(@{$self->{'exclude'}->{$type}}, @$exclude);
 128     $self->{'orig_exclude'} = $self->{'exclude'};
 129   }
 130   else {
 131     $self->{'orig_exclude'} = {};
 132   }
 133
 134   ## Add a hash reference for our workspace type
 135   if (!defined $previous_workspace_name{$self->{'wctype'}}) {
 136     $previous_workspace_name{$self->{'wctype'}} = {};
 137   }
 138
 139   ## Warn users about unnecessary options
 140   if ($self->get_hierarchy() && $self->workspace_per_project()) {
 141     $self->warning("The -hierarchy option is unnecessary " .
 142                    "for the " . $self->{'wctype'} . " type.");
 143   }
 144   if ($self->{'coexistence'} && !$self->supports_make_coexistence()) {
 145     $self->warning("Using the -make_coexistence option has " .
 146                    "no effect on the " . $self->{'wctype'} . " type.");
 147   }
 148
 149   ## multi-process config
 150   $num_workers = $workers if $workers > $num_workers;
 151   $wdir = $workers_dir;
 152   $wport = $workers_port;
 153
 154   return $self;
 155 }
 156
 157
 158 sub default_cacheok {
 159   return 1;
 160 }
 161
 162 sub set_verbose_ordering {
 163   my($self, $value) = @_;
 164   $self->{'verbose_ordering'} = $value;
 165 }
 166
 167
 168 sub modify_assignment_value {
 169   ## Workspace assignments do not need modification.
 170   return $_[2];
 171 }
 172
 173
 174 sub parse_line {
 175   my($self, $ih, $line, $flags) = @_;
 176   my($status, $error, @values) = $self->parse_known($line, $ih);
 177
 178   ## Was the line recognized?
 179   if ($status && defined $values[0]) {
 180     if ($values[0] eq $self->{'grammar_type'}) {
 181       my $name = $values[1];
 182       if (defined $name && $name eq '}') {
 183         if (!defined $self->{'reading_parent'}->[0]) {
 184           ## Fill in all the default values
 185           $self->generate_defaults();
 186
 187           ## End of workspace; Have subclass write out the file
 188           ## Generate the project files
 189           my($gstat, $creator, $err);
 190           if ($num_workers > 0) {
 191             if (!defined ($wport)) {
 192               ## use temp files for multiprocess mpc
 193               ## Lock the temp directory before generating project files.
 194               my $lock = 'mpc-worker.lock';
 195
 196               ## check for valid temp directory
 197               if (!$wdir) {
 198                 if ($^O eq 'MSWin32') {
 199                   $wdir = $ENV{TEMP};
 200                 }
 201                 else {
 202                   $wdir = '/tmp/mpc';
 203                 }
 204               }
 205
 206               ## shouldn't happen
 207               if (!$wdir) {
 208                 die "Error: No temporary directory found. Supply one with \"-worker_dir\" option.\n";
 209               }
 210
 211               $self->diagnostic("Multiprocess MPC using \"$wdir\" for temporary files.");
 212
 213               unless (-d $wdir) {
 214                 mkdir $wdir || die "Error: Can't find or create directory $wdir\n"
 215               }
 216
 217               ## lock the directory
 218               if (-e "$wdir/$lock") {
 219                 die "Error: Another instance of MPC is using $wdir, or a previous session failed to remove the lock file $lock\n";
 220               }
 221               else {
 222                 open (FDL, ">$wdir/$lock") || die "Error reating lock file $lock in $wdir\n";
 223                 print FDL "File generated by MPC process ", $$, " on ", scalar (localtime(time())), "\n";
 224                 close FDL;
 225
 226                 $self->diagnostic("Multiprocess MPC created lock file $wdir/$lock");
 227               }
 228
 229               ## generate the project files
 230               ($gstat, $creator, $err) = $self->generate_project_files_fork();
 231
 232               ## Release temp directory lock;
 233               if (!unlink("$wdir/$lock")) {
 234                 $self->error("Multiprocess MPC unable to remove lock file $wdir/$lock");
 235               }
 236               else {
 237                 $self->diagnostic("Multiprocess MPC removed $wdir/$lock");
 238               }
 239
 240             }
 241             else {
 242               ## Socket-based Multiprocess MPC
 243               ($gstat, $creator, $err) =
 244                   $self->generate_project_files_fork_socket();
 245             }
 246           }
 247           else {
 248             ($gstat, $creator, $err) = $self->generate_project_files();
 249           }
 250           if ($gstat) {
 251             #exit(1);
 252             ($status, $error) = $self->write_workspace($creator, 1);
 253             $self->{'assign'} = {};
 254           }
 255           else {
 256             $error = $err;
 257             $status = 0;
 258           }
 259
 260           $self->{'modified_count'} = 0;
 261           $self->{'workspace_name'} = undef;
 262           $self->{'projects'}       = [];
 263           $self->{'project_info'}   = {};
 264           $self->{'project_files'}  = [];
 265           $self->{'exclude'}        = $self->{'orig_exclude'};
 266           $self->{'associated'}     = {};
 267           $self->{'scoped_assign'}  = {};
 268           $self->{'aggregated_mpc'} = {};
 269           $self->{'aggregated_assign'} = {};
 270           $self->{'mpc_to_output'}  = {};
 271         }
 272         $self->{$self->{'type_check'}} = 0;
 273       }
 274       else {
 275         ## Workspace Beginning
 276         ## Deal with the inheritance hierarchy first
 277         if (defined $values[2]) {
 278           foreach my $parent (@{$values[2]}) {
 279             ## Read in the parent onto ourself
 280             my $file = $self->search_include_path("$parent.$wsbase");
 281             if (!defined $file) {
 282               $file = $self->search_include_path("$parent.$wsext");
 283             }
 284
 285             if (defined $file) {
 286               push(@{$self->{'reading_parent'}}, 1);
 287               $status = $self->parse_file($file);
 288               pop(@{$self->{'reading_parent'}});
 289
 290               $error = "Invalid parent: $parent" if (!$status);
 291             }
 292             else {
 293               $status = 0;
 294               $error = "Unable to locate parent: $parent";
 295             }
 296           }
 297         }
 298
 299         ## Set up some initial values
 300         if (defined $name) {
 301           if ($name =~ /[\/\\]/) {
 302             $status = 0;
 303             $error = 'Workspaces can not have a slash ' .
 304               'or a back slash in the name';
 305           }
 306           else {
 307             $name =~ s/^\(\s*//;
 308             $name =~ s/\s*\)$//;
 309
 310             ## Replace any *'s with the default name
 311             if (index($name, '*') >= 0) {
 312               $name = $self->fill_type_name(
 313                                $name, $self->get_default_workspace_name());
 314             }
 315
 316             $self->{'workspace_name'} = $name;
 317           }
 318         }
 319         $self->{$self->{'type_check'}} = 1;
 320       }
 321     }
 322     elsif ($values[0] eq '0') {
 323       if (defined $validNames{$values[1]}) {
 324         $self->process_assignment($values[1], $values[2], $flags);
 325       }
 326       else {
 327         $error = "Invalid assignment name: '$values[1]'";
 328         $status = 0;
 329       }
 330     }
 331     elsif ($values[0] eq '1') {
 332       if (defined $validNames{$values[1]}) {
 333         ## This code only runs when there is a non-scoped assignment.  As
 334         ## such, we can safely replace all environment variables here so
 335         ## that they are not incorrectly handled in aggregated
 336         ## workspaces.
 337         $self->replace_env_vars(\$values[2]) if ($values[2] =~ /\$/);
 338         $self->process_assignment_add($values[1], $values[2], $flags);
 339       }
 340       else {
 341         $error = "Invalid addition name: $values[1]";
 342         $status = 0;
 343       }
 344     }
 345     elsif ($values[0] eq '-1') {
 346       if (defined $validNames{$values[1]}) {
 347         $self->process_assignment_sub($values[1], $values[2], $flags);
 348       }
 349       else {
 350         $error = "Invalid subtraction name: $values[1]";
 351         $status = 0;
 352       }
 353     }
 354     elsif ($values[0] eq 'component') {
 355       my %copy = %{defined $flags ? $flags : $self->get_assignment_hash()};
 356       ($status, $error) = $self->parse_scope($ih,
 357                                              $values[1],
 358                                              $values[2],
 359                                              \%validNames,
 360                                              \%copy);
 361     }
 362     else {
 363       $error = "Unrecognized line: $line";
 364       $status = 0;
 365     }
 366   }
 367   elsif ($status == -1) {
 368     ## If the line contains a variable, try to replace it with an actual
 369     ## value.
 370     $line = $self->relative($line) if (index($line, '$') >= 0);
 371
 372     foreach my $expfile ($line =~ /[\?\*\[\]]/ ? $self->mpc_glob($line) :
 373                          $line) {
 374       if ($expfile =~ /\.$wsext$/) {
 375         my %copy = %{defined $flags ? $flags : $self->get_assignment_hash()};
 376         ($status, $error) = $self->aggregated_workspace($expfile, \%copy);
 377         last if (!$status);
 378       }
 379       else {
 380         push(@{$self->{'project_files'}}, $expfile);
 381         $status = 1;
 382       }
 383     }
 384   }
 385
 386   return $status, $error;
 387 }
 388
 389
 390 sub aggregated_workspace {
 391   my($self, $file, $flags) = @_;
 392   my $fh = new FileHandle();
 393
 394   if (open($fh, $file)) {
 395     my $oline = $self->get_line_number();
 396     my $tc    = $self->{$self->{'type_check'}};
 397     my $ag    = $self->{'handled_scopes'}->{$aggregated};
 398     my $pca   = $self->{'current_aggregated'};
 399     my $psbd  = $self->{'scoped_basedir'};
 400     my $prev_assign = $self->clone($self->get_assignment_hash());
 401     my($status, $error, @values) = (0, 'No recognizable lines');
 402
 403     $self->{'handled_scopes'}->{$aggregated} = undef;
 404     $self->set_line_number(0);
 405     $self->{$self->{'type_check'}} = 0;
 406     $self->{'current_aggregated'} = $file;
 407     $self->{'scoped_basedir'} = $self->mpc_dirname($file);
 408
 409     ## If the directory name for the file is the current directory, we
 410     ## need to empty it out.  If we don't, it will cause the file name to
 411     ## not match up with itself later on where scoped_basedir is used.
 412     $self->{'scoped_basedir'} = undef if ($self->{'scoped_basedir'} eq '.');
 413
 414     while (<$fh>) {
 415       my $line = $self->preprocess_line($fh, $_);
 416       ($status, $error, @values) = $self->parse_known($line, $fh);
 417
 418       ## Was the line recognized?
 419       if ($status) {
 420         if (defined $values[0]) {
 421           if ($values[0] eq $self->{'grammar_type'}) {
 422             if (defined $values[2]) {
 423               my $name = $self->mpc_basename($file);
 424               $name =~ s/\.[^\.]+$//;
 425               $status = 0;
 426               $error  = 'Aggregated workspace (' . $name .
 427                 ') can not inherit from another workspace';
 428             }
 429             else {
 430               ($status, $error) = $self->parse_scope($fh,
 431                                                      '',
 432                                                      $aggregated,
 433                                                      \%validNames,
 434                                                      $flags);
 435             }
 436           }
 437           else {
 438             $status = 0;
 439             $error = 'Unable to aggregate ' . $file;
 440           }
 441           last;
 442         }
 443       }
 444       else {
 445         last;
 446       }
 447     }
 448     close($fh);
 449
 450     if ($status) {
 451       $self->{'aggregated_assign'}->{$file} =
 452         $self->clone($self->get_assignment_hash());
 453       $self->{'assign'} = $prev_assign;
 454     }
 455
 456     $self->{'scoped_basedir'} = $psbd;
 457     $self->{'current_aggregated'} = $pca;
 458     $self->{'handled_scopes'}->{$aggregated} = $ag;
 459     $self->{$self->{'type_check'}} = $tc;
 460     $self->set_line_number($oline);
 461
 462     return $status, $error;
 463   }
 464
 465   return 0, 'Unable to open ' . $file;
 466 }
 467
 468
 469 sub parse_scope {
 470   my($self, $fh, $name, $type, $validNames, $flags, $elseflags) = @_;
 471
 472   if ($type eq $self->get_default_component_name()) {
 473     $type = $self->{'wctype'};
 474   }
 475
 476   if ($name eq 'exclude') {
 477     return $self->parse_exclude($fh, $type, $flags);
 478   }
 479   elsif ($name eq 'associate') {
 480     return $self->parse_associate($fh, $type);
 481   }
 482   elsif ($name eq 'specific') {
 483     return $self->parse_specific($fh, $type, $validNames, $flags, $elseflags);
 484   }
 485   else {
 486     return $self->SUPER::parse_scope($fh, $name, $type,
 487                                      $validNames, $flags, $elseflags);
 488   }
 489 }
 490
 491 sub process_types {
 492   my($self, $typestr) = @_;
 493   my $wcprops         = $self->get_properties();
 494   my %types;
 495   my %props;
 496   @types{split(/\s*,\s*/, $typestr)} = ();
 497
 498   ## If there is a property in the typestr, i.e., prop:, then
 499   ## we need to extract it into its own collection while removing
 500   ## it from the types collection.
 501   if (index($typestr, 'prop:') >= 0) {
 502     foreach my $key (keys %types) {
 503       if ($key =~ /^prop:\s*(\w+)/) {
 504         ## Add the property to the prop hash.
 505         $props{$1} = 1;
 506
 507         ## Remove the original property from the types.
 508         delete $types{$key};
 509       }
 510       elsif ($key =~ /^!prop:\s*(\w+)/) {
 511         ## Negate the property.
 512         $props{$1} = 0;
 513
 514         ## Remove the original property from the types.
 515         delete $types{$key};
 516       }
 517     }
 518   }
 519
 520   ## Now, process the properties and determine if this project
 521   ## type should be excluded. This will be the case if the property
 522   ## is valid and there exists a match between the listed properties
 523   ## and the workspace properties.
 524   while (my ($key, $val) = each %props) {
 525     if (exists $$wcprops{$key}) {
 526       if ($$wcprops{$key} == 1 and $$wcprops{$key} == $val) {
 527         $types{$self->{wctype}} = 1;
 528       }
 529       else {
 530         delete $types{$self->{wctype}};
 531       }
 532     }
 533     elsif ($val == 0) {
 534       $types{$self->{wctype}} = 1;
 535     }
 536   }
 537
 538   ## Remove all negated types from the collection.
 539   foreach my $key (keys %types) {
 540     if ($key =~ /^!\s*(\w+)/) {
 541       if ($1 eq $self->{wctype}) {
 542         ## Remove the negated key
 543         delete $types{$key};
 544
 545         ## Then delete the key that was negated in the exclusion
 546         delete $types{$1};
 547       }
 548     }
 549   }
 550
 551   return \%types;
 552 }
 553
 554 sub parse_exclude {
 555   my($self, $fh, $typestr, $flags) = @_;
 556   my $status          = 0;
 557   my $errorString     = 'Unable to process exclude';
 558   my $negated         = (index($typestr, '!') >= 0);
 559   my $types           = $self->process_types($typestr);
 560   my $count           = 1;
 561   my @exclude;
 562
 563   if (exists $$types{$self->{wctype}}) {
 564     while (<$fh>) {
 565       my $line = $self->preprocess_line($fh, $_);
 566
 567       if ($line eq '') {
 568       }
 569       elsif ($line =~ /^}(.*)$/) {
 570         --$count;
 571         if (defined $1 && $1 ne '') {
 572           $status = 0;
 573           $errorString = "Trailing characters found: '$1'";
 574         }
 575         else {
 576           $status = 1;
 577           $errorString = undef;
 578         }
 579         last if ($count == 0);
 580       }
 581       else {
 582         if ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
 583           ++$count;
 584         }
 585         elsif ($self->parse_assignment($line, [], $fh)) {
 586           ## Ignore all assignments
 587         }
 588         else {
 589           if ($line =~ /^"([^"]+)"$/) {
 590             $line = $1;
 591           }
 592
 593           ## If the line contains a variable, try to replace it with an
 594           ## actual value.
 595           $line = $self->relative($line) if (index($line, '$') >= 0);
 596
 597           if (defined $self->{'scoped_basedir'} &&
 598               $self->path_is_relative($line)) {
 599             $line = $self->{'scoped_basedir'} . '/' . $line;
 600           }
 601           if ($line =~ /[\?\*\[\]]/) {
 602             push(@exclude, $self->mpc_glob($line));
 603           }
 604           else {
 605             push(@exclude, $line);
 606           }
 607         }
 608       }
 609     }
 610
 611     foreach my $type (keys %$types) {
 612       if (!defined $self->{'exclude'}->{$type}) {
 613         $self->{'exclude'}->{$type} = [];
 614       }
 615       push(@{$self->{'exclude'}->{$type}}, @exclude);
 616     }
 617   }
 618   else {
 619     if ($negated) {
 620       ($status, $errorString) = $self->SUPER::parse_scope($fh,
 621                                                           'exclude',
 622                                                           $typestr,
 623                                                           \%validNames,
 624                                                           $flags);
 625     }
 626     else {
 627       ## If this exclude block didn't match the current type and the
 628       ## exclude wasn't negated, we need to eat the exclude block so that
 629       ## these lines don't get included into the workspace.
 630       while (<$fh>) {
 631         my $line = $self->preprocess_line($fh, $_);
 632
 633         if ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
 634           ++$count;
 635         }
 636         elsif ($line =~ /^}(.*)$/) {
 637           --$count;
 638           if (defined $1 && $1 ne '') {
 639             $status = 0;
 640             $errorString = "Trailing characters found: '$1'";
 641           }
 642           else {
 643             $status = 1;
 644             $errorString = undef;
 645           }
 646           last if ($count == 0);
 647         }
 648       }
 649     }
 650   }
 651
 652   return $status, $errorString;
 653 }
 654
 655
 656 sub parse_associate {
 657   my($self, $fh, $assoc_key) = @_;
 658   my $status      = 0;
 659   my $errorString = 'Unable to process associate';
 660   my $count       = 1;
 661   my @projects;
 662
 663   if (!defined $self->{'associated'}->{$assoc_key}) {
 664     $self->{'associated'}->{$assoc_key} = {};
 665   }
 666
 667   while (<$fh>) {
 668     my $line = $self->preprocess_line($fh, $_);
 669
 670     if ($line eq '') {
 671     }
 672     elsif ($line =~ /^}(.*)$/) {
 673       --$count;
 674       if (defined $1 && $1 ne '') {
 675         $errorString = "Trailing characters found: '$1'";
 676         last;
 677       }
 678       else {
 679         $status = 1;
 680         $errorString = undef;
 681       }
 682       last if ($count == 0);
 683     }
 684     else {
 685       if ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
 686         ++$count;
 687       }
 688       elsif ($self->parse_assignment($line, [], $fh)) {
 689         $errorString = 'Assignments are not ' .
 690           'allowed within an associate scope';
 691         last;
 692       }
 693       else {
 694         if ($line =~ /^"([^"]+)"$/) {
 695           $line = $1;
 696         }
 697
 698         ## If the line contains a variable, try to replace it with an
 699         ## actual value.
 700         $line = $self->relative($line) if (index($line, '$') >= 0);
 701
 702         if (defined $self->{'scoped_basedir'} &&
 703             $self->path_is_relative($line)) {
 704           $line = $self->{'scoped_basedir'} . '/' . $line;
 705         }
 706         if ($line =~ /[\?\*\[\]]/) {
 707           foreach my $file ($self->mpc_glob($line)) {
 708             $self->{'associated'}->{$assoc_key}->{$file} = 1;
 709           }
 710         }
 711         else {
 712           $self->{'associated'}->{$assoc_key}->{$line} = 1;
 713         }
 714       }
 715     }
 716   }
 717
 718   return $status, $errorString;
 719 }
 720
 721
 722 sub parse_specific {
 723   my($self, $fh, $typestr, $validNames, $flags, $elseflags) = @_;
 724   my $types   = $self->process_types($typestr);
 725   my $wctype  = $self->{'wctype'};
 726   my $matches = exists $types->{$wctype};
 727
 728   # $elseflags needs to be defined for Creator::parse_scope to allow "} else {"
 729   $elseflags = {} unless defined $elseflags;
 730
 731   # Assignments within 'specific' always go to the workspace-level assignment
 732   # hash table instead of the $flags bound to the scope.
 733   my $assign = $self->get_assignment_hash();
 734
 735   return $self->SUPER::parse_scope($fh, 'specific', $matches ? $wctype : undef,
 736                                    $validNames, $matches ? ($assign, $elseflags)
 737                                    : (undef, $assign));
 738 }
 739
 740
 741 sub handle_unknown_assignment {
 742   my $self   = shift;
 743   my $type   = shift;
 744   my @values = @_;
 745
 746   if (defined $type) {
 747     $self->process_any_assignment(undef, @values);
 748   }
 749
 750   return 1, undef;
 751 }
 752
 753
 754 sub excluded {
 755   my($self, $file) = @_;
 756
 757   foreach my $excluded (@{$self->{'exclude'}->{$self->{'wctype'}}}) {
 758     return 1 if ($excluded eq $file || index($file, "$excluded/") == 0);
 759   }
 760
 761   return 0;
 762 }
 763
 764
 765 sub handle_scoped_end {
 766   my($self, $type, $flags) = @_;
 767   my $status = 1;
 768   my $error;
 769
 770   ## Replace instances of $PWD with the current directory plus the
 771   ## scoped_basedir.  We have to do it now otherwise, $PWD will be the
 772   ## wrong directory if it's done later.
 773   if (defined $$flags{'cmdline'} && defined $self->{'scoped_basedir'} &&
 774       index($$flags{'cmdline'}, '$PWD') >= 0) {
 775     my $dir = $self->getcwd() . '/' . $self->{'scoped_basedir'};
 776     $$flags{'cmdline'} =~ s/\$PWD(\W)/$dir$1/g;
 777     $$flags{'cmdline'} =~ s/\$PWD$/$dir/;
 778   }
 779
 780   if ($type eq $aggregated && !defined $self->{'handled_scopes'}->{$type}) {
 781     ## Go back to the previous directory and add the directory contents
 782     ($status, $error) = $self->handle_scoped_unknown(undef, $type, $flags, '.');
 783   }
 784
 785   $self->{'handled_scopes'}->{$type} = undef;
 786   return $status, $error;
 787 }
 788
 789
 790 sub handle_scoped_unknown {
 791   my($self, $fh, $type, $flags, $line) = @_;
 792   my $status = 1;
 793   my $error;
 794   my $dupchk;
 795
 796   ## If $type is undef, we are in a skipped part of a specific block
 797   return 1 unless defined $type;
 798
 799   if ($line =~ /^\w+.*{/) {
 800     if (defined $fh) {
 801       my @values;
 802       my $tc = $self->{$self->{'type_check'}};
 803       $self->{$self->{'type_check'}} = 1;
 804       ($status, $error, @values) = $self->parse_line($fh, $line, $flags);
 805       $self->{$self->{'type_check'}} = $tc;
 806     }
 807     else {
 808       $status = 0;
 809       $error  = 'Unhandled line: ' . $line;
 810     }
 811     return $status, $error;
 812   }
 813
 814   ## If the line contains a variable, try to replace it with an actual
 815   ## value.
 816   if (index($line, '$') >= 0) {
 817     $line = $self->relative($line);
 818   }
 819   elsif (defined $self->{'scoped_basedir'}) {
 820     if ($self->path_is_relative($line)) {
 821       if ($line eq '.') {
 822         $line = $self->{'scoped_basedir'};
 823       }
 824       else {
 825         ## This is a relative path and the project may have been added
 826         ## previously without a relative path.  We need to convert the
 827         ## relative path into an absolute path and, if possible, remove
 828         ## the current working directory from the front.  This will get
 829         ## it down to a path that's relative to the current directory and
 830         ## likely to match up with the addition of this file or directory
 831         ## from an upper workspace.
 832         my $cwd = $self->getcwd();
 833         $line = $self->abs_path($self->{'scoped_basedir'} . "/$line");
 834         if (index($line, $cwd) == 0) {
 835           $line = substr($line, length($cwd) + 1);
 836         }
 837       }
 838     }
 839   }
 840
 841   ## We must build up the list of project files and use them as the
 842   ## keys in the duplicate hash check.  We need to call
 843   ## search_for_files() because the user may have just listed
 844   ## directories in the workspace and we need to deal with mpc files.
 845   my @files;
 846   $self->search_for_files($self->{'project_files'}, \@files);
 847   my %dup;
 848   @dup{@files} = ();
 849   $dupchk = \%dup;
 850
 851   ## If the aggregated workspace contains a scope (other than exclude)
 852   ## it will be processed in the block above and we will eventually get
 853   ## here, but by that time $type will no longer be $aggregated.  So,
 854   ## we just need to set it here to ensure that we don't add everything
 855   ## in the scoped_basedir directory in handle_scoped_end()
 856   $self->{'handled_scopes'}->{$aggregated} = 1;
 857
 858   if (-d $line) {
 859     my @files;
 860     $self->search_for_files([ $line ], \@files, $$flags{'implicit'});
 861
 862     ## If we are generating implicit projects within a scope, then
 863     ## we need to remove directories and the parent directories for which
 864     ## there is an mpc file.  Otherwise, the projects will be added
 865     ## twice.
 866     if ($$flags{'implicit'}) {
 867       my %remove;
 868       foreach my $file (@files) {
 869         if ($file =~ /\.mpc$/) {
 870           my $exc = $file;
 871           do {
 872             $exc = $self->mpc_dirname($exc);
 873             $remove{$exc} = 1;
 874           } while ($exc ne '.' && $exc !~ /[a-z]:[\/\\]/i);
 875         }
 876       }
 877
 878       my @acceptable;
 879       foreach my $file (@files) {
 880         push(@acceptable, $file) if (!defined $remove{$file});
 881       }
 882       @files = @acceptable;
 883     }
 884
 885     foreach my $file (@files) {
 886       $self->add_aggregated_mpc($file, $dupchk, $flags);
 887     }
 888   }
 889   else {
 890     foreach my $expfile ($line =~ /[\?\*\[\]]/ ? $self->mpc_glob($line) :
 891                          $line) {
 892       if ($expfile =~ /\.$wsext$/) {
 893         ## An aggregated workspace within an aggregated workspace or scope.
 894         ($status, $error) = $self->aggregated_workspace($expfile, $flags);
 895         last if (!$status);
 896       }
 897       else {
 898         $self->add_aggregated_mpc($expfile, $dupchk, $flags);
 899       }
 900     }
 901   }
 902   $self->{'handled_scopes'}->{$type} = 1;
 903
 904   return $status, $error;
 905 }
 906
 907
 908 sub add_aggregated_mpc {
 909   my($self, $file, $dupchk, $flags) = @_;
 910   if (!$self->excluded($file)) {
 911     if (defined $dupchk && exists $$dupchk{$file}) {
 912       $self->information("Duplicate mpc file ($file) added by an " .
 913                          'aggregate workspace.  It will be ignored.');
 914     }
 915     else {
 916       $self->{'scoped_assign'}->{$file} = $flags;
 917       push(@{$self->{'project_files'}}, $file);
 918       push(@{$self->{'aggregated_mpc'}->{$self->{'current_aggregated'}}},
 919            $file) if defined $self->{'current_aggregated'};
 920     }
 921   }
 922 }
 923
 924
 925 sub search_for_files {
 926   my($self, $files, $array, $impl) = @_;
 927   my $excluded = 0;
 928
 929   foreach my $file (@$files) {
 930     if (-d $file) {
 931       my @f = $self->generate_default_file_list(
 932                                                 $file,
 933                                                 $self->{'exclude'}->{$self->{'wctype'}},
 934                                                 \$excluded);
 935       $self->search_for_files(\@f, $array, $impl);
 936       if ($impl) {
 937         $file =~ s/^\.\///;
 938
 939         # Strip out ^ symbols
 940         $file =~ s/\^//g if ($onVMS);
 941
 942         unshift(@$array, $file);
 943       }
 944     }
 945     elsif ($file =~ /\.mpc$/) {
 946       $file =~ s/^\.\///;
 947
 948       # Strip out ^ symbols
 949       $file =~ s/\^//g if ($onVMS);
 950
 951       unshift(@$array, $file);
 952     }
 953   }
 954
 955   return $excluded;
 956 }
 957
 958
 959 sub remove_duplicate_projects {
 960   my($self, $list) = @_;
 961   my $count = scalar(@$list);
 962
 963   for (my $i = 0; $i < $count; ++$i) {
 964     my $file = $$list[$i];
 965     foreach my $inner (@$list) {
 966       if ($file ne $inner &&
 967           $file eq $self->mpc_dirname($inner) && ! -d $inner) {
 968         splice(@$list, $i, 1);
 969         --$count;
 970         --$i;
 971         last;
 972       }
 973     }
 974   }
 975 }
 976
 977
 978 sub generate_default_components {
 979   my($self, $files, $impl, $excluded) = @_;
 980   my $pjf = $self->{'project_files'};
 981
 982   if (defined $$pjf[0]) {
 983     ## If we have files, then process directories
 984     my @built;
 985     foreach my $file (@$pjf) {
 986       if (!$self->excluded($file)) {
 987         if (-d $file) {
 988           my @found;
 989           my @gen = $self->generate_default_file_list(
 990                                                       $file,
 991                                                       $self->{'exclude'}->{$self->{'wctype'}});
 992           $self->search_for_files(\@gen, \@found, $impl);
 993           push(@built, @found);
 994           if ($impl || $self->{'scoped_assign'}->{$file}->{'implicit'}) {
 995             push(@built, $file);
 996           }
 997         }
 998         else {
 999           push(@built, $file);
1000         }
1001       }
1002     }
1003
1004     ## If the workspace is set to implicit remove duplicates from this
1005     ## list.
1006     $self->remove_duplicate_projects(\@built) if ($impl);
1007
1008     ## Set the project files
1009     $self->{'project_files'} = \@built;
1010   }
1011   else {
1012     ## Add all of the wanted files in this directory
1013     ## and in the subdirectories.
1014     $excluded |= $self->search_for_files($files, $pjf, $impl);
1015
1016     ## If the workspace is set to implicit remove duplicates from this
1017     ## list.
1018     $self->remove_duplicate_projects($pjf) if ($impl);
1019
1020     ## If no files were found, then we push the empty
1021     ## string, so the Project Creator will generate
1022     ## the default project file.
1023     push(@$pjf, '') if (!defined $$pjf[0] && !$excluded);
1024   }
1025 }
1026
1027
1028 sub get_default_workspace_name {
1029   my $self = shift;
1030   my $name = $self->{'current_input'};
1031
1032   if ($name eq '') {
1033     $name = $self->base_directory();
1034   }
1035   else {
1036     ## Since files on UNIX can have back slashes, we transform them
1037     ## into underscores.
1038     $name =~ s/\\/_/g;
1039
1040     ## Take off the extension
1041     $name =~ s/\.[^\.]+$//;
1042   }
1043
1044   return $name;
1045 }
1046
1047
1048 sub generate_defaults {
1049   my $self = shift;
1050
1051   ## Generate default workspace name
1052   if (!defined $self->{'workspace_name'}) {
1053     $self->{'workspace_name'} = $self->get_default_workspace_name();
1054   }
1055
1056   ## Modify the exclude list if we have changed directory from the original
1057   ## starting directory.  Just take off the difference from the front.
1058   my @original;
1059   my $top   = $self->getcwd() . '/';
1060   my $start = $self->getstartdir() . '/';
1061
1062   if ($start ne $top && $top =~ s/^$start//) {
1063     foreach my $exclude (@{$self->{'exclude'}->{$self->{'wctype'}}}) {
1064       push(@original, $exclude);
1065       $exclude =~ s/^$top//;
1066     }
1067   }
1068
1069   my $excluded = 0;
1070   my @files = $self->generate_default_file_list(
1071                                                 '.',
1072                                                 $self->{'exclude'}->{$self->{'wctype'}},
1073                                                 \$excluded);
1074
1075   ## Generate default components
1076   $self->generate_default_components(\@files,
1077                                      $self->get_assignment('implicit'),
1078                                      $excluded);
1079
1080   ## Return the actual exclude list of we modified it
1081   if (defined $original[0]) {
1082     $self->{'exclude'}->{$self->{'wctype'}} = \@original;
1083   }
1084 }
1085
1086
1087 sub get_workspace_name {
1088   return $_[0]->{'workspace_name'};
1089 }
1090
1091
1092 sub get_current_output_name {
1093   return $_[0]->{'current_output'};
1094 }
1095
1096
1097 sub write_and_compare_file {
1098   my($self, $outdir, $oname, $func, @params) = @_;
1099   my $fh    = new FileHandle();
1100   my $status = 1;
1101   my $errorString = undef;
1102
1103   ## Set the output directory if one wasn't provided
1104   $outdir = $self->get_outdir() if (!defined $outdir);
1105
1106   ## Create the full name and pull off the directory.  The directory
1107   ## portion may not be the same as $outdir, since $name could possibly
1108   ## contain a directory portion too.
1109   my $name = "$outdir/$oname";
1110   my $dir  = $self->mpc_dirname($name);
1111
1112   ## Make the full path if necessary
1113   mkpath($dir, 0, 0777) if ($dir ne '.');
1114
1115   ## Set the current output data member to our file's full name
1116   $self->{'current_output'} = $name;
1117
1118   if ($self->compare_output()) {
1119     ## First write the output to a temporary file
1120     my $tmp = "$outdir/MWC$>.$$";
1121     my $different = 1;
1122     if (open($fh, ">$tmp")) {
1123       ($status, $errorString) = &$func($self, $fh, @params);
1124       close($fh);
1125
1126       $different = 0 if ($status && !$self->files_are_different($name, $tmp));
1127     }
1128     else {
1129       $status = 0;
1130       $errorString = "Unable to open $tmp for output.";
1131     }
1132
1133     if ($status) {
1134       if ($different) {
1135         unlink($name);
1136
1137         if (!rename($tmp, $name)) {
1138           $status = 0;
1139           $errorString = "Unable to open $name for output";
1140         }
1141       }
1142       else {
1143         ## There is no need to rename, so remove our temp file.
1144         unlink($tmp);
1145       }
1146     }
1147   }
1148   else {
1149     if (open($fh, ">$name")) {
1150       &$func($self, $fh, @params);
1151       close($fh);
1152     }
1153     else {
1154       $status = 0;
1155       $errorString = "Unable to open $name for output.";
1156     }
1157   }
1158
1159   return $status, $errorString;
1160 }
1161
1162 sub write_workspace {
1163
1164   my($self, $creator, $addfile) = @_;
1165   my $status = 1;
1166   my $errorString;
1167   my $duplicates = 0;
1168
1169   if ($self->get_toplevel()) {
1170
1171     ## There is usually a progress indicator callback provided, but if
1172     ## the output is being redirected, there will be no progress
1173     ## indicator.
1174     my $progress = $self->get_progress_callback();
1175     &$progress() if (defined $progress);
1176
1177     if ($addfile) {
1178
1179       ## To be consistent across multiple project types, we disallow
1180       ## duplicate project names for all types, not just VC6.
1181       ## Note that these name are handled case-insensitive by VC6
1182       my %names;
1183       foreach my $project (@{$self->{'projects'}}) {
1184         my $name = lc($self->{'project_info'}->{$project}->[ProjectCreator::PROJECT_NAME]);
1185         if (defined $names{$name}) {
1186           ++$duplicates;
1187           $self->error("Duplicate case-insensitive project '$name'. " .
1188                        "Look in " . $self->mpc_dirname($project) .
1189                        " and " . $self->mpc_dirname($names{$name}) .
1190                        " for project name conflicts.");
1191         }
1192         else {
1193           $names{$name} = $project;
1194         }
1195       }
1196     }
1197     else {
1198       $self->{'per_project_workspace_name'} = 1;
1199     }
1200
1201     my $name = $self->transform_file_name($self->workspace_file_name());
1202
1203     my $abort_creation = 0;
1204     if ($duplicates > 0) {
1205       $abort_creation = 1;
1206       $errorString = "Duplicate case-insensitive project names are " .
1207         "not allowed within a workspace.";
1208       $status = 0;
1209     }
1210     else {
1211       if (!defined $self->{'projects'}->[0]) {
1212         $self->information('No projects were created.');
1213         $abort_creation = 1;
1214       }
1215     }
1216
1217     if (!$abort_creation) {
1218       ## Verify and possibly modify the dependencies
1219       if ($addfile) {
1220         $self->verify_build_ordering();
1221       }
1222
1223       if ($addfile || !$self->file_written($name)) {
1224         ($status, $errorString) = $self->write_and_compare_file(
1225                                                                 undef, $name,
1226                                                                 sub {
1227                                                                   my($self, $fh) = @_;
1228                                                                   $self->pre_workspace($fh, $creator, $addfile);
1229                                                                   my($status, $errorString) = $self->write_comps($fh, $creator, $addfile);
1230                                                                   ## If write_comps() does't return a status, set status to true.
1231                                                                   $status = 1 if (!defined $status || $status eq "");
1232                                                                   if ($status) {
1233                                                                     my $wsHelper = WorkspaceHelper::get($self);
1234                                                                     $wsHelper->perform_custom_processing($fh, $creator, $addfile);
1235
1236                                                                     $self->post_workspace($fh, $creator, $addfile);
1237                                                                   }
1238                                                                   return $status, $errorString;
1239                                                                 });
1240         $self->add_file_written($name) if ($status && $addfile);
1241       }
1242
1243       my $additional = $self->get_additional_output();
1244       foreach my $entry (@$additional) {
1245         ($status, $errorString) = $self->write_and_compare_file(@$entry);
1246         if (!$status) {
1247           last;
1248         }
1249       }
1250
1251       if ($addfile && $self->{'generate_dot'}) {
1252         my $dh     = new FileHandle();
1253         my $wsname = $self->get_workspace_name();
1254         if (open($dh, ">$wsname.dot")) {
1255           my %targnum;
1256           my @list = $self->number_target_deps($self->{'projects'},
1257                                                $self->{'project_info'},
1258                                                \%targnum, 0);
1259           ## If the workspace name contains a dot, we will replace it
1260           ## with two underscores.  Graphviz does not accept names with
1261           ## dots.
1262           $wsname =~ s/\./__/g;
1263           print $dh "digraph $wsname {\n";
1264           foreach my $project (@{$self->{'projects'}}) {
1265             if (defined $targnum{$project}) {
1266               ## If the project name contains a dot, we will replace it
1267               ## with two underscores.  Graphviz does not accept names
1268               ## with dots.
1269               my $pname = $self->{'project_info'}->{$project}->[ProjectCreator::PROJECT_NAME];
1270               $pname =~ s/\./__/g;
1271               foreach my $number (@{$targnum{$project}}) {
1272                 my $depr = $self->{'project_info'}->{$list[$number]}->[ProjectCreator::PROJECT_NAME];
1273                 $depr =~ s/\./__/g;
1274                 print $dh "  $pname -> ", $depr, ";\n";
1275               }
1276             }
1277           }
1278           print $dh "}\n";
1279           close($dh);
1280         }
1281         else {
1282           $self->warning("Unable to write to $wsname.dot.");
1283         }
1284       }
1285     }
1286
1287     $self->{'per_project_workspace_name'} = undef if (!$addfile);
1288   }
1289
1290   return $status, $errorString;
1291 }
1292
1293
1294 sub save_project_info {
1295   my($self, $gen, $gpi, $gll, $dir, $projects, $pi, $ll) = @_;
1296   my $c = 0;
1297
1298   ## For each file written
1299   foreach my $pj (@$gen) {
1300     ## Save the full path to the project file in the array
1301     my $full = ($dir ne '.' ? "$dir/" : '') . $pj;
1302     push(@$projects, $full);
1303
1304     ## Get the corresponding generated project info and save it
1305     ## in the hash map keyed on the full project file name
1306     $$pi{$full} = $$gpi[$c];
1307     $c++;
1308   }
1309
1310   foreach my $key (keys %$gll) {
1311     $$ll{$key} = $$gll{$key};
1312   }
1313 }
1314
1315
1316 sub topname {
1317   my($self, $file) = @_;
1318   my $dir  = '.';
1319   my $rest = $file;
1320   if ($file =~ /^([^\/\\]+)[\/\\](.*)/ && $1 !~ /^[a-z]:$/i) {
1321     $dir  = $1;
1322     $rest = $2;
1323   }
1324   return $dir, $rest;
1325 }
1326
1327
1328 sub generate_hierarchy {
1329   my($self, $creator, $origproj, $originfo) = @_;
1330   my $current;
1331   my @saved;
1332   my %sinfo;
1333   my $cwd = $self->getcwd();
1334   my $status = 1;
1335   my $errorString;
1336
1337   ## Make a copy of these.  We will be modifying them.
1338   ## It is necessary to sort the projects to get the correct ordering.
1339   ## Projects in the current directory must come before projects in
1340   ## other directories.
1341   my @projects  = sort { return $self->sort_projects_by_directory($a, $b) + 0;
1342                        } @{$origproj};
1343   my %projinfo  = %{$originfo};
1344
1345   foreach my $prj (@projects) {
1346     ## If the project path starts with ./ the code assumed that the top was
1347     ## the current directory and would end up not creating the workspace as
1348     ## it should have been.  We will clean up the project directory and pass
1349     ## that to topname() instead.
1350     my $clean = $prj;
1351     $clean =~ s/^\.[\/]+//;
1352
1353     my($top, $rest) = $self->topname($clean);
1354     if (!defined $current) {
1355       $current = $top;
1356       push(@saved, $rest);
1357       $sinfo{$rest} = $projinfo{$prj};
1358     }
1359     elsif ($top ne $current) {
1360       if ($current ne '.') {
1361         ## Write out the hierarchical workspace
1362         $self->cd($current);
1363         ($status, $errorString) = $self->generate_hierarchy($creator, \@saved, \%sinfo);
1364
1365         $self->{'projects'}       = \@saved;
1366         $self->{'project_info'}   = \%sinfo;
1367         $self->{'workspace_name'} = $self->base_directory();
1368         ($status, $errorString) = $self->write_workspace($creator) if ($status);
1369
1370         last if !$status;
1371         $self->cd($cwd);
1372       }
1373
1374       ## Start the next one
1375       $current = $top;
1376       @saved = ($rest);
1377       %sinfo = ();
1378       $sinfo{$rest} = $projinfo{$prj};
1379     }
1380     else {
1381       push(@saved, $rest);
1382       $sinfo{$rest} = $projinfo{$prj};
1383     }
1384   }
1385   if ($status && defined $current && $current ne '.') {
1386     $self->cd($current);
1387     ($status, $errorString) = $self->generate_hierarchy($creator, \@saved, \%sinfo);
1388
1389     $self->{'projects'}       = \@saved;
1390     $self->{'project_info'}   = \%sinfo;
1391     $self->{'workspace_name'} = $self->base_directory();
1392     ($status, $errorString) = $self->write_workspace($creator) if ($status);
1393
1394     $self->cd($cwd);
1395   }
1396
1397   return $status, $errorString;
1398 }
1399
1400 sub generate_project_files {
1401   my $self      = shift;
1402   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1403   my @projects;
1404   my %pi;
1405   my %liblocs;
1406   my $creator = $self->project_creator();
1407   my $cwd = $self->getcwd();
1408   my $impl = $self->get_assignment('implicit');
1409   my $postkey = $creator->get_dynamic() .
1410     $creator->get_static() . "-$self";
1411   my $previmpl  = $impl;
1412   my $prevcache = $self->{'cacheok'};
1413   my %gstate    = $creator->save_state();
1414   my $genimpdep = $self->generate_implicit_project_dependencies();
1415   my $errorString;
1416
1417   $Data::Dumper::Indent = 0;
1418
1419   ## Save this project creator setting for later use in the
1420   ## number_target_deps() method.
1421   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1422
1423   ## Remove the address portion of the $self string
1424   $postkey =~ s/=.*//;
1425
1426   ## Set the source file callback on our project creator
1427   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1428
1429   foreach my $ofile (@{$self->{'project_files'}}) {
1430     if (!$self->excluded($ofile)) {
1431       my $file    = $ofile;
1432       my $dir     = $self->mpc_dirname($file);
1433       my $restore = 0;
1434
1435       if (defined $self->{'scoped_assign'}->{$ofile}) {
1436         ## Handle the implicit assignment
1437         my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
1438         if (defined $oi) {
1439           $previmpl = $impl;
1440           $impl     = $oi;
1441         }
1442
1443         ## Handle the cmdline assignment
1444         my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
1445         if (defined $cmdline && $cmdline ne '') {
1446           ## Save the cacheok value
1447           $prevcache = $self->{'cacheok'};
1448
1449           ## Get the current parameters and process the command line
1450           my %parameters = $self->current_parameters();
1451           $self->process_cmdline($cmdline, \%parameters);
1452
1453           ## Set the parameters on the creator
1454           $creator->restore_state(\%parameters);
1455           $restore = 1;
1456         }
1457       }
1458
1459       ## If we are generating implicit projects and the file is a
1460       ## directory, then we set the dir to the file and empty the file
1461       if ($impl && -d $file) {
1462         $dir  = $file;
1463         $file = '';
1464
1465         ## If the implicit assignment value was not a number, then
1466         ## we will add this value to our base projects.
1467         if ($impl !~ /^\d+$/) {
1468           my $bps = $creator->get_baseprojs();
1469           push(@$bps, split(/\s+/, $impl));
1470           $restore = 1;
1471           $self->{'cacheok'} = 0;
1472         }
1473       }
1474
1475       ## Generate the key for this project file
1476       my $prkey = $self->getcwd() . '/' .
1477         ($file eq '' ? $dir : $file) . "-$postkey";
1478
1479       ## We must change to the subdirectory for
1480       ## which this project file is intended
1481       if ($self->cd($dir)) {
1482         my $files_written = [];
1483         my $gen_proj_info = [];
1484         my $gen_lib_locs  = {};
1485         if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1486           $files_written = $allprojects{$prkey};
1487           $gen_proj_info = $allprinfo{$prkey};
1488           $gen_lib_locs  = $allliblocs{$prkey};
1489
1490           $status = 1;
1491         }
1492         else {
1493           $status = $creator->generate($self->mpc_basename($file));
1494
1495           ## If any one project file fails, then stop
1496           ## processing altogether.
1497           if (!$status) {
1498             ## We don't restore the state before we leave,
1499             ## but that's ok since we will be exiting right now.
1500             return $status, $creator,
1501               "Unable to process " . ($file eq '' ? " in $dir" : $file);
1502           }
1503
1504           ## Get the individual project information and
1505           ## generated file name(s)
1506           $files_written = $creator->get_files_written();
1507           $gen_proj_info = $creator->get_project_info();
1508           $gen_lib_locs  = $creator->get_lib_locations();
1509
1510           if ($self->{'cacheok'}) {
1511             $allprojects{$prkey} = $files_written;
1512             $allprinfo{$prkey}   = $gen_proj_info;
1513             $allliblocs{$prkey}  = $gen_lib_locs;
1514           }
1515
1516           push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
1517         }
1518         $self->cd($cwd);
1519         $self->save_project_info($files_written, $gen_proj_info,
1520                                  $gen_lib_locs, $dir,
1521                                  \@projects, \%pi, \%liblocs);
1522       }
1523       else {
1524         ## Unable to change to the directory.
1525         ## We don't restore the state before we leave,
1526         ## but that's ok since we will be exiting soon.
1527         return 0, $creator, "Unable to change directory to $dir";
1528       }
1529
1530       ## Return things to the way they were
1531       $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
1532       if ($restore) {
1533         $self->{'cacheok'} = $prevcache;
1534         $creator->restore_state(\%gstate);
1535       }
1536     }
1537     else {
1538       ## This one was excluded, so status is ok
1539       $status = 1;
1540     }
1541
1542   }
1543
1544   ## Add implicit project dependencies based on source files
1545   ## that have been used by multiple projects.  If we do it here
1546   ## before we call generate_hierarchy(), we don't have to call it
1547   ## in generate_hierarchy() for each workspace.
1548   $self->{'projects'}     = \@projects;
1549   $self->{'project_info'} = \%pi;
1550
1551   if ($status && $genimpdep) {
1552     $self->add_implicit_project_dependencies($creator, $cwd);
1553   }
1554
1555   ## If we are generating the hierarchical workspaces, then do so
1556   $self->{'lib_locations'} = \%liblocs;
1557   if ($self->get_hierarchy() || $self->workspace_per_project()) {
1558     my $orig = $self->{'workspace_name'};
1559     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
1560     $self->{'workspace_name'} = $orig;
1561   }
1562
1563   ## Reset the projects and project_info
1564   $self->{'projects'}      = \@projects;
1565   $self->{'project_info'}  = \%pi;
1566
1567   return $status, $creator, $errorString;
1568 }
1569
1570 sub generate_project_files_fork {
1571   my $self   = shift;
1572   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1573
1574   my @projects;
1575   my %pi;
1576   my %liblocs;
1577
1578   my $creator = $self->project_creator('child');
1579   my $cwd = $self->getcwd();
1580   my $impl = $self->get_assignment('implicit');
1581   my $postkey = $creator->get_dynamic() .
1582     $creator->get_static() . "-$self";
1583   my $previmpl  = $impl;
1584   my $prevcache = $self->{'cacheok'};
1585   my %gstate    = $creator->save_state();
1586   my $genimpdep = $self->generate_implicit_project_dependencies();
1587   my $errorString;
1588
1589   my @save;
1590   my $VAR1;
1591   $Data::Dumper::Indent = 0;
1592
1593   ## Save this project creator setting for later use in the
1594   ## number_target_deps() method.
1595   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1596
1597   ## Remove the address portion of the $self string
1598   $postkey =~ s/=.*//;
1599
1600   ## Set the source file callback on our project creator
1601   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1602
1603   my $pid;
1604   my @pids;
1605   my $tmp = 'mpctmp00000000';
1606
1607   ## remove old temp files
1608   my @tmpfiles = glob "${wdir}/mpctmp*";
1609   for my $file (@tmpfiles) {
1610     unlink $file || die "Error: Unable to delete tmp file $file in directory $wdir";
1611   }
1612
1613   my $num_tmp_files = scalar (@tmpfiles);
1614
1615   $self->diagnostic("Multiprocess MPC removed $num_tmp_files existing files like \"mpctmp\*\" in $wdir.");
1616
1617   foreach my $ofile (@{$self->{'project_files'}}) {
1618     if ($#pids + 1 >= $num_workers) {
1619       waitpid(shift @pids, 0);
1620     }
1621
1622     ++$tmp;
1623
1624     ## open the output file in parent so it can die if there's an error
1625     open (FD, ">${wdir}/$tmp") || die "Can't open $tmp for write";
1626
1627     $pid = fork();
1628     if ($pid != 0) {
1629       push @pids, $pid;
1630     }
1631     else {
1632       $self->{'pid'} = 'child';
1633
1634       if (!$self->excluded($ofile)) {
1635         my $file    = $ofile;
1636         my $dir     = $self->mpc_dirname($file);
1637         my $restore = 0;
1638
1639         if (defined $self->{'scoped_assign'}->{$ofile}) {
1640           ## Handle the implicit assignment
1641           my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
1642           if (defined $oi) {
1643             $previmpl = $impl;
1644             $impl     = $oi;
1645           }
1646
1647           ## Handle the cmdline assignment
1648           my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
1649           if (defined $cmdline && $cmdline ne '') {
1650             ## Save the cacheok value
1651             $prevcache = $self->{'cacheok'};
1652
1653             ## Get the current parameters and process the command line
1654             my %parameters = $self->current_parameters();
1655             $self->process_cmdline($cmdline, \%parameters);
1656
1657             ## Set the parameters on the creator
1658             $creator->restore_state(\%parameters);
1659             $restore = 1;
1660           }
1661         }
1662
1663         ## If we are generating implicit projects and the file is a
1664         ## directory, then we set the dir to the file and empty the file
1665         if ($impl && -d $file) {
1666           $dir  = $file;
1667           $file = '';
1668
1669           ## If the implicit assignment value was not a number, then
1670           ## we will add this value to our base projects.
1671           if ($impl !~ /^\d+$/) {
1672             my $bps = $creator->get_baseprojs();
1673             push(@$bps, split(/\s+/, $impl));
1674             $restore = 1;
1675             $self->{'cacheok'} = 0;
1676           }
1677         }
1678
1679         ## Generate the key for this project file
1680         my $prkey = $self->getcwd() . '/' .
1681           ($file eq '' ? $dir : $file) . "-$postkey";
1682
1683         ## We must change to the subdirectory for
1684         ## which this project file is intended
1685
1686         if ($self->cd($dir)) {
1687           my $files_written = [];
1688           my $gen_proj_info = [];
1689           my $gen_lib_locs  = {};
1690
1691           if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1692             $files_written = $allprojects{$prkey};
1693             $gen_proj_info = $allprinfo{$prkey};
1694             $gen_lib_locs  = $allliblocs{$prkey};
1695
1696             $status = 1;
1697           }
1698           else {
1699             $status = $creator->generate($self->mpc_basename($file));
1700
1701             ## If any one project file fails, then stop
1702             ## processing altogether.
1703             if (!$status) {
1704               # save the status info and exit. the parent will
1705               # see the error.
1706               print FD "$status|Unable to process " .
1707                 ($file eq '' ? " in $dir" : $file) . "\n";
1708
1709               exit(1);          # child error
1710             }
1711
1712             ## Get the individual project information and
1713             ## generated file name(s)
1714             $files_written = $creator->get_files_written();
1715             $gen_proj_info = $creator->get_project_info();
1716             $gen_lib_locs  = $creator->get_lib_locations();
1717
1718           }
1719
1720
1721           print FD "$status|''|$self->{'cacheok'}|$previmpl|$prevcache\n";
1722           print FD "$ofile|$prkey|$dir|$cwd|$restore\n";
1723
1724           print FD Dumper ($files_written), "\n";
1725           print FD Dumper ($gen_proj_info), "\n";
1726           print FD Dumper ($gen_lib_locs), "\n";
1727
1728           # there's a callback that sets the project file list
1729           # since we can't callback between processes we store
1730           # the list for later
1731           print FD Dumper ($self->{'project_file_list'}), "\n";
1732
1733         }
1734         else {
1735           ## Unable to change to the directory.
1736           ## We don't restore the state before we leave,
1737           ## but that's ok since we will be exiting soon.
1738           print FD "$status|Unable to change directory to $dir\n";
1739
1740           exit (1);             # child error
1741         }
1742
1743       }
1744       else {
1745         ## This one was excluded, so status is ok
1746         ## no need to set though since the child will exit.
1747         #$status = 1;
1748       }
1749
1750       exit(0);                  # child is finished
1751     }
1752   }
1753
1754   for $pid (@pids) {
1755     # this will also reap any zombies
1756     waitpid($pid, 0);
1757   }
1758
1759   my ($msg, $cacheok, $ofile, $prkey, $dir, $restore);
1760
1761   # read the children's stored data
1762   my @kid_data = glob "${wdir}/mpctmp*";
1763
1764   for my $kd (@kid_data) {
1765     open (FD, "<$kd") || die "Can't open $kd for read";
1766
1767     ($status, $msg, $cacheok, $previmpl, $prevcache) = split /\|/, <FD>;
1768
1769     if (!$status) {
1770       return $status, $creator, $msg;
1771     }
1772
1773     ($ofile, $prkey, $dir, $cwd, $restore) = split /\|/, <FD>;
1774
1775     eval (<FD>);
1776     my $files_written = $VAR1;
1777
1778     eval (<FD>);
1779     my $gen_proj_info = $VAR1;
1780
1781     # have to reconstitute gen_lib_locs in the same order it was
1782     # created or else multi-process implicit dependency may differ from
1783     # single process.
1784     eval (<FD>);
1785     my $gen_lib_locs;
1786     for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
1787                         substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
1788
1789       $gen_lib_locs->{substr ($k, index ($k, '|') + 1)} =
1790         $VAR1->{$k};
1791     }
1792
1793     # have to reconstitute project_file_list in the same order it was
1794     # created or else multi-process implicit dependency may differ from
1795     # single process.
1796     eval (<FD>);
1797     for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
1798                         substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
1799
1800       $self->{'project_file_list'}->{substr ($k, index ($k, '|') + 1)} =
1801         $VAR1->{$k};
1802     }
1803
1804     $self->{'cacheok'} = $cacheok;
1805     my $full = $self->path_is_relative($dir) ? "$cwd/$dir" : $dir;
1806     if ($self->cd($full)) {
1807       if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1808
1809         $files_written = $allprojects{$prkey};
1810         $gen_proj_info = $allprinfo{$prkey};
1811         $gen_lib_locs  = $allliblocs{$prkey};
1812         $status = 1;
1813       }
1814       else {
1815         # file is already generated. check status
1816         if (!$status) {
1817
1818           ## We don't restore the state before we leave,
1819           ## but that's ok since we will be exiting right now.
1820           return $status, $creator, $msg;
1821         }
1822
1823         ## Get the individual project information and
1824         ## generated file name(s)
1825         if ($self->{'cacheok'}) {
1826
1827           $allprojects{$prkey} = $files_written;
1828           $allprinfo{$prkey}   = $gen_proj_info;
1829           $allliblocs{$prkey}  = $gen_lib_locs;
1830         }
1831
1832         push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
1833       }
1834
1835       $self->cd($cwd);
1836       $self->save_project_info($files_written, $gen_proj_info,
1837                                $gen_lib_locs, $dir,
1838                                \@projects, \%pi, \%liblocs);
1839     }
1840     else {
1841       ## Unable to change to the directory.
1842       ## We don't restore the state before we leave,
1843       ## but that's ok since we will be exiting soon.
1844       return 0, $creator, "Unable to change directory to $full";
1845     }
1846
1847     ## Return things to the way they were
1848     $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
1849     if ($restore) {
1850       $self->{'cacheok'} = $prevcache;
1851       $creator->restore_state(\%gstate);
1852     }
1853   }
1854
1855   ## Add implicit project dependencies based on source files
1856   ## that have been used by multiple projects.  If we do it here
1857   ## before we call generate_hierarchy(), we don't have to call it
1858   ## in generate_hierarchy() for each workspace.
1859   $self->{'projects'}     = \@projects;
1860   $self->{'project_info'} = \%pi;
1861
1862   if ($status && $genimpdep) {
1863     #print "aipd: $cwd\n", Dumper ($creator), "\n";
1864     $self->add_implicit_project_dependencies($creator, $cwd);
1865   }
1866
1867   ## If we are generating the hierarchical workspaces, then do so
1868   $self->{'lib_locations'} = \%liblocs;
1869   if ($self->get_hierarchy() || $self->workspace_per_project()) {
1870     my $orig = $self->{'workspace_name'};
1871     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
1872     $self->{'workspace_name'} = $orig;
1873   }
1874
1875   ## Reset the projects and project_info
1876   $self->{'projects'}      = \@projects;
1877   $self->{'project_info'}  = \%pi;
1878
1879   return $status, $creator, $errorString;
1880 }
1881
1882 sub send_to_parent {
1883   my $self = shift;
1884   my $arr = shift;
1885
1886   # send the data
1887   my $sock = new IO::Socket::INET (
1888                                    PeerAddr => 'localhost',
1889                                    PeerPort => $wport,
1890                                    Proto => 'tcp',
1891                                   );
1892
1893   if (!defined ($sock)) {
1894     die "Child could not create socket";
1895   }
1896
1897   map { print $sock "$_\n"; } @$arr;
1898   $sock->close();
1899 }
1900
1901 sub generate_project_files_fork_socket {
1902   my $self      = shift;
1903   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1904
1905   my @projects;
1906   my %pi;
1907   my %liblocs;
1908
1909   my $creator = $self->project_creator('child');
1910   my $cwd = $self->getcwd();
1911   my $impl = $self->get_assignment('implicit');
1912   my $postkey = $creator->get_dynamic() .
1913     $creator->get_static() . "-$self";
1914   my $previmpl  = $impl;
1915   my $prevcache = $self->{'cacheok'};
1916   my %gstate    = $creator->save_state();
1917   my $genimpdep = $self->generate_implicit_project_dependencies();
1918   my $errorString;
1919
1920   my @save;
1921   my $VAR1;
1922   $Data::Dumper::Indent = 0;
1923
1924   ## Save this project creator setting for later use in the
1925   ## number_target_deps() method.
1926   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1927
1928   ## Remove the address portion of the $self string
1929   $postkey =~ s/=.*//;
1930
1931   ## Set the source file callback on our project creator
1932   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1933
1934   my $pid;
1935   my @pids;
1936   my @pdata;                    # parents data sent from children.
1937
1938   ## setup workers' data
1939   my @wdata;
1940   my $beg;
1941   my $fin;
1942
1943   my $num_prj_files = $#{$self->{'project_files'}} + 1;
1944
1945   ## reduce the number of workers if necessary
1946   ## what if $num_workers > SOMAXCONN?? (unlikely)
1947   if ($num_workers > SOMAXCONN) {
1948     $self->diagnostic("Multiprocess MPC reducing # workers from $num_workers to " . SOMAXCONN . ", the max # of queued connections");
1949     $num_workers = SOMAXCONN;
1950   }
1951
1952   if ($num_workers > $num_prj_files) {
1953     # don't fork more workers than there are jobs
1954     $self->diagnostic("Multiprocess MPC reducing # workers from $num_workers to $num_prj_files, the number of project files.");
1955     $num_workers = $num_prj_files;
1956   }
1957
1958   my $num_per_worker = int ($num_prj_files / $num_workers);
1959   my $num_lines_per_prj = 6;
1960
1961   $self->diagnostic("Multiprocess MPC using $num_workers workers to process $num_prj_files project files.");
1962
1963   for (my $wctr = 0; $wctr < $num_workers; ++$wctr) {
1964     $beg = $wctr * $num_per_worker;
1965     $fin = $beg + $num_per_worker - 1;
1966
1967     @{$wdata[$wctr]} = @{$self->{'project_files'}}[$beg..$fin];
1968   }
1969
1970   ## give any remaining data to last worker.
1971   if ($num_prj_files > $num_per_worker * $num_workers) {
1972     push @{$wdata[$num_workers - 1]} ,
1973       @{$self->{'project_files'}}[$num_per_worker
1974                                   * $num_workers..$#{$self->{'project_files'}}];
1975
1976   }
1977
1978   ## Setup listener. Do this before fork so that (in the rare case)
1979   ## when child tries to send data before the accept(), the socket
1980   ## is at least initialized.
1981   my $sock = new IO::Socket::INET (
1982                                    LocalHost => 'localhost',
1983                                    LocalPort => $wport,
1984                                    Proto     => 'tcp',
1985                                    Listen    => $num_workers,
1986                                    Reuse     => 1
1987                                   );
1988   if (!defined ($sock)) {
1989     die "Error setting up parent listener";
1990   }
1991
1992   ## spawn the workers.
1993   my $id = 0;
1994   while ($id < $num_workers) {
1995     # use pipes as barrier
1996     $pid = fork();
1997     if ($pid != 0) {
1998       push @pids, $pid;
1999     }
2000     else {
2001       ## after fork, child knows its id and which data to use.
2002       $self->{'pid'} = 'child';
2003       last;
2004     }
2005     ++$id;
2006   }
2007
2008   if ($self->{pid} eq 'parent') {
2009     $self->diagnostic("Multiprocess MPC using port $wport.");
2010
2011     # read the data from the kids
2012     for (my $ctr = 0; $ctr < $num_workers; ++$ctr) {
2013       my $handle = $sock->accept();
2014       die "Accept error" if !$handle;
2015       my $id = <$handle>;
2016       @{$pdata[$id]} = <$handle>;
2017
2018       # each project as 6 records
2019       if ((($#{$pdata[$id]} + 1) / $num_lines_per_prj) != $num_per_worker) {
2020         if ($#{$pdata[$id]} != 0) {
2021           # 0 indicates a failed status which will be delt with later
2022           if (($id == $num_workers - 1) && ((($#{$pdata[$id]} + 1) / $num_lines_per_prj) != $num_per_worker + $#{$self->{'project_files'}} + 1 - ($num_workers * $num_per_worker))) {
2023             # The last child may have more than num_per_worker records
2024             my $rec = $#{$pdata[$id]} + 1;
2025             my $exp = $num_per_worker * $num_lines_per_prj;
2026             die "There is an error in the child data. Expected $exp. Received $rec";
2027           }
2028         }
2029       }
2030     }
2031     # all data has been read
2032     $sock->close();
2033   }
2034   else {
2035     ## This is the code the workers run.
2036     undef $sock;
2037     ## generate projects
2038     my @cdata = ($id);
2039     foreach my $ofile (@{$wdata[$id]}) {
2040       if (!$self->excluded($ofile)) {
2041         my $file    = $ofile;
2042         my $dir     = $self->mpc_dirname($file);
2043         my $restore = 0;
2044
2045         if (defined $self->{'scoped_assign'}->{$ofile}) {
2046           ## Handle the implicit assignment
2047           my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
2048           if (defined $oi) {
2049             $previmpl = $impl;
2050             $impl     = $oi;
2051           }
2052
2053           ## Handle the cmdline assignment
2054           my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
2055           if (defined $cmdline && $cmdline ne '') {
2056             ## Save the cacheok value
2057             $prevcache = $self->{'cacheok'};
2058
2059             ## Get the current parameters and process the command line
2060             my %parameters = $self->current_parameters();
2061             $self->process_cmdline($cmdline, \%parameters);
2062
2063             ## Set the parameters on the creator
2064             $creator->restore_state(\%parameters);
2065             $restore = 1;
2066           }
2067         }
2068
2069         ## If we are generating implicit projects and the file is a
2070         ## directory, then we set the dir to the file and empty the file
2071         if ($impl && -d $file) {
2072           $dir  = $file;
2073           $file = '';
2074
2075           ## If the implicit assignment value was not a number, then
2076           ## we will add this value to our base projects.
2077           if ($impl !~ /^\d+$/) {
2078             my $bps = $creator->get_baseprojs();
2079             push(@$bps, split(/\s+/, $impl));
2080             $restore = 1;
2081             $self->{'cacheok'} = 0;
2082           }
2083         }
2084
2085         ## Generate the key for this project file
2086         my $prkey = $self->getcwd() . '/' .
2087           ($file eq '' ? $dir : $file) . "-$postkey";
2088
2089         ## We must change to the subdirectory for
2090         ## which this project file is intended
2091
2092         if ($self->cd($dir)) {
2093           my $files_written = [];
2094           my $gen_proj_info = [];
2095           my $gen_lib_locs  = {};
2096
2097           if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
2098             $files_written = $allprojects{$prkey};
2099             $gen_proj_info = $allprinfo{$prkey};
2100             $gen_lib_locs  = $allliblocs{$prkey};
2101
2102             $status = 1;
2103           }
2104           else {
2105             $status = $creator->generate($self->mpc_basename($file));
2106
2107             ## If any one project file fails, then stop
2108             ## processing altogether.
2109             if (!$status) {
2110               # save the status info and exit. the parent will
2111               # see the error.
2112               @cdata = ($id);
2113               push @cdata, "$status|Unable to process " .
2114                 ($file eq '' ? " in $dir" : $file) . "\n";
2115
2116               $self->send_to_parent(\@cdata);
2117               exit(1);          # child error
2118             }
2119
2120             ## Get the individual project information and
2121             ## generated file name(s)
2122             $files_written = $creator->get_files_written();
2123             $gen_proj_info = $creator->get_project_info();
2124             $gen_lib_locs  = $creator->get_lib_locations();
2125
2126           }
2127
2128           push @cdata, "$status|''|$self->{'cacheok'}|$previmpl|$prevcache";
2129           push @cdata, "$ofile|$prkey|$dir|$cwd|$restore";
2130           push @cdata, Dumper ($files_written);
2131           push @cdata, Dumper ($gen_proj_info);
2132           push @cdata, Dumper ($gen_lib_locs);
2133
2134           # there's a callback that sets the project file list
2135           # since we can't callback between processes we store
2136           # the list for later
2137           push @cdata, Dumper ($self->{'project_file_list'});
2138
2139           $self->cd($cwd);
2140
2141         }
2142         else {
2143           ## Unable to change to the directory.
2144           ## We don't restore the state before we leave,
2145           ## but that's ok since we will be exiting soon.
2146           @cdata = ($id);
2147           push @cdata, "$status|Unable to change directory to $dir\n";
2148           $self->send_to_parent(\@cdata);
2149
2150           exit (1);             # child error
2151         }
2152
2153         ## Return things to the way they were
2154         $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
2155         if ($restore) {
2156           $self->{'cacheok'} = $prevcache;
2157           $creator->restore_state(\%gstate);
2158         }
2159       }
2160       else {
2161         ## This one was excluded, so status is ok
2162         ## no need to set though since the child will exit.
2163         #$status = 1;
2164       }
2165     }
2166
2167     # send all the data at once.
2168     $self->send_to_parent(\@cdata);
2169
2170     exit (0);
2171
2172     # end of child
2173   }
2174
2175   # This is the parent again.
2176
2177   for $pid (@pids) {
2178     # this will reap any zombies
2179     waitpid($pid, 0);
2180   }
2181
2182   my ($msg, $cacheok, $ofile, $prkey, $dir, $restore);
2183
2184   # read the children's stored data
2185   for (my $i = 0; $i < $num_workers; ++$i) {
2186     for (my $j = 0; $j <  $#{$pdata[$i]} + 1; ++$j) {
2187       ($status, $msg, $cacheok, $previmpl, $prevcache) = split /\|/, ${$pdata[$i]}[$j++];
2188
2189       # check that the child was successful
2190       if (!$status) {
2191         return $status, $creator, $msg;
2192       }
2193
2194       ($ofile, $prkey, $dir, $cwd, $restore) = split /\|/, ${$pdata[$i]}[$j++];
2195
2196       eval (${$pdata[$i]}[$j++]);
2197       my $files_written = $VAR1;
2198
2199       eval (${$pdata[$i]}[$j++]);
2200       my $gen_proj_info = $VAR1;
2201
2202       # have to reconstitute gen_lib_locs in the same order it was
2203       # created or else multi-process implicit dependency may differ from
2204       # single process.
2205       eval (${$pdata[$i]}[$j++]);
2206       my $gen_lib_locs;
2207       for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
2208                           substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
2209
2210         $gen_lib_locs->{substr ($k, index ($k, '|') + 1)} =
2211           $VAR1->{$k};
2212       }
2213
2214       # have to reconstitute project_file_list in the same order it was
2215       # created or else multi-process implicit dependency may differ from
2216       # single process.
2217       eval (${$pdata[$i]}[$j]);
2218       for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
2219                           substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
2220
2221         $self->{'project_file_list'}->{substr ($k, index ($k, '|') + 1)} =
2222           $VAR1->{$k};
2223       }
2224
2225       $self->{'cacheok'} = $cacheok;
2226       if ($self->cd($dir)) {
2227         if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
2228
2229           $files_written = $allprojects{$prkey};
2230           $gen_proj_info = $allprinfo{$prkey};
2231           $gen_lib_locs  = $allliblocs{$prkey};
2232           $status = 1;
2233         }
2234         else {
2235           # file is already generated. check status
2236           if (!$status) {
2237
2238             ## We don't restore the state before we leave,
2239             ## but that's ok since we will be exiting right now.
2240             return $status, $creator, $msg;
2241           }
2242
2243           ## Get the individual project information and
2244           ## generated file name(s)
2245           if ($self->{'cacheok'}) {
2246
2247             $allprojects{$prkey} = $files_written;
2248             $allprinfo{$prkey}   = $gen_proj_info;
2249             $allliblocs{$prkey}  = $gen_lib_locs;
2250           }
2251
2252           push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
2253         }
2254
2255         $self->cd($cwd);
2256         $self->save_project_info($files_written, $gen_proj_info,
2257                                  $gen_lib_locs, $dir,
2258                                  \@projects, \%pi, \%liblocs);
2259       }
2260       else {
2261
2262         ## Unable to change to the directory.
2263         ## We don't restore the state before we leave,
2264         ## but that's ok since we will be exiting soon.
2265         return 0, $creator, $msg;
2266
2267       }
2268
2269       ## Return things to the way they were
2270       $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
2271       if ($restore) {
2272         $self->{'cacheok'} = $prevcache;
2273         $creator->restore_state(\%gstate);
2274       }
2275     }
2276   }
2277
2278   ## Add implicit project dependencies based on source files
2279   ## that have been used by multiple projects.  If we do it here
2280   ## before we call generate_hierarchy(), we don't have to call it
2281   ## in generate_hierarchy() for each workspace.
2282   $self->{'projects'}     = \@projects;
2283   $self->{'project_info'} = \%pi;
2284
2285   if ($status && $genimpdep) {
2286     #print "aipd: $cwd\n", Dumper ($creator), "\n";
2287     $self->add_implicit_project_dependencies($creator, $cwd);
2288   }
2289
2290   ## If we are generating the hierarchical workspaces, then do so
2291   $self->{'lib_locations'} = \%liblocs;
2292   if ($self->get_hierarchy() || $self->workspace_per_project()) {
2293     my $orig = $self->{'workspace_name'};
2294     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
2295     $self->{'workspace_name'} = $orig;
2296   }
2297
2298   ## Reset the projects and project_info
2299   $self->{'projects'}      = \@projects;
2300   $self->{'project_info'}  = \%pi;
2301
2302   return $status, $creator, $errorString;
2303 }
2304
2305
2306 sub array_contains {
2307   my($self, $left, $right) = @_;
2308   my %check;
2309
2310   ## Initialize the hash keys with the left side array
2311   @check{@$left} = ();
2312
2313   ## Check each element on the right against the left.
2314   foreach my $r (@$right) {
2315     return 1 if (exists $check{$r});
2316   }
2317
2318   return 0;
2319 }
2320
2321
2322 sub non_intersection {
2323   my($self, $left, $right, $over) = @_;
2324   my $status = 0;
2325   my %check;
2326
2327   ## Initialize the hash keys with the left side array
2328   @check{@$left} = ();
2329
2330   ## Check each element on the right against the left.
2331   ## Store anything that isn't in the left side in the over array.
2332   foreach my $r (@$right) {
2333     if (exists $check{$r}) {
2334       $status = 1;
2335     }
2336     else {
2337       push(@$over, $r);
2338     }
2339   }
2340   return $status;
2341 }
2342
2343
2344 sub indirect_dependency {
2345   my($self, $dir, $ccheck, $cfile) = @_;
2346
2347   $self->{'indirect_checked'}->{$ccheck} = 1;
2348   if (index($self->{'project_info'}->{$ccheck}->[ProjectCreator::DEPENDENCIES], $cfile) >= 0) {
2349     return 1;
2350   }
2351   else {
2352     my $deps = $self->create_array(
2353                                    $self->{'project_info'}->{$ccheck}->[ProjectCreator::DEPENDENCIES]);
2354     foreach my $dep (@$deps) {
2355       if (defined $self->{'project_info'}->{"$dir$dep"} &&
2356           !defined $self->{'indirect_checked'}->{"$dir$dep"} &&
2357           $self->indirect_dependency($dir, "$dir$dep", $cfile)) {
2358         return 1;
2359       }
2360     }
2361   }
2362
2363   return 0;
2364 }
2365
2366
2367 sub add_implicit_project_dependencies {
2368   my($self, $creator, $cwd) = @_;
2369   my %bidir;
2370   my %save;
2371
2372   ## Take the current working directory and regular expression'ize it.
2373   $cwd = $self->escape_regex_special($cwd);
2374
2375   ## Look at each projects file list and check it against all of the
2376   ## others.  If any of the other projects file lists contains anothers
2377   ## file, then they are dependent (due to build parallelism).  So, we
2378   ## append the dependency and remove the file in question from the
2379   ## project so that the next time around the foreach, we don't find it
2380   ## as a dependent on the one that we just modified.
2381   my @pflkeys = keys %{$self->{'project_file_list'}};
2382
2383   foreach my $key (@pflkeys) {
2384     foreach my $ikey (@pflkeys) {
2385       ## Not the same project and
2386       ## The same directory and
2387       ## We've not already added a dependency to this project
2388       if ($key ne $ikey &&
2389           ($self->{'project_file_list'}->{$key}->[1] eq
2390            $self->{'project_file_list'}->{$ikey}->[1]) &&
2391           (!defined $bidir{$ikey} ||
2392            !$self->array_contains($bidir{$ikey}, [$key]))) {
2393         my @over;
2394         if ($self->non_intersection(
2395                                     $self->{'project_file_list'}->{$key}->[2],
2396                                     $self->{'project_file_list'}->{$ikey}->[2],
2397                                     \@over)) {
2398           ## The project contains shared source files, so we need to
2399           ## look into adding an implicit inter-project dependency.
2400           $save{$ikey} = $self->{'project_file_list'}->{$ikey}->[2];
2401           $self->{'project_file_list'}->{$ikey}->[2] = \@over;
2402           if (defined $bidir{$key}) {
2403             push(@{$bidir{$key}}, $ikey);
2404           }
2405           else {
2406             $bidir{$key} = [$ikey];
2407           }
2408           my $append = $creator->translate_value('after', $key);
2409           my $file   = $self->{'project_file_list'}->{$ikey}->[0];
2410           my $dir    = $self->{'project_file_list'}->{$ikey}->[1];
2411           my $cfile  = $creator->translate_value('after', $ikey);
2412           ## Remove our starting directory from the projects directory
2413           ## to get the right part of the directory to prepend.
2414           $dir =~ s/^$cwd[\/\\]*//;
2415
2416           ## Turn the append value into a key for 'project_info' and
2417           ## prepend the directory to the file.
2418           my $ccheck = $append;
2419           $ccheck =~ s/"//g;
2420           if ($dir ne '') {
2421             $dir .= '/';
2422             $ccheck = "$dir$ccheck";
2423             $file = "$dir$file";
2424           }
2425
2426           ## If the append value key contains a reference to the project
2427           ## that we were going to append the dependency value, then
2428           ## ignore the generated dependency.  It is redundant and
2429           ## quite possibly wrong.
2430           $self->{'indirect_checked'} = {};
2431           if (defined $self->{'project_info'}->{$file} &&
2432               (!defined $self->{'project_info'}->{$ccheck} ||
2433                !$self->indirect_dependency($dir, $ccheck, $cfile))) {
2434             ## Append the dependency
2435             $self->{'project_info'}->{$file}->[ProjectCreator::DEPENDENCIES] .= " $append";
2436           }
2437         }
2438       }
2439     }
2440   }
2441
2442   ## Restore the modified values in case this method is called again
2443   ## which is the case when using the -hierarchy option.
2444   foreach my $skey (keys %save) {
2445     $self->{'project_file_list'}->{$skey}->[2] = $save{$skey};
2446   }
2447 }
2448
2449
2450 sub get_projects {
2451   return $_[0]->{'projects'};
2452 }
2453
2454
2455 sub get_project_info {
2456   return $_[0]->{'project_info'};
2457 }
2458
2459
2460 sub get_lib_locations {
2461   return $_[0]->{'lib_locations'};
2462 }
2463
2464
2465 sub get_first_level_directory {
2466   my($self, $file) = @_;
2467
2468   if (($file =~ tr/\///) > 0) {
2469     my $dir = $file;
2470     $dir =~ s/^([^\/]+\/).*/$1/;
2471     $dir =~ s/\/+$//;
2472     return $dir;
2473   }
2474
2475   return '.';
2476 }
2477
2478
2479 sub get_associated_projects {
2480   return $_[0]->{'associated'};
2481 }
2482
2483
2484 sub sort_within_group {
2485   my($self, $list, $start, $end) = @_;
2486   my $deps;
2487   my %seen;
2488   my $ccount  = 0;
2489   my $cmax    = ($end - $start) + 1;
2490   my $previ   = -1;
2491   my $prevpjs = [];
2492   my $movepjs = [];
2493
2494   ## Put the projects in the order specified
2495   ## by the project dependencies.
2496   for (my $i = $start; $i <= $end; ++$i) {
2497     ## If our moved project equals our previously moved project then
2498     ## we count this as a possible circular dependency.
2499     my $key = "@$list";
2500     if ($seen{$key} ||
2501         (defined $$movepjs[0] && defined $$prevpjs[0] &&
2502          $$movepjs[0] == $$prevpjs[0] && $$movepjs[1] == $$prevpjs[1])) {
2503       ++$ccount;
2504     }
2505     else {
2506       $ccount = 0;
2507     }
2508
2509     ## Detect circular dependencies
2510     if ($ccount > $cmax) {
2511       my @prjs;
2512       foreach my $mvgr (@$movepjs) {
2513         push(@prjs, $$list[$mvgr]);
2514       }
2515       my $other = $$movepjs[0] - 1;
2516       if ($other < $start || $other == $$movepjs[1] || !defined $$list[$other]) {
2517         $other = undef;
2518       }
2519       $self->warning('Circular dependency detected while processing the ' .
2520                      ($self->{'current_input'} eq '' ?
2521                       'default' : $self->{'current_input'}) .
2522                      ' workspace. ' .
2523                      'The following projects are involved: ' .
2524                      (defined $other ? "$$list[$other], " : '') .
2525                      join(' and ', @prjs));
2526       return;
2527     }
2528
2529     ## Keep track of the previous project movement
2530     $seen{$key} = 1;
2531     $prevpjs = $movepjs;
2532     $movepjs = [] if ($previ < $i);
2533     $previ = $i;
2534
2535     $deps = $self->get_validated_ordering($$list[$i]);
2536     if (defined $$deps[0]) {
2537       my $baseproj = ($self->{'dependency_is_filename'} ?
2538                       $self->mpc_basename($$list[$i]) :
2539                       $self->{'project_info'}->{$$list[$i]}->[ProjectCreator::PROJECT_NAME]);
2540       my $moved = 0;
2541       foreach my $dep (@$deps) {
2542         if ($baseproj ne $dep) {
2543           ## See if the dependency is listed after this project
2544           for (my $j = $i + 1; $j <= $end; ++$j) {
2545             my $ldep = ($self->{'dependency_is_filename'} ?
2546                         $self->mpc_basename($$list[$j]) :
2547                         $self->{'project_info'}->{$$list[$j]}->[ProjectCreator::PROJECT_NAME]);
2548             if ($ldep eq $dep) {
2549               $movepjs = [$i, $j];
2550               ## If so, move it in front of the current project.
2551               ## The original code, which had splices, didn't always
2552               ## work correctly (especially on AIX for some reason).
2553               my $save = $$list[$j];
2554               for (my $k = $j; $k > $i; --$k) {
2555                 $$list[$k] = $$list[$k - 1];
2556               }
2557               $$list[$i] = $save;
2558
2559               ## Mark that an entry has been moved
2560               $moved = 1;
2561               $j--;
2562             }
2563           }
2564         }
2565       }
2566       --$i if ($moved);
2567     }
2568   }
2569 }
2570
2571
2572 sub build_dependency_chain {
2573   my($self, $name, $len, $list, $ni, $glen, $groups, $map, $gdeps) = @_;
2574   my $deps = $self->get_validated_ordering($name);
2575
2576   if (defined $$deps[0]) {
2577     foreach my $dep (@$deps) {
2578       ## Find the item in the list that matches our current dependency
2579       my $mapped = $$map{$dep};
2580       if (defined $mapped) {
2581         for (my $i = 0; $i < $len; $i++) {
2582           if ($$list[$i] eq $mapped) {
2583
2584             ## Locate the group number to which the dependency belongs
2585             for (my $j = 0; $j < $glen; $j++) {
2586               if ($i >= $$groups[$j]->[0] && $i <= $$groups[$j]->[1]) {
2587
2588                 if ($j != $ni) {
2589                   ## Add every project in the group to the dependency chain
2590                   for (my $k = $$groups[$j]->[0]; $k <= $$groups[$j]->[1]; $k++) {
2591                     my $ldep = $self->mpc_basename($$list[$k]);
2592                     if (!exists $$gdeps{$ldep}) {
2593                       $$gdeps{$ldep} = 1;
2594                       $self->build_dependency_chain($$list[$k],
2595                                                     $len, $list, $j,
2596                                                     $glen, $groups,
2597                                                     $map, $gdeps);
2598                     }
2599                   }
2600                 }
2601                 last;
2602               }
2603             }
2604             last;
2605           }
2606         }
2607       }
2608
2609       $$gdeps{$dep} = 1;
2610     }
2611   }
2612 }
2613
2614
2615 sub sort_by_groups {
2616   my($self, $list, $grindex) = @_;
2617   my @groups = @$grindex;
2618   my $llen   = scalar(@$list);
2619
2620   ## Check for duplicates first before we attempt to sort the groups.
2621   ## If there is a duplicate, we quietly return immediately.  The
2622   ## duplicates will be flagged as an error when creating the main
2623   ## workspace.
2624   my %dupcheck;
2625   foreach my $proj (@$list) {
2626     my $base = $self->mpc_basename($proj);
2627     return undef if (defined $dupcheck{$base});
2628     $dupcheck{$base} = $proj;
2629   }
2630
2631   my %circular_checked;
2632   for (my $gi = 0; $gi <= $#groups; ++$gi) {
2633     ## Detect circular dependencies
2634     if (!$circular_checked{$gi}) {
2635       $circular_checked{$gi} = 1;
2636       for (my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
2637         my %gdeps;
2638         $self->build_dependency_chain($$list[$i], $llen, $list, $gi,
2639                                       $#groups + 1, \@groups,
2640                                       \%dupcheck, \%gdeps);
2641         if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
2642           ## There was a cirular dependency, get all of the directories
2643           ## involved.
2644           my %dirs;
2645           foreach my $gdep (keys %gdeps) {
2646             $dirs{$self->mpc_dirname($dupcheck{$gdep})} = 1;
2647           }
2648
2649           ## If the current directory was involved, translate that into
2650           ## a directory relative to the start directory.
2651           if (defined $dirs{'.'}) {
2652             my $cwd = $self->getcwd();
2653             my $start = $self->getstartdir();
2654             if ($cwd ne $start) {
2655               my $startre = $self->escape_regex_special($start);
2656               delete $dirs{'.'};
2657               $cwd =~ s/^$startre[\\\/]//;
2658               $dirs{$cwd} = 1;
2659             }
2660           }
2661
2662           ## Display a warining to the user
2663           my @keys = sort keys %dirs;
2664           $self->warning('Circular directory dependency detected in the ' .
2665                          ($self->{'current_input'} eq '' ?
2666                           'default' : $self->{'current_input'}) .
2667                          ' workspace. ' .
2668                          'The following director' .
2669                          ($#keys == 0 ? 'y is' : 'ies are') .
2670                          ' involved: ' . join(', ', @keys));
2671           return;
2672         }
2673       }
2674     }
2675
2676     ## Build up the group dependencies
2677     my %gdeps;
2678     for (my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
2679       my $deps = $self->get_validated_ordering($$list[$i]);
2680       @gdeps{@$deps} = () if (defined $$deps[0]);
2681     }
2682
2683     ## Search the rest of the groups for any of the group dependencies
2684     for (my $gj = $gi + 1; $gj <= $#groups; ++$gj) {
2685       for (my $i = $groups[$gj]->[0]; $i <= $groups[$gj]->[1]; ++$i) {
2686         if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
2687           ## Move this group ($gj) in front of the current group ($gi)
2688           my @save;
2689           for (my $j = $groups[$gi]->[1] + 1; $j <= $groups[$gj]->[1]; ++$j) {
2690             push(@save, $$list[$j]);
2691           }
2692           my $offset = $groups[$gj]->[1] - $groups[$gi]->[1];
2693           for (my $j = $groups[$gi]->[1]; $j >= $groups[$gi]->[0]; --$j) {
2694             $$list[$j + $offset] = $$list[$j];
2695           }
2696           for (my $j = 0; $j <= $#save; ++$j) {
2697             $$list[$groups[$gi]->[0] + $j] = $save[$j];
2698           }
2699
2700           ## Update the group indices
2701           my $shiftamt = ($groups[$gi]->[1] - $groups[$gi]->[0]) + 1;
2702           for (my $j = $gi + 1; $j <= $gj; ++$j) {
2703             $groups[$j]->[0] -= $shiftamt;
2704             $groups[$j]->[1] -= $shiftamt;
2705           }
2706           my @grsave = @{$groups[$gi]};
2707           $grsave[0] += $offset;
2708           $grsave[1] += $offset;
2709           for (my $j = $gi; $j < $gj; ++$j) {
2710             $groups[$j] = $groups[$j + 1];
2711             $circular_checked{$j} = $circular_checked{$j + 1};
2712           }
2713           $groups[$gj] = \@grsave;
2714           $circular_checked{$gj} = 1;
2715
2716           ## Start over from the first group
2717           $gi = -1;
2718
2719           ## Exit from the outter ($gj) loop
2720           $gj = $#groups;
2721           last;
2722         }
2723       }
2724     }
2725   }
2726 }
2727
2728
2729 sub sort_dependencies {
2730   my($self, $projects, $groups) = @_;
2731   my @list = sort { return $self->sort_projects_by_directory($a, $b) + 0;
2732                   } @$projects;
2733   ## The list above is sorted by directory in order to keep projects
2734   ## within the same directory together.  Otherwise, when groups are
2735   ## created we may get multiple groups for the same directory.
2736
2737   ## Put the projects in the order specified
2738   ## by the project dependencies.  We only need to do
2739   ## this if there is more than one element in the array.
2740   if ($#list > 0) {
2741     ## If the parameter wasn't passed in or it was passed in
2742     ## and was true, sort with directory groups in mind
2743     if (!defined $groups || $groups) {
2744       ## First determine the individual groups
2745       my @grindex;
2746       my $previous = [0, undef];
2747       for (my $li = 0; $li <= $#list; ++$li) {
2748         my $dir = $self->get_first_level_directory($list[$li]);
2749         if (!defined $previous->[1]) {
2750           $previous = [$li, $dir];
2751         }
2752         elsif ($previous->[1] ne $dir) {
2753           push(@grindex, [$previous->[0], $li - 1]);
2754           $previous = [$li, $dir];
2755         }
2756       }
2757       push(@grindex, [$previous->[0], $#list]);
2758
2759       ## Next, sort the individual groups
2760       foreach my $gr (@grindex) {
2761         $self->sort_within_group(\@list, @$gr) if ($$gr[0] != $$gr[1]);
2762       }
2763
2764       ## Now sort the groups as single entities
2765       $self->sort_by_groups(\@list, \@grindex) if ($#grindex > 0);
2766     }
2767     else {
2768       $self->sort_within_group(\@list, 0, $#list);
2769     }
2770   }
2771
2772   return @list;
2773 }
2774
2775
2776 sub number_target_deps {
2777   my($self, $projects, $pjs, $targets, $groups) = @_;
2778   my @list = $self->sort_dependencies($projects, $groups);
2779
2780   ## This block of code must be done after the list of dependencies
2781   ## has been sorted in order to get the correct project numbers.
2782   for (my $i = 0; $i <= $#list; ++$i) {
2783     my $project = $list[$i];
2784     if (defined $$pjs{$project}) {
2785       my($name, $deps) = @{$$pjs{$project}};
2786       if (defined $deps && $deps ne '') {
2787         my @numbers;
2788         my %dhash;
2789         @dhash{@{$self->create_array($deps)}} = ();
2790
2791         ## For each dependency, search in the sorted list
2792         ## up to the point of this project for the projects
2793         ## that this one depends on.  When the project is
2794         ## found, we put the target number in the numbers array.
2795         for (my $j = 0; $j < $i; ++$j) {
2796           ## If the dependency is a filename, then take the basename of
2797           ## the project file.  Otherwise, get the project name based on
2798           ## the project file from the "project_info".
2799           my $key = ($self->{'dependency_is_filename'} ?
2800                      $self->mpc_basename($list[$j]) :
2801                      $self->{'project_info'}->{$list[$j]}->[ProjectCreator::PROJECT_NAME]);
2802           push(@numbers, $j) if (exists $dhash{$key});
2803         }
2804
2805         ## Store the array in the hash keyed on the project file.
2806         $$targets{$project} = \@numbers if (defined $numbers[0]);
2807       }
2808     }
2809   }
2810
2811   return @list;
2812 }
2813
2814
2815 sub project_target_translation {
2816   my($self, $case) = @_;
2817   my %map;
2818
2819   ## Translate project names to avoid target collision with
2820   ## some versions of make.
2821   foreach my $key (keys %{$self->{'project_info'}}) {
2822     my $dir  = $self->mpc_dirname($key);
2823     my $name = $self->{'project_info'}->{$key}->[ProjectCreator::PROJECT_NAME];
2824
2825     ## We want to compare to the upper most directory.  This will be the
2826     ## one that may conflict with the project name.
2827     $dir =~ s/[\/\\].*//;
2828     if (($case && $dir eq $name) || (!$case && lc($dir) eq lc($name))) {
2829       $map{$key} = "$name-target";
2830     }
2831     else {
2832       $map{$key} = $name;
2833     }
2834   }
2835   return \%map;
2836 }
2837
2838
2839 sub optionError {
2840   my($self, $str) = @_;
2841   $self->warning("$self->{'current_input'}: $str.") if (defined $str);
2842 }
2843
2844
2845 sub process_cmdline {
2846   my($self, $cmdline, $parameters) = @_;
2847
2848   ## Set cache use to default.
2849   $self->{'cacheok'} = $self->default_cacheok();
2850
2851   if (defined $cmdline && $cmdline ne '') {
2852     my $args = $self->create_array($cmdline);
2853
2854     ## Look for environment variables
2855     foreach my $arg (@$args) {
2856       $self->replace_env_vars(\$arg) if ($arg =~ /\$/);
2857     }
2858
2859     my $options = $self->options('MWC', {}, 0, @$args);
2860     if (defined $options) {
2861       foreach my $key (keys %$options) {
2862         my $type = $self->is_set($key, $options);
2863
2864         if (!defined $type) {
2865           ## This option was not used, so we ignore it
2866         }
2867         elsif ($type eq 'ARRAY') {
2868           push(@{$parameters->{$key}}, @{$options->{$key}});
2869         }
2870         elsif ($type eq 'HASH') {
2871           my $merge = ($key eq 'addtemp' || $key eq 'addproj');
2872           foreach my $hk (keys %{$options->{$key}}) {
2873             if ($merge && defined $parameters->{$key}->{$hk}) {
2874               push(@{$parameters->{$key}->{$hk}}, @{$options->{$key}->{$hk}});
2875             }
2876             else {
2877               $parameters->{$key}->{$hk} = $options->{$key}->{$hk};
2878             }
2879           }
2880         }
2881         elsif ($type eq 'SCALAR') {
2882           $parameters->{$key} = $options->{$key};
2883         }
2884       }
2885
2886       ## Some option data members are named consistently with the MPC
2887       ## option name.  In this case, we can use this foreach loop.
2888       foreach my $consistent_opt ('exclude', 'for_eclipse', 'gendot',
2889                                   'gfeature_file', 'into',
2890                                   'make_coexistence', 'recurse') {
2891         ## Issue warnings for the options provided by the user
2892         if ($self->is_set($consistent_opt, $options)) {
2893           $self->optionError("-$consistent_opt is ignored");
2894         }
2895       }
2896
2897       ## For those that are inconsistent, we have special code to deal
2898       ## with them.
2899       if ($self->is_set('reldefs', $options)) {
2900         $self->optionError('-noreldefs is ignored');
2901       }
2902
2903       ## Make sure no input files were specified (we can't handle it).
2904       if (defined $options->{'input'}->[0]) {
2905         $self->optionError('Command line files ' .
2906                            'specified in a workspace are ignored');
2907       }
2908
2909       ## Determine if it's ok to use the cache
2910       my @cacheInvalidating = ('global', 'include', 'baseprojs',
2911                                'template', 'ti', 'relative', 'language',
2912                                'addtemp', 'addproj', 'feature_file',
2913                                'features', 'use_env', 'expand_vars');
2914       foreach my $key (@cacheInvalidating) {
2915         if ($self->is_set($key, $options)) {
2916           $self->{'cacheok'} = 0;
2917           last;
2918         }
2919       }
2920     }
2921   }
2922 }
2923
2924
2925 sub current_parameters {
2926   my $self = shift;
2927   my %parameters = $self->save_state();
2928
2929   ## We always want the project creator to generate a toplevel
2930   $parameters{'toplevel'} = 1;
2931   return %parameters;
2932 }
2933
2934
2935 sub project_creator {
2936   my $self = shift;
2937   my $pid = shift;
2938   if (not defined $pid) {
2939     $pid = 'parent';
2940   }
2941
2942   my $str = "$self";
2943
2944   ## NOTE: If the subclassed WorkspaceCreator name prefix does not
2945   ##       match the name prefix of the ProjectCreator, this code
2946   ##       will not work and the subclassed WorkspaceCreator will
2947   ##       need to override this method.
2948
2949   $str =~ s/Workspace/Project/;
2950   $str =~ s/=HASH.*//;
2951
2952   ## Set up values for each project creator
2953   ## If we have command line arguments in the workspace, then
2954   ## we process them before creating the project creator
2955   my $cmdline    = $self->get_assignment('cmdline');
2956   my %parameters = $self->current_parameters();
2957   $self->process_cmdline($cmdline, \%parameters);
2958
2959   ## Create the new project creator with the updated parameters
2960   return $str->new($parameters{'global'},
2961                    $parameters{'include'},
2962                    $parameters{'template'},
2963                    $parameters{'ti'},
2964                    $parameters{'dynamic'},
2965                    $parameters{'static'},
2966                    $parameters{'relative'},
2967                    $parameters{'addtemp'},
2968                    $parameters{'addproj'},
2969                    $parameters{'progress'},
2970                    $parameters{'toplevel'},
2971                    $parameters{'baseprojs'},
2972                    $self->{'global_feature_file'},
2973                    $parameters{'relative_file'},
2974                    $parameters{'feature_file'},
2975                    $parameters{'features'},
2976                    $parameters{'hierarchy'},
2977                    $self->{'exclude'}->{$self->{'wctype'}},
2978                    $self->make_coexistence(),
2979                    $parameters{'name_modifier'},
2980                    $parameters{'apply_project'},
2981                    $self->{'generate_ins'} || $parameters{'genins'},
2982                    $self->get_into(),
2983                    $parameters{'language'},
2984                    $parameters{'use_env'},
2985                    $parameters{'expand_vars'},
2986                    $self->{'gendot'},
2987                    $parameters{'comments'},
2988                    $self->{'for_eclipse'},
2989                    $pid);
2990 }
2991
2992
2993 sub sort_files {
2994   #my $self = shift;
2995   return 0;
2996 }
2997
2998
2999 sub make_coexistence {
3000   return $_[0]->{'coexistence'};
3001 }
3002
3003
3004 sub get_modified_workspace_name {
3005   my($self, $name, $ext, $nows) = @_;
3006   my $nmod  = $self->get_name_modifier();
3007   my $oname = $name;
3008
3009   if (defined $nmod) {
3010     $nmod =~ s/\*/$name/g;
3011     $name = $nmod;
3012   }
3013
3014   ## If this is a per project workspace, then we should not
3015   ## modify the workspace name.  It may overwrite another workspace
3016   ## but that's ok, it will only be a per project workspace.
3017   ## Also, if we don't want the workspace name attached ($nows) then
3018   ## we just return the name plus the extension.
3019   return "$name$ext" if ($nows || $self->{'per_project_workspace_name'});
3020
3021   my $pwd    = $self->getcwd();
3022   my $type   = $self->{'wctype'};
3023   my $wsname = $self->get_workspace_name();
3024
3025   if (!defined $previous_workspace_name{$type}->{$pwd}) {
3026     $previous_workspace_name{$type}->{$pwd} = $wsname;
3027     $self->{'current_workspace_name'} = undef;
3028   }
3029   else {
3030     my $prefix = ($oname eq $wsname ? $name : "$name.$wsname");
3031     $previous_workspace_name{$type}->{$pwd} = $wsname;
3032     while ($self->file_written("$prefix" .
3033                                ($self->{'modified_count'} > 0 ?
3034                                 ".$self->{'modified_count'}" : '') .
3035                                "$ext")) {
3036       ++$self->{'modified_count'};
3037     }
3038     $self->{'current_workspace_name'} =
3039       "$prefix" . ($self->{'modified_count'} > 0 ?
3040                    ".$self->{'modified_count'}" : '') . "$ext";
3041   }
3042
3043   return (defined $self->{'current_workspace_name'} ?
3044           $self->{'current_workspace_name'} : "$name$ext");
3045 }
3046
3047
3048 sub generate_recursive_input_list {
3049   my($self, $dir, $exclude) = @_;
3050   return $self->extension_recursive_input_list($dir, $exclude, $wsext);
3051 }
3052
3053
3054 sub verify_build_ordering {
3055   my $self = shift;
3056   foreach my $project (@{$self->{'projects'}}) {
3057     $self->get_validated_ordering($project);
3058   }
3059 }
3060
3061
3062 sub get_validated_ordering {
3063   my($self, $project) = @_;
3064   my $deps;
3065
3066   if (defined $self->{'ordering_cache'}->{$project}) {
3067     $deps = $self->{'ordering_cache'}->{$project};
3068   }
3069   else {
3070     $deps = [];
3071     if (defined $self->{'project_info'}->{$project}) {
3072       my($name, $dstr) = @{$self->{'project_info'}->{$project}};
3073       if (defined $dstr && $dstr ne '') {
3074         $deps = $self->create_array($dstr);
3075         my $dlen = scalar(@$deps);
3076         for (my $i = 0; $i < $dlen; $i++) {
3077           my $dep   = $$deps[$i];
3078           my $found = 0;
3079           ## Avoid circular dependencies
3080           if ($dep ne $name && $dep ne $self->mpc_basename($project)) {
3081             foreach my $p (@{$self->{'projects'}}) {
3082               if ($dep eq $self->{'project_info'}->{$p}->[ProjectCreator::PROJECT_NAME] ||
3083                   $dep eq $self->mpc_basename($p)) {
3084                 $found = 1;
3085                 last;
3086               }
3087             }
3088             if (!$found) {
3089               if ($self->{'verbose_ordering'}) {
3090                 $self->warning("processing '$project' and '$name' references '$dep' which has " .
3091                                "not been processed.");
3092               }
3093               splice(@$deps, $i, 1);
3094               --$dlen;
3095               --$i;
3096             }
3097           }
3098           else {
3099             ## If a project references itself, we must remove it
3100             ## from the list of dependencies.
3101             splice(@$deps, $i, 1);
3102             --$dlen;
3103             --$i;
3104           }
3105         }
3106       }
3107
3108       $self->{'ordering_cache'}->{$project} = $deps;
3109     }
3110   }
3111
3112   return $deps;
3113 }
3114
3115
3116 sub source_listing_callback {
3117   my($self, $project_file, $project_name, $list) = @_;
3118
3119   # have to keep projects in the the same order as if run in
3120   # single process. otherwise implicit dependencies produces
3121   # different output
3122   if ($self->{'pid'} ne 'parent') {
3123     $project_name = ++$self->{'imp_dep_ctr'} . '|' . $project_name;
3124   }
3125
3126   $self->{'project_file_list'}->{$project_name} = [ $project_file,
3127                                                     $self->getcwd(), $list ];
3128 }
3129
3130
3131 sub sort_projects_by_directory {
3132   my($self, $left, $right) = @_;
3133   my $sa = index($left, '/');
3134   my $sb = index($right, '/');
3135
3136   if ($sa >= 0 && $sb == -1) {
3137     return 1;
3138   }
3139   elsif ($sb >= 0 && $sa == -1) {
3140     return -1;
3141   }
3142   return $left cmp $right;
3143 }
3144
3145
3146 sub get_relative_dep_file {
3147   my($self, $creator, $project, $dep) = @_;
3148
3149   ## If the dependency is a filename, we have to find the key that
3150   ## matches the project file.
3151   if ($creator->dependency_is_filename()) {
3152     foreach my $key (keys %{$self->{'project_file_list'}}) {
3153       if ($self->{'project_file_list'}->{$key}->[0] eq $dep) {
3154         $dep = $key;
3155         last;
3156       }
3157     }
3158   }
3159
3160   if (defined $self->{'project_file_list'}->{$dep}) {
3161     my $base = $self->{'project_file_list'}->{$dep}->[1];
3162     my @dirs = grep(!/^$/, split('/', $base));
3163     my $last = -1;
3164     $project =~ s/^\///;
3165     for (my $i = 0; $i <= $#dirs; $i++) {
3166       my $dir = $dirs[$i];
3167       if ($project =~ s/^$dir\///) {
3168         $last = $i;
3169       }
3170       else {
3171         last;
3172       }
3173     }
3174
3175     my $dependee = $self->{'project_file_list'}->{$dep}->[0];
3176     if ($last == -1) {
3177       return $base . '/' . $dependee;
3178     }
3179     else {
3180       my $built = '';
3181       for (my $i = $last + 1; $i <= $#dirs; $i++) {
3182         $built .= $dirs[$i] . '/';
3183       }
3184       $built .= $dependee;
3185
3186       ## If the project contains a portion of the current working directory,
3187       ## we need to strip it off.  If the workspace is a directory below one
3188       ## of the projects, the directory count will be incorrect due to the
3189       ## use of '..' within the project path.
3190       my $re;
3191       my $dir = $self->getcwd();
3192       while($dir =~ s!^[^/]*/!! &&
3193             ($re = $dir . '/' . ('../' x (($dir =~ tr/\///) + 1))) &&
3194             $project !~ s!^$re!!) {
3195       }
3196
3197       ## The code above is tricky
3198       $self->debug("Project on which this project depends: $project");
3199
3200       my $dircount = ($project =~ tr/\///);
3201       return ('../' x $dircount) . $built;
3202     }
3203   }
3204   return undef;
3205 }
3206
3207
3208 sub create_command_line_string {
3209   my $self = shift;
3210   my @args = @_;
3211   my $str;
3212
3213   foreach my $arg (@args) {
3214     $arg =~ s/^\-\-/-/;
3215     if ($arg =~ /\$/ && $^O ne 'MSWin32') {
3216       ## If we're not running on Windows and the command line argument
3217       ## contains a dollar sign, we need to wrap the argument in single
3218       ## quotes so that the UNIX shell does not interpret it.
3219       $arg = "'$arg'";
3220     }
3221     else {
3222       ## Unfortunately, the Windows command line shell does not
3223       ## understand single quotes correctly.  So, we have the distinction
3224       ## above and handle dollar signs here too.
3225       $arg = "\"$arg\"" if ($arg =~ /[\s\*\$]/);
3226     }
3227     if (defined $str) {
3228       $str .= " $arg";
3229     }
3230     else {
3231       $str = $arg;
3232     }
3233   }
3234   return $str;
3235 }
3236
3237
3238 sub print_workspace_comment {
3239   my $self = shift;
3240   my $fh   = shift;
3241
3242   if ($self->{'workspace_comments'}) {
3243     foreach my $line (@_) {
3244       print $fh $line;
3245     }
3246   }
3247 }
3248
3249
3250 sub get_initial_relative_values {
3251   my $self = shift;
3252   return $self->get_relative(), $self->get_expand_vars();
3253 }
3254
3255
3256 sub get_secondary_relative_values {
3257   return \%ENV, $_[0]->get_expand_vars();
3258 }
3259
3260
3261 sub convert_all_variables {
3262   #my $self = shift;
3263   return 1;
3264 }
3265
3266
3267 sub workspace_file_name {
3268   my $self = shift;
3269   return $self->get_modified_workspace_name($self->get_workspace_name(),
3270                                             $self->workspace_file_extension());
3271 }
3272
3273
3274 sub relative {
3275   my $self = shift;
3276   my $line = $self->SUPER::relative(shift);
3277   $line =~ s/\\/\//g;
3278   return $line;
3279 }
3280
3281 # ************************************************************
3282 # Virtual Methods To Be Overridden
3283 # ************************************************************
3284
3285 sub requires_make_coexistence {
3286   #my $self = shift;
3287   return 0;
3288 }
3289
3290
3291 sub supports_make_coexistence {
3292   #my $self = shift;
3293   return 0;
3294 }
3295
3296
3297 sub generate_implicit_project_dependencies {
3298   #my $self = shift;
3299   return 0;
3300 }
3301
3302
3303 sub workspace_file_extension {
3304   #my $self = shift;
3305   return '';
3306 }
3307
3308
3309 sub workspace_per_project {
3310   #my $self = shift;
3311   return 0;
3312 }
3313
3314
3315 sub default_verbose_ordering {
3316   return 0;                     # Don't warning if there are missing dependencies.
3317 }
3318
3319
3320 sub pre_workspace {
3321   #my $self    = shift;
3322   #my $fh      = shift;
3323   #my $creator = shift;
3324   #my $top     = shift;
3325 }
3326
3327
3328 sub write_comps {
3329   #my $self    = shift;
3330   #my $fh      = shift;
3331   #my $creator = shift;
3332   #my $top     = shift;
3333 }
3334
3335
3336 sub post_workspace {
3337   #my $self    = shift;
3338   #my $fh      = shift;
3339   #my $creator = shift;
3340   #my $top     = shift;
3341 }
3342
3343 sub requires_forward_slashes {
3344   #my $self = shift;
3345   return 0;
3346 }
3347
3348 sub get_additional_output {
3349   #my $self = shift;
3350
3351   ## This method should return an array reference of array references.
3352   ## For each entry, the array should be laid out as follows:
3353   ## [ <directory or undef to use the current output directory>,
3354   ##   <file name>,
3355   ##   <function to write body of file, $self and $fh are first params>,
3356   ##   <optional additional parameter 1>,
3357   ##   ...,
3358   ##   <optional additional parameter N>
3359   ## ]
3360   return [];
3361 }
3362
3363 1;