modules/StringProcessor.pm

   1 package StringProcessor;
   2
   3 # ************************************************************
   4 # Description   : Perform various algorithms on strings
   5 # Author        : Chad Elliott
   6 # Create Date   : 3/07/2003
   7 # ************************************************************
   8
   9 # ************************************************************
  10 # Pragmas
  11 # ************************************************************
  12
  13 use strict;
  14
  15 # ************************************************************
  16 # Subroutine Section
  17 # ************************************************************
  18
  19 sub parse_assignment {
  20   my($self, $line, $values) = @_;
  21
  22   ## In MPC, a scope can have spaces in it.  However, it can not end
  23   ## in a space.
  24   ## Line may have embedded new lines, so using 's' modifier.
  25   if ($line =~ /^((\w+[-\s\w]+\w::)*\w+)\s*([\-+]?=)\s*(.*)?/s) {
  26     my $op = ($3 eq '+=' ? 1 : $3 eq '-=' ? -1 : 0);
  27     push(@$values, $op, $self->resolve_alias(lc($1)), $4);
  28     return 1;
  29   }
  30
  31   return 0;
  32 }
  33
  34
  35 sub extractType {
  36   my($self, $name) = @_;
  37   my $type = $name;
  38
  39   if ($name =~ /(.*)(Project|Workspace)Creator/) {
  40     $type = $1;
  41   }
  42
  43   return lc($type);
  44 }
  45
  46
  47 sub process_special {
  48   my($self, $line) = @_;
  49
  50   ## Replace all escaped double quotes and escaped backslashes
  51   ## with special characters
  52   my $escaped = ($line =~ s/\\\\/\01/g);
  53   $escaped |= ($line =~ s/\\"/\02/g);
  54
  55   ## Un-escape all other characters
  56   $line =~ s/\\(.)/$1/g;
  57
  58   ## Remove any non-escaped double quotes
  59   $line =~ s/"//g;
  60
  61   ## Put the escaped double quotes and backslashes back in
  62   if ($escaped) {
  63     $line =~ s/\02/"/g;
  64     $line =~ s/\01/\\/g;
  65   }
  66
  67   return $line;
  68 }
  69
  70
  71 sub create_array {
  72   my($self, $line) = @_;
  73   my @array;
  74
  75   ## Replace all escaped double and single quotes with special
  76   ## characters.  We need to distinguish between doubly escaped quotes
  77   ## (<%equote%>) and escaped quotes (\").  We also need to retain the
  78   ## escaped escape characters.
  79   my $escaped = ($line =~ s/\\\\\"/\01/g);
  80   $escaped |= ($line =~ s/\\\'/\02/g);
  81   $escaped |= ($line =~ s/\\ /\03/g);
  82   $escaped |= ($line =~ s/\\\t/\04/g);
  83   $escaped |= ($line =~ s/\\\"/\05/g);
  84   $escaped |= ($line =~ s/\\\\/\06/g);
  85
  86   foreach my $part (grep(!/^\s*$/,
  87                          split(/(\"[^\"]+\"|\'[^\']+\'|\s+)/, $line))) {
  88     ## Remove enclosing double and single quotes
  89     $part =~ s/^"(.*)"$/$1/;
  90     $part =~ s/^'(.*)'$/$1/;
  91
  92     ## Put any escaped escaped characters back into the string, but
  93     ## processed to take out one of the escape sequences.
  94     if ($escaped) {
  95       $part =~ s/\01/\\"/g;
  96       $part =~ s/\02/\'/g;
  97       $part =~ s/\03/ /g;
  98       $part =~ s/\04/\t/g;
  99       $part =~ s/\05/\"/g;
 100       $part =~ s/\06/\\/g;
 101     }
 102
 103     ## Push it onto the array
 104     push(@array, $part);
 105   }
 106
 107   return \@array;
 108 }
 109
 110
 111 sub crlf {
 112   #my $self = shift;
 113   return "\n";
 114 }
 115
 116
 117 sub windows_crlf {
 118   ## Windows and cygwin require a carriage return and line feed.
 119   ## However, at some point cygwin changed the way it does output and can
 120   ## be controled through an environment variable.
 121   return ($^O eq 'MSWin32' ||
 122           ($^O eq 'cygwin' &&
 123            ($] < 5.008 || (defined $ENV{PERLIO} && $ENV{PERLIO} eq 'crlf'))) ?
 124            "\n" : "\r\n");
 125 }
 126
 127
 128 sub resolve_alias {
 129   #my $self = shift;
 130   #my $name = shift;
 131   return $_[1];
 132 }
 133
 134 sub fgrep {
 135   my($str, $array) = @_;
 136   foreach my $target (@$array) {
 137     return 1 if ($str eq $target);
 138   }
 139   return undef;
 140 }
 141
 142 sub merge {
 143   # Push each element of @$list on to @$into, unless it's already in @$into.
 144   my($into, $list) = @_;
 145   foreach my $in (@$list) {
 146     push(@$into, $in) if (!fgrep($in, $into));
 147   }
 148 }
 149
 150 1;