Subversion Repositories gelsvn

Rev

Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
107 bj 1 
package Creator;
2 
 
3 
# ************************************************************
4 
# Description   : Base class for workspace and project 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::Basename;
16 
 
17 
use Parser;
18 
 
19 
use vars qw(@ISA);
20 
@ISA = qw(Parser);
21 
 
22 
# ************************************************************
23 
# Data Section
24 
# ************************************************************
25 
 
26 
my(@statekeys) = ('global', 'include', 'template', 'ti',
27 
                  'dynamic', 'static', 'relative', 'addtemp',
28 
                  'addproj', 'progress', 'toplevel', 'baseprojs',
29 
                  'feature_file', 'features', 'hierarchy',
30 
                  'name_modifier', 'apply_project', 'into', 'use_env',
31 
                  'expand_vars',
32 
                 );
33 
 
34 
my(%all_written) = ();
35 
 
36 
# ************************************************************
37 
# Subroutine Section
38 
# ************************************************************
39 
 
40 
sub new {
41 
  my($class)      = shift;
42 
  my($global)     = shift;
43 
  my($inc)        = shift;
44 
  my($template)   = shift;
45 
  my($ti)         = shift;
46 
  my($dynamic)    = shift;
47 
  my($static)     = shift;
48 
  my($relative)   = shift;
49 
  my($addtemp)    = shift;
50 
  my($addproj)    = shift;
51 
  my($progress)   = shift;
52 
  my($toplevel)   = shift;
53 
  my($baseprojs)  = shift;
54 
  my($feature)    = shift;
55 
  my($features)   = shift;
56 
  my($hierarchy)  = shift;
57 
  my($nmodifier)  = shift;
58 
  my($applypj)    = shift;
59 
  my($into)       = shift;
60 
  my($language)   = shift;
61 
  my($use_env)    = shift;
62 
  my($expandvars) = shift;
63 
  my($type)       = shift;
64 
  my($self)       = Parser::new($class, $inc);
65 
 
66 
  $self->{'relative'}        = $relative;
67 
  $self->{'template'}        = $template;
68 
  $self->{'ti'}              = $ti;
69 
  $self->{'global'}          = $global;
70 
  $self->{'grammar_type'}    = $type;
71 
  $self->{'type_check'}      = $type . '_defined';
72 
  $self->{'global_read'}     = 0;
73 
  $self->{'current_input'}   = '';
74 
  $self->{'progress'}        = $progress;
75 
  $self->{'addtemp'}         = $addtemp;
76 
  $self->{'addproj'}         = $addproj;
77 
  $self->{'toplevel'}        = $toplevel;
78 
  $self->{'files_written'}   = {};
79 
  $self->{'real_fwritten'}   = [];
80 
  $self->{'reading_global'}  = 0;
81 
  $self->{'global_assign'}   = {};
82 
  $self->{'assign'}          = {};
83 
  $self->{'baseprojs'}       = $baseprojs;
84 
  $self->{'dynamic'}         = $dynamic;
85 
  $self->{'static'}          = $static;
86 
  $self->{'feature_file'}    = $feature;
87 
  $self->{'features'}        = $features;
88 
  $self->{'hierarchy'}       = $hierarchy;
89 
  $self->{'name_modifier'}   = $nmodifier;
90 
  $self->{'apply_project'}   = $applypj;
91 
  $self->{'into'}            = $into;
92 
  $self->{'language'}        = $language;
93 
  $self->{'use_env'}         = $use_env;
94 
  $self->{'expand_vars'}     = $expandvars;
95 
  $self->{'convert_slashes'} = $self->convert_slashes();
96 
 
97 
  return $self;
98 
}
99 
 
100 
 
101 
sub preprocess_line {
102 
  my($self) = shift;
103 
  my($fh)   = shift;
104 
  my($line) = shift;
105 
 
106 
  $line = $self->strip_line($line);
107 
  while ($line =~ /\\$/) {
108 
    $line =~ s/\s*\\$/ /;
109 
    my($next) = $fh->getline();
110 
    if (defined $next) {
111 
      $line .= $self->strip_line($next);
112 
    }
113 
  }
114 
  return $line;
115 
}
116 
 
117 
 
118 
sub generate_default_input {
119 
  my($self)  = shift;
120 
  my($status,
121 
     $error) = $self->parse_line(undef, "$self->{'grammar_type'} {");
122 
 
123 
  if ($status) {
124 
    ($status, $error) = $self->parse_line(undef, '}');
125 
  }
126 
 
127 
  if (!$status) {
128 
    $self->error($error);
129 
  }
130 
 
131 
  return $status;
132 
}
133 
 
134 
 
135 
sub parse_file {
136 
  my($self)  = shift;
137 
  my($input) = shift;
138 
  my($oline) = $self->get_line_number();
139 
 
140 
  ## Read the input file and get the last line number
141 
  my($status, $errorString) = $self->read_file($input);
142 
 
143 
  if (!$status) {
144 
    $self->error($errorString,
145 
                 "$input: line " . $self->get_line_number() . ':');
146 
  }
147 
  elsif ($status && $self->{$self->{'type_check'}}) {
148 
    ## If we are at the end of the file and the type we are looking at
149 
    ## is still defined, then we have an error
150 
    $self->error("Did not " .
151 
                 "find the end of the $self->{'grammar_type'}",
152 
                 "$input: line " . $self->get_line_number() . ':');
153 
    $status = 0;
154 
  }
155 
  $self->set_line_number($oline);
156 
 
157 
  return $status;
158 
}
159 
 
160 
 
161 
sub generate {
162 
  my($self)   = shift;
163 
  my($input)  = shift;
164 
  my($status) = 1;
165 
 
166 
  ## Reset the files_written hash array between processing each file
167 
  $self->{'files_written'} = {};
168 
  $self->{'real_fwritten'} = [];
169 
 
170 
  ## Allow subclasses to reset values before
171 
  ## each call to generate().
172 
  $self->reset_values();
173 
 
174 
  ## Read the global configuration file
175 
  if (!$self->{'global_read'}) {
176 
    $status = $self->read_global_configuration();
177 
    $self->{'global_read'} = 1;
178 
  }
179 
 
180 
  if ($status) {
181 
    $self->{'current_input'} = $input;
182 
 
183 
    ## An empty input file name says that we
184 
    ## should generate a default input file and use that
185 
    if ($input eq '') {
186 
      $status = $self->generate_default_input();
187 
    }
188 
    else {
189 
      $status = $self->parse_file($input);
190 
    }
191 
  }
192 
 
193 
  return $status;
194 
}
195 
 
196 
 
197 
sub parse_assignment {
198 
  my($self)   = shift;
199 
  my($line)   = shift;
200 
  my($values) = shift;
201 
 
202 
  if ($line =~ /^(\w+(::\w+)*)\s*\+=\s*(.*)?/) {
203 
    my($name)  = lc($1);
204 
    my($value) = $3;
205 
    push(@$values, 'assign_add', $name, $value);
206 
    return 1;
207 
  }
208 
  elsif ($line =~ /^(\w+(::\w+)*)\s*=\s*(.*)?/) {
209 
    my($name)  = lc($1);
210 
    my($value) = $3;
211 
    push(@$values, 'assignment', $name, $value);
212 
    return 1;
213 
  }
214 
  elsif ($line =~ /^(\w+(::\w+)*)\s*\-=\s*(.*)?/) {
215 
    my($name)  = lc($1);
216 
    my($value) = $3;
217 
    push(@$values, 'assign_sub', $name, $value);
218 
    return 1;
219 
  }
220 
 
221 
  return 0;
222 
}
223 
 
224 
 
225 
sub parse_known {
226 
  my($self)        = shift;
227 
  my($line)        = shift;
228 
  my($status)      = 1;
229 
  my($errorString) = undef;
230 
  my($type)        = $self->{'grammar_type'};
231 
  my(@values)      = ();
232 
 
233 
  ##
234 
  ## Each regexp that looks for the '{' looks for it at the
235 
  ## end of the line.  It is purposely this way to decrease
236 
  ## the amount of extra lines in each file.  This
237 
  ## allows for the most compact file as human readably
238 
  ## possible.
239 
  ##
240 
  if ($line eq '') {
241 
  }
242 
  elsif ($line =~ /^$type\s*(\([^\)]+\))?\s*(:.*)?\s*{$/) {
243 
    my($name)    = $1;
244 
    my($parents) = $2;
245 
    if ($self->{$self->{'type_check'}}) {
246 
      $errorString = "Did not find the end of the $type";
247 
      $status = 0;
248 
    }
249 
    else {
250 
      if (defined $parents) {
251 
        my(@parents) = ();
252 
        $parents =~ s/^://;
253 
        foreach my $parent (split(',', $parents)) {
254 
          $parent =~ s/^\s+//;
255 
          $parent =~ s/\s+$//;
256 
          if ($parent ne '') {
257 
            push(@parents, $parent);
258 
          }
259 
        }
260 
        if (!defined $parents[0]) {
261 
          ## The : was used, but no parents followed.  This
262 
          ## is an error.
263 
          $errorString = 'No parents listed';
264 
          $status = 0;
265 
        }
266 
        $parents = \@parents;
267 
      }
268 
      push(@values, $type, $name, $parents);
269 
    }
270 
  }
271 
  elsif ($line =~ /^}$/) {
272 
    if ($self->{$self->{'type_check'}}) {
273 
      push(@values, $type, $line);
274 
    }
275 
    else {
276 
      $errorString = "Did not find the beginning of the $type";
277 
      $status = 0;
278 
    }
279 
  }
280 
  elsif ($line =~ /^(feature)\s*\(([^\)]+)\)\s*(:.*)?\s*{$/) {
281 
    my($type)    = $1;
282 
    my($name)    = $2;
283 
    my($parents) = $3;
284 
    my(@names)   = split(/\s*,\s*/, $name);
285 
 
286 
    if (defined $parents) {
287 
      my(@parents) = ();
288 
      $parents =~ s/^://;
289 
      foreach my $parent (split(',', $parents)) {
290 
        $parent =~ s/^\s+//;
291 
        $parent =~ s/\s+$//;
292 
        if ($parent ne '') {
293 
          push(@parents, $parent);
294 
        }
295 
      }
296 
      if (!defined $parents[0]) {
297 
        ## The : was used, but no parents followed.  This
298 
        ## is an error.
299 
        $errorString = 'No parents listed';
300 
        $status = 0;
301 
      }
302 
      $parents = \@parents;
303 
    }
304 
    push(@values, $type, \@names, $parents);
305 
  }
306 
  elsif (!$self->{$self->{'type_check'}}) {
307 
    $errorString = "No $type was defined";
308 
    $status = 0;
309 
  }
310 
  elsif ($self->parse_assignment($line, \@values)) {
311 
    ## If this returns true, then we've found an assignment
312 
  }
313 
  elsif ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
314 
    my($comp) = lc($1);
315 
    my($name) = $2;
316 
 
317 
    if (defined $name) {
318 
      $name =~ s/^\(\s*//;
319 
      $name =~ s/\s*\)$//;
320 
    }
321 
    else {
322 
      $name = $self->get_default_component_name();
323 
    }
324 
    push(@values, 'component', $comp, $name);
325 
  }
326 
  else {
327 
    $errorString = "Unrecognized line: $line";
328 
    $status = -1;
329 
  }
330 
 
331 
  return $status, $errorString, @values;
332 
}
333 
 
334 
 
335 
sub parse_scope {
336 
  my($self)        = shift;
337 
  my($fh)          = shift;
338 
  my($name)        = shift;
339 
  my($type)        = shift;
340 
  my($validNames)  = shift;
341 
  my($flags)       = shift;
342 
  my($elseflags)   = shift;
343 
  my($status)      = 0;
344 
  my($errorString) = "Unable to process $name";
345 
 
346 
  if (!defined $flags) {
347 
    $flags = {};
348 
  }
349 
 
350 
  while(<$fh>) {
351 
    my($line) = $self->preprocess_line($fh, $_);
352 
 
353 
    if ($line eq '') {
354 
    }
355 
    elsif ($line =~ /^}$/) {
356 
      ($status, $errorString) = $self->handle_scoped_end($type, $flags);
357 
      last;
358 
    }
198 bj 359 
    elsif ($line =~ /^}\s*else\s*{$/) {
360 
      if (defined $elseflags) {
361 
        ## From here on out anything after this goes into the $elseflags
362 
        $flags = $elseflags;
363 
        $elseflags = undef;
107 bj 364 
 
198 bj 365 
        ## We need to adjust the type also.  If there was a type
366 
        ## then the first part of the clause was used.  If there was
367 
        ## no type, then the first part was ignored and the second
368 
        ## part will be used.
369 
        if (defined $type) {
370 
          $type = undef;
371 
        }
372 
        else {
373 
          $type = $self->get_default_component_name();
374 
        }
107 bj 375 
      }
376 
      else {
198 bj 377 
        $status = 0;
378 
        $errorString = 'An else is not allowed in this context';
379 
        last;
107 bj 380 
      }
381 
    }
382 
    else {
383 
      my(@values) = ();
198 bj 384 
      if (defined $validNames && $self->parse_assignment($line, \@values)) {
107 bj 385 
        if (defined $$validNames{$values[1]}) {
386 
          if ($values[0] eq 'assignment') {
387 
            $self->process_assignment($values[1], $values[2], $flags);
388 
          }
389 
          elsif ($values[0] eq 'assign_add') {
390 
            $self->process_assignment_add($values[1], $values[2], $flags);
391 
          }
392 
          elsif ($values[0] eq 'assign_sub') {
393 
            $self->process_assignment_sub($values[1], $values[2], $flags);
394 
          }
395 
        }
396 
        else {
397 
          ($status,
398 
           $errorString) = $self->handle_unknown_assignment($type,
399 
                                                            @values);
400 
          if (!$status) {
401 
            last;
402 
          }
403 
        }
404 
      }
405 
      else {
406 
        ($status, $errorString) = $self->handle_scoped_unknown($fh,
407 
                                                               $type,
408 
                                                               $flags,
409 
                                                               $line);
410 
        if (!$status) {
411 
          last;
412 
        }
413 
      }
414 
    }
415 
  }
416 
  return $status, $errorString;
417 
}
418 
 
419 
 
420 
sub base_directory {
421 
  my($self) = shift;
422 
  return basename($self->getcwd());
423 
}
424 
 
425 
 
426 
sub generate_default_file_list {
427 
  my($self)    = shift;
428 
  my($dir)     = shift;
429 
  my($exclude) = shift;
430 
  my($recurse) = shift;
431 
  my($dh)      = new FileHandle();
432 
  my(@files)   = ();
433 
 
434 
  if (opendir($dh, $dir)) {
435 
    my($need_dir) = ($dir ne '.');
436 
    my($skip)     = 0;
437 
    foreach my $file (grep(!/^\.\.?$/, readdir($dh))) {
198 bj 438 
      $file =~ s/\.dir$// if ($^O eq 'VMS');
439 
 
107 bj 440 
      ## Prefix each file name with the directory only if it's not '.'
441 
      my($full) = ($need_dir ? "$dir/" : '') . $file;
442 
 
443 
      if (defined $$exclude[0]) {
444 
        foreach my $exc (@$exclude) {
445 
          if ($full eq $exc) {
446 
            $skip = 1;
447 
            last;
448 
          }
449 
        }
450 
      }
451 
 
452 
      if ($skip) {
453 
        $skip = 0;
454 
      }
455 
      else {
456 
        if ($recurse && -d $full) {
457 
          push(@files,
458 
               $self->generate_default_file_list($full, $exclude, $recurse));
459 
        }
460 
        else {
461 
          push(@files, $full);
462 
        }
463 
      }
464 
    }
465 
 
466 
    if ($self->sort_files()) {
467 
      @files = sort { $self->file_sorter($a, $b) } @files;
468 
    }
469 
 
470 
    closedir($dh);
471 
  }
472 
  return @files;
473 
}
474 
 
475 
 
476 
sub transform_file_name {
477 
  my($self) = shift;
478 
  my($name) = shift;
479 
 
480 
  $name =~ s/[\s\-]/_/g;
481 
  return $name;
482 
}
483 
 
484 
 
485 
sub file_written {
486 
  my($self) = shift;
487 
  my($file) = shift;
488 
  return (defined $all_written{$self->getcwd() . '/' . $file});
489 
}
490 
 
491 
 
492 
sub add_file_written {
493 
  my($self) = shift;
494 
  my($file) = shift;
495 
  my($key)  = lc($file);
496 
 
497 
  if (defined $self->{'files_written'}->{$key}) {
498 
    $self->warning("$self->{'grammar_type'} $file has " .
499 
                   "possibly been overwritten.");
500 
  }
501 
  else {
502 
    $self->{'files_written'}->{$key} = $file;
503 
    push(@{$self->{'real_fwritten'}}, $file);
504 
  }
505 
 
506 
  $all_written{$self->getcwd() . '/' . $file} = 1;
507 
}
508 
 
509 
 
510 
sub extension_recursive_input_list {
511 
  my($self)    = shift;
512 
  my($dir)     = shift;
513 
  my($exclude) = shift;
514 
  my($ext)     = shift;
515 
  my($fh)      = new FileHandle();
516 
  my(@files)   = ();
517 
 
518 
  if (opendir($fh, $dir)) {
519 
    foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
198 bj 520 
      $file =~ s/\.dir$// if ($^O eq 'VMS');
521 
 
107 bj 522 
      my($skip) = 0;
523 
      my($full) = ($dir ne '.' ? "$dir/" : '') . $file;
524 
 
525 
      ## Check for command line exclusions
526 
      if (defined $$exclude[0]) {
527 
        foreach my $exc (@$exclude) {
528 
          if ($full eq $exc) {
529 
            $skip = 1;
530 
            last;
531 
          }
532 
        }
533 
      }
534 
 
535 
      ## If we are not skipping this directory or file, then check it out
536 
      if (!$skip) {
537 
        if (-d $full) {
538 
          push(@files, $self->extension_recursive_input_list($full,
539 
                                                             $exclude,
540 
                                                             $ext));
541 
        }
542 
        elsif ($full =~ /$ext$/) {
543 
          push(@files, $full);
544 
        }
545 
      }
546 
    }
547 
    closedir($fh);
548 
  }
549 
 
550 
  return @files;
551 
}
552 
 
553 
 
554 
sub modify_assignment_value {
555 
  my($self)  = shift;
556 
  my($name)  = shift;
557 
  my($value) = shift;
558 
 
559 
  if ($self->{'convert_slashes'} && $name !~ /flags/) {
560 
    $value = $self->slash_to_backslash($value);
561 
  }
562 
  return $value;
563 
}
564 
 
565 
 
566 
sub get_assignment_hash {
567 
  ## NOTE: If anything in this block changes, then you must make the
568 
  ## same change in process_assignment.
569 
  my($self)   = shift;
570 
  my($tag)    = ($self->{'reading_global'} ? 'global_assign' : 'assign');
571 
  my($assign) = $self->{$tag};
572 
 
573 
  ## If we haven't yet defined the hash table in this project
574 
  if (!defined $assign) {
575 
    $assign = {};
576 
    $self->{$tag} = $assign;
577 
  }
578 
 
579 
  return $assign;
580 
}
581 
 
582 
 
583 
sub process_assignment {
584 
  my($self)   = shift;
585 
  my($name)   = shift;
586 
  my($value)  = shift;
587 
  my($assign) = shift;
588 
 
589 
  ## If no hash table was passed in
590 
  if (!defined $assign) {
591 
    ## NOTE: If anything in this block changes, then you must make the
592 
    ## same change in get_assignment_hash.
593 
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : 'assign');
594 
    $assign  = $self->{$tag};
595 
 
596 
    ## If we haven't yet defined the hash table in this project
597 
    if (!defined $assign) {
598 
      $assign = {};
599 
      $self->{$tag} = $assign;
600 
    }
601 
  }
602 
 
603 
  if (defined $value) {
604 
    $value =~ s/^\s+//;
605 
    $value =~ s/\s+$//;
606 
 
607 
    ## Modify the assignment value before saving it
608 
    $$assign{$name} = $self->modify_assignment_value($name, $value);
609 
  }
610 
  else {
611 
    $$assign{$name} = undef;
612 
  }
613 
}
614 
 
615 
 
616 
sub process_assignment_add {
617 
  my($self)   = shift;
618 
  my($name)   = shift;
619 
  my($value)  = shift;
620 
  my($assign) = shift;
621 
  my($nval)   = $self->get_assignment_for_modification($name, $assign);
622 
 
623 
  ## Remove all duplicate parts from the value to be added.
624 
  ## Whether anything gets removed or not is up to the implementation
625 
  ## of the sub classes.
626 
  $value = $self->remove_duplicate_addition($name, $value, $nval);
627 
 
628 
  ## If there is anything to add, then do so
629 
  if ($value ne '') {
630 
    if (defined $nval) {
631 
      if ($self->preserve_assignment_order($name)) {
632 
        $nval .= " $value";
633 
      }
634 
      else {
635 
        $nval = "$value $nval";
636 
      }
637 
    }
638 
    else {
639 
      $nval = $value;
640 
    }
641 
    $self->process_assignment($name, $nval, $assign);
642 
  }
643 
}
644 
 
645 
 
646 
sub process_assignment_sub {
647 
  my($self)   = shift;
648 
  my($name)   = shift;
649 
  my($value)  = shift;
650 
  my($assign) = shift;
651 
  my($nval)   = $self->get_assignment_for_modification($name, $assign, 1);
652 
 
653 
  if (defined $nval) {
654 
    ## Remove double quotes if there are any
655 
    $value =~ s/^\"(.*)\"$/$1/;
656 
 
657 
    ## Escape any regular expression special characters
658 
    $value = $self->escape_regex_special($value);
659 
 
660 
    ## Due to the way process_assignment() works, we only need to
661 
    ## attempt to remove a value that is either followed by a space
662 
    ## or at the end of the line (single values are always at the end
663 
    ## of the line).
664 
    if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
665 
      $self->process_assignment($name, $nval, $assign);
666 
    }
198 bj 667 
    else {
668 
      ## Try the same thing only with double quotes around the value.
669 
      ## Double quotes will be preserved in the value when the value
670 
      ## contains spaces.
671 
      $value = '"' . $value . '"';
672 
      if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
673 
        $self->process_assignment($name, $nval, $assign);
674 
      }
675 
    }
107 bj 676 
  }
677 
}
678 
 
679 
 
680 
sub fill_type_name {
681 
  my($self)  = shift;
682 
  my($names) = shift;
683 
  my($def)   = shift;
684 
  my($array) = ($names =~ /\s/ ? $self->create_array($names) : [$names]);
685 
 
686 
  $names = '';
687 
  foreach my $name (@$array) {
688 
    if ($name =~ /\*/) {
689 
      my($pre)  = $def . '_';
690 
      my($mid)  = '_' . $def . '_';
691 
      my($post) = '_' . $def;
692 
 
693 
      ## Replace the beginning and end first then the middle
694 
      $name =~ s/^\*/$pre/;
695 
      $name =~ s/\*$/$post/;
696 
      $name =~ s/\*/$mid/g;
697 
 
698 
      ## Remove any trailing underscore or any underscore that is followed
699 
      ## by a space.  This value could be a space separated list.
700 
      $name =~ s/_$//;
701 
      $name =~ s/_\s/ /g;
702 
      $name =~ s/\s_/ /g;
703 
 
704 
      ## If any one word is capitalized then capitalize each word
705 
      if ($name =~ /[A-Z][0-9a-z_]+/) {
706 
        ## Do the first word
707 
        if ($name =~ /^([a-z])([^_]+)/) {
708 
          my($first) = uc($1);
709 
          my($rest)  = $2;
710 
          $name =~ s/^[a-z][^_]+/$first$rest/;
711 
        }
712 
        ## Do subsequent words
713 
        while($name =~ /(_[a-z])([^_]+)/) {
714 
          my($first) = uc($1);
715 
          my($rest)  = $2;
716 
          $name =~ s/_[a-z][^_]+/$first$rest/;
717 
        }
718 
      }
719 
    }
720 
 
721 
    $names .= $name . ' ';
722 
  }
723 
  $names =~ s/\s+$//;
724 
 
725 
  return $names;
726 
}
727 
 
728 
 
729 
sub save_state {
730 
  my($self)     = shift;
731 
  my($selected) = shift;
732 
  my(%state)    = ();
733 
 
734 
  ## Make a deep copy of each state value.  That way our array
735 
  ## references and hash references do not get accidentally modified.
736 
  foreach my $skey (defined $selected ? $selected : @statekeys) {
737 
    if (defined $self->{$skey}) {
738 
      if (UNIVERSAL::isa($self->{$skey}, 'ARRAY')) {
739 
        $state{$skey} = [];
740 
        foreach my $element (@{$self->{$skey}}) {
741 
          push(@{$state{$skey}}, $element);
742 
        }
743 
      }
744 
      elsif (UNIVERSAL::isa($self->{$skey}, 'HASH')) {
745 
        $state{$skey} = {};
746 
        foreach my $key (keys %{$self->{$skey}}) {
747 
          $state{$skey}->{$key} = $self->{$skey}->{$key};
748 
        }
749 
      }
750 
      else {
751 
        $state{$skey} = $self->{$skey};
752 
      }
753 
    }
754 
  }
755 
 
756 
  return %state;
757 
}
758 
 
759 
 
760 
sub restore_state {
761 
  my($self)     = shift;
762 
  my($state)    = shift;
763 
  my($selected) = shift;
764 
 
765 
  ## Make a deep copy of each state value.  That way our array
766 
  ## references and hash references do not get accidentally modified.
767 
  foreach my $skey (defined $selected ? $selected : @statekeys) {
768 
    if (defined $state->{$skey}) {
769 
      if (UNIVERSAL::isa($state->{$skey}, 'ARRAY')) {
770 
        my(@arr) = @{$state->{$skey}};
771 
        $self->{$skey} = \@arr;
772 
      }
773 
      elsif (UNIVERSAL::isa($state->{$skey}, 'HASH')) {
774 
        my(%hash) = %{$state->{$skey}};
775 
        $self->{$skey} = \%hash;
776 
      }
777 
      else {
778 
        $self->{$skey} = $state->{$skey};
779 
      }
780 
    }
781 
  }
782 
}
783 
 
784 
 
785 
sub get_global_cfg {
786 
  my($self) = shift;
787 
  return $self->{'global'};
788 
}
789 
 
790 
 
791 
sub get_template_override {
792 
  my($self) = shift;
793 
  return $self->{'template'};
794 
}
795 
 
796 
 
797 
sub get_ti_override {
798 
  my($self) = shift;
799 
  return $self->{'ti'};
800 
}
801 
 
802 
 
803 
sub get_relative {
804 
  my($self) = shift;
805 
  return $self->{'relative'};
806 
}
807 
 
808 
 
809 
sub get_progress_callback {
810 
  my($self) = shift;
811 
  return $self->{'progress'};
812 
}
813 
 
814 
 
815 
sub get_addtemp {
816 
  my($self) = shift;
817 
  return $self->{'addtemp'};
818 
}
819 
 
820 
 
821 
sub get_addproj {
822 
  my($self) = shift;
823 
  return $self->{'addproj'};
824 
}
825 
 
826 
 
827 
sub get_toplevel {
828 
  my($self) = shift;
829 
  return $self->{'toplevel'};
830 
}
831 
 
832 
 
833 
sub get_into {
834 
  my($self) = shift;
835 
  return $self->{'into'};
836 
}
837 
 
838 
 
839 
sub get_use_env {
840 
  my($self) = shift;
841 
  return $self->{'use_env'};
842 
}
843 
 
844 
 
845 
sub get_expand_vars {
846 
  my($self) = shift;
847 
  return $self->{'expand_vars'};
848 
}
849 
 
850 
 
851 
sub get_files_written {
852 
  my($self)  = shift;
853 
  return $self->{'real_fwritten'};
854 
}
855 
 
856 
 
857 
sub get_assignment {
858 
  my($self)   = shift;
859 
  my($name)   = shift;
860 
  my($assign) = shift;
861 
 
862 
  ## If no hash table was passed in
863 
  if (!defined $assign) {
864 
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : 'assign');
865 
    $assign = $self->{$tag};
866 
  }
867 
 
868 
  return $$assign{$name};
869 
}
870 
 
871 
 
872 
sub get_assignment_for_modification {
873 
  my($self)        = shift;
874 
  my($name)        = shift;
875 
  my($assign)      = shift;
876 
  my($subtraction) = shift;
877 
  return $self->get_assignment($name, $assign);
878 
}
879 
 
880 
 
881 
sub get_baseprojs {
882 
  my($self) = shift;
883 
  return $self->{'baseprojs'};
884 
}
885 
 
886 
 
887 
sub get_dynamic {
888 
  my($self) = shift;
889 
  return $self->{'dynamic'};
890 
}
891 
 
892 
 
893 
sub get_static {
894 
  my($self) = shift;
895 
  return $self->{'static'};
896 
}
897 
 
898 
 
899 
sub get_default_component_name {
900 
  #my($self) = shift;
901 
  return 'default';
902 
}
903 
 
904 
 
905 
sub get_hierarchy {
906 
  my($self) = shift;
907 
  return $self->{'hierarchy'};
908 
}
909 
 
910 
 
911 
sub get_name_modifier {
912 
  my($self) = shift;
913 
  return $self->{'name_modifier'};
914 
}
915 
 
916 
 
917 
sub get_apply_project {
918 
  my($self) = shift;
919 
  return $self->{'apply_project'};
920 
}
921 
 
922 
 
923 
sub get_language {
924 
  my($self) = shift;
925 
  return $self->{'language'};
926 
}
927 
 
928 
sub get_outdir {
929 
  my($self) = shift;
930 
  if (defined $self->{'into'}) {
931 
    my($outdir) = $self->getcwd();
932 
    my($re)     = $self->escape_regex_special($self->getstartdir());
933 
 
934 
    $outdir =~ s/^$re//;
935 
    return $self->{'into'} . $outdir;
936 
  }
937 
  else {
938 
    return '.';
939 
  }
940 
}
941 
 
942 
# ************************************************************
943 
# Virtual Methods To Be Overridden
944 
# ************************************************************
945 
 
946 
sub preserve_assignment_order {
947 
  #my($self) = shift;
948 
  #my($name) = shift;
949 
  return 1;
950 
}
951 
 
952 
 
953 
sub compare_output {
954 
  #my($self) = shift;
955 
  return 0;
956 
}
957 
 
958 
 
959 
sub handle_scoped_end {
960 
  #my($self)  = shift;
961 
  #my($type)  = shift;
962 
  #my($flags) = shift;
963 
  return 1, undef;
964 
}
965 
 
966 
 
967 
sub handle_unknown_assignment {
968 
  my($self)   = shift;
969 
  my($type)   = shift;
970 
  my(@values) = @_;
971 
  return 0, "Invalid assignment name: $values[1]";
972 
}
973 
 
974 
 
975 
sub handle_scoped_unknown {
976 
  my($self)  = shift;
977 
  my($fh)    = shift;
978 
  my($type)  = shift;
979 
  my($flags) = shift;
980 
  my($line)  = shift;
981 
  return 0, "Unrecognized line: $line";
982 
}
983 
 
984 
 
985 
sub remove_duplicate_addition {
986 
  my($self)    = shift;
987 
  my($name)    = shift;
988 
  my($value)   = shift;
989 
  my($current) = shift;
990 
  return $value;
991 
}
992 
 
993 
 
994 
sub generate_recursive_input_list {
995 
  #my($self)    = shift;
996 
  #my($dir)     = shift;
997 
  #my($exclude) = shift;
998 
  return ();
999 
}
1000 
 
1001 
 
1002 
sub reset_values {
1003 
  #my($self) = shift;
1004 
}
1005 
 
1006 
 
1007 
sub sort_files {
1008 
  #my($self) = shift;
1009 
  return 1;
1010 
}
1011 
 
1012 
 
1013 
sub file_sorter {
1014 
  my($self)  = shift;
1015 
  my($left)  = shift;
1016 
  my($right) = shift;
1017 
  return $left cmp $right;
1018 
}
1019 
 
1020 
 
1021 
sub read_global_configuration {
1022 
  #my($self)  = shift;
1023 
  #my($input) = shift;
1024 
  return 1;
1025 
}
1026 
 
1027 
 
1028 
1;