WebSVN – gelsvn – Diff – /trunk/MPC/modules/Creator.pm


package Creator;
 
# ************************************************************
# Description   : Base class for workspace and project creators
# Author        : Chad Elliott
# Create Date   : 5/13/2002
# ************************************************************
 
# ************************************************************
# Pragmas
# ************************************************************
 
use strict;
use FileHandle;
use File::Basename;
 
use Parser;
 
use vars qw(@ISA);
@ISA = qw(Parser);
 
# ************************************************************
# Data Section
# ************************************************************
 
my(@statekeys) = ('global', 'include', 'template', 'ti',
                  'dynamic', 'static', 'relative', 'addtemp',
                  'addproj', 'progress', 'toplevel', 'baseprojs',
                  'feature_file', 'features', 'hierarchy',
                  'name_modifier', 'apply_project', 'into', 'use_env',
                  'expand_vars',
                 );
 
my(%all_written) = ();
 
# ************************************************************
# Subroutine Section
# ************************************************************
 
sub new {
  my($class)      = shift;
  my($global)     = shift;
  my($inc)        = shift;
  my($template)   = shift;
  my($ti)         = shift;
  my($dynamic)    = shift;
  my($static)     = shift;
  my($relative)   = shift;
  my($addtemp)    = shift;
  my($addproj)    = shift;
  my($progress)   = shift;
  my($toplevel)   = shift;
  my($baseprojs)  = shift;
  my($feature)    = shift;
  my($features)   = shift;
  my($hierarchy)  = shift;
  my($nmodifier)  = shift;
  my($applypj)    = shift;
  my($into)       = shift;
  my($language)   = shift;
  my($use_env)    = shift;
  my($expandvars) = shift;
  my($type)       = shift;
  my($self)       = Parser::new($class, $inc);
 
  $self->{'relative'}        = $relative;
  $self->{'template'}        = $template;
  $self->{'ti'}              = $ti;
  $self->{'global'}          = $global;
  $self->{'grammar_type'}    = $type;
  $self->{'type_check'}      = $type . '_defined';
  $self->{'global_read'}     = 0;
  $self->{'current_input'}   = '';
  $self->{'progress'}        = $progress;
  $self->{'addtemp'}         = $addtemp;
  $self->{'addproj'}         = $addproj;
  $self->{'toplevel'}        = $toplevel;
  $self->{'files_written'}   = {};
  $self->{'real_fwritten'}   = [];
  $self->{'reading_global'}  = 0;
  $self->{'global_assign'}   = {};
  $self->{'assign'}          = {};
  $self->{'baseprojs'}       = $baseprojs;
  $self->{'dynamic'}         = $dynamic;
  $self->{'static'}          = $static;
  $self->{'feature_file'}    = $feature;
  $self->{'features'}        = $features;
  $self->{'hierarchy'}       = $hierarchy;
  $self->{'name_modifier'}   = $nmodifier;
  $self->{'apply_project'}   = $applypj;
  $self->{'into'}            = $into;
  $self->{'language'}        = $language;
  $self->{'use_env'}         = $use_env;
  $self->{'expand_vars'}     = $expandvars;
  $self->{'convert_slashes'} = $self->convert_slashes();
 
  return $self;
}
 
 
sub preprocess_line {
  my($self) = shift;
  my($fh)   = shift;
  my($line) = shift;
 
  $line = $self->strip_line($line);
  while ($line =~ /\\$/) {
    $line =~ s/\s*\\$/ /;
    my($next) = $fh->getline();
    if (defined $next) {
      $line .= $self->strip_line($next);
    }
  }
  return $line;
}
 
 
sub generate_default_input {
  my($self)  = shift;
  my($status,
     $error) = $self->parse_line(undef, "$self->{'grammar_type'} {");
 
  if ($status) {
    ($status, $error) = $self->parse_line(undef, '}');
  }
 
  if (!$status) {
    $self->error($error);
  }
 
  return $status;
}
 
 
sub parse_file {
  my($self)  = shift;
  my($input) = shift;
  my($oline) = $self->get_line_number();
 
  ## Read the input file and get the last line number
  my($status, $errorString) = $self->read_file($input);
 
  if (!$status) {
    $self->error($errorString,
                 "$input: line " . $self->get_line_number() . ':');
  }
  elsif ($status && $self->{$self->{'type_check'}}) {
    ## If we are at the end of the file and the type we are looking at
    ## is still defined, then we have an error
    $self->error("Did not " .
                 "find the end of the $self->{'grammar_type'}",
                 "$input: line " . $self->get_line_number() . ':');
    $status = 0;
  }
  $self->set_line_number($oline);
 
  return $status;
}
 
 
sub generate {
  my($self)   = shift;
  my($input)  = shift;
  my($status) = 1;
 
  ## Reset the files_written hash array between processing each file
  $self->{'files_written'} = {};
  $self->{'real_fwritten'} = [];
 
  ## Allow subclasses to reset values before
  ## each call to generate().
  $self->reset_values();
 
  ## Read the global configuration file
  if (!$self->{'global_read'}) {
    $status = $self->read_global_configuration();
    $self->{'global_read'} = 1;
  }
 
  if ($status) {
    $self->{'current_input'} = $input;
 
    ## An empty input file name says that we
    ## should generate a default input file and use that
    if ($input eq '') {
      $status = $self->generate_default_input();
    }
    else {
      $status = $self->parse_file($input);
    }
  }
 
  return $status;
}
 
 
sub parse_assignment {
  my($self)   = shift;
  my($line)   = shift;
  my($values) = shift;
 
  if ($line =~ /^(\w+(::\w+)*)\s*\+=\s*(.*)?/) {
    my($name)  = lc($1);
    my($value) = $3;
    push(@$values, 'assign_add', $name, $value);
    return 1;
  }
  elsif ($line =~ /^(\w+(::\w+)*)\s*=\s*(.*)?/) {
    my($name)  = lc($1);
    my($value) = $3;
    push(@$values, 'assignment', $name, $value);
    return 1;
  }
  elsif ($line =~ /^(\w+(::\w+)*)\s*\-=\s*(.*)?/) {
    my($name)  = lc($1);
    my($value) = $3;
    push(@$values, 'assign_sub', $name, $value);
    return 1;
  }
 
  return 0;
}
 
 
sub parse_known {
  my($self)        = shift;
  my($line)        = shift;
  my($status)      = 1;
  my($errorString) = undef;
  my($type)        = $self->{'grammar_type'};
  my(@values)      = ();
 
  ##
  ## Each regexp that looks for the '{' looks for it at the
  ## end of the line.  It is purposely this way to decrease
  ## the amount of extra lines in each file.  This
  ## allows for the most compact file as human readably
  ## possible.
  ##
  if ($line eq '') {
  }
  elsif ($line =~ /^$type\s*(\([^\)]+\))?\s*(:.*)?\s*{$/) {
    my($name)    = $1;
    my($parents) = $2;
    if ($self->{$self->{'type_check'}}) {
      $errorString = "Did not find the end of the $type";
      $status = 0;
    }
    else {
      if (defined $parents) {
        my(@parents) = ();
        $parents =~ s/^://;
        foreach my $parent (split(',', $parents)) {
          $parent =~ s/^\s+//;
          $parent =~ s/\s+$//;
          if ($parent ne '') {
            push(@parents, $parent);
          }
        }
        if (!defined $parents[0]) {
          ## The : was used, but no parents followed.  This
          ## is an error.
          $errorString = 'No parents listed';
          $status = 0;
        }
        $parents = \@parents;
      }
      push(@values, $type, $name, $parents);
    }
  }
  elsif ($line =~ /^}$/) {
    if ($self->{$self->{'type_check'}}) {
      push(@values, $type, $line);
    }
    else {
      $errorString = "Did not find the beginning of the $type";
      $status = 0;
    }
  }
  elsif ($line =~ /^(feature)\s*\(([^\)]+)\)\s*(:.*)?\s*{$/) {
    my($type)    = $1;
    my($name)    = $2;
    my($parents) = $3;
    my(@names)   = split(/\s*,\s*/, $name);
 
    if (defined $parents) {
      my(@parents) = ();
      $parents =~ s/^://;
      foreach my $parent (split(',', $parents)) {
        $parent =~ s/^\s+//;
        $parent =~ s/\s+$//;
        if ($parent ne '') {
          push(@parents, $parent);
        }
      }
      if (!defined $parents[0]) {
        ## The : was used, but no parents followed.  This
        ## is an error.
        $errorString = 'No parents listed';
        $status = 0;
      }
      $parents = \@parents;
    }
    push(@values, $type, \@names, $parents);
  }
  elsif (!$self->{$self->{'type_check'}}) {
    $errorString = "No $type was defined";
    $status = 0;
  }
  elsif ($self->parse_assignment($line, \@values)) {
    ## If this returns true, then we've found an assignment
  }
  elsif ($line =~ /^(\w+)\s*(\([^\)]+\))?\s*{$/) {
    my($comp) = lc($1);
    my($name) = $2;
 
    if (defined $name) {
      $name =~ s/^\(\s*//;
      $name =~ s/\s*\)$//;
    }
    else {
      $name = $self->get_default_component_name();
    }
    push(@values, 'component', $comp, $name);
  }
  else {
    $errorString = "Unrecognized line: $line";
    $status = -1;
  }
 
  return $status, $errorString, @values;
}
 
 
sub parse_scope {
  my($self)        = shift;
  my($fh)          = shift;
  my($name)        = shift;
  my($type)        = shift;
  my($validNames)  = shift;
  my($flags)       = shift;
  my($elseflags)   = shift;
  my($status)      = 0;
  my($errorString) = "Unable to process $name";
 
  if (!defined $flags) {
    $flags = {};
  }
 
  while(<$fh>) {
    my($line) = $self->preprocess_line($fh, $_);
 
    if ($line eq '') {
    }
    elsif ($line =~ /^}$/) {
      ($status, $errorString) = $self->handle_scoped_end($type, $flags);
      last;
    }
    elsif ($line =~ /^}\s*else\s*{$/) {
      if (defined $elseflags) {
        ## From here on out anything after this goes into the $elseflags
        $flags = $elseflags;
        $elseflags = undef;
 
        ## We need to adjust the type also.  If there was a type
        ## then the first part of the clause was used.  If there was
        ## no type, then the first part was ignored and the second
        ## part will be used.
        if (defined $type) {
          $type = undef;
        }
        else {
          $type = $self->get_default_component_name();
        }
      }
      else {
        $status = 0;
        $errorString = 'An else is not allowed in this context';
        last;
      }
    }
    else {
      my(@values) = ();
      if (defined $validNames && $self->parse_assignment($line, \@values)) {
        if (defined $$validNames{$values[1]}) {
          if ($values[0] eq 'assignment') {
            $self->process_assignment($values[1], $values[2], $flags);
          }
          elsif ($values[0] eq 'assign_add') {
            $self->process_assignment_add($values[1], $values[2], $flags);
          }
          elsif ($values[0] eq 'assign_sub') {
            $self->process_assignment_sub($values[1], $values[2], $flags);
          }
        }
        else {
          ($status,
           $errorString) = $self->handle_unknown_assignment($type,
                                                            @values);
          if (!$status) {
            last;
          }
        }
      }
      else {
        ($status, $errorString) = $self->handle_scoped_unknown($fh,
                                                               $type,
                                                               $flags,
                                                               $line);
        if (!$status) {
          last;
        }
      }
    }
  }
  return $status, $errorString;
}
 
 
sub base_directory {
  my($self) = shift;
  return basename($self->getcwd());
}
 
 
sub generate_default_file_list {
  my($self)    = shift;
  my($dir)     = shift;
  my($exclude) = shift;
  my($recurse) = shift;
  my($dh)      = new FileHandle();
  my(@files)   = ();
 
  if (opendir($dh, $dir)) {
    my($need_dir) = ($dir ne '.');
    my($skip)     = 0;
    foreach my $file (grep(!/^\.\.?$/, readdir($dh))) {
 
      $file =~ s/\.dir$// if ($^O eq 'VMS');
 
      ## Prefix each file name with the directory only if it's not '.'
      my($full) = ($need_dir ? "$dir/" : '') . $file;
 
      if (defined $$exclude[0]) {
        foreach my $exc (@$exclude) {
          if ($full eq $exc) {
            $skip = 1;
            last;
          }
        }
      }
 
      if ($skip) {
        $skip = 0;
      }
      else {
        if ($recurse && -d $full) {
          push(@files,
               $self->generate_default_file_list($full, $exclude, $recurse));
        }
        else {
          push(@files, $full);
        }
      }
    }
 
    if ($self->sort_files()) {
      @files = sort { $self->file_sorter($a, $b) } @files;
    }
 
    closedir($dh);
  }
  return @files;
}
 
 
sub transform_file_name {
  my($self) = shift;
  my($name) = shift;
 
  $name =~ s/[\s\-]/_/g;
  return $name;
}
 
 
sub file_written {
  my($self) = shift;
  my($file) = shift;
  return (defined $all_written{$self->getcwd() . '/' . $file});
}
 
 
sub add_file_written {
  my($self) = shift;
  my($file) = shift;
  my($key)  = lc($file);
 
  if (defined $self->{'files_written'}->{$key}) {
    $self->warning("$self->{'grammar_type'} $file has " .
                   "possibly been overwritten.");
  }
  else {
    $self->{'files_written'}->{$key} = $file;
    push(@{$self->{'real_fwritten'}}, $file);
  }
 
  $all_written{$self->getcwd() . '/' . $file} = 1;
}
 
 
sub extension_recursive_input_list {
  my($self)    = shift;
  my($dir)     = shift;
  my($exclude) = shift;
  my($ext)     = shift;
  my($fh)      = new FileHandle();
  my(@files)   = ();
 
  if (opendir($fh, $dir)) {
    foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
 
      $file =~ s/\.dir$// if ($^O eq 'VMS');
 
      my($skip) = 0;
      my($full) = ($dir ne '.' ? "$dir/" : '') . $file;
 
      ## Check for command line exclusions
      if (defined $$exclude[0]) {
        foreach my $exc (@$exclude) {
          if ($full eq $exc) {
            $skip = 1;
            last;
          }
        }
      }
 
      ## If we are not skipping this directory or file, then check it out
      if (!$skip) {
        if (-d $full) {
          push(@files, $self->extension_recursive_input_list($full,
                                                             $exclude,
                                                             $ext));
        }
        elsif ($full =~ /$ext$/) {
          push(@files, $full);
        }
      }
    }
    closedir($fh);
  }
 
  return @files;
}
 
 
sub modify_assignment_value {
  my($self)  = shift;
  my($name)  = shift;
  my($value) = shift;
 
  if ($self->{'convert_slashes'} && $name !~ /flags/) {
    $value = $self->slash_to_backslash($value);
  }
  return $value;
}
 
 
sub get_assignment_hash {
  ## NOTE: If anything in this block changes, then you must make the
  ## same change in process_assignment.
  my($self)   = shift;
  my($tag)    = ($self->{'reading_global'} ? 'global_assign' : 'assign');
  my($assign) = $self->{$tag};
 
  ## If we haven't yet defined the hash table in this project
  if (!defined $assign) {
    $assign = {};
    $self->{$tag} = $assign;
  }
 
  return $assign;
}
 
 
sub process_assignment {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
 
  ## If no hash table was passed in
  if (!defined $assign) {
    ## NOTE: If anything in this block changes, then you must make the
    ## same change in get_assignment_hash.
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : 'assign');
    $assign  = $self->{$tag};
 
    ## If we haven't yet defined the hash table in this project
    if (!defined $assign) {
      $assign = {};
      $self->{$tag} = $assign;
    }
  }
 
  if (defined $value) {
    $value =~ s/^\s+//;
    $value =~ s/\s+$//;
 
    ## Modify the assignment value before saving it
    $$assign{$name} = $self->modify_assignment_value($name, $value);
  }
  else {
    $$assign{$name} = undef;
  }
}
 
 
sub process_assignment_add {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
  my($nval)   = $self->get_assignment_for_modification($name, $assign);
 
  ## Remove all duplicate parts from the value to be added.
  ## Whether anything gets removed or not is up to the implementation
  ## of the sub classes.
  $value = $self->remove_duplicate_addition($name, $value, $nval);
 
  ## If there is anything to add, then do so
  if ($value ne '') {
    if (defined $nval) {
      if ($self->preserve_assignment_order($name)) {
        $nval .= " $value";
      }
      else {
        $nval = "$value $nval";
      }
    }
    else {
      $nval = $value;
    }
    $self->process_assignment($name, $nval, $assign);
  }
}
 
 
sub process_assignment_sub {
  my($self)   = shift;
  my($name)   = shift;
  my($value)  = shift;
  my($assign) = shift;
  my($nval)   = $self->get_assignment_for_modification($name, $assign, 1);
 
  if (defined $nval) {
    ## Remove double quotes if there are any
    $value =~ s/^\"(.*)\"$/$1/;
 
    ## Escape any regular expression special characters
    $value = $self->escape_regex_special($value);
 
    ## Due to the way process_assignment() works, we only need to
    ## attempt to remove a value that is either followed by a space
    ## or at the end of the line (single values are always at the end
    ## of the line).
    if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
      $self->process_assignment($name, $nval, $assign);
    }
    else {
      ## Try the same thing only with double quotes around the value.
      ## Double quotes will be preserved in the value when the value
      ## contains spaces.
      $value = '"' . $value . '"';
      if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
        $self->process_assignment($name, $nval, $assign);
      }
    }
  }
}
 
 
sub fill_type_name {
  my($self)  = shift;
  my($names) = shift;
  my($def)   = shift;
  my($array) = ($names =~ /\s/ ? $self->create_array($names) : [$names]);
 
  $names = '';
  foreach my $name (@$array) {
    if ($name =~ /\*/) {
      my($pre)  = $def . '_';
      my($mid)  = '_' . $def . '_';
      my($post) = '_' . $def;
 
      ## Replace the beginning and end first then the middle
      $name =~ s/^\*/$pre/;
      $name =~ s/\*$/$post/;
      $name =~ s/\*/$mid/g;
 
      ## Remove any trailing underscore or any underscore that is followed
      ## by a space.  This value could be a space separated list.
      $name =~ s/_$//;
      $name =~ s/_\s/ /g;
      $name =~ s/\s_/ /g;
 
      ## If any one word is capitalized then capitalize each word
      if ($name =~ /[A-Z][0-9a-z_]+/) {
        ## Do the first word
        if ($name =~ /^([a-z])([^_]+)/) {
          my($first) = uc($1);
          my($rest)  = $2;
          $name =~ s/^[a-z][^_]+/$first$rest/;
        }
        ## Do subsequent words
        while($name =~ /(_[a-z])([^_]+)/) {
          my($first) = uc($1);
          my($rest)  = $2;
          $name =~ s/_[a-z][^_]+/$first$rest/;
        }
      }
    }
 
    $names .= $name . ' ';
  }
  $names =~ s/\s+$//;
 
  return $names;
}
 
 
sub save_state {
  my($self)     = shift;
  my($selected) = shift;
  my(%state)    = ();
 
  ## Make a deep copy of each state value.  That way our array
  ## references and hash references do not get accidentally modified.
  foreach my $skey (defined $selected ? $selected : @statekeys) {
    if (defined $self->{$skey}) {
      if (UNIVERSAL::isa($self->{$skey}, 'ARRAY')) {
        $state{$skey} = [];
        foreach my $element (@{$self->{$skey}}) {
          push(@{$state{$skey}}, $element);
        }
      }
      elsif (UNIVERSAL::isa($self->{$skey}, 'HASH')) {
        $state{$skey} = {};
        foreach my $key (keys %{$self->{$skey}}) {
          $state{$skey}->{$key} = $self->{$skey}->{$key};
        }
      }
      else {
        $state{$skey} = $self->{$skey};
      }
    }
  }
 
  return %state;
}
 
 
sub restore_state {
  my($self)     = shift;
  my($state)    = shift;
  my($selected) = shift;
 
  ## Make a deep copy of each state value.  That way our array
  ## references and hash references do not get accidentally modified.
  foreach my $skey (defined $selected ? $selected : @statekeys) {
    if (defined $state->{$skey}) {
      if (UNIVERSAL::isa($state->{$skey}, 'ARRAY')) {
        my(@arr) = @{$state->{$skey}};
        $self->{$skey} = \@arr;
      }
      elsif (UNIVERSAL::isa($state->{$skey}, 'HASH')) {
        my(%hash) = %{$state->{$skey}};
        $self->{$skey} = \%hash;
      }
      else {
        $self->{$skey} = $state->{$skey};
      }
    }
  }
}
 
 
sub get_global_cfg {
  my($self) = shift;
  return $self->{'global'};
}
 
 
sub get_template_override {
  my($self) = shift;
  return $self->{'template'};
}
 
 
sub get_ti_override {
  my($self) = shift;
  return $self->{'ti'};
}
 
 
sub get_relative {
  my($self) = shift;
  return $self->{'relative'};
}
 
 
sub get_progress_callback {
  my($self) = shift;
  return $self->{'progress'};
}
 
 
sub get_addtemp {
  my($self) = shift;
  return $self->{'addtemp'};
}
 
 
sub get_addproj {
  my($self) = shift;
  return $self->{'addproj'};
}
 
 
sub get_toplevel {
  my($self) = shift;
  return $self->{'toplevel'};
}
 
 
sub get_into {
  my($self) = shift;
  return $self->{'into'};
}
 
 
sub get_use_env {
  my($self) = shift;
  return $self->{'use_env'};
}
 
 
sub get_expand_vars {
  my($self) = shift;
  return $self->{'expand_vars'};
}
 
 
sub get_files_written {
  my($self)  = shift;
  return $self->{'real_fwritten'};
}
 
 
sub get_assignment {
  my($self)   = shift;
  my($name)   = shift;
  my($assign) = shift;
 
  ## If no hash table was passed in
  if (!defined $assign) {
    my($tag) = ($self->{'reading_global'} ? 'global_assign' : 'assign');
    $assign = $self->{$tag};
  }
 
  return $$assign{$name};
}
 
 
sub get_assignment_for_modification {
  my($self)        = shift;
  my($name)        = shift;
  my($assign)      = shift;
  my($subtraction) = shift;
  return $self->get_assignment($name, $assign);
}
 
 
sub get_baseprojs {
  my($self) = shift;
  return $self->{'baseprojs'};
}
 
 
sub get_dynamic {
  my($self) = shift;
  return $self->{'dynamic'};
}
 
 
sub get_static {
  my($self) = shift;
  return $self->{'static'};
}
 
 
sub get_default_component_name {
  #my($self) = shift;
  return 'default';
}
 
 
sub get_hierarchy {
  my($self) = shift;
  return $self->{'hierarchy'};
}
 
 
sub get_name_modifier {
  my($self) = shift;
  return $self->{'name_modifier'};
}
 
 
sub get_apply_project {
  my($self) = shift;
  return $self->{'apply_project'};
}
 
 
sub get_language {
  my($self) = shift;
  return $self->{'language'};
}
 
sub get_outdir {
  my($self) = shift;
  if (defined $self->{'into'}) {
    my($outdir) = $self->getcwd();
    my($re)     = $self->escape_regex_special($self->getstartdir());
 
    $outdir =~ s/^$re//;
    return $self->{'into'} . $outdir;
  }
  else {
    return '.';
  }
}
 
# ************************************************************
# Virtual Methods To Be Overridden
# ************************************************************
 
sub preserve_assignment_order {
  #my($self) = shift;
  #my($name) = shift;
  return 1;
}
 
 
sub compare_output {
  #my($self) = shift;
  return 0;
}
 
 
sub handle_scoped_end {
  #my($self)  = shift;
  #my($type)  = shift;
  #my($flags) = shift;
  return 1, undef;
}
 
 
sub handle_unknown_assignment {
  my($self)   = shift;
  my($type)   = shift;
  my(@values) = @_;
  return 0, "Invalid assignment name: $values[1]";
}
 
 
sub handle_scoped_unknown {
  my($self)  = shift;
  my($fh)    = shift;
  my($type)  = shift;
  my($flags) = shift;
  my($line)  = shift;
  return 0, "Unrecognized line: $line";
}
 
 
sub remove_duplicate_addition {
  my($self)    = shift;
  my($name)    = shift;
  my($value)   = shift;
  my($current) = shift;
  return $value;
}
 
 
sub generate_recursive_input_list {
  #my($self)    = shift;
  #my($dir)     = shift;
  #my($exclude) = shift;
  return ();
}
 
 
sub reset_values {
  #my($self) = shift;
}
 
 
sub sort_files {
  #my($self) = shift;
  return 1;
}
 
 
sub file_sorter {
  my($self)  = shift;
  my($left)  = shift;
  my($right) = shift;
  return $left cmp $right;
}
 
 
sub read_global_configuration {
  #my($self)  = shift;
  #my($input) = shift;
  return 1;
}
 
 
1;
 

Rev 107	Rev 198
1	`package Creator;`	1	`package Creator;`
2		2
3	`# ************************************************************`	3	`# ************************************************************`
4	`# Description : Base class for workspace and project creators`	4	`# Description : Base class for workspace and project creators`
5	`# Author : Chad Elliott`	5	`# Author : Chad Elliott`
6	`# Create Date : 5/13/2002`	6	`# Create Date : 5/13/2002`
7	`# ************************************************************`	7	`# ************************************************************`
8		8
9	`# ************************************************************`	9	`# ************************************************************`
10	`# Pragmas`	10	`# Pragmas`
11	`# ************************************************************`	11	`# ************************************************************`
12		12
13	`use strict;`	13	`use strict;`
14	`use FileHandle;`	14	`use FileHandle;`
15	`use File::Basename;`	15	`use File::Basename;`
16		16
17	`use Parser;`	17	`use Parser;`
18		18
19	`use vars qw(@ISA);`	19	`use vars qw(@ISA);`
20	`@ISA = qw(Parser);`	20	`@ISA = qw(Parser);`
21		21
22	`# ************************************************************`	22	`# ************************************************************`
23	`# Data Section`	23	`# Data Section`
24	`# ************************************************************`	24	`# ************************************************************`
25		25
26	`my(@statekeys) = ('global', 'include', 'template', 'ti',`	26	`my(@statekeys) = ('global', 'include', 'template', 'ti',`
27	`'dynamic', 'static', 'relative', 'addtemp',`	27	`'dynamic', 'static', 'relative', 'addtemp',`
28	`'addproj', 'progress', 'toplevel', 'baseprojs',`	28	`'addproj', 'progress', 'toplevel', 'baseprojs',`
29	`'feature_file', 'features', 'hierarchy',`	29	`'feature_file', 'features', 'hierarchy',`
30	`'name_modifier', 'apply_project', 'into', 'use_env',`	30	`'name_modifier', 'apply_project', 'into', 'use_env',`
31	`'expand_vars',`	31	`'expand_vars',`
32	`);`	32	`);`
33		33
34	`my(%all_written) = ();`	34	`my(%all_written) = ();`
35		35
36	`# ************************************************************`	36	`# ************************************************************`
37	`# Subroutine Section`	37	`# Subroutine Section`
38	`# ************************************************************`	38	`# ************************************************************`
39		39
40	`sub new {`	40	`sub new {`
41	`my($class) = shift;`	41	`my($class) = shift;`
42	`my($global) = shift;`	42	`my($global) = shift;`
43	`my($inc) = shift;`	43	`my($inc) = shift;`
44	`my($template) = shift;`	44	`my($template) = shift;`
45	`my($ti) = shift;`	45	`my($ti) = shift;`
46	`my($dynamic) = shift;`	46	`my($dynamic) = shift;`
47	`my($static) = shift;`	47	`my($static) = shift;`
48	`my($relative) = shift;`	48	`my($relative) = shift;`
49	`my($addtemp) = shift;`	49	`my($addtemp) = shift;`
50	`my($addproj) = shift;`	50	`my($addproj) = shift;`
51	`my($progress) = shift;`	51	`my($progress) = shift;`
52	`my($toplevel) = shift;`	52	`my($toplevel) = shift;`
53	`my($baseprojs) = shift;`	53	`my($baseprojs) = shift;`
54	`my($feature) = shift;`	54	`my($feature) = shift;`
55	`my($features) = shift;`	55	`my($features) = shift;`
56	`my($hierarchy) = shift;`	56	`my($hierarchy) = shift;`
57	`my($nmodifier) = shift;`	57	`my($nmodifier) = shift;`
58	`my($applypj) = shift;`	58	`my($applypj) = shift;`
59	`my($into) = shift;`	59	`my($into) = shift;`
60	`my($language) = shift;`	60	`my($language) = shift;`
61	`my($use_env) = shift;`	61	`my($use_env) = shift;`
62	`my($expandvars) = shift;`	62	`my($expandvars) = shift;`
63	`my($type) = shift;`	63	`my($type) = shift;`
64	`my($self) = Parser::new($class, $inc);`	64	`my($self) = Parser::new($class, $inc);`
65		65
66	`$self->{'relative'} = $relative;`	66	`$self->{'relative'} = $relative;`
67	`$self->{'template'} = $template;`	67	`$self->{'template'} = $template;`
68	`$self->{'ti'} = $ti;`	68	`$self->{'ti'} = $ti;`
69	`$self->{'global'} = $global;`	69	`$self->{'global'} = $global;`
70	`$self->{'grammar_type'} = $type;`	70	`$self->{'grammar_type'} = $type;`
71	`$self->{'type_check'} = $type . '_defined';`	71	`$self->{'type_check'} = $type . '_defined';`
72	`$self->{'global_read'} = 0;`	72	`$self->{'global_read'} = 0;`
73	`$self->{'current_input'} = '';`	73	`$self->{'current_input'} = '';`
74	`$self->{'progress'} = $progress;`	74	`$self->{'progress'} = $progress;`
75	`$self->{'addtemp'} = $addtemp;`	75	`$self->{'addtemp'} = $addtemp;`
76	`$self->{'addproj'} = $addproj;`	76	`$self->{'addproj'} = $addproj;`
77	`$self->{'toplevel'} = $toplevel;`	77	`$self->{'toplevel'} = $toplevel;`
78	`$self->{'files_written'} = {};`	78	`$self->{'files_written'} = {};`
79	`$self->{'real_fwritten'} = [];`	79	`$self->{'real_fwritten'} = [];`
80	`$self->{'reading_global'} = 0;`	80	`$self->{'reading_global'} = 0;`
81	`$self->{'global_assign'} = {};`	81	`$self->{'global_assign'} = {};`
82	`$self->{'assign'} = {};`	82	`$self->{'assign'} = {};`
83	`$self->{'baseprojs'} = $baseprojs;`	83	`$self->{'baseprojs'} = $baseprojs;`
84	`$self->{'dynamic'} = $dynamic;`	84	`$self->{'dynamic'} = $dynamic;`
85	`$self->{'static'} = $static;`	85	`$self->{'static'} = $static;`
86	`$self->{'feature_file'} = $feature;`	86	`$self->{'feature_file'} = $feature;`
87	`$self->{'features'} = $features;`	87	`$self->{'features'} = $features;`
88	`$self->{'hierarchy'} = $hierarchy;`	88	`$self->{'hierarchy'} = $hierarchy;`
89	`$self->{'name_modifier'} = $nmodifier;`	89	`$self->{'name_modifier'} = $nmodifier;`
90	`$self->{'apply_project'} = $applypj;`	90	`$self->{'apply_project'} = $applypj;`
91	`$self->{'into'} = $into;`	91	`$self->{'into'} = $into;`
92	`$self->{'language'} = $language;`	92	`$self->{'language'} = $language;`
93	`$self->{'use_env'} = $use_env;`	93	`$self->{'use_env'} = $use_env;`
94	`$self->{'expand_vars'} = $expandvars;`	94	`$self->{'expand_vars'} = $expandvars;`
95	`$self->{'convert_slashes'} = $self->convert_slashes();`	95	`$self->{'convert_slashes'} = $self->convert_slashes();`
96		96
97	`return $self;`	97	`return $self;`
98	`}`	98	`}`
99		99
100		100
101	`sub preprocess_line {`	101	`sub preprocess_line {`
102	`my($self) = shift;`	102	`my($self) = shift;`
103	`my($fh) = shift;`	103	`my($fh) = shift;`
104	`my($line) = shift;`	104	`my($line) = shift;`
105		105
106	`$line = $self->strip_line($line);`	106	`$line = $self->strip_line($line);`
107	`while ($line =~ /\\$/) {`	107	`while ($line =~ /\\$/) {`
108	`$line =~ s/\s*\\$/ /;`	108	`$line =~ s/\s*\\$/ /;`
109	`my($next) = $fh->getline();`	109	`my($next) = $fh->getline();`
110	`if (defined $next) {`	110	`if (defined $next) {`
111	`$line .= $self->strip_line($next);`	111	`$line .= $self->strip_line($next);`
112	`}`	112	`}`
113	`}`	113	`}`
114	`return $line;`	114	`return $line;`
115	`}`	115	`}`
116		116
117		117
118	`sub generate_default_input {`	118	`sub generate_default_input {`
119	`my($self) = shift;`	119	`my($self) = shift;`
120	`my($status,`	120	`my($status,`
121	`$error) = $self->parse_line(undef, "$self->{'grammar_type'} {");`	121	`$error) = $self->parse_line(undef, "$self->{'grammar_type'} {");`
122		122
123	`if ($status) {`	123	`if ($status) {`
124	`($status, $error) = $self->parse_line(undef, '}');`	124	`($status, $error) = $self->parse_line(undef, '}');`
125	`}`	125	`}`
126		126
127	`if (!$status) {`	127	`if (!$status) {`
128	`$self->error($error);`	128	`$self->error($error);`
129	`}`	129	`}`
130		130
131	`return $status;`	131	`return $status;`
132	`}`	132	`}`
133		133
134		134
135	`sub parse_file {`	135	`sub parse_file {`
136	`my($self) = shift;`	136	`my($self) = shift;`
137	`my($input) = shift;`	137	`my($input) = shift;`
138	`my($oline) = $self->get_line_number();`	138	`my($oline) = $self->get_line_number();`
139		139
140	`## Read the input file and get the last line number`	140	`## Read the input file and get the last line number`
141	`my($status, $errorString) = $self->read_file($input);`	141	`my($status, $errorString) = $self->read_file($input);`
142		142
143	`if (!$status) {`	143	`if (!$status) {`
144	`$self->error($errorString,`	144	`$self->error($errorString,`
145	`"$input: line " . $self->get_line_number() . ':');`	145	`"$input: line " . $self->get_line_number() . ':');`
146	`}`	146	`}`
147	`elsif ($status && $self->{$self->{'type_check'}}) {`	147	`elsif ($status && $self->{$self->{'type_check'}}) {`
148	`## If we are at the end of the file and the type we are looking at`	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`	149	`## is still defined, then we have an error`
150	`$self->error("Did not " .`	150	`$self->error("Did not " .`
151	`"find the end of the $self->{'grammar_type'}",`	151	`"find the end of the $self->{'grammar_type'}",`
152	`"$input: line " . $self->get_line_number() . ':');`	152	`"$input: line " . $self->get_line_number() . ':');`
153	`$status = 0;`	153	`$status = 0;`
154	`}`	154	`}`
155	`$self->set_line_number($oline);`	155	`$self->set_line_number($oline);`
156		156
157	`return $status;`	157	`return $status;`
158	`}`	158	`}`
159		159
160		160
161	`sub generate {`	161	`sub generate {`
162	`my($self) = shift;`	162	`my($self) = shift;`
163	`my($input) = shift;`	163	`my($input) = shift;`
164	`my($status) = 1;`	164	`my($status) = 1;`
165		165
166	`## Reset the files_written hash array between processing each file`	166	`## Reset the files_written hash array between processing each file`
167	`$self->{'files_written'} = {};`	167	`$self->{'files_written'} = {};`
168	`$self->{'real_fwritten'} = [];`	168	`$self->{'real_fwritten'} = [];`
169		169
170	`## Allow subclasses to reset values before`	170	`## Allow subclasses to reset values before`
171	`## each call to generate().`	171	`## each call to generate().`
172	`$self->reset_values();`	172	`$self->reset_values();`
173		173
174	`## Read the global configuration file`	174	`## Read the global configuration file`
175	`if (!$self->{'global_read'}) {`	175	`if (!$self->{'global_read'}) {`
176	`$status = $self->read_global_configuration();`	176	`$status = $self->read_global_configuration();`
177	`$self->{'global_read'} = 1;`	177	`$self->{'global_read'} = 1;`
178	`}`	178	`}`
179		179
180	`if ($status) {`	180	`if ($status) {`
181	`$self->{'current_input'} = $input;`	181	`$self->{'current_input'} = $input;`
182		182
183	`## An empty input file name says that we`	183	`## An empty input file name says that we`
184	`## should generate a default input file and use that`	184	`## should generate a default input file and use that`
185	`if ($input eq '') {`	185	`if ($input eq '') {`
186	`$status = $self->generate_default_input();`	186	`$status = $self->generate_default_input();`
187	`}`	187	`}`
188	`else {`	188	`else {`
189	`$status = $self->parse_file($input);`	189	`$status = $self->parse_file($input);`
190	`}`	190	`}`
191	`}`	191	`}`
192		192
193	`return $status;`	193	`return $status;`
194	`}`	194	`}`
195		195
196		196
197	`sub parse_assignment {`	197	`sub parse_assignment {`
198	`my($self) = shift;`	198	`my($self) = shift;`
199	`my($line) = shift;`	199	`my($line) = shift;`
200	`my($values) = shift;`	200	`my($values) = shift;`
201		201
202	`if ($line =~ /^(\w+(::\w+))\s\+=\s(.)?/) {`	202	`if ($line =~ /^(\w+(::\w+))\s\+=\s(.)?/) {`
203	`my($name) = lc($1);`	203	`my($name) = lc($1);`
204	`my($value) = $3;`	204	`my($value) = $3;`
205	`push(@$values, 'assign_add', $name, $value);`	205	`push(@$values, 'assign_add', $name, $value);`
206	`return 1;`	206	`return 1;`
207	`}`	207	`}`
208	`elsif ($line =~ /^(\w+(::\w+))\s=\s(.)?/) {`	208	`elsif ($line =~ /^(\w+(::\w+))\s=\s(.)?/) {`
209	`my($name) = lc($1);`	209	`my($name) = lc($1);`
210	`my($value) = $3;`	210	`my($value) = $3;`
211	`push(@$values, 'assignment', $name, $value);`	211	`push(@$values, 'assignment', $name, $value);`
212	`return 1;`	212	`return 1;`
213	`}`	213	`}`
214	`elsif ($line =~ /^(\w+(::\w+))\s\-=\s(.)?/) {`	214	`elsif ($line =~ /^(\w+(::\w+))\s\-=\s(.)?/) {`
215	`my($name) = lc($1);`	215	`my($name) = lc($1);`
216	`my($value) = $3;`	216	`my($value) = $3;`
217	`push(@$values, 'assign_sub', $name, $value);`	217	`push(@$values, 'assign_sub', $name, $value);`
218	`return 1;`	218	`return 1;`
219	`}`	219	`}`
220		220
221	`return 0;`	221	`return 0;`
222	`}`	222	`}`
223		223
224		224
225	`sub parse_known {`	225	`sub parse_known {`
226	`my($self) = shift;`	226	`my($self) = shift;`
227	`my($line) = shift;`	227	`my($line) = shift;`
228	`my($status) = 1;`	228	`my($status) = 1;`
229	`my($errorString) = undef;`	229	`my($errorString) = undef;`
230	`my($type) = $self->{'grammar_type'};`	230	`my($type) = $self->{'grammar_type'};`
231	`my(@values) = ();`	231	`my(@values) = ();`
232		232
233	`##`	233	`##`
234	`## Each regexp that looks for the '{' looks for it at the`	234	`## Each regexp that looks for the '{' looks for it at the`
235	`## end of the line. It is purposely this way to decrease`	235	`## end of the line. It is purposely this way to decrease`
236	`## the amount of extra lines in each file. This`	236	`## the amount of extra lines in each file. This`
237	`## allows for the most compact file as human readably`	237	`## allows for the most compact file as human readably`
238	`## possible.`	238	`## possible.`
239	`##`	239	`##`
240	`if ($line eq '') {`	240	`if ($line eq '') {`
241	`}`	241	`}`
242	`elsif ($line =~ /^$type\s(\([^\)]+\))?\s(:.)?\s{$/) {`	242	`elsif ($line =~ /^$type\s(\([^\)]+\))?\s(:.)?\s{$/) {`
243	`my($name) = $1;`	243	`my($name) = $1;`
244	`my($parents) = $2;`	244	`my($parents) = $2;`
245	`if ($self->{$self->{'type_check'}}) {`	245	`if ($self->{$self->{'type_check'}}) {`
246	`$errorString = "Did not find the end of the $type";`	246	`$errorString = "Did not find the end of the $type";`
247	`$status = 0;`	247	`$status = 0;`
248	`}`	248	`}`
249	`else {`	249	`else {`
250	`if (defined $parents) {`	250	`if (defined $parents) {`
251	`my(@parents) = ();`	251	`my(@parents) = ();`
252	`$parents =~ s/^://;`	252	`$parents =~ s/^://;`
253	`foreach my $parent (split(',', $parents)) {`	253	`foreach my $parent (split(',', $parents)) {`
254	`$parent =~ s/^\s+//;`	254	`$parent =~ s/^\s+//;`
255	`$parent =~ s/\s+$//;`	255	`$parent =~ s/\s+$//;`
256	`if ($parent ne '') {`	256	`if ($parent ne '') {`
257	`push(@parents, $parent);`	257	`push(@parents, $parent);`
258	`}`	258	`}`
259	`}`	259	`}`
260	`if (!defined $parents[0]) {`	260	`if (!defined $parents[0]) {`
261	`## The : was used, but no parents followed. This`	261	`## The : was used, but no parents followed. This`
262	`## is an error.`	262	`## is an error.`
263	`$errorString = 'No parents listed';`	263	`$errorString = 'No parents listed';`
264	`$status = 0;`	264	`$status = 0;`
265	`}`	265	`}`
266	`$parents = \@parents;`	266	`$parents = \@parents;`
267	`}`	267	`}`
268	`push(@values, $type, $name, $parents);`	268	`push(@values, $type, $name, $parents);`
269	`}`	269	`}`
270	`}`	270	`}`
271	`elsif ($line =~ /^}$/) {`	271	`elsif ($line =~ /^}$/) {`
272	`if ($self->{$self->{'type_check'}}) {`	272	`if ($self->{$self->{'type_check'}}) {`
273	`push(@values, $type, $line);`	273	`push(@values, $type, $line);`
274	`}`	274	`}`
275	`else {`	275	`else {`
276	`$errorString = "Did not find the beginning of the $type";`	276	`$errorString = "Did not find the beginning of the $type";`
277	`$status = 0;`	277	`$status = 0;`
278	`}`	278	`}`
279	`}`	279	`}`
280	`elsif ($line =~ /^(feature)\s\(([^\)]+)\)\s(:.)?\s{$/) {`	280	`elsif ($line =~ /^(feature)\s\(([^\)]+)\)\s(:.)?\s{$/) {`
281	`my($type) = $1;`	281	`my($type) = $1;`
282	`my($name) = $2;`	282	`my($name) = $2;`
283	`my($parents) = $3;`	283	`my($parents) = $3;`
284	`my(@names) = split(/\s,\s/, $name);`	284	`my(@names) = split(/\s,\s/, $name);`
285		285
286	`if (defined $parents) {`	286	`if (defined $parents) {`
287	`my(@parents) = ();`	287	`my(@parents) = ();`
288	`$parents =~ s/^://;`	288	`$parents =~ s/^://;`
289	`foreach my $parent (split(',', $parents)) {`	289	`foreach my $parent (split(',', $parents)) {`
290	`$parent =~ s/^\s+//;`	290	`$parent =~ s/^\s+//;`
291	`$parent =~ s/\s+$//;`	291	`$parent =~ s/\s+$//;`
292	`if ($parent ne '') {`	292	`if ($parent ne '') {`
293	`push(@parents, $parent);`	293	`push(@parents, $parent);`
294	`}`	294	`}`
295	`}`	295	`}`
296	`if (!defined $parents[0]) {`	296	`if (!defined $parents[0]) {`
297	`## The : was used, but no parents followed. This`	297	`## The : was used, but no parents followed. This`
298	`## is an error.`	298	`## is an error.`
299	`$errorString = 'No parents listed';`	299	`$errorString = 'No parents listed';`
300	`$status = 0;`	300	`$status = 0;`
301	`}`	301	`}`
302	`$parents = \@parents;`	302	`$parents = \@parents;`
303	`}`	303	`}`
304	`push(@values, $type, \@names, $parents);`	304	`push(@values, $type, \@names, $parents);`
305	`}`	305	`}`
306	`elsif (!$self->{$self->{'type_check'}}) {`	306	`elsif (!$self->{$self->{'type_check'}}) {`
307	`$errorString = "No $type was defined";`	307	`$errorString = "No $type was defined";`
308	`$status = 0;`	308	`$status = 0;`
309	`}`	309	`}`
310	`elsif ($self->parse_assignment($line, \@values)) {`	310	`elsif ($self->parse_assignment($line, \@values)) {`
311	`## If this returns true, then we've found an assignment`	311	`## If this returns true, then we've found an assignment`
312	`}`	312	`}`
313	`elsif ($line =~ /^(\w+)\s(\([^\)]+\))?\s{$/) {`	313	`elsif ($line =~ /^(\w+)\s(\([^\)]+\))?\s{$/) {`
314	`my($comp) = lc($1);`	314	`my($comp) = lc($1);`
315	`my($name) = $2;`	315	`my($name) = $2;`
316		316
317	`if (defined $name) {`	317	`if (defined $name) {`
318	`$name =~ s/^\(\s*//;`	318	`$name =~ s/^\(\s*//;`
319	`$name =~ s/\s*\)$//;`	319	`$name =~ s/\s*\)$//;`
320	`}`	320	`}`
321	`else {`	321	`else {`
322	`$name = $self->get_default_component_name();`	322	`$name = $self->get_default_component_name();`
323	`}`	323	`}`
324	`push(@values, 'component', $comp, $name);`	324	`push(@values, 'component', $comp, $name);`
325	`}`	325	`}`
326	`else {`	326	`else {`
327	`$errorString = "Unrecognized line: $line";`	327	`$errorString = "Unrecognized line: $line";`
328	`$status = -1;`	328	`$status = -1;`
329	`}`	329	`}`
330		330
331	`return $status, $errorString, @values;`	331	`return $status, $errorString, @values;`
332	`}`	332	`}`
333		333
334		334
335	`sub parse_scope {`	335	`sub parse_scope {`
336	`my($self) = shift;`	336	`my($self) = shift;`
337	`my($fh) = shift;`	337	`my($fh) = shift;`
338	`my($name) = shift;`	338	`my($name) = shift;`
339	`my($type) = shift;`	339	`my($type) = shift;`
340	`my($validNames) = shift;`	340	`my($validNames) = shift;`
341	`my($flags) = shift;`	341	`my($flags) = shift;`
342	`my($elseflags) = shift;`	342	`my($elseflags) = shift;`
343	`my($status) = 0;`	343	`my($status) = 0;`
344	`my($errorString) = "Unable to process $name";`	344	`my($errorString) = "Unable to process $name";`
345		345
346	`if (!defined $flags) {`	346	`if (!defined $flags) {`
347	`$flags = {};`	347	`$flags = {};`
348	`}`	348	`}`
349		349
350	`while(<$fh>) {`	350	`while(<$fh>) {`
351	`my($line) = $self->preprocess_line($fh, $_);`	351	`my($line) = $self->preprocess_line($fh, $_);`
352		352
353	`if ($line eq '') {`	353	`if ($line eq '') {`
354	`}`	354	`}`
355	`elsif ($line =~ /^}$/) {`	355	`elsif ($line =~ /^}$/) {`
356	`($status, $errorString) = $self->handle_scoped_end($type, $flags);`	356	`($status, $errorString) = $self->handle_scoped_end($type, $flags);`
357	`last;`	357	`last;`
358	`}`	358	`}`
359	`elsif (defined $elseflags && $line =~ /^}\selse\s{$/) {`	359	`elsif ($line =~ /^}\selse\s{$/) {`
-		360	`if (defined $elseflags) {`
360	`## From here on out anything after this goes into the $elseflags`	361	`## From here on out anything after this goes into the $elseflags`
361	`$flags = $elseflags;`	362	`$flags = $elseflags;`
362	`$elseflags = undef;`	363	`$elseflags = undef;`
363		364
364	`## We need to adjust the type also. If there was a type`	365	`## We need to adjust the type also. If there was a type`
365	`## then the first part of the clause was used. If there was`	366	`## then the first part of the clause was used. If there was`
366	`## no type, then the first part was ignored and the second`	367	`## no type, then the first part was ignored and the second`
367	`## part will be used.`	368	`## part will be used.`
368	`if (defined $type) {`	369	`if (defined $type) {`
369	`$type = undef;`	370	`$type = undef;`
-		371	`}`
-		372	`else {`
-		373	`$type = $self->get_default_component_name();`
-		374	`}`
370	`}`	375	`}`
371	`else {`	376	`else {`
-		377	`$status = 0;`
372	`$type = $self->get_default_component_name();`	378	`$errorString = 'An else is not allowed in this context';`
-		379	`last;`
373	`}`	380	`}`
374	`}`	381	`}`
375	`else {`	382	`else {`
376	`my(@values) = ();`	383	`my(@values) = ();`
377	`if ($self->parse_assignment($line, \@values)) {`	384	`if (defined $validNames && $self->parse_assignment($line, \@values)) {`
378	`if (defined $$validNames{$values[1]}) {`	385	`if (defined $$validNames{$values[1]}) {`
379	`if ($values[0] eq 'assignment') {`	386	`if ($values[0] eq 'assignment') {`
380	`$self->process_assignment($values[1], $values[2], $flags);`	387	`$self->process_assignment($values[1], $values[2], $flags);`
381	`}`	388	`}`
382	`elsif ($values[0] eq 'assign_add') {`	389	`elsif ($values[0] eq 'assign_add') {`
383	`$self->process_assignment_add($values[1], $values[2], $flags);`	390	`$self->process_assignment_add($values[1], $values[2], $flags);`
384	`}`	391	`}`
385	`elsif ($values[0] eq 'assign_sub') {`	392	`elsif ($values[0] eq 'assign_sub') {`
386	`$self->process_assignment_sub($values[1], $values[2], $flags);`	393	`$self->process_assignment_sub($values[1], $values[2], $flags);`
387	`}`	394	`}`
388	`}`	395	`}`
389	`else {`	396	`else {`
390	`($status,`	397	`($status,`
391	`$errorString) = $self->handle_unknown_assignment($type,`	398	`$errorString) = $self->handle_unknown_assignment($type,`
392	`@values);`	399	`@values);`
393	`if (!$status) {`	400	`if (!$status) {`
394	`last;`	401	`last;`
395	`}`	402	`}`
396	`}`	403	`}`
397	`}`	404	`}`
398	`else {`	405	`else {`
399	`($status, $errorString) = $self->handle_scoped_unknown($fh,`	406	`($status, $errorString) = $self->handle_scoped_unknown($fh,`
400	`$type,`	407	`$type,`
401	`$flags,`	408	`$flags,`
402	`$line);`	409	`$line);`
403	`if (!$status) {`	410	`if (!$status) {`
404	`last;`	411	`last;`
405	`}`	412	`}`
406	`}`	413	`}`
407	`}`	414	`}`
408	`}`	415	`}`
409	`return $status, $errorString;`	416	`return $status, $errorString;`
410	`}`	417	`}`
411		418
412		419
413	`sub base_directory {`	420	`sub base_directory {`
414	`my($self) = shift;`	421	`my($self) = shift;`
415	`return basename($self->getcwd());`	422	`return basename($self->getcwd());`
416	`}`	423	`}`
417		424
418		425
419	`sub generate_default_file_list {`	426	`sub generate_default_file_list {`
420	`my($self) = shift;`	427	`my($self) = shift;`
421	`my($dir) = shift;`	428	`my($dir) = shift;`
422	`my($exclude) = shift;`	429	`my($exclude) = shift;`
423	`my($recurse) = shift;`	430	`my($recurse) = shift;`
424	`my($dh) = new FileHandle();`	431	`my($dh) = new FileHandle();`
425	`my(@files) = ();`	432	`my(@files) = ();`
426		433
427	`if (opendir($dh, $dir)) {`	434	`if (opendir($dh, $dir)) {`
428	`my($need_dir) = ($dir ne '.');`	435	`my($need_dir) = ($dir ne '.');`
429	`my($skip) = 0;`	436	`my($skip) = 0;`
430	`foreach my $file (grep(!/^\.\.?$/, readdir($dh))) {`	437	`foreach my $file (grep(!/^\.\.?$/, readdir($dh))) {`
431	`if ($^O eq 'VMS') {`	-
432	`$file =~ s/\.dir$//;`	438	`$file =~ s/\.dir$// if ($^O eq 'VMS');`
433	`}`	439
434	`## Prefix each file name with the directory only if it's not '.'`	440	`## Prefix each file name with the directory only if it's not '.'`
435	`my($full) = ($need_dir ? "$dir/" : '') . $file;`	441	`my($full) = ($need_dir ? "$dir/" : '') . $file;`
436		442
437	`if (defined $$exclude[0]) {`	443	`if (defined $$exclude[0]) {`
438	`foreach my $exc (@$exclude) {`	444	`foreach my $exc (@$exclude) {`
439	`if ($full eq $exc) {`	445	`if ($full eq $exc) {`
440	`$skip = 1;`	446	`$skip = 1;`
441	`last;`	447	`last;`
442	`}`	448	`}`
443	`}`	449	`}`
444	`}`	450	`}`
445		451
446	`if ($skip) {`	452	`if ($skip) {`
447	`$skip = 0;`	453	`$skip = 0;`
448	`}`	454	`}`
449	`else {`	455	`else {`
450	`if ($recurse && -d $full) {`	456	`if ($recurse && -d $full) {`
451	`push(@files,`	457	`push(@files,`
452	`$self->generate_default_file_list($full, $exclude, $recurse));`	458	`$self->generate_default_file_list($full, $exclude, $recurse));`
453	`}`	459	`}`
454	`else {`	460	`else {`
455	`push(@files, $full);`	461	`push(@files, $full);`
456	`}`	462	`}`
457	`}`	463	`}`
458	`}`	464	`}`
459		465
460	`if ($self->sort_files()) {`	466	`if ($self->sort_files()) {`
461	`@files = sort { $self->file_sorter($a, $b) } @files;`	467	`@files = sort { $self->file_sorter($a, $b) } @files;`
462	`}`	468	`}`
463		469
464	`closedir($dh);`	470	`closedir($dh);`
465	`}`	471	`}`
466	`return @files;`	472	`return @files;`
467	`}`	473	`}`
468		474
469		475
470	`sub transform_file_name {`	476	`sub transform_file_name {`
471	`my($self) = shift;`	477	`my($self) = shift;`
472	`my($name) = shift;`	478	`my($name) = shift;`
473		479
474	`$name =~ s/[\s\-]/_/g;`	480	`$name =~ s/[\s\-]/_/g;`
475	`return $name;`	481	`return $name;`
476	`}`	482	`}`
477		483
478		484
479	`sub file_written {`	485	`sub file_written {`
480	`my($self) = shift;`	486	`my($self) = shift;`
481	`my($file) = shift;`	487	`my($file) = shift;`
482	`return (defined $all_written{$self->getcwd() . '/' . $file});`	488	`return (defined $all_written{$self->getcwd() . '/' . $file});`
483	`}`	489	`}`
484		490
485		491
486	`sub add_file_written {`	492	`sub add_file_written {`
487	`my($self) = shift;`	493	`my($self) = shift;`
488	`my($file) = shift;`	494	`my($file) = shift;`
489	`my($key) = lc($file);`	495	`my($key) = lc($file);`
490		496
491	`if (defined $self->{'files_written'}->{$key}) {`	497	`if (defined $self->{'files_written'}->{$key}) {`
492	`$self->warning("$self->{'grammar_type'} $file has " .`	498	`$self->warning("$self->{'grammar_type'} $file has " .`
493	`"possibly been overwritten.");`	499	`"possibly been overwritten.");`

Subversion Repositories gelsvn

(root)/trunk/MPC/modules/Creator.pm @ 201 – Rev 107 → 198