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

 # Pragmas
 # ************************************************************
 use strict;
 use FileHandle;
-use File::Basename;
 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',
+                  'expand_vars', 'language',
                  );
 my(%all_written) = ();
+my($onVMS) = ($^O eq 'VMS');
 # ************************************************************
 # Subroutine Section
 # ************************************************************
   $self->{'addproj'}         = $addproj;
   $self->{'toplevel'}        = $toplevel;
   $self->{'files_written'}   = {};
   $self->{'real_fwritten'}   = [];
   $self->{'reading_global'}  = 0;
-  $self->{'global_assign'}   = {};
+  $self->{$gassign_key}      = {};
-  $self->{'assign'}          = {};
+  $self->{$assign_key}       = {};
   $self->{'baseprojs'}       = $baseprojs;
   $self->{'dynamic'}         = $dynamic;
   $self->{'static'}          = $static;
   $self->{'feature_file'}    = $feature;
   $self->{'features'}        = $features;
   $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 parse_assignment {
   my($self)   = shift;
   my($line)   = shift;
   my($values) = shift;
-  if ($line =~ /^(\w+(::\w+)*)\s*\+=\s*(.*)?/) {
+  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);
+    push(@$values, $3, lc($1), $4);
-    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;
+}
       $errorString = "Did not find the end of the $type";
       $status = 0;
+    }
     else {
       if (defined $parents) {
-        my(@parents) = ();
-        $parents =~ s/^://;
+        $parents =~ s/^:\s*//;
-        foreach my $parent (split(',', $parents)) {
-          $parent =~ s/^\s+//;
-          $parent =~ s/\s+$//;
+        $parents =~ s/\s+$//;
-          if ($parent ne '') {
-            push(@parents, $parent);
+        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;
     my($name)    = $2;
     my($parents) = $3;
     my(@names)   = split(/\s*,\s*/, $name);
     if (defined $parents) {
-      my(@parents) = ();
-      $parents =~ s/^://;
+      $parents =~ s/^:\s*//;
-      foreach my $parent (split(',', $parents)) {
-        $parent =~ s/^\s+//;
-        $parent =~ s/\s+$//;
+      $parents =~ s/\s+$//;
-        if ($parent ne '') {
-          push(@parents, $parent);
+      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;
+    }
     else {
       my(@values) = ();
       if (defined $validNames && $self->parse_assignment($line, \@values)) {
         if (defined $$validNames{$values[1]}) {
-          if ($values[0] eq 'assignment') {
+          if ($values[0] eq '=') {
             $self->process_assignment($values[1], $values[2], $flags);
+          }
-          elsif ($values[0] eq 'assign_add') {
+          elsif ($values[0] eq '+=') {
             $self->process_assignment_add($values[1], $values[2], $flags);
+          }
-          elsif ($values[0] eq 'assign_sub') {
+          elsif ($values[0] eq '-=') {
             $self->process_assignment_sub($values[1], $values[2], $flags);
+          }
+        }
         else {
           ($status,
+}
 sub base_directory {
   my($self) = shift;
-  return basename($self->getcwd());
+  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 ($^O eq 'VMS');
+      $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]) {
+        }
+      }
       if ($skip) {
         $skip = 0;
+        $$fileexc = 1 if (defined $fileexc);
+      }
       else {
         if ($recurse && -d $full) {
           push(@files,
-               $self->generate_default_file_list($full, $exclude, $recurse));
+               $self->generate_default_file_list($full, $exclude,
+                                                 $fileexc, $recurse));
+        }
         else {
           push(@files, $full);
+        }
+      }
   my($self) = shift;
   my($file) = shift;
   my($key)  = lc($file);
   if (defined $self->{'files_written'}->{$key}) {
-    $self->warning("$self->{'grammar_type'} $file has " .
+    $self->warning("$self->{'grammar_type'} $file " .
+                   ($self->{'case_tolerant'} ?
-                   "possibly been overwritten.");
+                           "has been overwritten." :
+                           "of differing case has been processed."));
+  }
   else {
     $self->{'files_written'}->{$key} = $file;
     push(@{$self->{'real_fwritten'}}, $file);
+  }
   my($fh)      = new FileHandle();
   my(@files)   = ();
   if (opendir($fh, $dir)) {
     foreach my $file (grep(!/^\.\.?$/, readdir($fh))) {
-      $file =~ s/\.dir$// if ($^O eq 'VMS');
+      $file =~ s/\.dir$// if ($onVMS);
       my($skip) = 0;
       my($full) = ($dir ne '.' ? "$dir/" : '') . $file;
       ## Check for command line exclusions
 sub modify_assignment_value {
   my($self)  = shift;
   my($name)  = shift;
   my($value) = shift;
-  if ($self->{'convert_slashes'} && $name !~ /flags/) {
+  if ($self->{'convert_slashes'} && index($name, 'flags') == -1) {
-    $value = $self->slash_to_backslash($value);
+    $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;
+  my($self) = shift;
-  my($tag)    = ($self->{'reading_global'} ? 'global_assign' : 'assign');
+  return $self->{$self->{'reading_global'} ? $gassign_key : $assign_key};
-  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;
   ## 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};
+    $assign  = $self->{$self->{'reading_global'} ?
-    ## If we haven't yet defined the hash table in this project
+                               $gassign_key : $assign_key};
-    if (!defined $assign) {
-      $assign = {};
-      $self->{$tag} = $assign;
-    }
+  }
   if (defined $value) {
     $value =~ s/^\s+//;
     $value =~ s/\s+$//;
 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);
+  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;
-    ## Due to the way process_assignment() works, we only need to
+    for(my $i = 0; $i <= $last; $i++) {
+      if ($i == $last) {
-    ## attempt to remove a value that is either followed by a space
+        ## If we did not find the string to subtract in the original
-    ## or at the end of the line (single values are always at the end
+        ## value, try again after expanding template variables for
-    ## of the line).
+        ## subtraction.
-    if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
-      $self->process_assignment($name, $nval, $assign);
+        $nval = $self->get_assignment_for_modification($name, $assign, 1);
-    }
+      }
-    else {
+      for(my $j = 0; $j <= $last; $j++) {
-      ## Try the same thing only with double quotes around the value.
+        ## 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
-      ## Double quotes will be preserved in the value when the value
+        ## attempt to remove a value that is either followed by a space
-      ## contains spaces.
+        ## or at the end of the line (single values are always at the end
-      $value = '"' . $value . '"';
+        ## of the line).
-      if ($nval =~ s/$value\s+// || $nval =~ s/$value$//) {
+        if ($nval =~ s/$re\s+// || $nval =~ s/$re$//) {
-        $self->process_assignment($name, $nval, $assign);
+          $self->process_assignment($name, $nval, $assign);
+          $found = 1;
+          last;
+        }
+      }
+      last if ($found);
+    }
+  }
+}
   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->{$self->{'reading_global'} ?
-    $assign = $self->{$tag};
+                              $gassign_key : $assign_key};
+  }
   return $$assign{$name};
+}
 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());
   return 1;
+}
 sub file_sorter {
-  my($self)  = shift;
+  #my($self)  = shift;
-  my($left)  = shift;
+  #my($left)  = shift;
-  my($right) = shift;
+  #my($right) = shift;
-  return $left cmp $right;
+  return $_[1] cmp $_[2];
+}
 sub read_global_configuration {
   #my($self)  = shift;

Subversion Repositories gelsvn

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