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     my($top, $rest) = $self->topname($prj);
1347
1348     if (!defined $current) {
1349       $current = $top;
1350       push(@saved, $rest);
1351       $sinfo{$rest} = $projinfo{$prj};
1352     }
1353     elsif ($top ne $current) {
1354       if ($current ne '.') {
1355         ## Write out the hierachical workspace
1356         $self->cd($current);
1357         ($status, $errorString) = $self->generate_hierarchy($creator, \@saved, \%sinfo);
1358
1359         $self->{'projects'}       = \@saved;
1360         $self->{'project_info'}   = \%sinfo;
1361         $self->{'workspace_name'} = $self->base_directory();
1362         ($status, $errorString) = $self->write_workspace($creator) if ($status);
1363
1364         last if !$status;
1365         $self->cd($cwd);
1366       }
1367
1368       ## Start the next one
1369       $current = $top;
1370       @saved = ($rest);
1371       %sinfo = ();
1372       $sinfo{$rest} = $projinfo{$prj};
1373     }
1374     else {
1375       push(@saved, $rest);
1376       $sinfo{$rest} = $projinfo{$prj};
1377     }
1378   }
1379   if ($status && defined $current && $current ne '.') {
1380     $self->cd($current);
1381     ($status, $errorString) = $self->generate_hierarchy($creator, \@saved, \%sinfo);
1382
1383     $self->{'projects'}       = \@saved;
1384     $self->{'project_info'}   = \%sinfo;
1385     $self->{'workspace_name'} = $self->base_directory();
1386     ($status, $errorString) = $self->write_workspace($creator) if ($status);
1387
1388     $self->cd($cwd);
1389   }
1390
1391   return $status, $errorString;
1392 }
1393
1394 sub generate_project_files {
1395   my $self      = shift;
1396   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1397   my @projects;
1398   my %pi;
1399   my %liblocs;
1400   my $creator = $self->project_creator();
1401   my $cwd = $self->getcwd();
1402   my $impl = $self->get_assignment('implicit');
1403   my $postkey = $creator->get_dynamic() .
1404     $creator->get_static() . "-$self";
1405   my $previmpl  = $impl;
1406   my $prevcache = $self->{'cacheok'};
1407   my %gstate    = $creator->save_state();
1408   my $genimpdep = $self->generate_implicit_project_dependencies();
1409   my $errorString;
1410
1411   $Data::Dumper::Indent = 0;
1412
1413   ## Save this project creator setting for later use in the
1414   ## number_target_deps() method.
1415   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1416
1417   ## Remove the address portion of the $self string
1418   $postkey =~ s/=.*//;
1419
1420   ## Set the source file callback on our project creator
1421   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1422
1423   foreach my $ofile (@{$self->{'project_files'}}) {
1424     if (!$self->excluded($ofile)) {
1425       my $file    = $ofile;
1426       my $dir     = $self->mpc_dirname($file);
1427       my $restore = 0;
1428
1429       if (defined $self->{'scoped_assign'}->{$ofile}) {
1430         ## Handle the implicit assignment
1431         my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
1432         if (defined $oi) {
1433           $previmpl = $impl;
1434           $impl     = $oi;
1435         }
1436
1437         ## Handle the cmdline assignment
1438         my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
1439         if (defined $cmdline && $cmdline ne '') {
1440           ## Save the cacheok value
1441           $prevcache = $self->{'cacheok'};
1442
1443           ## Get the current parameters and process the command line
1444           my %parameters = $self->current_parameters();
1445           $self->process_cmdline($cmdline, \%parameters);
1446
1447           ## Set the parameters on the creator
1448           $creator->restore_state(\%parameters);
1449           $restore = 1;
1450         }
1451       }
1452
1453       ## If we are generating implicit projects and the file is a
1454       ## directory, then we set the dir to the file and empty the file
1455       if ($impl && -d $file) {
1456         $dir  = $file;
1457         $file = '';
1458
1459         ## If the implicit assignment value was not a number, then
1460         ## we will add this value to our base projects.
1461         if ($impl !~ /^\d+$/) {
1462           my $bps = $creator->get_baseprojs();
1463           push(@$bps, split(/\s+/, $impl));
1464           $restore = 1;
1465           $self->{'cacheok'} = 0;
1466         }
1467       }
1468
1469       ## Generate the key for this project file
1470       my $prkey = $self->getcwd() . '/' .
1471         ($file eq '' ? $dir : $file) . "-$postkey";
1472
1473       ## We must change to the subdirectory for
1474       ## which this project file is intended
1475       if ($self->cd($dir)) {
1476         my $files_written = [];
1477         my $gen_proj_info = [];
1478         my $gen_lib_locs  = {};
1479         if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1480           $files_written = $allprojects{$prkey};
1481           $gen_proj_info = $allprinfo{$prkey};
1482           $gen_lib_locs  = $allliblocs{$prkey};
1483
1484           $status = 1;
1485         }
1486         else {
1487           $status = $creator->generate($self->mpc_basename($file));
1488
1489           ## If any one project file fails, then stop
1490           ## processing altogether.
1491           if (!$status) {
1492             ## We don't restore the state before we leave,
1493             ## but that's ok since we will be exiting right now.
1494             return $status, $creator,
1495               "Unable to process " . ($file eq '' ? " in $dir" : $file);
1496           }
1497
1498           ## Get the individual project information and
1499           ## generated file name(s)
1500           $files_written = $creator->get_files_written();
1501           $gen_proj_info = $creator->get_project_info();
1502           $gen_lib_locs  = $creator->get_lib_locations();
1503
1504           if ($self->{'cacheok'}) {
1505             $allprojects{$prkey} = $files_written;
1506             $allprinfo{$prkey}   = $gen_proj_info;
1507             $allliblocs{$prkey}  = $gen_lib_locs;
1508           }
1509
1510           push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
1511         }
1512         $self->cd($cwd);
1513         $self->save_project_info($files_written, $gen_proj_info,
1514                                  $gen_lib_locs, $dir,
1515                                  \@projects, \%pi, \%liblocs);
1516       }
1517       else {
1518         ## Unable to change to the directory.
1519         ## We don't restore the state before we leave,
1520         ## but that's ok since we will be exiting soon.
1521         return 0, $creator, "Unable to change directory to $dir";
1522       }
1523
1524       ## Return things to the way they were
1525       $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
1526       if ($restore) {
1527         $self->{'cacheok'} = $prevcache;
1528         $creator->restore_state(\%gstate);
1529       }
1530     }
1531     else {
1532       ## This one was excluded, so status is ok
1533       $status = 1;
1534     }
1535
1536   }
1537
1538   ## Add implict project dependencies based on source files
1539   ## that have been used by multiple projects.  If we do it here
1540   ## before we call generate_hierarchy(), we don't have to call it
1541   ## in generate_hierarchy() for each workspace.
1542   $self->{'projects'}     = \@projects;
1543   $self->{'project_info'} = \%pi;
1544
1545   if ($status && $genimpdep) {
1546     $self->add_implicit_project_dependencies($creator, $cwd);
1547   }
1548
1549   ## If we are generating the hierarchical workspaces, then do so
1550   $self->{'lib_locations'} = \%liblocs;
1551   if ($self->get_hierarchy() || $self->workspace_per_project()) {
1552     my $orig = $self->{'workspace_name'};
1553     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
1554     $self->{'workspace_name'} = $orig;
1555   }
1556
1557   ## Reset the projects and project_info
1558   $self->{'projects'}      = \@projects;
1559   $self->{'project_info'}  = \%pi;
1560
1561   return $status, $creator, $errorString;
1562 }
1563
1564 sub generate_project_files_fork {
1565   my $self   = shift;
1566   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1567
1568   my @projects;
1569   my %pi;
1570   my %liblocs;
1571
1572   my $creator = $self->project_creator('child');
1573   my $cwd = $self->getcwd();
1574   my $impl = $self->get_assignment('implicit');
1575   my $postkey = $creator->get_dynamic() .
1576     $creator->get_static() . "-$self";
1577   my $previmpl  = $impl;
1578   my $prevcache = $self->{'cacheok'};
1579   my %gstate    = $creator->save_state();
1580   my $genimpdep = $self->generate_implicit_project_dependencies();
1581   my $errorString;
1582
1583   my @save;
1584   my $VAR1;
1585   $Data::Dumper::Indent = 0;
1586
1587   ## Save this project creator setting for later use in the
1588   ## number_target_deps() method.
1589   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1590
1591   ## Remove the address portion of the $self string
1592   $postkey =~ s/=.*//;
1593
1594   ## Set the source file callback on our project creator
1595   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1596
1597   my $pid;
1598   my @pids;
1599   my $tmp = 'mpctmp00000000';
1600
1601   ## remove old temp files
1602   my @tmpfiles = glob "${wdir}/mpctmp*";
1603   for my $file (@tmpfiles) {
1604     unlink $file || die "Error: Unable to delete tmp file $file in directory $wdir";
1605   }
1606
1607   my $num_tmp_files = scalar (@tmpfiles);
1608
1609   $self->diagnostic("Multiprocess MPC removed $num_tmp_files existing files like \"mpctmp\*\" in $wdir.");
1610
1611   foreach my $ofile (@{$self->{'project_files'}}) {
1612     if ($#pids + 1 >= $num_workers) {
1613       waitpid(shift @pids, 0);
1614     }
1615
1616     ++$tmp;
1617
1618     ## open the output file in parent so it can die if there's an error
1619     open (FD, ">${wdir}/$tmp") || die "Can't open $tmp for write";
1620
1621     $pid = fork();
1622     if ($pid != 0) {
1623       push @pids, $pid;
1624     }
1625     else {
1626       $self->{'pid'} = 'child';
1627
1628       if (!$self->excluded($ofile)) {
1629         my $file    = $ofile;
1630         my $dir     = $self->mpc_dirname($file);
1631         my $restore = 0;
1632
1633         if (defined $self->{'scoped_assign'}->{$ofile}) {
1634           ## Handle the implicit assignment
1635           my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
1636           if (defined $oi) {
1637             $previmpl = $impl;
1638             $impl     = $oi;
1639           }
1640
1641           ## Handle the cmdline assignment
1642           my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
1643           if (defined $cmdline && $cmdline ne '') {
1644             ## Save the cacheok value
1645             $prevcache = $self->{'cacheok'};
1646
1647             ## Get the current parameters and process the command line
1648             my %parameters = $self->current_parameters();
1649             $self->process_cmdline($cmdline, \%parameters);
1650
1651             ## Set the parameters on the creator
1652             $creator->restore_state(\%parameters);
1653             $restore = 1;
1654           }
1655         }
1656
1657         ## If we are generating implicit projects and the file is a
1658         ## directory, then we set the dir to the file and empty the file
1659         if ($impl && -d $file) {
1660           $dir  = $file;
1661           $file = '';
1662
1663           ## If the implicit assignment value was not a number, then
1664           ## we will add this value to our base projects.
1665           if ($impl !~ /^\d+$/) {
1666             my $bps = $creator->get_baseprojs();
1667             push(@$bps, split(/\s+/, $impl));
1668             $restore = 1;
1669             $self->{'cacheok'} = 0;
1670           }
1671         }
1672
1673         ## Generate the key for this project file
1674         my $prkey = $self->getcwd() . '/' .
1675           ($file eq '' ? $dir : $file) . "-$postkey";
1676
1677         ## We must change to the subdirectory for
1678         ## which this project file is intended
1679
1680         if ($self->cd($dir)) {
1681           my $files_written = [];
1682           my $gen_proj_info = [];
1683           my $gen_lib_locs  = {};
1684
1685           if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1686             $files_written = $allprojects{$prkey};
1687             $gen_proj_info = $allprinfo{$prkey};
1688             $gen_lib_locs  = $allliblocs{$prkey};
1689
1690             $status = 1;
1691           }
1692           else {
1693             $status = $creator->generate($self->mpc_basename($file));
1694
1695             ## If any one project file fails, then stop
1696             ## processing altogether.
1697             if (!$status) {
1698               # save the status info and exit. the parent will
1699               # see the error.
1700               print FD "$status|Unable to process " .
1701                 ($file eq '' ? " in $dir" : $file) . "\n";
1702
1703               exit(1);          # child error
1704             }
1705
1706             ## Get the individual project information and
1707             ## generated file name(s)
1708             $files_written = $creator->get_files_written();
1709             $gen_proj_info = $creator->get_project_info();
1710             $gen_lib_locs  = $creator->get_lib_locations();
1711
1712           }
1713
1714
1715           print FD "$status|''|$self->{'cacheok'}|$previmpl|$prevcache\n";
1716           print FD "$ofile|$prkey|$dir|$cwd|$restore\n";
1717
1718           print FD Dumper ($files_written), "\n";
1719           print FD Dumper ($gen_proj_info), "\n";
1720           print FD Dumper ($gen_lib_locs), "\n";
1721
1722           # there's a callback that sets the project file list
1723           # since we can't callback between processes we store
1724           # the list for later
1725           print FD Dumper ($self->{'project_file_list'}), "\n";
1726
1727         }
1728         else {
1729           ## Unable to change to the directory.
1730           ## We don't restore the state before we leave,
1731           ## but that's ok since we will be exiting soon.
1732           print FD "$status|Unable to change directory to $dir\n";
1733
1734           exit (1);             # child error
1735         }
1736
1737       }
1738       else {
1739         ## This one was excluded, so status is ok
1740         ## no need to set though since the child will exit.
1741         #$status = 1;
1742       }
1743
1744       exit(0);                  # child is finished
1745     }
1746   }
1747
1748   for $pid (@pids) {
1749     # this will also reap any zombies
1750     waitpid($pid, 0);
1751   }
1752
1753   my ($msg, $cacheok, $ofile, $prkey, $dir, $restore);
1754
1755   # read the children's stored data
1756   my @kid_data = glob "${wdir}/mpctmp*";
1757
1758   for my $kd (@kid_data) {
1759     open (FD, "<$kd") || die "Can't open $kd for read";
1760
1761     ($status, $msg, $cacheok, $previmpl, $prevcache) = split /\|/, <FD>;
1762
1763     if (!$status) {
1764       return $status, $creator, $msg;
1765     }
1766
1767     ($ofile, $prkey, $dir, $cwd, $restore) = split /\|/, <FD>;
1768
1769     eval (<FD>);
1770     my $files_written = $VAR1;
1771
1772     eval (<FD>);
1773     my $gen_proj_info = $VAR1;
1774
1775     # have to reconstitute gen_lib_locs in the same order it was
1776     # created or else multi-process implicit dependency may differ from
1777     # single process.
1778     eval (<FD>);
1779     my $gen_lib_locs;
1780     for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
1781                         substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
1782
1783       $gen_lib_locs->{substr ($k, index ($k, '|') + 1)} =
1784         $VAR1->{$k};
1785     }
1786
1787     # have to reconstitute project_file_list in the same order it was
1788     # created or else multi-process implicit dependency may differ from
1789     # single process.
1790     eval (<FD>);
1791     for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
1792                         substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
1793
1794       $self->{'project_file_list'}->{substr ($k, index ($k, '|') + 1)} =
1795         $VAR1->{$k};
1796     }
1797
1798     $self->{'cacheok'} = $cacheok;
1799     if ($self->cd($dir)) {
1800       if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1801
1802         $files_written = $allprojects{$prkey};
1803         $gen_proj_info = $allprinfo{$prkey};
1804         $gen_lib_locs  = $allliblocs{$prkey};
1805         $status = 1;
1806       }
1807       else {
1808         # file is already generated. check status
1809         if (!$status) {
1810
1811           ## We don't restore the state before we leave,
1812           ## but that's ok since we will be exiting right now.
1813           return $status, $creator, $msg;
1814         }
1815
1816         ## Get the individual project information and
1817         ## generated file name(s)
1818         if ($self->{'cacheok'}) {
1819
1820           $allprojects{$prkey} = $files_written;
1821           $allprinfo{$prkey}   = $gen_proj_info;
1822           $allliblocs{$prkey}  = $gen_lib_locs;
1823         }
1824
1825         push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
1826       }
1827
1828       $self->cd($cwd);
1829       $self->save_project_info($files_written, $gen_proj_info,
1830                                $gen_lib_locs, $dir,
1831                                \@projects, \%pi, \%liblocs);
1832     }
1833     else {
1834       ## Unable to change to the directory.
1835       ## We don't restore the state before we leave,
1836       ## but that's ok since we will be exiting soon.
1837       return 0, $creator, $msg;
1838
1839     }
1840
1841     ## Return things to the way they were
1842     $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
1843     if ($restore) {
1844       $self->{'cacheok'} = $prevcache;
1845       $creator->restore_state(\%gstate);
1846     }
1847   }
1848
1849   ## Add implict project dependencies based on source files
1850   ## that have been used by multiple projects.  If we do it here
1851   ## before we call generate_hierarchy(), we don't have to call it
1852   ## in generate_hierarchy() for each workspace.
1853   $self->{'projects'}     = \@projects;
1854   $self->{'project_info'} = \%pi;
1855
1856   if ($status && $genimpdep) {
1857     #print "aipd: $cwd\n", Dumper ($creator), "\n";
1858     $self->add_implicit_project_dependencies($creator, $cwd);
1859   }
1860
1861   ## If we are generating the hierarchical workspaces, then do so
1862   $self->{'lib_locations'} = \%liblocs;
1863   if ($self->get_hierarchy() || $self->workspace_per_project()) {
1864     my $orig = $self->{'workspace_name'};
1865     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
1866     $self->{'workspace_name'} = $orig;
1867   }
1868
1869   ## Reset the projects and project_info
1870   $self->{'projects'}      = \@projects;
1871   $self->{'project_info'}  = \%pi;
1872
1873   return $status, $creator, $errorString;
1874 }
1875
1876 sub send_to_parent {
1877   my $self = shift;
1878   my $arr = shift;
1879
1880   # send the data
1881   my $sock = new IO::Socket::INET (
1882                                    PeerAddr => 'localhost',
1883                                    PeerPort => $wport,
1884                                    Proto => 'tcp',
1885                                   );
1886
1887   if (!defined ($sock)) {
1888     die "Child could not create socket";
1889   }
1890
1891   map { print $sock "$_\n"; } @$arr;
1892   $sock->close();
1893 }
1894
1895 sub generate_project_files_fork_socket {
1896   my $self      = shift;
1897   my $status = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1898
1899   my @projects;
1900   my %pi;
1901   my %liblocs;
1902
1903   my $creator = $self->project_creator('child');
1904   my $cwd = $self->getcwd();
1905   my $impl = $self->get_assignment('implicit');
1906   my $postkey = $creator->get_dynamic() .
1907     $creator->get_static() . "-$self";
1908   my $previmpl  = $impl;
1909   my $prevcache = $self->{'cacheok'};
1910   my %gstate    = $creator->save_state();
1911   my $genimpdep = $self->generate_implicit_project_dependencies();
1912   my $errorString;
1913
1914   my @save;
1915   my $VAR1;
1916   $Data::Dumper::Indent = 0;
1917
1918   ## Save this project creator setting for later use in the
1919   ## number_target_deps() method.
1920   $self->{'dependency_is_filename'} = $creator->dependency_is_filename();
1921
1922   ## Remove the address portion of the $self string
1923   $postkey =~ s/=.*//;
1924
1925   ## Set the source file callback on our project creator
1926   $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1927
1928   my $pid;
1929   my @pids;
1930   my @pdata;                    # parents data sent from children.
1931
1932   ## setup workers' data
1933   my @wdata;
1934   my $beg;
1935   my $fin;
1936
1937   my $num_prj_files = $#{$self->{'project_files'}} + 1;
1938
1939   ## reduce the number of workers if necessary
1940   ## what if $num_workers > SOMAXCONN?? (unlikely)
1941   if ($num_workers > SOMAXCONN) {
1942     $self->diagnostic("Multiprocess MPC reducing # workers from $num_workers to " . SOMAXCONN . ", the max # of queued connections");
1943     $num_workers = SOMAXCONN;
1944   }
1945
1946   if ($num_workers > $num_prj_files) {
1947     # don't fork more workers than there are jobs
1948     $self->diagnostic("Multiprocess MPC reducing # workers from $num_workers to $num_prj_files, the number of project files.");
1949     $num_workers = $num_prj_files;
1950   }
1951
1952   my $num_per_worker = int ($num_prj_files / $num_workers);
1953   my $num_lines_per_prj = 6;
1954
1955   $self->diagnostic("Multiprocess MPC using $num_workers workers to process $num_prj_files project files.");
1956
1957   for (my $wctr = 0; $wctr < $num_workers; ++$wctr) {
1958     $beg = $wctr * $num_per_worker;
1959     $fin = $beg + $num_per_worker - 1;
1960
1961     @{$wdata[$wctr]} = @{$self->{'project_files'}}[$beg..$fin];
1962   }
1963
1964   ## give any remaining data to last worker.
1965   if ($num_prj_files > $num_per_worker * $num_workers) {
1966     push @{$wdata[$num_workers - 1]} ,
1967       @{$self->{'project_files'}}[$num_per_worker
1968                                   * $num_workers..$#{$self->{'project_files'}}];
1969
1970   }
1971
1972   ## Setup listener. Do this before fork so that (in the rare case)
1973   ## when child tries to send data before the accept(), the socket
1974   ## is at least initialized.
1975   my $sock = new IO::Socket::INET (
1976                                    LocalHost => 'localhost',
1977                                    LocalPort => $wport,
1978                                    Proto     => 'tcp',
1979                                    Listen    => $num_workers,
1980                                    Reuse     => 1
1981                                   );
1982   if (!defined ($sock)) {
1983     die "Error setting up parent listener";
1984   }
1985
1986   ## spawn the workers.
1987   my $id = 0;
1988   while ($id < $num_workers) {
1989     # use pipes as barrier
1990     $pid = fork();
1991     if ($pid != 0) {
1992       push @pids, $pid;
1993     }
1994     else {
1995       ## after fork, child knows its id and which data to use.
1996       $self->{'pid'} = 'child';
1997       last;
1998     }
1999     ++$id;
2000   }
2001
2002   if ($self->{pid} eq 'parent') {
2003     $self->diagnostic("Multiprocess MPC using port $wport.");
2004
2005     # read the data from the kids
2006     for (my $ctr = 0; $ctr < $num_workers; ++$ctr) {
2007       my $handle = $sock->accept();
2008       die "Accept error" if !$handle;
2009       my $id = <$handle>;
2010       @{$pdata[$id]} = <$handle>;
2011
2012       # each project as 6 records
2013       if ((($#{$pdata[$id]} + 1) / $num_lines_per_prj) != $num_per_worker) {
2014         if ($#{$pdata[$id]} != 0) {
2015           # 0 indicates a failed status which will be delt with later
2016           if (($id == $num_workers - 1) && ((($#{$pdata[$id]} + 1) / $num_lines_per_prj) != $num_per_worker + $#{$self->{'project_files'}} + 1 - ($num_workers * $num_per_worker))) {
2017             # The last child may have more than num_per_worker records
2018             my $rec = $#{$pdata[$id]} + 1;
2019             my $exp = $num_per_worker * $num_lines_per_prj;
2020             die "There is an error in the child data. Expected $exp. Received $rec";
2021           }
2022         }
2023       }
2024     }
2025     # all data has been read
2026     $sock->close();
2027   }
2028   else {
2029     ## This is the code the workers run.
2030     undef $sock;
2031     ## generate projects
2032     my @cdata = ($id);
2033     foreach my $ofile (@{$wdata[$id]}) {
2034       if (!$self->excluded($ofile)) {
2035         my $file    = $ofile;
2036         my $dir     = $self->mpc_dirname($file);
2037         my $restore = 0;
2038
2039         if (defined $self->{'scoped_assign'}->{$ofile}) {
2040           ## Handle the implicit assignment
2041           my $oi = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
2042           if (defined $oi) {
2043             $previmpl = $impl;
2044             $impl     = $oi;
2045           }
2046
2047           ## Handle the cmdline assignment
2048           my $cmdline = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
2049           if (defined $cmdline && $cmdline ne '') {
2050             ## Save the cacheok value
2051             $prevcache = $self->{'cacheok'};
2052
2053             ## Get the current parameters and process the command line
2054             my %parameters = $self->current_parameters();
2055             $self->process_cmdline($cmdline, \%parameters);
2056
2057             ## Set the parameters on the creator
2058             $creator->restore_state(\%parameters);
2059             $restore = 1;
2060           }
2061         }
2062
2063         ## If we are generating implicit projects and the file is a
2064         ## directory, then we set the dir to the file and empty the file
2065         if ($impl && -d $file) {
2066           $dir  = $file;
2067           $file = '';
2068
2069           ## If the implicit assignment value was not a number, then
2070           ## we will add this value to our base projects.
2071           if ($impl !~ /^\d+$/) {
2072             my $bps = $creator->get_baseprojs();
2073             push(@$bps, split(/\s+/, $impl));
2074             $restore = 1;
2075             $self->{'cacheok'} = 0;
2076           }
2077         }
2078
2079         ## Generate the key for this project file
2080         my $prkey = $self->getcwd() . '/' .
2081           ($file eq '' ? $dir : $file) . "-$postkey";
2082
2083         ## We must change to the subdirectory for
2084         ## which this project file is intended
2085
2086         if ($self->cd($dir)) {
2087           my $files_written = [];
2088           my $gen_proj_info = [];
2089           my $gen_lib_locs  = {};
2090
2091           if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
2092             $files_written = $allprojects{$prkey};
2093             $gen_proj_info = $allprinfo{$prkey};
2094             $gen_lib_locs  = $allliblocs{$prkey};
2095
2096             $status = 1;
2097           }
2098           else {
2099             $status = $creator->generate($self->mpc_basename($file));
2100
2101             ## If any one project file fails, then stop
2102             ## processing altogether.
2103             if (!$status) {
2104               # save the status info and exit. the parent will
2105               # see the error.
2106               @cdata = ($id);
2107               push @cdata, "$status|Unable to process " .
2108                 ($file eq '' ? " in $dir" : $file) . "\n";
2109
2110               $self->send_to_parent(\@cdata);
2111               exit(1);          # child error
2112             }
2113
2114             ## Get the individual project information and
2115             ## generated file name(s)
2116             $files_written = $creator->get_files_written();
2117             $gen_proj_info = $creator->get_project_info();
2118             $gen_lib_locs  = $creator->get_lib_locations();
2119
2120           }
2121
2122           push @cdata, "$status|''|$self->{'cacheok'}|$previmpl|$prevcache";
2123           push @cdata, "$ofile|$prkey|$dir|$cwd|$restore";
2124           push @cdata, Dumper ($files_written);
2125           push @cdata, Dumper ($gen_proj_info);
2126           push @cdata, Dumper ($gen_lib_locs);
2127
2128           # there's a callback that sets the project file list
2129           # since we can't callback between processes we store
2130           # the list for later
2131           push @cdata, Dumper ($self->{'project_file_list'});
2132
2133           $self->cd($cwd);
2134
2135         }
2136         else {
2137           ## Unable to change to the directory.
2138           ## We don't restore the state before we leave,
2139           ## but that's ok since we will be exiting soon.
2140           @cdata = ($id);
2141           push @cdata, "$status|Unable to change directory to $dir\n";
2142           $self->send_to_parent(\@cdata);
2143
2144           exit (1);             # child error
2145         }
2146
2147         ## Return things to the way they were
2148         $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
2149         if ($restore) {
2150           $self->{'cacheok'} = $prevcache;
2151           $creator->restore_state(\%gstate);
2152         }
2153       }
2154       else {
2155         ## This one was excluded, so status is ok
2156         ## no need to set though since the child will exit.
2157         #$status = 1;
2158       }
2159     }
2160
2161     # send all the data at once.
2162     $self->send_to_parent(\@cdata);
2163
2164     exit (0);
2165
2166     # end of child
2167   }
2168
2169   # This is the parent again.
2170
2171   for $pid (@pids) {
2172     # this will reap any zombies
2173     waitpid($pid, 0);
2174   }
2175
2176   my ($msg, $cacheok, $ofile, $prkey, $dir, $restore);
2177
2178   # read the children's stored data
2179   for (my $i = 0; $i < $num_workers; ++$i) {
2180     for (my $j = 0; $j <  $#{$pdata[$i]} + 1; ++$j) {
2181       ($status, $msg, $cacheok, $previmpl, $prevcache) = split /\|/, ${$pdata[$i]}[$j++];
2182
2183       # check that the child was successful
2184       if (!$status) {
2185         return $status, $creator, $msg;
2186       }
2187
2188       ($ofile, $prkey, $dir, $cwd, $restore) = split /\|/, ${$pdata[$i]}[$j++];
2189
2190       eval (${$pdata[$i]}[$j++]);
2191       my $files_written = $VAR1;
2192
2193       eval (${$pdata[$i]}[$j++]);
2194       my $gen_proj_info = $VAR1;
2195
2196       # have to reconstitute gen_lib_locs in the same order it was
2197       # created or else multi-process implicit dependency may differ from
2198       # single process.
2199       eval (${$pdata[$i]}[$j++]);
2200       my $gen_lib_locs;
2201       for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
2202                           substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
2203
2204         $gen_lib_locs->{substr ($k, index ($k, '|') + 1)} =
2205           $VAR1->{$k};
2206       }
2207
2208       # have to reconstitute project_file_list in the same order it was
2209       # created or else multi-process implicit dependency may differ from
2210       # single process.
2211       eval (${$pdata[$i]}[$j]);
2212       for my $k (sort { substr($a, 0 , index ($a, '|')) <=>
2213                           substr ($b, 0, index ($b, '|')) } keys %$VAR1) {
2214
2215         $self->{'project_file_list'}->{substr ($k, index ($k, '|') + 1)} =
2216           $VAR1->{$k};
2217       }
2218
2219       $self->{'cacheok'} = $cacheok;
2220       if ($self->cd($dir)) {
2221         if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
2222
2223           $files_written = $allprojects{$prkey};
2224           $gen_proj_info = $allprinfo{$prkey};
2225           $gen_lib_locs  = $allliblocs{$prkey};
2226           $status = 1;
2227         }
2228         else {
2229           # file is already generated. check status
2230           if (!$status) {
2231
2232             ## We don't restore the state before we leave,
2233             ## but that's ok since we will be exiting right now.
2234             return $status, $creator, $msg;
2235           }
2236
2237           ## Get the individual project information and
2238           ## generated file name(s)
2239           if ($self->{'cacheok'}) {
2240
2241             $allprojects{$prkey} = $files_written;
2242             $allprinfo{$prkey}   = $gen_proj_info;
2243             $allliblocs{$prkey}  = $gen_lib_locs;
2244           }
2245
2246           push(@{$self->{'mpc_to_output'}->{$ofile}}, @$files_written);
2247         }
2248
2249         $self->cd($cwd);
2250         $self->save_project_info($files_written, $gen_proj_info,
2251                                  $gen_lib_locs, $dir,
2252                                  \@projects, \%pi, \%liblocs);
2253       }
2254       else {
2255
2256         ## Unable to change to the directory.
2257         ## We don't restore the state before we leave,
2258         ## but that's ok since we will be exiting soon.
2259         return 0, $creator, $msg;
2260
2261       }
2262
2263       ## Return things to the way they were
2264       $impl = $previmpl if (defined $self->{'scoped_assign'}->{$ofile});
2265       if ($restore) {
2266         $self->{'cacheok'} = $prevcache;
2267         $creator->restore_state(\%gstate);
2268       }
2269     }
2270   }
2271
2272   ## Add implict project dependencies based on source files
2273   ## that have been used by multiple projects.  If we do it here
2274   ## before we call generate_hierarchy(), we don't have to call it
2275   ## in generate_hierarchy() for each workspace.
2276   $self->{'projects'}     = \@projects;
2277   $self->{'project_info'} = \%pi;
2278
2279   if ($status && $genimpdep) {
2280     #print "aipd: $cwd\n", Dumper ($creator), "\n";
2281     $self->add_implicit_project_dependencies($creator, $cwd);
2282   }
2283
2284   ## If we are generating the hierarchical workspaces, then do so
2285   $self->{'lib_locations'} = \%liblocs;
2286   if ($self->get_hierarchy() || $self->workspace_per_project()) {
2287     my $orig = $self->{'workspace_name'};
2288     ($status, $errorString) = $self->generate_hierarchy($creator, \@projects, \%pi);
2289     $self->{'workspace_name'} = $orig;
2290   }
2291
2292   ## Reset the projects and project_info
2293   $self->{'projects'}      = \@projects;
2294   $self->{'project_info'}  = \%pi;
2295
2296   return $status, $creator, $errorString;
2297 }
2298
2299
2300 sub array_contains {
2301   my($self, $left, $right) = @_;
2302   my %check;
2303
2304   ## Initialize the hash keys with the left side array
2305   @check{@$left} = ();
2306
2307   ## Check each element on the right against the left.
2308   foreach my $r (@$right) {
2309     return 1 if (exists $check{$r});
2310   }
2311
2312   return 0;
2313 }
2314
2315
2316 sub non_intersection {
2317   my($self, $left, $right, $over) = @_;
2318   my $status = 0;
2319   my %check;
2320
2321   ## Initialize the hash keys with the left side array
2322   @check{@$left} = ();
2323
2324   ## Check each element on the right against the left.
2325   ## Store anything that isn't in the left side in the over array.
2326   foreach my $r (@$right) {
2327     if (exists $check{$r}) {
2328       $status = 1;
2329     }
2330     else {
2331       push(@$over, $r);
2332     }
2333   }
2334   return $status;
2335 }
2336
2337
2338 sub indirect_dependency {
2339   my($self, $dir, $ccheck, $cfile) = @_;
2340
2341   $self->{'indirect_checked'}->{$ccheck} = 1;
2342   if (index($self->{'project_info'}->{$ccheck}->[ProjectCreator::DEPENDENCIES], $cfile) >= 0) {
2343     return 1;
2344   }
2345   else {
2346     my $deps = $self->create_array(
2347                                    $self->{'project_info'}->{$ccheck}->[ProjectCreator::DEPENDENCIES]);
2348     foreach my $dep (@$deps) {
2349       if (defined $self->{'project_info'}->{"$dir$dep"} &&
2350           !defined $self->{'indirect_checked'}->{"$dir$dep"} &&
2351           $self->indirect_dependency($dir, "$dir$dep", $cfile)) {
2352         return 1;
2353       }
2354     }
2355   }
2356
2357   return 0;
2358 }
2359
2360
2361 sub add_implicit_project_dependencies {
2362   my($self, $creator, $cwd) = @_;
2363   my %bidir;
2364   my %save;
2365
2366   ## Take the current working directory and regular expression'ize it.
2367   $cwd = $self->escape_regex_special($cwd);
2368
2369   ## Look at each projects file list and check it against all of the
2370   ## others.  If any of the other projects file lists contains anothers
2371   ## file, then they are dependent (due to build parallelism).  So, we
2372   ## append the dependency and remove the file in question from the
2373   ## project so that the next time around the foreach, we don't find it
2374   ## as a dependent on the one that we just modified.
2375   my @pflkeys = keys %{$self->{'project_file_list'}};
2376
2377   foreach my $key (@pflkeys) {
2378     foreach my $ikey (@pflkeys) {
2379       ## Not the same project and
2380       ## The same directory and
2381       ## We've not already added a dependency to this project
2382       if ($key ne $ikey &&
2383           ($self->{'project_file_list'}->{$key}->[1] eq
2384            $self->{'project_file_list'}->{$ikey}->[1]) &&
2385           (!defined $bidir{$ikey} ||
2386            !$self->array_contains($bidir{$ikey}, [$key]))) {
2387         my @over;
2388         if ($self->non_intersection(
2389                                     $self->{'project_file_list'}->{$key}->[2],
2390                                     $self->{'project_file_list'}->{$ikey}->[2],
2391                                     \@over)) {
2392           ## The project contains shared source files, so we need to
2393           ## look into adding an implicit inter-project dependency.
2394           $save{$ikey} = $self->{'project_file_list'}->{$ikey}->[2];
2395           $self->{'project_file_list'}->{$ikey}->[2] = \@over;
2396           if (defined $bidir{$key}) {
2397             push(@{$bidir{$key}}, $ikey);
2398           }
2399           else {
2400             $bidir{$key} = [$ikey];
2401           }
2402           my $append = $creator->translate_value('after', $key);
2403           my $file   = $self->{'project_file_list'}->{$ikey}->[0];
2404           my $dir    = $self->{'project_file_list'}->{$ikey}->[1];
2405           my $cfile  = $creator->translate_value('after', $ikey);
2406           ## Remove our starting directory from the projects directory
2407           ## to get the right part of the directory to prepend.
2408           $dir =~ s/^$cwd[\/\\]*//;
2409
2410           ## Turn the append value into a key for 'project_info' and
2411           ## prepend the directory to the file.
2412           my $ccheck = $append;
2413           $ccheck =~ s/"//g;
2414           if ($dir ne '') {
2415             $dir .= '/';
2416             $ccheck = "$dir$ccheck";
2417             $file = "$dir$file";
2418           }
2419
2420           ## If the append value key contains a reference to the project
2421           ## that we were going to append the dependency value, then
2422           ## ignore the generated dependency.  It is redundant and
2423           ## quite possibly wrong.
2424           $self->{'indirect_checked'} = {};
2425           if (defined $self->{'project_info'}->{$file} &&
2426               (!defined $self->{'project_info'}->{$ccheck} ||
2427                !$self->indirect_dependency($dir, $ccheck, $cfile))) {
2428             ## Append the dependency
2429             $self->{'project_info'}->{$file}->[ProjectCreator::DEPENDENCIES] .= " $append";
2430           }
2431         }
2432       }
2433     }
2434   }
2435
2436   ## Restore the modified values in case this method is called again
2437   ## which is the case when using the -hierarchy option.
2438   foreach my $skey (keys %save) {
2439     $self->{'project_file_list'}->{$skey}->[2] = $save{$skey};
2440   }
2441 }
2442
2443
2444 sub get_projects {
2445   return $_[0]->{'projects'};
2446 }
2447
2448
2449 sub get_project_info {
2450   return $_[0]->{'project_info'};
2451 }
2452
2453
2454 sub get_lib_locations {
2455   return $_[0]->{'lib_locations'};
2456 }
2457
2458
2459 sub get_first_level_directory {
2460   my($self, $file) = @_;
2461
2462   if (($file =~ tr/\///) > 0) {
2463     my $dir = $file;
2464     $dir =~ s/^([^\/]+\/).*/$1/;
2465     $dir =~ s/\/+$//;
2466     return $dir;
2467   }
2468
2469   return '.';
2470 }
2471
2472
2473 sub get_associated_projects {
2474   return $_[0]->{'associated'};
2475 }
2476
2477
2478 sub sort_within_group {
2479   my($self, $list, $start, $end) = @_;
2480   my $deps;
2481   my %seen;
2482   my $ccount  = 0;
2483   my $cmax    = ($end - $start) + 1;
2484   my $previ   = -1;
2485   my $prevpjs = [];
2486   my $movepjs = [];
2487
2488   ## Put the projects in the order specified
2489   ## by the project dependencies.
2490   for (my $i = $start; $i <= $end; ++$i) {
2491     ## If our moved project equals our previously moved project then
2492     ## we count this as a possible circular dependency.
2493     my $key = "@$list";
2494     if ($seen{$key} ||
2495         (defined $$movepjs[0] && defined $$prevpjs[0] &&
2496          $$movepjs[0] == $$prevpjs[0] && $$movepjs[1] == $$prevpjs[1])) {
2497       ++$ccount;
2498     }
2499     else {
2500       $ccount = 0;
2501     }
2502
2503     ## Detect circular dependencies
2504     if ($ccount > $cmax) {
2505       my @prjs;
2506       foreach my $mvgr (@$movepjs) {
2507         push(@prjs, $$list[$mvgr]);
2508       }
2509       my $other = $$movepjs[0] - 1;
2510       if ($other < $start || $other == $$movepjs[1] || !defined $$list[$other]) {
2511         $other = undef;
2512       }
2513       $self->warning('Circular dependency detected while processing the ' .
2514                      ($self->{'current_input'} eq '' ?
2515                       'default' : $self->{'current_input'}) .
2516                      ' workspace. ' .
2517                      'The following projects are involved: ' .
2518                      (defined $other ? "$$list[$other], " : '') .
2519                      join(' and ', @prjs));
2520       return;
2521     }
2522
2523     ## Keep track of the previous project movement
2524     $seen{$key} = 1;
2525     $prevpjs = $movepjs;
2526     $movepjs = [] if ($previ < $i);
2527     $previ = $i;
2528
2529     $deps = $self->get_validated_ordering($$list[$i]);
2530     if (defined $$deps[0]) {
2531       my $baseproj = ($self->{'dependency_is_filename'} ?
2532                       $self->mpc_basename($$list[$i]) :
2533                       $self->{'project_info'}->{$$list[$i]}->[ProjectCreator::PROJECT_NAME]);
2534       my $moved = 0;
2535       foreach my $dep (@$deps) {
2536         if ($baseproj ne $dep) {
2537           ## See if the dependency is listed after this project
2538           for (my $j = $i + 1; $j <= $end; ++$j) {
2539             my $ldep = ($self->{'dependency_is_filename'} ?
2540                         $self->mpc_basename($$list[$j]) :
2541                         $self->{'project_info'}->{$$list[$j]}->[ProjectCreator::PROJECT_NAME]);
2542             if ($ldep eq $dep) {
2543               $movepjs = [$i, $j];
2544               ## If so, move it in front of the current project.
2545               ## The original code, which had splices, didn't always
2546               ## work correctly (especially on AIX for some reason).
2547               my $save = $$list[$j];
2548               for (my $k = $j; $k > $i; --$k) {
2549                 $$list[$k] = $$list[$k - 1];
2550               }
2551               $$list[$i] = $save;
2552
2553               ## Mark that an entry has been moved
2554               $moved = 1;
2555               $j--;
2556             }
2557           }
2558         }
2559       }
2560       --$i if ($moved);
2561     }
2562   }
2563 }
2564
2565
2566 sub build_dependency_chain {
2567   my($self, $name, $len, $list, $ni, $glen, $groups, $map, $gdeps) = @_;
2568   my $deps = $self->get_validated_ordering($name);
2569
2570   if (defined $$deps[0]) {
2571     foreach my $dep (@$deps) {
2572       ## Find the item in the list that matches our current dependency
2573       my $mapped = $$map{$dep};
2574       if (defined $mapped) {
2575         for (my $i = 0; $i < $len; $i++) {
2576           if ($$list[$i] eq $mapped) {
2577
2578             ## Locate the group number to which the dependency belongs
2579             for (my $j = 0; $j < $glen; $j++) {
2580               if ($i >= $$groups[$j]->[0] && $i <= $$groups[$j]->[1]) {
2581
2582                 if ($j != $ni) {
2583                   ## Add every project in the group to the dependency chain
2584                   for (my $k = $$groups[$j]->[0]; $k <= $$groups[$j]->[1]; $k++) {
2585                     my $ldep = $self->mpc_basename($$list[$k]);
2586                     if (!exists $$gdeps{$ldep}) {
2587                       $$gdeps{$ldep} = 1;
2588                       $self->build_dependency_chain($$list[$k],
2589                                                     $len, $list, $j,
2590                                                     $glen, $groups,
2591                                                     $map, $gdeps);
2592                     }
2593                   }
2594                 }
2595                 last;
2596               }
2597             }
2598             last;
2599           }
2600         }
2601       }
2602
2603       $$gdeps{$dep} = 1;
2604     }
2605   }
2606 }
2607
2608
2609 sub sort_by_groups {
2610   my($self, $list, $grindex) = @_;
2611   my @groups = @$grindex;
2612   my $llen   = scalar(@$list);
2613
2614   ## Check for duplicates first before we attempt to sort the groups.
2615   ## If there is a duplicate, we quietly return immediately.  The
2616   ## duplicates will be flagged as an error when creating the main
2617   ## workspace.
2618   my %dupcheck;
2619   foreach my $proj (@$list) {
2620     my $base = $self->mpc_basename($proj);
2621     return undef if (defined $dupcheck{$base});
2622     $dupcheck{$base} = $proj;
2623   }
2624
2625   my %circular_checked;
2626   for (my $gi = 0; $gi <= $#groups; ++$gi) {
2627     ## Detect circular dependencies
2628     if (!$circular_checked{$gi}) {
2629       $circular_checked{$gi} = 1;
2630       for (my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
2631         my %gdeps;
2632         $self->build_dependency_chain($$list[$i], $llen, $list, $gi,
2633                                       $#groups + 1, \@groups,
2634                                       \%dupcheck, \%gdeps);
2635         if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
2636           ## There was a cirular dependency, get all of the directories
2637           ## involved.
2638           my %dirs;
2639           foreach my $gdep (keys %gdeps) {
2640             $dirs{$self->mpc_dirname($dupcheck{$gdep})} = 1;
2641           }
2642
2643           ## If the current directory was involved, translate that into
2644           ## a directory relative to the start directory.
2645           if (defined $dirs{'.'}) {
2646             my $cwd = $self->getcwd();
2647             my $start = $self->getstartdir();
2648             if ($cwd ne $start) {
2649               my $startre = $self->escape_regex_special($start);
2650               delete $dirs{'.'};
2651               $cwd =~ s/^$startre[\\\/]//;
2652               $dirs{$cwd} = 1;
2653             }
2654           }
2655
2656           ## Display a warining to the user
2657           my @keys = sort keys %dirs;
2658           $self->warning('Circular directory dependency detected in the ' .
2659                          ($self->{'current_input'} eq '' ?
2660                           'default' : $self->{'current_input'}) .
2661                          ' workspace. ' .
2662                          'The following director' .
2663                          ($#keys == 0 ? 'y is' : 'ies are') .
2664                          ' involved: ' . join(', ', @keys));
2665           return;
2666         }
2667       }
2668     }
2669
2670     ## Build up the group dependencies
2671     my %gdeps;
2672     for (my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
2673       my $deps = $self->get_validated_ordering($$list[$i]);
2674       @gdeps{@$deps} = () if (defined $$deps[0]);
2675     }
2676
2677     ## Search the rest of the groups for any of the group dependencies
2678     for (my $gj = $gi + 1; $gj <= $#groups; ++$gj) {
2679       for (my $i = $groups[$gj]->[0]; $i <= $groups[$gj]->[1]; ++$i) {
2680         if (exists $gdeps{$self->mpc_basename($$list[$i])}) {
2681           ## Move this group ($gj) in front of the current group ($gi)
2682           my @save;
2683           for (my $j = $groups[$gi]->[1] + 1; $j <= $groups[$gj]->[1]; ++$j) {
2684             push(@save, $$list[$j]);
2685           }
2686           my $offset = $groups[$gj]->[1] - $groups[$gi]->[1];
2687           for (my $j = $groups[$gi]->[1]; $j >= $groups[$gi]->[0]; --$j) {
2688             $$list[$j + $offset] = $$list[$j];
2689           }
2690           for (my $j = 0; $j <= $#save; ++$j) {
2691             $$list[$groups[$gi]->[0] + $j] = $save[$j];
2692           }
2693
2694           ## Update the group indices
2695           my $shiftamt = ($groups[$gi]->[1] - $groups[$gi]->[0]) + 1;
2696           for (my $j = $gi + 1; $j <= $gj; ++$j) {
2697             $groups[$j]->[0] -= $shiftamt;
2698             $groups[$j]->[1] -= $shiftamt;
2699           }
2700           my @grsave = @{$groups[$gi]};
2701           $grsave[0] += $offset;
2702           $grsave[1] += $offset;
2703           for (my $j = $gi; $j < $gj; ++$j) {
2704             $groups[$j] = $groups[$j + 1];
2705             $circular_checked{$j} = $circular_checked{$j + 1};
2706           }
2707           $groups[$gj] = \@grsave;
2708           $circular_checked{$gj} = 1;
2709
2710           ## Start over from the first group
2711           $gi = -1;
2712
2713           ## Exit from the outter ($gj) loop
2714           $gj = $#groups;
2715           last;
2716         }
2717       }
2718     }
2719   }
2720 }
2721
2722
2723 sub sort_dependencies {
2724   my($self, $projects, $groups) = @_;
2725   my @list = sort { return $self->sort_projects_by_directory($a, $b) + 0;
2726                   } @$projects;
2727   ## The list above is sorted by directory in order to keep projects
2728   ## within the same directory together.  Otherwise, when groups are
2729   ## created we may get multiple groups for the same directory.
2730
2731   ## Put the projects in the order specified
2732   ## by the project dependencies.  We only need to do
2733   ## this if there is more than one element in the array.
2734   if ($#list > 0) {
2735     ## If the parameter wasn't passed in or it was passed in
2736     ## and was true, sort with directory groups in mind
2737     if (!defined $groups || $groups) {
2738       ## First determine the individual groups
2739       my @grindex;
2740       my $previous = [0, undef];
2741       for (my $li = 0; $li <= $#list; ++$li) {
2742         my $dir = $self->get_first_level_directory($list[$li]);
2743         if (!defined $previous->[1]) {
2744           $previous = [$li, $dir];
2745         }
2746         elsif ($previous->[1] ne $dir) {
2747           push(@grindex, [$previous->[0], $li - 1]);
2748           $previous = [$li, $dir];
2749         }
2750       }
2751       push(@grindex, [$previous->[0], $#list]);
2752
2753       ## Next, sort the individual groups
2754       foreach my $gr (@grindex) {
2755         $self->sort_within_group(\@list, @$gr) if ($$gr[0] != $$gr[1]);
2756       }
2757
2758       ## Now sort the groups as single entities
2759       $self->sort_by_groups(\@list, \@grindex) if ($#grindex > 0);
2760     }
2761     else {
2762       $self->sort_within_group(\@list, 0, $#list);
2763     }
2764   }
2765
2766   return @list;
2767 }
2768
2769
2770 sub number_target_deps {
2771   my($self, $projects, $pjs, $targets, $groups) = @_;
2772   my @list = $self->sort_dependencies($projects, $groups);
2773
2774   ## This block of code must be done after the list of dependencies
2775   ## has been sorted in order to get the correct project numbers.
2776   for (my $i = 0; $i <= $#list; ++$i) {
2777     my $project = $list[$i];
2778     if (defined $$pjs{$project}) {
2779       my($name, $deps) = @{$$pjs{$project}};
2780       if (defined $deps && $deps ne '') {
2781         my @numbers;
2782         my %dhash;
2783         @dhash{@{$self->create_array($deps)}} = ();
2784
2785         ## For each dependency, search in the sorted list
2786         ## up to the point of this project for the projects
2787         ## that this one depends on.  When the project is
2788         ## found, we put the target number in the numbers array.
2789         for (my $j = 0; $j < $i; ++$j) {
2790           ## If the dependency is a filename, then take the basename of
2791           ## the project file.  Otherwise, get the project name based on
2792           ## the project file from the "project_info".
2793           my $key = ($self->{'dependency_is_filename'} ?
2794                      $self->mpc_basename($list[$j]) :
2795                      $self->{'project_info'}->{$list[$j]}->[ProjectCreator::PROJECT_NAME]);
2796           push(@numbers, $j) if (exists $dhash{$key});
2797         }
2798
2799         ## Store the array in the hash keyed on the project file.
2800         $$targets{$project} = \@numbers if (defined $numbers[0]);
2801       }
2802     }
2803   }
2804
2805   return @list;
2806 }
2807
2808
2809 sub project_target_translation {
2810   my($self, $case) = @_;
2811   my %map;
2812
2813   ## Translate project names to avoid target collision with
2814   ## some versions of make.
2815   foreach my $key (keys %{$self->{'project_info'}}) {
2816     my $dir  = $self->mpc_dirname($key);
2817     my $name = $self->{'project_info'}->{$key}->[ProjectCreator::PROJECT_NAME];
2818
2819     ## We want to compare to the upper most directory.  This will be the
2820     ## one that may conflict with the project name.
2821     $dir =~ s/[\/\\].*//;
2822     if (($case && $dir eq $name) || (!$case && lc($dir) eq lc($name))) {
2823       $map{$key} = "$name-target";
2824     }
2825     else {
2826       $map{$key} = $name;
2827     }
2828   }
2829   return \%map;
2830 }
2831
2832
2833 sub optionError {
2834   my($self, $str) = @_;
2835   $self->warning("$self->{'current_input'}: $str.") if (defined $str);
2836 }
2837
2838
2839 sub process_cmdline {
2840   my($self, $cmdline, $parameters) = @_;
2841
2842   ## Set cache use to default.
2843   $self->{'cacheok'} = $self->default_cacheok();
2844
2845   if (defined $cmdline && $cmdline ne '') {
2846     my $args = $self->create_array($cmdline);
2847
2848     ## Look for environment variables
2849     foreach my $arg (@$args) {
2850       $self->replace_env_vars(\$arg) if ($arg =~ /\$/);
2851     }
2852
2853     my $options = $self->options('MWC', {}, 0, @$args);
2854     if (defined $options) {
2855       foreach my $key (keys %$options) {
2856         my $type = $self->is_set($key, $options);
2857
2858         if (!defined $type) {
2859           ## This option was not used, so we ignore it
2860         }
2861         elsif ($type eq 'ARRAY') {
2862           push(@{$parameters->{$key}}, @{$options->{$key}});
2863         }
2864         elsif ($type eq 'HASH') {
2865           my $merge = ($key eq 'addtemp' || $key eq 'addproj');
2866           foreach my $hk (keys %{$options->{$key}}) {
2867             if ($merge && defined $parameters->{$key}->{$hk}) {
2868               push(@{$parameters->{$key}->{$hk}}, @{$options->{$key}->{$hk}});
2869             }
2870             else {
2871               $parameters->{$key}->{$hk} = $options->{$key}->{$hk};
2872             }
2873           }
2874         }
2875         elsif ($type eq 'SCALAR') {
2876           $parameters->{$key} = $options->{$key};
2877         }
2878       }
2879
2880       ## Some option data members are named consistently with the MPC
2881       ## option name.  In this case, we can use this foreach loop.
2882       foreach my $consistent_opt ('exclude', 'for_eclipse', 'gendot',
2883                                   'gfeature_file', 'into',
2884                                   'make_coexistence', 'recurse') {
2885         ## Issue warnings for the options provided by the user
2886         if ($self->is_set($consistent_opt, $options)) {
2887           $self->optionError("-$consistent_opt is ignored");
2888         }
2889       }
2890
2891       ## For those that are inconsistent, we have special code to deal
2892       ## with them.
2893       if ($self->is_set('reldefs', $options)) {
2894         $self->optionError('-noreldefs is ignored');
2895       }
2896
2897       ## Make sure no input files were specified (we can't handle it).
2898       if (defined $options->{'input'}->[0]) {
2899         $self->optionError('Command line files ' .
2900                            'specified in a workspace are ignored');
2901       }
2902
2903       ## Determine if it's ok to use the cache
2904       my @cacheInvalidating = ('global', 'include', 'baseprojs',
2905                                'template', 'ti', 'relative', 'language',
2906                                'addtemp', 'addproj', 'feature_file',
2907                                'features', 'use_env', 'expand_vars');
2908       foreach my $key (@cacheInvalidating) {
2909         if ($self->is_set($key, $options)) {
2910           $self->{'cacheok'} = 0;
2911           last;
2912         }
2913       }
2914     }
2915   }
2916 }
2917
2918
2919 sub current_parameters {
2920   my $self = shift;
2921   my %parameters = $self->save_state();
2922
2923   ## We always want the project creator to generate a toplevel
2924   $parameters{'toplevel'} = 1;
2925   return %parameters;
2926 }
2927
2928
2929 sub project_creator {
2930   my $self = shift;
2931   my $pid = shift;
2932   if (not defined $pid) {
2933     $pid = 'parent';
2934   }
2935
2936   my $str = "$self";
2937
2938   ## NOTE: If the subclassed WorkspaceCreator name prefix does not
2939   ##       match the name prefix of the ProjectCreator, this code
2940   ##       will not work and the subclassed WorkspaceCreator will
2941   ##       need to override this method.
2942
2943   $str =~ s/Workspace/Project/;
2944   $str =~ s/=HASH.*//;
2945
2946   ## Set up values for each project creator
2947   ## If we have command line arguments in the workspace, then
2948   ## we process them before creating the project creator
2949   my $cmdline    = $self->get_assignment('cmdline');
2950   my %parameters = $self->current_parameters();
2951   $self->process_cmdline($cmdline, \%parameters);
2952
2953   ## Create the new project creator with the updated parameters
2954   return $str->new($parameters{'global'},
2955                    $parameters{'include'},
2956                    $parameters{'template'},
2957                    $parameters{'ti'},
2958                    $parameters{'dynamic'},
2959                    $parameters{'static'},
2960                    $parameters{'relative'},
2961                    $parameters{'addtemp'},
2962                    $parameters{'addproj'},
2963                    $parameters{'progress'},
2964                    $parameters{'toplevel'},
2965                    $parameters{'baseprojs'},
2966                    $self->{'global_feature_file'},
2967                    $parameters{'relative_file'},
2968                    $parameters{'feature_file'},
2969                    $parameters{'features'},
2970                    $parameters{'hierarchy'},
2971                    $self->{'exclude'}->{$self->{'wctype'}},
2972                    $self->make_coexistence(),
2973                    $parameters{'name_modifier'},
2974                    $parameters{'apply_project'},
2975                    $self->{'generate_ins'} || $parameters{'genins'},
2976                    $self->get_into(),
2977                    $parameters{'language'},
2978                    $parameters{'use_env'},
2979                    $parameters{'expand_vars'},
2980                    $self->{'gendot'},
2981                    $parameters{'comments'},
2982                    $self->{'for_eclipse'},
2983                    $pid);
2984 }
2985
2986
2987 sub sort_files {
2988   #my $self = shift;
2989   return 0;
2990 }
2991
2992
2993 sub make_coexistence {
2994   return $_[0]->{'coexistence'};
2995 }
2996
2997
2998 sub get_modified_workspace_name {
2999   my($self, $name, $ext, $nows) = @_;
3000   my $nmod  = $self->get_name_modifier();
3001   my $oname = $name;
3002
3003   if (defined $nmod) {
3004     $nmod =~ s/\*/$name/g;
3005     $name = $nmod;
3006   }
3007
3008   ## If this is a per project workspace, then we should not
3009   ## modify the workspace name.  It may overwrite another workspace
3010   ## but that's ok, it will only be a per project workspace.
3011   ## Also, if we don't want the workspace name attached ($nows) then
3012   ## we just return the name plus the extension.
3013   return "$name$ext" if ($nows || $self->{'per_project_workspace_name'});
3014
3015   my $pwd    = $self->getcwd();
3016   my $type   = $self->{'wctype'};
3017   my $wsname = $self->get_workspace_name();
3018
3019   if (!defined $previous_workspace_name{$type}->{$pwd}) {
3020     $previous_workspace_name{$type}->{$pwd} = $wsname;
3021     $self->{'current_workspace_name'} = undef;
3022   }
3023   else {
3024     my $prefix = ($oname eq $wsname ? $name : "$name.$wsname");
3025     $previous_workspace_name{$type}->{$pwd} = $wsname;
3026     while ($self->file_written("$prefix" .
3027                                ($self->{'modified_count'} > 0 ?
3028                                 ".$self->{'modified_count'}" : '') .
3029                                "$ext")) {
3030       ++$self->{'modified_count'};
3031     }
3032     $self->{'current_workspace_name'} =
3033       "$prefix" . ($self->{'modified_count'} > 0 ?
3034                    ".$self->{'modified_count'}" : '') . "$ext";
3035   }
3036
3037   return (defined $self->{'current_workspace_name'} ?
3038           $self->{'current_workspace_name'} : "$name$ext");
3039 }
3040
3041
3042 sub generate_recursive_input_list {
3043   my($self, $dir, $exclude) = @_;
3044   return $self->extension_recursive_input_list($dir, $exclude, $wsext);
3045 }
3046
3047
3048 sub verify_build_ordering {
3049   my $self = shift;
3050   foreach my $project (@{$self->{'projects'}}) {
3051     $self->get_validated_ordering($project);
3052   }
3053 }
3054
3055
3056 sub get_validated_ordering {
3057   my($self, $project) = @_;
3058   my $deps;
3059
3060   if (defined $self->{'ordering_cache'}->{$project}) {
3061     $deps = $self->{'ordering_cache'}->{$project};
3062   }
3063   else {
3064     $deps = [];
3065     if (defined $self->{'project_info'}->{$project}) {
3066       my($name, $dstr) = @{$self->{'project_info'}->{$project}};
3067       if (defined $dstr && $dstr ne '') {
3068         $deps = $self->create_array($dstr);
3069         my $dlen = scalar(@$deps);
3070         for (my $i = 0; $i < $dlen; $i++) {
3071           my $dep   = $$deps[$i];
3072           my $found = 0;
3073           ## Avoid circular dependencies
3074           if ($dep ne $name && $dep ne $self->mpc_basename($project)) {
3075             foreach my $p (@{$self->{'projects'}}) {
3076               if ($dep eq $self->{'project_info'}->{$p}->[ProjectCreator::PROJECT_NAME] ||
3077                   $dep eq $self->mpc_basename($p)) {
3078                 $found = 1;
3079                 last;
3080               }
3081             }
3082             if (!$found) {
3083               if ($self->{'verbose_ordering'}) {
3084                 $self->warning("processing '$project' and '$name' references '$dep' which has " .
3085                                "not been processed.");
3086               }
3087               splice(@$deps, $i, 1);
3088               --$dlen;
3089               --$i;
3090             }
3091           }
3092           else {
3093             ## If a project references itself, we must remove it
3094             ## from the list of dependencies.
3095             splice(@$deps, $i, 1);
3096             --$dlen;
3097             --$i;
3098           }
3099         }
3100       }
3101
3102       $self->{'ordering_cache'}->{$project} = $deps;
3103     }
3104   }
3105
3106   return $deps;
3107 }
3108
3109
3110 sub source_listing_callback {
3111   my($self, $project_file, $project_name, $list) = @_;
3112
3113   # have to keep projects in the the same order as if run in
3114   # single process. otherwise implicit dependencies produces
3115   # different output
3116   if ($self->{'pid'} ne 'parent') {
3117     $project_name = ++$self->{'imp_dep_ctr'} . '|' . $project_name;
3118   }
3119
3120   $self->{'project_file_list'}->{$project_name} = [ $project_file,
3121                                                     $self->getcwd(), $list ];
3122 }
3123
3124
3125 sub sort_projects_by_directory {
3126   my($self, $left, $right) = @_;
3127   my $sa = index($left, '/');
3128   my $sb = index($right, '/');
3129
3130   if ($sa >= 0 && $sb == -1) {
3131     return 1;
3132   }
3133   elsif ($sb >= 0 && $sa == -1) {
3134     return -1;
3135   }
3136   return $left cmp $right;
3137 }
3138
3139
3140 sub get_relative_dep_file {
3141   my($self, $creator, $project, $dep) = @_;
3142
3143   ## If the dependency is a filename, we have to find the key that
3144   ## matches the project file.
3145   if ($creator->dependency_is_filename()) {
3146     foreach my $key (keys %{$self->{'project_file_list'}}) {
3147       if ($self->{'project_file_list'}->{$key}->[0] eq $dep) {
3148         $dep = $key;
3149         last;
3150       }
3151     }
3152   }
3153
3154   if (defined $self->{'project_file_list'}->{$dep}) {
3155     my $base = $self->{'project_file_list'}->{$dep}->[1];
3156     my @dirs = grep(!/^$/, split('/', $base));
3157     my $last = -1;
3158     $project =~ s/^\///;
3159     for (my $i = 0; $i <= $#dirs; $i++) {
3160       my $dir = $dirs[$i];
3161       if ($project =~ s/^$dir\///) {
3162         $last = $i;
3163       }
3164       else {
3165         last;
3166       }
3167     }
3168
3169     my $dependee = $self->{'project_file_list'}->{$dep}->[0];
3170     if ($last == -1) {
3171       return $base . '/' . $dependee;
3172     }
3173     else {
3174       my $built = '';
3175       for (my $i = $last + 1; $i <= $#dirs; $i++) {
3176         $built .= $dirs[$i] . '/';
3177       }
3178       $built .= $dependee;
3179
3180       ## If the project contains a portion of the current working directory,
3181       ## we need to strip it off.  If the workspace is a directory below one
3182       ## of the projects, the directory count will be incorrect due to the
3183       ## use of '..' within the project path.
3184       my $re;
3185       my $dir = $self->getcwd();
3186       while($dir =~ s!^[^/]*/!! &&
3187             ($re = $dir . '/' . ('../' x (($dir =~ tr/\///) + 1))) &&
3188             $project !~ s!^$re!!) {
3189       }
3190
3191       ## The code above is tricky
3192       $self->debug("Project on which this project depends: $project");
3193
3194       my $dircount = ($project =~ tr/\///);
3195       return ('../' x $dircount) . $built;
3196     }
3197   }
3198   return undef;
3199 }
3200
3201
3202 sub create_command_line_string {
3203   my $self = shift;
3204   my @args = @_;
3205   my $str;
3206
3207   foreach my $arg (@args) {
3208     $arg =~ s/^\-\-/-/;
3209     if ($arg =~ /\$/ && $^O ne 'MSWin32') {
3210       ## If we're not running on Windows and the command line argument
3211       ## contains a dollar sign, we need to wrap the argument in single
3212       ## quotes so that the UNIX shell does not interpret it.
3213       $arg = "'$arg'";
3214     }
3215     else {
3216       ## Unfortunately, the Windows command line shell does not
3217       ## understand single quotes correctly.  So, we have the distinction
3218       ## above and handle dollar signs here too.
3219       $arg = "\"$arg\"" if ($arg =~ /[\s\*\$]/);
3220     }
3221     if (defined $str) {
3222       $str .= " $arg";
3223     }
3224     else {
3225       $str = $arg;
3226     }
3227   }
3228   return $str;
3229 }
3230
3231
3232 sub print_workspace_comment {
3233   my $self = shift;
3234   my $fh   = shift;
3235
3236   if ($self->{'workspace_comments'}) {
3237     foreach my $line (@_) {
3238       print $fh $line;
3239     }
3240   }
3241 }
3242
3243
3244 sub get_initial_relative_values {
3245   my $self = shift;
3246   return $self->get_relative(), $self->get_expand_vars();
3247 }
3248
3249
3250 sub get_secondary_relative_values {
3251   return \%ENV, $_[0]->get_expand_vars();
3252 }
3253
3254
3255 sub convert_all_variables {
3256   #my $self = shift;
3257   return 1;
3258 }
3259
3260
3261 sub workspace_file_name {
3262   my $self = shift;
3263   return $self->get_modified_workspace_name($self->get_workspace_name(),
3264                                             $self->workspace_file_extension());
3265 }
3266
3267
3268 sub relative {
3269   my $self = shift;
3270   my $line = $self->SUPER::relative(shift);
3271   $line =~ s/\\/\//g;
3272   return $line;
3273 }
3274
3275 # ************************************************************
3276 # Virtual Methods To Be Overridden
3277 # ************************************************************
3278
3279 sub requires_make_coexistence {
3280   #my $self = shift;
3281   return 0;
3282 }
3283
3284
3285 sub supports_make_coexistence {
3286   #my $self = shift;
3287   return 0;
3288 }
3289
3290
3291 sub generate_implicit_project_dependencies {
3292   #my $self = shift;
3293   return 0;
3294 }
3295
3296
3297 sub workspace_file_extension {
3298   #my $self = shift;
3299   return '';
3300 }
3301
3302
3303 sub workspace_per_project {
3304   #my $self = shift;
3305   return 0;
3306 }
3307
3308
3309 sub default_verbose_ordering {
3310   return 0;                     # Don't warning if there are missing dependencies.
3311 }
3312
3313
3314 sub pre_workspace {
3315   #my $self    = shift;
3316   #my $fh      = shift;
3317   #my $creator = shift;
3318   #my $top     = shift;
3319 }
3320
3321
3322 sub write_comps {
3323   #my $self    = shift;
3324   #my $fh      = shift;
3325   #my $creator = shift;
3326   #my $top     = shift;
3327 }
3328
3329
3330 sub post_workspace {
3331   #my $self    = shift;
3332   #my $fh      = shift;
3333   #my $creator = shift;
3334   #my $top     = shift;
3335 }
3336
3337 sub requires_forward_slashes {
3338   #my $self = shift;
3339   return 0;
3340 }
3341
3342 sub get_additional_output {
3343   #my $self = shift;
3344
3345   ## This method should return an array reference of array references.
3346   ## For each entry, the array should be laid out as follows:
3347   ## [ <directory or undef to use the current output directory>,
3348   ##   <file name>,
3349   ##   <function to write body of file, $self and $fh are first params>,
3350   ##   <optional additional parameter 1>,
3351   ##   ...,
3352   ##   <optional additional parameter N>
3353   ## ]
3354   return [];
3355 }
3356
3357 1;