Subversion Repositories gelsvn

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
107 bj 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
use File::Compare;
17
use File::Basename;
18
 
19
use Creator;
20
use Options;
21
 
22
use vars qw(@ISA);
23
@ISA = qw(Creator Options);
24
 
25
# ************************************************************
26
# Data Section
27
# ************************************************************
28
 
29
my($wsext)  = 'mwc';
30
my($wsbase) = 'mwb';
31
 
32
## Valid names for assignments within a workspace
33
my(%validNames) = ('cmdline'  => 1,
34
                   'implicit' => 1,
35
                  );
36
 
37
## Singleton hash maps of project information
38
my(%allprinfo)   = ();
39
my(%allprojects) = ();
40
my(%allliblocs)  = ();
41
 
42
## Global previous workspace names
43
my(%previous_workspace_name) = ();
44
 
45
## Constant aggregated workspace type name
46
my($aggregated) = 'aggregated_workspace';
47
 
48
# ************************************************************
49
# Subroutine Section
50
# ************************************************************
51
 
52
sub new {
53
  my($class)      = shift;
54
  my($global)     = shift;
55
  my($inc)        = shift;
56
  my($template)   = shift;
57
  my($ti)         = shift;
58
  my($dynamic)    = shift;
59
  my($static)     = shift;
60
  my($relative)   = shift;
61
  my($addtemp)    = shift;
62
  my($addproj)    = shift;
63
  my($progress)   = shift;
64
  my($toplevel)   = shift;
65
  my($baseprojs)  = shift;
66
  my($gfeature)   = shift;
67
  my($feature)    = shift;
68
  my($features)   = shift;
69
  my($hierarchy)  = shift;
70
  my($exclude)    = shift;
71
  my($makeco)     = shift;
72
  my($nmod)       = shift;
73
  my($applypj)    = shift;
74
  my($genins)     = shift;
75
  my($into)       = shift;
76
  my($language)   = shift;
77
  my($use_env)    = shift;
78
  my($expandvars) = shift;
79
  my($self)       = Creator::new($class, $global, $inc,
80
                                 $template, $ti, $dynamic, $static,
81
                                 $relative, $addtemp, $addproj,
82
                                 $progress, $toplevel, $baseprojs,
83
                                 $feature, $features,
84
                                 $hierarchy, $nmod, $applypj,
85
                                 $into, $language, $use_env, $expandvars,
86
                                 'workspace');
87
 
88
  $self->{'workspace_name'}      = undef;
89
  $self->{$self->{'type_check'}} = 0;
90
  $self->{'projects'}            = [];
91
  $self->{'project_info'}        = {};
92
  $self->{'lib_locations'}       = {};
93
  $self->{'reading_parent'}      = [];
94
  $self->{'project_files'}       = [];
95
  $self->{'scoped_assign'}       = {};
96
  $self->{'cacheok'}             = 1;
97
  $self->{'exclude'}             = {};
98
  $self->{'wctype'}              = $self->extractType("$self");
99
  $self->{'modified_count'}      = 0;
100
  $self->{'global_feature_file'} = $gfeature;
101
  $self->{'coexistence'}         = $makeco;
102
  $self->{'project_file_list'}   = {};
103
  $self->{'ordering_cache'}      = {};
104
  $self->{'handled_scopes'}      = {};
105
  $self->{'generate_ins'}        = $genins;
106
  $self->{'scoped_basedir'}      = undef;
107
 
108
  if (defined $$exclude[0]) {
109
    my($type) = $self->{'wctype'};
110
    if (!defined $self->{'exclude'}->{$type}) {
111
      $self->{'exclude'}->{$type} = [];
112
    }
113
    push(@{$self->{'exclude'}->{$type}}, @$exclude);
114
  }
115
 
116
  ## Add a hash reference for our workspace type
117
  if (!defined $previous_workspace_name{$self->{'wctype'}}) {
118
    $previous_workspace_name{$self->{'wctype'}} = {};
119
  }
120
 
121
  ## Warn users about unnecessary options
122
  if ($self->get_hierarchy() && $self->workspace_per_project()) {
123
    $self->warning("The -hierarchy option is unnecessary " .
124
                   "for the " . $self->{'wctype'} . " type.");
125
  }
126
  if ($self->make_coexistence() && !$self->supports_make_coexistence()) {
127
    $self->warning("Using the -make_coexistence option has " .
128
                   "no effect on the " . $self->{'wctype'} . " type.");
129
  }
130
  return $self;
131
}
132
 
133
 
134
sub modify_assignment_value {
135
  my($self)  = shift;
136
  my($name)  = shift;
137
  my($value) = shift;
138
 
139
  ## Workspace assignments do not need modification.
140
  return $value;
141
}
142
 
143
 
144
sub parse_line {
145
  my($self)   = shift;
146
  my($ih)     = shift;
147
  my($line)   = shift;
148
  my($status, $error, @values) = $self->parse_known($line);
149
 
150
  ## Was the line recognized?
151
  if ($status && defined $values[0]) {
152
    if ($values[0] eq $self->{'grammar_type'}) {
153
      my($name) = $values[1];
154
      if (defined $name && $name eq '}') {
155
        if (!defined $self->{'reading_parent'}->[0]) {
156
          ## Fill in all the default values
157
          $self->generate_defaults();
158
 
159
          ## End of workspace; Have subclass write out the file
160
          ## Generate the project files
161
          my($gstat, $creator) = $self->generate_project_files();
162
          if ($gstat) {
163
            ($status, $error) = $self->write_workspace($creator, 1);
164
            $self->{'assign'} = {};
165
          }
166
          else {
167
            $error = 'Unable to generate all of the project files';
168
            $status = 0;
169
          }
170
 
171
          $self->{'modified_count'} = 0;
172
          $self->{'workspace_name'} = undef;
173
          $self->{'projects'}       = [];
174
          $self->{'project_info'}   = {};
175
          $self->{'project_files'}  = [];
176
        }
177
        $self->{$self->{'type_check'}} = 0;
178
      }
179
      else {
180
        ## Workspace Beginning
181
        ## Deal with the inheritance hiearchy first
182
        if (defined $values[2]) {
183
          foreach my $parent (@{$values[2]}) {
184
            ## Read in the parent onto ourself
185
            my($file) = $self->search_include_path("$parent.$wsbase");
186
            if (!defined $file) {
187
              $file = $self->search_include_path("$parent.$wsext");
188
            }
189
 
190
            if (defined $file) {
191
              push(@{$self->{'reading_parent'}}, 1);
192
              $status = $self->parse_file($file);
193
              pop(@{$self->{'reading_parent'}});
194
 
195
              if (!$status) {
196
                $error = "Invalid parent: $parent";
197
              }
198
            }
199
            else {
200
              $status = 0;
201
              $error = "Unable to locate parent: $parent";
202
            }
203
          }
204
        }
205
 
206
        ## Set up some initial values
207
        if (defined $name) {
208
          if ($name =~ /[\/\\]/) {
209
            $status = 0;
210
            $error = 'Workspaces can not have a slash ' .
211
                     'or a back slash in the name';
212
          }
213
          else {
214
            $name =~ s/^\(\s*//;
215
            $name =~ s/\s*\)$//;
216
 
217
            ## Replace any *'s with the default name
218
            if ($name =~ /\*/) {
219
              $name = $self->fill_type_name(
220
                                    $name,
221
                                    $self->get_default_workspace_name());
222
            }
223
 
224
            $self->{'workspace_name'} = $name;
225
          }
226
        }
227
        $self->{$self->{'type_check'}} = 1;
228
      }
229
    }
230
    elsif ($values[0] eq 'assignment') {
231
      if (defined $validNames{$values[1]}) {
232
        $self->process_assignment($values[1], $values[2]);
233
      }
234
      else {
235
        $error = "Invalid assignment name: $values[1]";
236
        $status = 0;
237
      }
238
    }
239
    elsif ($values[0] eq 'assign_add') {
240
      if (defined $validNames{$values[1]}) {
241
        $self->process_assignment_add($values[1], $values[2]);
242
      }
243
      else {
244
        $error = "Invalid addition name: $values[1]";
245
        $status = 0;
246
      }
247
    }
248
    elsif ($values[0] eq 'assign_sub') {
249
      if (defined $validNames{$values[1]}) {
250
        $self->process_assignment_sub($values[1], $values[2]);
251
      }
252
      else {
253
        $error = "Invalid subtraction name: $values[1]";
254
        $status = 0;
255
      }
256
    }
257
    elsif ($values[0] eq 'component') {
258
      ($status, $error) = $self->parse_scope($ih,
259
                                             $values[1],
260
                                             $values[2],
261
                                             \%validNames);
262
    }
263
    else {
264
      $error = "Unrecognized line: $line";
265
      $status = 0;
266
    }
267
  }
268
  elsif ($status == -1) {
269
    if ($line =~ /\.$wsext$/) {
270
      ($status, $error) = $self->aggregated_workspace($line);
271
    }
272
    else {
273
      push(@{$self->{'project_files'}}, $line);
274
      $status = 1;
275
    }
276
  }
277
 
278
  return $status, $error;
279
}
280
 
281
 
282
sub aggregated_workspace {
283
  my($self) = shift;
284
  my($file) = shift;
285
  my($fh)   = new FileHandle();
286
 
287
  if (open($fh, $file)) {
288
    my($oline) = $self->get_line_number();
289
    my($tc)    = $self->{$self->{'type_check'}};
290
    my($ag)    = $self->{'handled_scopes'}->{$aggregated};
291
    my($psbd)  = $self->{'scoped_basedir'};
292
    my($status, $error, @values) = (0, 'No recognizable lines');
293
 
294
    $self->{'handled_scopes'}->{$aggregated} = undef;
295
    $self->set_line_number(0);
296
    $self->{$self->{'type_check'}} = 0;
297
    $self->{'scoped_basedir'} = $self->mpc_dirname($file);
298
 
299
    while(<$fh>) {
300
      my($line) = $self->preprocess_line($fh, $_);
301
      ($status, $error, @values) = $self->parse_known($line);
302
 
303
      ## Was the line recognized?
304
      if ($status) {
305
        if (defined $values[0]) {
306
          if ($values[0] eq $self->{'grammar_type'}) {
307
            if (defined $values[2]) {
308
              my($name) = basename($file);
309
              $name =~ s/\.[^\.]+$//;
310
              $status = 0;
311
              $error  = 'Aggregated workspace (' . $name .
312
                        ') can not inherit from another workspace';
313
            }
314
            else {
315
              ($status, $error) = $self->parse_scope($fh,
316
                                                     '',
317
                                                     $aggregated,
318
                                                     \%validNames);
319
            }
320
          }
321
          else {
322
            $status = 0;
323
            $error = 'Unable to aggregate ' . $file;
324
          }
325
          last;
326
        }
327
      }
328
      else {
329
        last;
330
      }
331
    }
332
    close($fh);
333
 
334
    $self->{'scoped_basedir'} = $psbd;
335
    $self->{'handled_scopes'}->{$aggregated} = $ag;
336
    $self->{$self->{'type_check'}} = $tc;
337
    $self->set_line_number($oline);
338
 
339
    return $status, $error;
340
  }
341
 
342
  return 0, 'Unable to open ' . $file;
343
}
344
 
345
 
346
sub parse_scope {
347
  my($self)        = shift;
348
  my($fh)          = shift;
349
  my($name)        = shift;
350
  my($type)        = shift;
351
  my($validNames)  = shift;
352
  my($flags)       = shift;
353
  my($elseflags)   = shift;
354
 
355
  if ($name eq 'exclude') {
356
    return $self->parse_exclude($fh, $type);
357
  }
358
  else {
359
    return $self->SUPER::parse_scope($fh, $name, $type,
360
                                     $validNames, $flags, $elseflags);
361
  }
362
}
363
 
364
sub parse_exclude {
365
  my($self)        = shift;
366
  my($fh)          = shift;
367
  my($typestr)     = shift;
368
  my($status)      = 0;
369
  my($errorString) = 'Unable to process exclude';
370
  my($negated)     = undef;
371
 
372
  if ($typestr eq $self->get_default_component_name()) {
373
    $typestr = $self->{'wctype'};
374
  }
375
 
376
  my(@exclude) = ();
377
  my(%types)   = ();
378
  @types{split(/\s*,\s*/, $typestr)} = ();
379
 
380
  ## If there is a negation at all, add our
381
  ## current type, it may be removed below
382
  if ($typestr =~ /!/) {
383
    $negated = 1;
384
    $types{$self->{wctype}} = 1;
385
 
386
    ## Process negated exclusions
387
    foreach my $key (keys %types) {
388
      if ($key =~ /^!\s*(\w+)/) {
389
        ## Remove the negated key
390
        delete $types{$key};
391
 
392
        ## Then delete the key that was negated in the exclusion.
393
        delete $types{$1};
394
      }
395
    }
396
  }
397
 
398
  if (exists $types{$self->{wctype}}) {
399
    while(<$fh>) {
400
      my($line) = $self->preprocess_line($fh, $_);
401
 
402
      if ($line eq '') {
403
      }
404
      elsif ($line =~ /^}(.*)$/) {
405
        if (defined $1 && $1 ne '') {
406
          $status = 0;
407
          $errorString = "Trailing characters found: '$1'";
408
        }
409
        else {
410
          $status = 1;
411
          $errorString = undef;
412
        }
413
        last;
414
      }
415
      else {
416
        if (defined $self->{'scoped_basedir'}) {
417
          $line = $self->{'scoped_basedir'} . '/' . $line;
418
        }
419
        push(@exclude, $line);
420
      }
421
    }
422
 
423
    foreach my $type (keys %types) {
424
      if (!defined $self->{'exclude'}->{$type}) {
425
        $self->{'exclude'}->{$type} = [];
426
      }
427
      push(@{$self->{'exclude'}->{$type}}, @exclude);
428
    }
429
  }
430
  else {
431
    if ($negated) {
432
      ($status, $errorString) = $self->SUPER::parse_scope($fh,
433
                                                          'exclude',
434
                                                          $typestr,
435
                                                          \%validNames);
436
    }
437
    else {
438
      ## If this exclude block didn't match the current type and the
439
      ## exclude wasn't negated, we need to eat the exclude block so that
440
      ## these lines don't get included into the workspace.
441
      while(<$fh>) {
442
        my($line) = $self->preprocess_line($fh, $_);
443
 
444
        if ($line =~ /^}(.*)$/) {
445
          if (defined $1 && $1 ne '') {
446
            $status = 0;
447
            $errorString = "Trailing characters found: '$1'";
448
          }
449
          else {
450
            $status = 1;
451
            $errorString = undef;
452
          }
453
          last;
454
        }
455
      }
456
    }
457
  }
458
 
459
  return $status, $errorString;
460
}
461
 
462
 
463
sub excluded {
464
  my($self) = shift;
465
  my($file) = shift;
466
 
467
  foreach my $excluded (@{$self->{'exclude'}->{$self->{'wctype'}}}) {
468
    if ($excluded eq $file || $file =~ /^$excluded\//) {
469
      return 1;
470
    }
471
  }
472
 
473
  return 0;
474
}
475
 
476
 
477
sub handle_scoped_end {
478
  my($self)   = shift;
479
  my($type)   = shift;
480
  my($flags)  = shift;
481
  my($status) = 1;
482
  my($error)  = undef;
483
 
484
  if ($type eq $aggregated &&
485
      !defined $self->{'handled_scopes'}->{$type}) {
486
    ## Replace instances of $PWD with the current directory plus the
487
    ## scoped_basedir.  We have to do it now otherwise, $PWD will be the
488
    ## wrong directory if it's done later.
489
    if (defined $$flags{'cmdline'}) {
490
      my($dir) = $self->getcwd() . '/' . $self->{'scoped_basedir'};
491
      $$flags{'cmdline'} =~ s/\$PWD(\W)/$dir$1/g;
492
      $$flags{'cmdline'} =~ s/\$PWD$/$dir/;
493
    }
494
 
495
    ## Go back to the previous directory and add the directory contents
496
    ($status, $error) = $self->handle_scoped_unknown(undef, $type, $flags, '.');
497
  }
498
 
499
  $self->{'handled_scopes'}->{$type} = undef;
500
  return $status, $error;
501
}
502
 
503
 
504
sub handle_scoped_unknown {
505
  my($self)   = shift;
506
  my($fh)     = shift;
507
  my($type)   = shift;
508
  my($flags)  = shift;
509
  my($line)   = shift;
510
  my($status) = 1;
511
  my($error)  = undef;
512
  my($dupchk) = undef;
513
 
514
  if ($line =~ /^\w+.*{/) {
515
    if (defined $fh) {
516
      my(@values) = ();
517
      my($tc) = $self->{$self->{'type_check'}};
518
      $self->{$self->{'type_check'}} = 1;
519
      ($status, $error, @values) = $self->parse_line($fh, $line);
520
      $self->{$self->{'type_check'}} = $tc;
521
    }
522
    else {
523
      $status = 0;
524
      $error  = 'Unhandled line: ' . $line;
525
    }
526
    return $status, $error;
527
  }
528
 
529
  if ($type eq $aggregated) {
530
    $line = $self->{'scoped_basedir'} . ($line ne '.' ? "/$line" : '');
531
    my(%dup) = ();
532
    @dup{@{$self->{'project_files'}}} = ();
533
    $dupchk = \%dup;
534
  }
535
 
536
  if (-d $line) {
537
    my(@files) = ();
538
    $self->search_for_files([ $line ], \@files, $$flags{'implicit'});
539
 
540
    ## If we are generating implicit projects within a scope, then
541
    ## we need to remove directories and the parent directories for which
542
    ## there is an mpc file.  Otherwise, the projects will be added
543
    ## twice.
544
    if ($$flags{'implicit'}) {
545
      my(%remove) = ();
546
      foreach my $file (@files) {
547
        if ($file =~ /\.mpc$/) {
548
          my($exc) = $file;
549
          do {
550
            $exc = $self->mpc_dirname($exc);
551
            $remove{$exc} = 1;
552
          } while($exc ne '.' && $exc !~ /[a-z]:[\/\\]/i);
553
        }
554
      }
555
 
556
      my(@acceptable) = ();
557
      foreach my $file (@files) {
558
        if (!defined $remove{$file}) {
559
          push(@acceptable, $file);
560
        }
561
      }
562
      @files = @acceptable;
563
    }
564
 
565
    foreach my $file (@files) {
566
      if (!$self->excluded($file)) {
567
        if (defined $dupchk && exists $$dupchk{$file}) {
568
          $self->warning("Duplicate mpc file ($file) added by an " .
569
                         'aggregate workspace.  It will be ignored.');
570
        }
571
        else {
572
          $self->{'scoped_assign'}->{$file} = $flags;
573
          push(@{$self->{'project_files'}}, $file);
574
        }
575
      }
576
    }
577
  }
578
  else {
579
    if ($line =~ /\.$wsext$/) {
580
      ## An aggregated workspace within an aggregated workspace.
581
      ($status, $error) = $self->aggregated_workspace($line);
582
    }
583
    else {
584
      if (!$self->excluded($line)) {
585
        if (defined $dupchk && exists $$dupchk{$line}) {
586
          $self->warning("Duplicate mpc file ($line) added by an " .
587
                         'aggregate workspace.  It will be ignored.');
588
        }
589
        else {
590
          $self->{'scoped_assign'}->{$line} = $flags;
591
          push(@{$self->{'project_files'}}, $line);
592
        }
593
      }
594
    }
595
  }
596
  $self->{'handled_scopes'}->{$type} = 1;
597
 
598
  return $status, $error;
599
}
600
 
601
 
602
sub search_for_files {
603
  my($self)  = shift;
604
  my($files) = shift;
605
  my($array) = shift;
606
  my($impl)  = shift;
607
 
608
  foreach my $file (@$files) {
609
    if (-d $file) {
610
      my(@f) = $self->generate_default_file_list(
611
                         $file,
612
                         $self->{'exclude'}->{$self->{'wctype'}});
613
      $self->search_for_files(\@f, $array, $impl);
614
      if ($impl) {
615
        $file =~ s/^\.\///;
616
        unshift(@$array, $file);
617
      }
618
    }
619
    else {
620
      if ($file =~ /\.mpc$/) {
621
        $file =~ s/^\.\///;
622
        unshift(@$array, $file);
623
      }
624
    }
625
  }
626
}
627
 
628
 
629
sub remove_duplicate_projects {
630
  my($self)  = shift;
631
  my($list)  = shift;
632
  my($count) = scalar(@$list);
633
 
634
  for(my $i = 0; $i < $count; ++$i) {
635
    my($file) = $$list[$i];
636
    foreach my $inner (@$list) {
637
      if ($file ne $inner && $file eq $self->mpc_dirname($inner) && ! -d $inner) {
638
        splice(@$list, $i, 1);
639
        --$count;
640
        --$i;
641
        last;
642
      }
643
    }
644
  }
645
}
646
 
647
 
648
sub generate_default_components {
649
  my($self)  = shift;
650
  my($files) = shift;
651
  my($impl)  = shift;
652
  my($pjf)   = $self->{'project_files'};
653
 
654
  if (defined $$pjf[0]) {
655
    ## If we have files, then process directories
656
    my(@built) = ();
657
    foreach my $file (@$pjf) {
658
      if (!$self->excluded($file)) {
659
        if (-d $file) {
660
          my(@found) = ();
661
          my(@gen)   = $self->generate_default_file_list(
662
                                $file,
663
                                $self->{'exclude'}->{$self->{'wctype'}});
664
          $self->search_for_files(\@gen, \@found, $impl);
665
          push(@built, @found);
666
          if ($impl || $self->{'scoped_assign'}->{$file}->{'implicit'}) {
667
            push(@built, $file);
668
          }
669
        }
670
        else {
671
          push(@built, $file);
672
        }
673
      }
674
    }
675
 
676
    ## If the workspace is set to implicit
677
    if ($impl) {
678
      ## Remove duplicates from this list
679
      $self->remove_duplicate_projects(\@built);
680
    }
681
 
682
    ## Set the project files
683
    $self->{'project_files'} = \@built;
684
  }
685
  else {
686
    ## Add all of the wanted files in this directory
687
    ## and in the subdirectories.
688
    $self->search_for_files($files, $pjf, $impl);
689
 
690
    ## If the workspace is set to implicit
691
    if ($impl) {
692
      ## Remove duplicates from this list
693
      $self->remove_duplicate_projects($pjf);
694
    }
695
 
696
    ## If no files were found, then we push the empty
697
    ## string, so the Project Creator will generate
698
    ## the default project file.
699
    if (!defined $$pjf[0]) {
700
      push(@$pjf, '');
701
    }
702
  }
703
}
704
 
705
 
706
sub get_default_workspace_name {
707
  my($self) = shift;
708
  my($name) = $self->{'current_input'};
709
 
710
  if ($name eq '') {
711
    $name = $self->base_directory();
712
  }
713
  else {
714
    ## Since files on UNIX can have back slashes, we transform them
715
    ## into underscores.
716
    $name =~ s/\\/_/g;
717
 
718
    ## Take off the extension
719
    $name =~ s/\.[^\.]+$//;
720
  }
721
 
722
  return $name;
723
}
724
 
725
 
726
sub generate_defaults {
727
  my($self) = shift;
728
 
729
  ## Generate default workspace name
730
  if (!defined $self->{'workspace_name'}) {
731
    $self->{'workspace_name'} = $self->get_default_workspace_name();
732
  }
733
 
734
  my(@files) = $self->generate_default_file_list(
735
                        '.',
736
                        $self->{'exclude'}->{$self->{'wctype'}});
737
 
738
  ## Generate default components
739
  $self->generate_default_components(\@files,
740
                                     $self->get_assignment('implicit'));
741
}
742
 
743
 
744
sub get_workspace_name {
745
  my($self) = shift;
746
  return $self->{'workspace_name'};
747
}
748
 
749
 
750
sub get_current_output_name {
751
  my($self) = shift;
752
  return $self->{'current_output'};
753
}
754
 
755
 
756
sub write_workspace {
757
  my($self)      = shift;
758
  my($creator)   = shift;
759
  my($addfile)   = shift;
760
  my($status)    = 1;
761
  my($error)     = undef;
762
  my($duplicates) = 0;
763
 
764
  if ($self->get_toplevel()) {
765
    my($progress) = $self->get_progress_callback();
766
 
767
    if (defined $progress) {
768
      &$progress();
769
    }
770
 
771
    if ($addfile) {
772
      ## To be consistent across multiple project types, we disallow
773
      ## duplicate project names for all types, not just VC6.
774
      ## Note that these name are handled case-insensitive by VC6
775
      my(%names) = ();
776
      foreach my $project (@{$self->{'projects'}}) {
777
        my($name) = lc($self->{'project_info'}->{$project}->[0]);
778
        if (defined $names{$name}) {
779
          ++$duplicates;
780
          $self->error("Duplicate case-insensitive project '$name'. " .
781
                       "Look in " . $self->mpc_dirname($project) . " and " .
782
                       $self->mpc_dirname($names{$name}) .
783
                       " for project name conflicts.");
784
        }
785
        else {
786
          $names{$name} = $project;
787
        }
788
      }
789
    }
790
    else {
791
      $self->{'per_project_workspace_name'} = 1;
792
    }
793
 
794
    my($name)   = $self->transform_file_name($self->workspace_file_name());
795
    my($outdir) = $self->get_outdir();
796
    my($oname)  = $name;
797
 
798
    $name = "$outdir/$name";
799
 
800
    my($abort_creation) = 0;
801
    if ($duplicates > 0) {
802
      $abort_creation = 1;
803
      $error = "Duplicate case-insensitive project names are " .
804
               "not allowed within a workspace.";
805
      $status = 0;
806
    }
807
    else {
808
      if (!defined $self->{'projects'}->[0]) {
809
        $self->information('No projects were created.');
810
        $abort_creation = 1;
811
      }
812
    }
813
 
814
    if (!$abort_creation) {
815
      my($fh)  = new FileHandle();
816
      my($dir) = $self->mpc_dirname($name);
817
 
818
      ## Verify and possibly modify the dependencies
819
      if ($addfile) {
820
        $self->verify_build_ordering();
821
      }
822
 
823
      if ($dir ne '.') {
824
        mkpath($dir, 0, 0777);
825
      }
826
 
827
      if ($addfile || !$self->file_written($name)) {
828
        $self->{'current_output'} = $name;
829
        if ($self->compare_output()) {
830
          ## First write the output to a temporary file
831
          my($tmp) = "$outdir/MWC$>.$$";
832
          my($different) = 1;
833
          if (open($fh, ">$tmp")) {
834
            $self->pre_workspace($fh);
835
            $self->write_comps($fh, $creator, $addfile);
836
            $self->post_workspace($fh);
837
            close($fh);
838
 
839
            if (-r $name &&
840
                -s $tmp == -s $name && compare($tmp, $name) == 0) {
841
              $different = 0;
842
            }
843
          }
844
          else {
845
            $error = "Unable to open $tmp for output.";
846
            $status = 0;
847
          }
848
 
849
          if ($status) {
850
            if ($different) {
851
              unlink($name);
852
              if (rename($tmp, $name)) {
853
                if ($addfile) {
854
                  $self->add_file_written($oname);
855
                }
856
              }
857
              else {
858
                $error = 'Unable to open ' . $self->getcwd() .
859
                         "/$name for output";
860
                $status = 0;
861
              }
862
            }
863
            else {
864
              ## We will pretend that we wrote the file
865
              unlink($tmp);
866
              if ($addfile) {
867
                $self->add_file_written($oname);
868
              }
869
            }
870
          }
871
        }
872
        else {
873
          if (open($fh, ">$name")) {
874
            $self->pre_workspace($fh);
875
            $self->write_comps($fh, $creator, $addfile);
876
            $self->post_workspace($fh);
877
            close($fh);
878
 
879
            if ($addfile) {
880
              $self->add_file_written($oname);
881
            }
882
          }
883
          else {
884
            $error = "Unable to open $name for output.";
885
            $status = 0;
886
          }
887
        }
888
      }
889
    }
890
 
891
    if (!$addfile) {
892
      $self->{'per_project_workspace_name'} = undef;
893
    }
894
  }
895
 
896
  return $status, $error;
897
}
898
 
899
 
900
sub save_project_info {
901
  my($self)     = shift;
902
  my($gen)      = shift;
903
  my($gpi)      = shift;
904
  my($gll)      = shift;
905
  my($dir)      = shift;
906
  my($projects) = shift;
907
  my($pi)       = shift;
908
  my($ll)       = shift;
909
  my($c)        = 0;
910
 
911
  ## For each file written
912
  foreach my $pj (@$gen) {
913
    ## Save the full path to the project file in the array
914
    my($full) = ($dir ne '.' ? "$dir/" : '') . $pj;
915
    push(@$projects, $full);
916
 
917
    ## Get the corresponding generated project info and save it
918
    ## in the hash map keyed on the full project file name
919
    $$pi{$full} = $$gpi[$c];
920
    $c++;
921
  }
922
 
923
  foreach my $key (keys %$gll) {
924
    $$ll{$key} = $$gll{$key};
925
  }
926
}
927
 
928
 
929
sub topname {
930
  my($self) = shift;
931
  my($file) = shift;
932
  my($dir)  = '.';
933
  my($rest) = $file;
934
  if ($file =~ /^([^\/\\]+)[\/\\](.*)/) {
935
    $dir  = $1;
936
    $rest = $2;
937
  }
938
  return $dir, $rest;
939
}
940
 
941
 
942
sub generate_hierarchy {
943
  my($self)      = shift;
944
  my($creator)   = shift;
945
  my($origproj)  = shift;
946
  my($originfo)  = shift;
947
  my($current)   = undef;
948
  my(@saved)     = ();
949
  my(%sinfo)     = ();
950
  my($cwd)       = $self->getcwd();
951
 
952
  ## Make a copy of these.  We will be modifying them.
953
  ## It is necessary to sort the projects to get the correct ordering.
954
  ## Projects in the current directory must come before projects in
955
  ## other directories.
956
  my(@projects)  = sort { my($sa) = ($a =~ /\//);
957
                          my($sb) = ($b =~ /\//);
958
                          if ($sa && !$sb) {
959
                            return 1;
960
                          }
961
                          elsif ($sb && !$sa) {
962
                            return -1;
963
                          }
964
                          return $a cmp $b;
965
                        } @{$origproj};
966
  my(%projinfo)  = %{$originfo};
967
 
968
  foreach my $prj (@projects) {
969
    my($top, $rest) = $self->topname($prj);
970
 
971
    if (!defined $current) {
972
      $current = $top;
973
      push(@saved, $rest);
974
      $sinfo{$rest} = $projinfo{$prj};
975
    }
976
    elsif ($top ne $current) {
977
      if ($current ne '.') {
978
        ## Write out the hierachical workspace
979
        $self->cd($current);
980
        $self->generate_hierarchy($creator, \@saved, \%sinfo);
981
 
982
        $self->{'projects'}       = \@saved;
983
        $self->{'project_info'}   = \%sinfo;
984
        $self->{'workspace_name'} = $self->base_directory();
985
 
986
        my($status, $error) = $self->write_workspace($creator);
987
        if (!$status) {
988
          $self->error($error);
989
        }
990
        $self->cd($cwd);
991
      }
992
 
993
      ## Start the next one
994
      $current = $top;
995
      @saved = ($rest);
996
      %sinfo = ();
997
      $sinfo{$rest} = $projinfo{$prj};
998
    }
999
    else {
1000
      push(@saved, $rest);
1001
      $sinfo{$rest} = $projinfo{$prj};
1002
    }
1003
  }
1004
  if (defined $current && $current ne '.') {
1005
    $self->cd($current);
1006
    $self->generate_hierarchy($creator, \@saved, \%sinfo);
1007
 
1008
    $self->{'projects'}       = \@saved;
1009
    $self->{'project_info'}   = \%sinfo;
1010
    $self->{'workspace_name'} = $self->base_directory();
1011
 
1012
    my($status, $error) = $self->write_workspace($creator);
1013
    if (!$status) {
1014
      $self->error($error);
1015
    }
1016
    $self->cd($cwd);
1017
  }
1018
}
1019
 
1020
 
1021
sub generate_project_files {
1022
  my($self)      = shift;
1023
  my($status)    = (scalar @{$self->{'project_files'}} == 0 ? 1 : 0);
1024
  my(@projects)  = ();
1025
  my(%pi)        = ();
1026
  my(%liblocs)   = ();
1027
  my($creator)   = $self->project_creator();
1028
  my($cwd)       = $self->getcwd();
1029
  my($impl)      = $self->get_assignment('implicit');
1030
  my($postkey)   = $creator->get_dynamic() .
1031
                   $creator->get_static() . "-$self";
1032
  my($previmpl)  = $impl;
1033
  my($prevcache) = $self->{'cacheok'};
1034
  my(%gstate)    = $creator->save_state();
1035
  my($genimpdep) = $self->generate_implicit_project_dependencies();
1036
 
1037
  ## Remove the address portion of the $self string
1038
  $postkey =~ s/=.*//;
1039
 
1040
  ## Set the source file callback on our project creator
1041
  $creator->set_source_listing_callback([\&source_listing_callback, $self]);
1042
 
1043
  foreach my $ofile (@{$self->{'project_files'}}) {
1044
    if (!$self->excluded($ofile)) {
1045
      my($file)    = $ofile;
1046
      my($dir)     = $self->mpc_dirname($file);
1047
      my($restore) = 0;
1048
 
1049
      if (defined $self->{'scoped_assign'}->{$ofile}) {
1050
        ## Handle the implicit assignment
1051
        my($oi) = $self->{'scoped_assign'}->{$ofile}->{'implicit'};
1052
        if (defined $oi) {
1053
          $previmpl = $impl;
1054
          $impl     = $oi;
1055
        }
1056
 
1057
        ## Handle the cmdline assignment
1058
        my($cmdline) = $self->{'scoped_assign'}->{$ofile}->{'cmdline'};
1059
        if (defined $cmdline && $cmdline ne '') {
1060
          ## Save the cacheok value
1061
          $prevcache = $self->{'cacheok'};
1062
 
1063
          ## Get the current parameters and process the command line
1064
          my(%parameters) = $self->current_parameters();
1065
          $self->process_cmdline($cmdline, \%parameters);
1066
 
1067
          ## Set the parameters on the creator
1068
          $creator->restore_state(\%parameters);
1069
          $restore = 1;
1070
        }
1071
      }
1072
 
1073
      ## If we are generating implicit projects and the file is a
1074
      ## directory, then we set the dir to the file and empty the file
1075
      if ($impl && -d $file) {
1076
        $dir  = $file;
1077
        $file = '';
1078
 
1079
        ## If the implicit assignment value was not a number, then
1080
        ## we will add this value to our base projects.
1081
        if ($impl !~ /^\d+$/) {
1082
          my($bps) = $creator->get_baseprojs();
1083
          push(@$bps, split(/\s+/, $impl));
1084
          $restore = 1;
1085
          $self->{'cacheok'} = 0;
1086
        }
1087
      }
1088
 
1089
      ## Generate the key for this project file
1090
      my($prkey) = $self->getcwd() . '/' .
1091
                   ($file eq '' ? $dir : $file) . "-$postkey";
1092
 
1093
      ## We must change to the subdirectory for
1094
      ## which this project file is intended
1095
      if ($self->cd($dir)) {
1096
        my($files_written) = [];
1097
        my($gen_proj_info) = [];
1098
        my($gen_lib_locs)  = {};
1099
        if ($self->{'cacheok'} && defined $allprojects{$prkey}) {
1100
          $files_written = $allprojects{$prkey};
1101
          $gen_proj_info = $allprinfo{$prkey};
1102
          $gen_lib_locs  = $allliblocs{$prkey};
1103
          $status = 1;
1104
        }
1105
        else {
1106
          $status = $creator->generate(basename($file));
1107
 
1108
          ## If any one project file fails, then stop
1109
          ## processing altogether.
1110
          if (!$status) {
1111
            ## We don't restore the state before we leave,
1112
            ## but that's ok since we will be exiting soon.
1113
            return $status, $creator;
1114
          }
1115
 
1116
          ## Get the individual project information and
1117
          ## generated file name(s)
1118
          $files_written = $creator->get_files_written();
1119
          $gen_proj_info = $creator->get_project_info();
1120
          $gen_lib_locs  = $creator->get_lib_locations();
1121
 
1122
          if ($self->{'cacheok'}) {
1123
            $allprojects{$prkey} = $files_written;
1124
            $allprinfo{$prkey}   = $gen_proj_info;
1125
            $allliblocs{$prkey}  = $gen_lib_locs;
1126
          }
1127
        }
1128
        $self->cd($cwd);
1129
        $self->save_project_info($files_written, $gen_proj_info,
1130
                                 $gen_lib_locs, $dir,
1131
                                 \@projects, \%pi, \%liblocs);
1132
      }
1133
      else {
1134
        ## Unable to change to the directory.
1135
        ## We don't restore the state before we leave,
1136
        ## but that's ok since we will be exiting soon.
1137
        return 0, $creator;
1138
      }
1139
 
1140
      ## Return things to the way they were
1141
      if (defined $self->{'scoped_assign'}->{$ofile}) {
1142
        $impl = $previmpl;
1143
      }
1144
      if ($restore) {
1145
        $self->{'cacheok'} = $prevcache;
1146
        $creator->restore_state(\%gstate);
1147
      }
1148
    }
1149
    else {
1150
      ## This one was excluded, so status is ok
1151
      $status = 1;
1152
    }
1153
  }
1154
 
1155
  ## Add implict project dependencies based on source files
1156
  ## that have been used by multiple projects.  If we do it here
1157
  ## before we call generate_hierarchy(), we don't have to call it
1158
  ## in generate_hierarchy() for each workspace.
1159
  $self->{'projects'}     = \@projects;
1160
  $self->{'project_info'} = \%pi;
1161
  if ($status && $genimpdep) {
1162
    $self->add_implicit_project_dependencies($creator, $cwd);
1163
  }
1164
 
1165
  ## If we are generating the hierarchical workspaces, then do so
1166
  $self->{'lib_locations'} = \%liblocs;
1167
  if ($self->get_hierarchy() || $self->workspace_per_project()) {
1168
    my($orig) = $self->{'workspace_name'};
1169
    $self->generate_hierarchy($creator, \@projects, \%pi);
1170
    $self->{'workspace_name'} = $orig;
1171
  }
1172
 
1173
  ## Reset the projects and project_info
1174
  $self->{'projects'}      = \@projects;
1175
  $self->{'project_info'}  = \%pi;
1176
 
1177
  return $status, $creator;
1178
}
1179
 
1180
 
1181
sub array_contains {
1182
  my($self)   = shift;
1183
  my($left)   = shift;
1184
  my($right)  = shift;
1185
  my(%check)  = ();
1186
 
1187
  ## Initialize the hash keys with the left side array
1188
  @check{@$left} = ();
1189
 
1190
  ## Check each element on the right against the left.
1191
  foreach my $r (@$right) {
1192
    if (exists $check{$r}) {
1193
      return 1;
1194
    }
1195
  }
1196
 
1197
  return 0;
1198
}
1199
 
1200
 
1201
sub non_intersection {
1202
  my($self)   = shift;
1203
  my($left)   = shift;
1204
  my($right)  = shift;
1205
  my($over)   = shift;
1206
  my($status) = 0;
1207
  my(%check)  = ();
1208
 
1209
  ## Initialize the hash keys with the left side array
1210
  @check{@$left} = ();
1211
 
1212
  ## Check each element on the right against the left.
1213
  ## Store anything that isn't in the left side in the over array.
1214
  foreach my $r (@$right) {
1215
    if (exists $check{$r}) {
1216
      $status = 1;
1217
    }
1218
    else {
1219
      push(@$over, $r);
1220
    }
1221
  }
1222
  return $status;
1223
}
1224
 
1225
 
1226
sub indirect_depdency {
1227
  my($self)   = shift;
1228
  my($dir)    = shift;
1229
  my($ccheck) = shift;
1230
  my($cfile)  = shift;
1231
 
1232
  if ($self->{'project_info'}->{$ccheck}->[1] =~ /$cfile/) {
1233
    return 1;
1234
  }
1235
  else {
1236
    my($deps) = $self->create_array(
1237
                         $self->{'project_info'}->{$ccheck}->[1]);
1238
    foreach my $dep (@$deps) {
1239
      if (defined $self->{'project_info'}->{"$dir$dep"} &&
1240
          $self->indirect_depdency($dir, "$dir$dep", $cfile)) {
1241
        return 1;
1242
      }
1243
    }
1244
  }
1245
 
1246
  return 0;
1247
}
1248
 
1249
 
1250
sub add_implicit_project_dependencies {
1251
  my($self)      = shift;
1252
  my($creator)   = shift;
1253
  my($cwd)       = shift;
1254
  my(%bidir)     = ();
1255
  my(%save)      = ();
1256
 
1257
  ## Take the current working directory and regular expression'ize it.
1258
  $cwd = $self->escape_regex_special($cwd);
1259
 
1260
  ## Look at each projects file list and check it against all of the
1261
  ## others.  If any of the other projects file lists contains anothers
1262
  ## file, then they are dependent (due to build parallelism).  So, we
1263
  ## append the dependency and remove the file in question from the
1264
  ## project so that the next time around the foreach, we don't find it
1265
  ## as a dependent on the one that we just modified.
1266
  my(@pflkeys) = keys %{$self->{'project_file_list'}};
1267
  foreach my $key (@pflkeys) {
1268
    foreach my $ikey (@pflkeys) {
1269
      ## Not the same project and
1270
      ## The same directory and
1271
      ## We've not already added a dependency to this project
1272
      if ($key ne $ikey &&
1273
          ($self->{'project_file_list'}->{$key}->[1] eq
1274
           $self->{'project_file_list'}->{$ikey}->[1]) &&
1275
          (!defined $bidir{$ikey} ||
1276
           !$self->array_contains($bidir{$ikey}, [$key]))) {
1277
        my(@over) = ();
1278
        if ($self->non_intersection(
1279
                      $self->{'project_file_list'}->{$key}->[2],
1280
                      $self->{'project_file_list'}->{$ikey}->[2],
1281
                      \@over)) {
1282
          ## The project contains shared source files, so we need to
1283
          ## look into adding an implicit inter-project dependency.
1284
          $save{$ikey} = $self->{'project_file_list'}->{$ikey}->[2];
1285
          $self->{'project_file_list'}->{$ikey}->[2] = \@over;
1286
          if (defined $bidir{$key}) {
1287
            push(@{$bidir{$key}}, $ikey);
1288
          }
1289
          else {
1290
            $bidir{$key} = [$ikey];
1291
          }
1292
          my($append) = $creator->translate_value('after', $key);
1293
          my($file)   = $self->{'project_file_list'}->{$ikey}->[0];
1294
          my($dir)    = $self->{'project_file_list'}->{$ikey}->[1];
1295
          my($cfile)  = $self->escape_regex_special(
1296
                              $creator->translate_value('after', $ikey));
1297
          ## Remove our starting directory from the projects directory
1298
          ## to get the right part of the directory to prepend.
1299
          $dir =~ s/^$cwd[\/\\]*//;
1300
 
1301
          ## Turn the append value into a key for 'project_info' and
1302
          ## prepend the directory to the file.
1303
          my($ccheck) = $append;
1304
          $ccheck =~ s/"//g;
1305
          if ($dir ne '') {
1306
            $dir .= '/';
1307
            $ccheck = "$dir$ccheck";
1308
            $file = "$dir$file";
1309
          }
1310
 
1311
          ## If the append value key contains a reference to the project
1312
          ## that we were going to append the dependency value, then
1313
          ## ignore the generated dependency.  It is redundant and
1314
          ## quite possibly wrong.
1315
          if (!defined $self->{'project_info'}->{$ccheck} ||
1316
              !$self->indirect_depdency($dir, $ccheck, $cfile)) {
1317
            ## Append the dependency
1318
            $self->{'project_info'}->{$file}->[1] .= " $append";
1319
          }
1320
        }
1321
      }
1322
    }
1323
  }
1324
 
1325
  ## Restore the modified values in case this method is called again
1326
  ## which is the case when using the -hierarchy option.
1327
  foreach my $skey (keys %save) {
1328
    $self->{'project_file_list'}->{$skey}->[2] = $save{$skey};
1329
  }
1330
}
1331
 
1332
 
1333
sub get_projects {
1334
  my($self) = shift;
1335
  return $self->{'projects'};
1336
}
1337
 
1338
 
1339
sub get_project_info {
1340
  my($self) = shift;
1341
  return $self->{'project_info'};
1342
}
1343
 
1344
 
1345
sub get_lib_locations {
1346
  my($self) = shift;
1347
  return $self->{'lib_locations'};
1348
}
1349
 
1350
 
1351
sub get_first_level_directory {
1352
  my($self) = shift;
1353
  my($file) = shift;
1354
  my($dir)  = undef;
1355
  if (($file =~ tr/\///) > 0) {
1356
    $dir = $file;
1357
    $dir =~ s/^([^\/]+\/).*/$1/;
1358
    $dir =~ s/\/+$//;
1359
  }
1360
  else {
1361
    $dir = '.';
1362
  }
1363
  return $dir;
1364
}
1365
 
1366
 
1367
sub sort_within_group {
1368
  my($self)    = shift;
1369
  my($list)    = shift;
1370
  my($start)   = shift;
1371
  my($end)     = shift;
1372
  my($deps)    = undef;
1373
  my($ccount)  = 0;
1374
  my($cmax)    = ($end - $start) + 1;
1375
  my($previ)   = -1;
1376
  my($prevpjs) = [];
1377
  my($movepjs) = [];
1378
 
1379
  ## Put the projects in the order specified
1380
  ## by the project dpendencies.
1381
  for(my $i = $start; $i <= $end; ++$i) {
1382
    ## If our moved project equals our previously moved project then
1383
    ## we count this as a possible circular dependency.
1384
    if (defined $$movepjs[0] && defined $$prevpjs[0] &&
1385
        $$movepjs[0] == $$prevpjs[0] && $$movepjs[1] == $$prevpjs[1]) {
1386
      ++$ccount;
1387
    }
1388
    else {
1389
      $ccount = 0;
1390
    }
1391
 
1392
    ## Detect circular dependencies
1393
    if ($ccount > $cmax) {
1394
      my(@prjs) = ();
1395
      foreach my $mvgr (@$movepjs) {
1396
        push(@prjs, $$list[$mvgr]);
1397
      }
1398
      my($other) = $$movepjs[0] - 1;
1399
      if ($other < $start || $other == $$movepjs[1] || !defined $$list[$other]) {
1400
        $other = undef;
1401
      }
1402
      $self->warning('Circular dependency detected while processing the ' .
1403
                     ($self->{'current_input'} eq '' ?
1404
                       'default' : $self->{'current_input'}) .
1405
                     ' workspace. ' .
1406
                     'The following projects are involved: ' .
1407
                     (defined $other ? "$$list[$other], " : '') .
1408
                     join(' and ', @prjs));
1409
      return;
1410
    }
1411
 
1412
    ## Keep track of the previous project movement
1413
    $prevpjs = $movepjs;
1414
    if ($previ < $i) {
1415
      $movepjs = [];
1416
    }
1417
    $previ = $i;
1418
 
1419
    $deps = $self->get_validated_ordering($$list[$i]);
1420
    if ($deps ne '') {
1421
      my($baseproj) = basename($$list[$i]);
1422
      my($darr) = $self->create_array($deps);
1423
 
1424
      my($moved) = 0;
1425
      foreach my $dep (@$darr) {
1426
        if ($baseproj ne $dep) {
1427
          ## See if the dependency is listed after this project
1428
          for(my $j = $i + 1; $j <= $end; ++$j) {
1429
            if (basename($$list[$j]) eq $dep) {
1430
              $movepjs = [$i, $j];
1431
              ## If so, move it in front of the current project.
1432
              ## The original code, which had splices, didn't always
1433
              ## work correctly (especially on AIX for some reason).
1434
              my($save) = $$list[$j];
1435
              for(my $k = $j; $k > $i; --$k) {
1436
                $$list[$k] = $$list[$k - 1];
1437
              }
1438
              $$list[$i] = $save;
1439
 
1440
              ## Mark that an entry has been moved
1441
              $moved = 1;
1442
              $j--;
1443
            }
1444
          }
1445
        }
1446
      }
1447
      if ($moved) {
1448
        $i--;
1449
      }
1450
    }
1451
  }
1452
}
1453
 
1454
 
1455
sub sort_by_groups {
1456
  my($self)    = shift;
1457
  my($list)    = shift;
1458
  my($grindex) = shift;
1459
  my(@groups)  = @$grindex;
1460
  my($ccount)  = 0;
1461
  my($cmax)    = $#groups;
1462
  my($prevgi)  = -1;
1463
  my($prevgrs) = [];
1464
  my($movegrs) = [];
1465
 
1466
  for(my $gi = 0; $gi <= $#groups; ++$gi) {
1467
    ## If our moved group equals our previously moved group then
1468
    ## we count this as a possible circular dependency.
1469
    if (defined $$movegrs[0] && defined $$prevgrs[0] &&
1470
        $$movegrs[0] == $$prevgrs[0] && $$movegrs[1] == $$prevgrs[1]) {
1471
      ++$ccount;
1472
    }
1473
    else {
1474
      $ccount = 0;
1475
    }
1476
 
1477
    ## Detect circular dependencies
1478
    if ($ccount > $cmax) {
1479
      my(@dirs) = ();
1480
      foreach my $mvgr (@$movegrs) {
1481
        push(@dirs, $$list[$groups[$mvgr]->[0]]);
1482
        $dirs[$#dirs] =~ s/[\/\\].*//;
1483
      }
1484
      $self->warning('Circular dependency detected while processing the ' .
1485
                     ($self->{'current_input'} eq '' ?
1486
                       'default' : $self->{'current_input'}) .
1487
                     ' workspace. ' .
1488
                     'The following directories are involved: ' .
1489
                     join(' and ', @dirs));
1490
      return;
1491
    }
1492
 
1493
    ## Build up the group dependencies
1494
    my(%gdeps) = ();
1495
    for(my $i = $groups[$gi]->[0]; $i <= $groups[$gi]->[1]; ++$i) {
1496
      my($deps) = $self->get_validated_ordering($$list[$i]);
1497
      if ($deps ne '') {
1498
        my($darr) = $self->create_array($deps);
1499
        foreach my $dep (@$darr) {
1500
          $gdeps{$dep} = 1;
1501
        }
1502
      }
1503
    }
1504
 
1505
    ## Keep track of the previous group movement
1506
    $prevgrs = $movegrs;
1507
    if ($prevgi < $gi) {
1508
      $movegrs = [];
1509
    }
1510
    $prevgi = $gi;
1511
 
1512
    ## Search the rest of the groups for any of the group dependencies
1513
    my($moved) = 0;
1514
    for(my $gj = $gi + 1; $gj <= $#groups; ++$gj) {
1515
      for(my $i = $groups[$gj]->[0]; $i <= $groups[$gj]->[1]; ++$i) {
1516
        if (defined $gdeps{basename($$list[$i])}) {
1517
          ## Move this group ($gj) in front of the current group ($gi)
1518
          $movegrs = [$gj, $gi];
1519
          my(@save) = ();
1520
          for(my $j = $groups[$gi]->[1] + 1; $j <= $groups[$gj]->[1]; ++$j) {
1521
            push(@save, $$list[$j]);
1522
          }
1523
          my($offset) = $groups[$gj]->[1] - $groups[$gi]->[1];
1524
          for(my $j = $groups[$gi]->[1]; $j >= $groups[$gi]->[0]; --$j) {
1525
            $$list[$j + $offset] = $$list[$j];
1526
          }
1527
          for(my $j = 0; $j <= $#save; ++$j) {
1528
            $$list[$groups[$gi]->[0] + $j] = $save[$j];
1529
          }
1530
 
1531
          ## Update the group indices
1532
          my($shiftamt) = ($groups[$gi]->[1] - $groups[$gi]->[0]) + 1;
1533
          for(my $j = $gi + 1; $j <= $gj; ++$j) {
1534
            $groups[$j]->[0] -= $shiftamt;
1535
            $groups[$j]->[1] -= $shiftamt;
1536
          }
1537
          my(@grsave) = @{$groups[$gi]};
1538
          $grsave[0] += $offset;
1539
          $grsave[1] += $offset;
1540
          for(my $j = $gi; $j < $gj; ++$j) {
1541
            $groups[$j] = $groups[$j + 1];
1542
          }
1543
          $groups[$gj] = \@grsave;
1544
 
1545
          ## Signify that we have moved a group
1546
          $moved = 1;
1547
          last;
1548
        }
1549
      }
1550
      if ($moved) {
1551
        ## Start over from the first group
1552
        $gi = -1;
1553
        last;
1554
      }
1555
    }
1556
  }
1557
}
1558
 
1559
 
1560
sub sort_dependencies {
1561
  my($self)     = shift;
1562
  my($projects) = shift;
1563
  my(@list)     = sort @$projects;
1564
 
1565
  ## Put the projects in the order specified
1566
  ## by the project dpendencies.  We only need to do
1567
  ## this if there is more than one element in the array.
1568
  if ($#list > 0) {
1569
    ## First determine the individual groups
1570
    my(@grindex)  = ();
1571
    my($previous) = [0, undef];
1572
    for(my $li = 0; $li <= $#list; ++$li) {
1573
      my($dir) = $self->get_first_level_directory($list[$li]);
1574
      if (!defined $previous->[1]) {
1575
        $previous = [$li, $dir];
1576
      }
1577
      elsif ($previous->[1] ne $dir) {
1578
        push(@grindex, [$previous->[0], $li - 1]);
1579
        $previous = [$li, $dir];
1580
      }
1581
    }
1582
     push(@grindex, [$previous->[0], $#list]);
1583
 
1584
    ## Next, sort the individual groups
1585
    foreach my $gr (@grindex) {
1586
      if ($$gr[0] != $$gr[1]) {
1587
        $self->sort_within_group(\@list, @$gr);
1588
      }
1589
    }
1590
 
1591
    ## Now sort the groups as single entities
1592
    if ($#grindex > 0) {
1593
      $self->sort_by_groups(\@list, \@grindex);
1594
    }
1595
  }
1596
 
1597
  return @list;
1598
}
1599
 
1600
 
1601
sub number_target_deps {
1602
  my($self)     = shift;
1603
  my($projects) = shift;
1604
  my($pjs)      = shift;
1605
  my($targets)  = shift;
1606
  my(@list)     = $self->sort_dependencies($projects);
1607
 
1608
  ## This block of code must be done after the list of dependencies
1609
  ## has been sorted in order to get the correct project numbers.
1610
  for(my $i = 0; $i <= $#list; ++$i) {
1611
    my($project) = $list[$i];
1612
    if (defined $$pjs{$project}) {
1613
      my($name, $deps) = @{$$pjs{$project}};
1614
      if (defined $deps && $deps ne '') {
1615
        my(%targetnumbers) = ();
1616
        my($darr) = $self->create_array($deps);
1617
 
1618
        ## For each dependency, search in the sorted list
1619
        ## up to the point of this project for the projects
1620
        ## that this one depends on.  When the project is
1621
        ## found, we put the target number in a hash map (to avoid
1622
        ## duplicates).
1623
        foreach my $dep (@$darr) {
1624
          for(my $j = 0; $j < $i; ++$j) {
1625
            if (basename($list[$j]) eq $dep) {
1626
              $targetnumbers{$j} = 1;
1627
            }
1628
          }
1629
        }
1630
 
1631
        ## Get the keys of the hash map and store the
1632
        ## array in the hash keyed on the project file.
1633
        my(@numbers) = sort { $a <=> $b } keys %targetnumbers;
1634
        if (defined $numbers[0]) {
1635
          $$targets{$project} = \@numbers;
1636
        }
1637
      }
1638
    }
1639
  }
1640
 
1641
  return @list;
1642
}
1643
 
1644
 
1645
sub project_target_translation {
1646
  my($self)  = shift;
1647
  my($cased) = shift;
1648
  my(%map)   = ();
1649
 
1650
  ## Translate project names to avoid target collision with
1651
  ## some versions of make.
1652
  foreach my $key (keys %{$self->{'project_info'}}) {
1653
    my($dir)  = $self->mpc_dirname($key);
1654
    my($name) = $self->{'project_info'}->{$key}->[0];
1655
 
1656
    if (($cased && $dir eq $name) || (!$cased && lc($dir) eq lc($name))) {
1657
      $map{$key} = "$name-target";
1658
    }
1659
    else {
1660
      $map{$key} = $name;
1661
    }
1662
  }
1663
  return \%map;
1664
}
1665
 
1666
 
1667
sub optionError {
1668
  my($self) = shift;
1669
  my($str)  = shift;
1670
  $self->warning("$self->{'current_input'}: $str.");
1671
}
1672
 
1673
 
1674
sub process_cmdline {
1675
  my($self)       = shift;
1676
  my($cmdline)    = shift;
1677
  my($parameters) = shift;
1678
 
1679
  ## It's ok to use the cache
1680
  $self->{'cacheok'} = 1;
1681
 
1682
  if (defined $cmdline && $cmdline ne '') {
1683
    my($args) = $self->create_array($cmdline);
1684
 
1685
    ## Look for environment variables
1686
    foreach my $arg (@$args) {
1687
      while($arg =~ /\$(\w+)/) {
1688
        my($name) = $1;
1689
        my($val)  = '';
1690
        if ($name eq 'PWD') {
1691
          $val = $self->getcwd();
1692
        }
1693
        elsif (defined $ENV{$name}) {
1694
          $val = $ENV{$name};
1695
        }
1696
        $arg =~ s/\$\w+/$val/;
1697
      }
1698
    }
1699
 
1700
    my($options) = $self->options('MWC', {}, 0, @$args);
1701
    if (defined $options) {
1702
      foreach my $key (keys %$options) {
1703
        my($type) = $self->is_set($key, $options);
1704
 
1705
        if (!defined $type) {
1706
          ## This option was not used, so we ignore it
1707
        }
1708
        elsif ($type eq 'ARRAY') {
1709
          push(@{$parameters->{$key}}, @{$options->{$key}});
1710
        }
1711
        elsif ($type eq 'HASH') {
1712
          foreach my $hk (keys %{$options->{$key}}) {
1713
            $parameters->{$key}->{$hk} = $options->{$key}->{$hk};
1714
          }
1715
        }
1716
        elsif ($type eq 'SCALAR') {
1717
          $parameters->{$key} = $options->{$key};
1718
        }
1719
      }
1720
 
1721
      ## Issue warnings for these options
1722
      if (defined $options->{'recurse'}) {
1723
        $self->optionError('-recurse is ignored');
1724
      }
1725
      if (defined $options->{'reldefs'}) {
1726
        $self->optionError('-noreldefs is ignored');
1727
      }
1728
      if (defined $options->{'coexistence'}) {
1729
        $self->optionError('-make_coexistence is ignored');
1730
      }
1731
      if (defined $options->{'genins'}) {
1732
        $self->optionError('-genins is ignored');
1733
      }
1734
      if (defined $options->{'into'}) {
1735
        $self->optionError('-into is ignored');
1736
      }
1737
      if (defined $options->{'language'}) {
1738
        $self->optionError('-language is ignored');
1739
      }
1740
      if (defined $options->{'input'}->[0]) {
1741
        $self->optionError('Command line files ' .
1742
                           'specified in a workspace are ignored');
1743
      }
1744
 
1745
      ## Determine if it's ok to use the cache
1746
      my(@cacheInvalidating) = ('global', 'include', 'baseprojs',
1747
                                'template', 'ti', 'relative',
1748
                                'addtemp', 'addproj', 'feature_file',
1749
                                'features', 'use_env', 'expand_vars');
1750
      foreach my $key (@cacheInvalidating) {
1751
        if ($self->is_set($key, $options)) {
1752
          $self->{'cacheok'} = 0;
1753
          last;
1754
        }
1755
      }
1756
    }
1757
  }
1758
}
1759
 
1760
 
1761
sub current_parameters {
1762
  my($self) = shift;
1763
  my(%parameters) = $self->save_state();
1764
 
1765
  ## We always want the project creator to generate a toplevel
1766
  $parameters{'toplevel'} = 1;
1767
  return %parameters;
1768
}
1769
 
1770
 
1771
sub project_creator {
1772
  my($self) = shift;
1773
  my($str)  = "$self";
1774
 
1775
  ## NOTE: If the subclassed WorkspaceCreator name prefix does not
1776
  ##       match the name prefix of the ProjectCreator, this code
1777
  ##       will not work and the subclassed WorkspaceCreator will
1778
  ##       need to override this method.
1779
 
1780
  $str =~ s/Workspace/Project/;
1781
  $str =~ s/=HASH.*//;
1782
 
1783
  ## Set up values for each project creator
1784
  ## If we have command line arguments in the workspace, then
1785
  ## we process them before creating the project creator
1786
  my($cmdline)    = $self->get_assignment('cmdline');
1787
  my(%parameters) = $self->current_parameters();
1788
  $self->process_cmdline($cmdline, \%parameters);
1789
 
1790
  ## Create the new project creator with the updated parameters
1791
  return $str->new($parameters{'global'},
1792
                   $parameters{'include'},
1793
                   $parameters{'template'},
1794
                   $parameters{'ti'},
1795
                   $parameters{'dynamic'},
1796
                   $parameters{'static'},
1797
                   $parameters{'relative'},
1798
                   $parameters{'addtemp'},
1799
                   $parameters{'addproj'},
1800
                   $parameters{'progress'},
1801
                   $parameters{'toplevel'},
1802
                   $parameters{'baseprojs'},
1803
                   $self->{'global_feature_file'},
1804
                   $parameters{'feature_file'},
1805
                   $parameters{'features'},
1806
                   $parameters{'hierarchy'},
1807
                   $self->{'exclude'}->{$self->{'wctype'}},
1808
                   $self->make_coexistence(),
1809
                   $parameters{'name_modifier'},
1810
                   $parameters{'apply_project'},
1811
                   $self->{'generate_ins'},
1812
                   $parameters{'into'},
1813
                   $self->get_language(),
1814
                   $parameters{'use_env'},
1815
                   $parameters{'expand_vars'});
1816
}
1817
 
1818
 
1819
sub sort_files {
1820
  #my($self) = shift;
1821
  return 0;
1822
}
1823
 
1824
 
1825
sub make_coexistence {
1826
  my($self) = shift;
1827
  return $self->{'coexistence'};
1828
}
1829
 
1830
 
1831
sub get_modified_workspace_name {
1832
  my($self)   = shift;
1833
  my($name)   = shift;
1834
  my($ext)    = shift;
1835
  my($nows)   = shift;
1836
  my($nmod)   = $self->get_name_modifier();
1837
 
1838
  if (defined $nmod) {
1839
    $nmod =~ s/\*/$name/g;
1840
    $name = $nmod;
1841
  }
1842
 
1843
  ## If this is a per project workspace, then we should not
1844
  ## modify the workspace name.  It may overwrite another workspace
1845
  ## but that's ok, it will only be a per project workspace.
1846
  ## Also, if we don't want the workspace name attached ($nows) then
1847
  ## we just return the name plus the extension.
1848
  if ($nows || $self->{'per_project_workspace_name'}) {
1849
    return "$name$ext";
1850
  }
1851
 
1852
  my($pwd)    = $self->getcwd();
1853
  my($type)   = $self->{'wctype'};
1854
  my($wsname) = $self->get_workspace_name();
1855
 
1856
  if (!defined $previous_workspace_name{$type}->{$pwd}) {
1857
    $previous_workspace_name{$type}->{$pwd} = $wsname;
1858
    $self->{'current_workspace_name'} = undef;
1859
  }
1860
  else {
1861
    my($prefix) = ($name eq $wsname ? $name : "$name.$wsname");
1862
    $previous_workspace_name{$type}->{$pwd} = $wsname;
1863
    while($self->file_written("$prefix" .
1864
                              ($self->{'modified_count'} > 0 ?
1865
                                   ".$self->{'modified_count'}" : '') .
1866
                              "$ext")) {
1867
      ++$self->{'modified_count'};
1868
    }
1869
    $self->{'current_workspace_name'} =
1870
               "$prefix" . ($self->{'modified_count'} > 0 ?
1871
                                ".$self->{'modified_count'}" : '') . "$ext";
1872
  }
1873
 
1874
  return (defined $self->{'current_workspace_name'} ?
1875
                  $self->{'current_workspace_name'} : "$name$ext");
1876
}
1877
 
1878
 
1879
sub generate_recursive_input_list {
1880
  my($self)    = shift;
1881
  my($dir)     = shift;
1882
  my($exclude) = shift;
1883
  return $self->extension_recursive_input_list($dir, $exclude, $wsext);
1884
}
1885
 
1886
 
1887
sub verify_build_ordering {
1888
  my($self) = shift;
1889
  foreach my $project (@{$self->{'projects'}}) {
1890
    $self->get_validated_ordering($project);
1891
  }
1892
}
1893
 
1894
 
1895
sub get_validated_ordering {
1896
  my($self)    = shift;
1897
  my($project) = shift;
1898
  my($deps)    = undef;
1899
 
1900
  if (defined $self->{'ordering_cache'}->{$project}) {
1901
    $deps = $self->{'ordering_cache'}->{$project};
1902
  }
1903
  else {
1904
    $deps = '';
1905
    if (defined $self->{'project_info'}->{$project}) {
1906
      my($name) = undef;
1907
      ($name, $deps) = @{$self->{'project_info'}->{$project}};
1908
      if (defined $deps && $deps ne '') {
1909
        my($darr) = $self->create_array($deps);
1910
        foreach my $dep (@$darr) {
1911
          my($found) = 0;
1912
          ## Avoid circular dependencies
1913
          if ($dep ne $name && $dep ne basename($project)) {
1914
            foreach my $p (@{$self->{'projects'}}) {
1915
              if ($dep eq $self->{'project_info'}->{$p}->[0] ||
1916
                  $dep eq basename($p)) {
1917
                $found = 1;
1918
                last;
1919
              }
1920
            }
1921
            if (!$found) {
1922
              if (defined $ENV{MPC_VERBOSE_ORDERING}) {
1923
                $self->warning("'$name' references '$dep' which has " .
1924
                               "not been processed.");
1925
              }
1926
              my($reg) = $self->escape_regex_special($dep);
1927
              $deps =~ s/\s*"$reg"\s*/ /g;
1928
            }
1929
          }
1930
        }
1931
 
1932
        $deps =~ s/^\s+//;
1933
        $deps =~ s/\s+$//;
1934
      }
1935
 
1936
      $self->{'ordering_cache'}->{$project} = $deps;
1937
    }
1938
  }
1939
 
1940
  return $deps;
1941
}
1942
 
1943
 
1944
sub source_listing_callback {
1945
  my($self)         = shift;
1946
  my($project_file) = shift;
1947
  my($project_name) = shift;
1948
  my(@files)        = @_;
1949
  my($cwd)          = $self->getcwd();
1950
  $self->{'project_file_list'}->{$project_name} = [ $project_file,
1951
                                                    $cwd, \@files ];
1952
}
1953
 
1954
# ************************************************************
1955
# Virtual Methods To Be Overridden
1956
# ************************************************************
1957
 
1958
sub supports_make_coexistence {
1959
  #my($self) = shift;
1960
  return 0;
1961
}
1962
 
1963
 
1964
sub generate_implicit_project_dependencies {
1965
  #my($self) = shift;
1966
  return 0;
1967
}
1968
 
1969
 
1970
sub workspace_file_name {
1971
  #my($self) = shift;
1972
  return '';
1973
}
1974
 
1975
 
1976
sub workspace_per_project {
1977
  #my($self) = shift;
1978
  return 0;
1979
}
1980
 
1981
 
1982
sub pre_workspace {
1983
  #my($self) = shift;
1984
  #my($fh)   = shift;
1985
}
1986
 
1987
 
1988
sub write_comps {
1989
  #my($self) = shift;
1990
  #my($fh)   = shift;
1991
  #my($gens) = shift;
1992
  #my($top)  = shift;
1993
}
1994
 
1995
 
1996
sub post_workspace {
1997
  #my($self) = shift;
1998
  #my($fh)   = shift;
1999
}
2000
 
2001
 
2002
1;