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 Parser;
 
use vars qw(@ISA);
@ISA = qw(Parser);
 
# ************************************************************
# Data Section
# ************************************************************
 
my($assign_key)  = 'assign';
my($gassign_key) = 'global_assign';
 
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', 'language',
                 );
 
my(%all_written) = ();
my($onVMS) = ($^O eq 'VMS');
 
# ************************************************************
# 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->{$gassign_key}      = {};
  $self->{$assign_key}       = {};
  $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();
  $self->{'case_tolerant'}   = $self->case_insensitive();
 
  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*(.*)?/) {
 
 
 
 
 
 
 
 
    push(@$values, $3, lc($1), $4);
 
 
 
 
 
 
    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) {
 
        $parents =~ s/^:\s*//;
 
 
        $parents =~ s/\s+$//;
 
        my(@parents) = split(/\s*,\s*/, $parents);
 
 
        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) {
 
      $parents =~ s/^:\s*//;
 
 
      $parents =~ s/\s+$//;
 
      my(@parents) = split(/\s*,\s*/, $parents);
 
 
      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 '=') {
            $self->process_assignment($values[1], $values[2], $flags);
          }
          elsif ($values[0] eq '+=') {
            $self->process_assignment_add($values[1], $values[2], $flags);
          }
          elsif ($values[0] eq '-=') {
            $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 $self->mpc_basename($self->getcwd());
}
 
 
sub generate_default_file_list {
  my($self)    = shift;
  my($dir)     = shift;
  my($exclude) = shift;
  my($fileexc) = 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 ($onVMS);
 
      ## 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;
        $$fileexc = 1 if (defined $fileexc);
      }
      else {
        if ($recurse && -d $full) {
          push(@files,
               $self->generate_default_file_list($full, $exclude,
                                                 $fileexc, $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 " .
                   ($self->{'case_tolerant'} ?
                           "has been overwritten." :
                           "of differing case has been processed."));
  }
  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 ($onVMS);
 
      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'} && index($name, 'flags') == -1) {
    $value =~ s/\//\\/g;
  }
  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;
  return $self->{$self->{'reading_global'} ? $gassign_key : $assign_key};
 
 
 
 
 
 
 
 
 
}
 
 
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.
 
    $assign  = $self->{$self->{'reading_global'} ?
 
                               $gassign_key : $assign_key};
 
 
 
 
  }
 
  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);
 
  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);
 
    my($last)  = 1;
    my($found) = undef;
    for(my $i = 0; $i <= $last; $i++) {
      if ($i == $last) {
        ## If we did not find the string to subtract in the original
        ## value, try again after expanding template variables for
        ## subtraction.
 
        $nval = $self->get_assignment_for_modification($name, $assign, 1);
      }
      for(my $j = 0; $j <= $last; $j++) {
        ## If we didn't find it the first time, try again with quotes
        my($re) = ($j == $last ? '"' . $value . '"' : $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/$re\s+// || $nval =~ s/$re$//) {
          $self->process_assignment($name, $nval, $assign);
          $found = 1;
          last;
        }
      }
      last if ($found);
    }
  }
}
 
 
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) {
    $assign = $self->{$self->{'reading_global'} ?
                              $gassign_key : $assign_key};
  }
 
  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 $_[1] cmp $_[2];
}
 
 
sub read_global_configuration {
  #my($self)  = shift;
  #my($input) = shift;
  return 1;
}
 
 
1;
 

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

Subversion Repositories gelsvn

(root)/trunk/MPC/modules/Creator.pm @ 242 – Rev 198 → 217