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   ## Remove any non-escaped double quotes
  56   $line =~ s/"//g;
  57
  58   ## Un-escape all other characters.  Using eval allows the user to pass
  59   ## escaped characters that will be converted to their actual character
  60   ## counterpart (i.e., \n, \f, etc).
  61   if (index($line, '\\') != -1) {
  62     eval("\$line = \"$line\"");
  63   }
  64
  65   ## Put the escaped double quotes and backslashes back in
  66   if ($escaped) {
  67     $line =~ s/\02/"/g;
  68     $line =~ s/\01/\\/g;
  69   }
  70
  71   return $line;
  72 }
  73
  74
  75 sub create_array {
  76   my($self, $line) = @_;
  77   my @array;
  78
  79   ## Replace all escaped double and single quotes with special
  80   ## characters.  We need to distinguish between doubly escaped quotes
  81   ## (<%equote%>) and escaped quotes (\").  We also need to retain the
  82   ## escaped escape characters.
  83   my $escaped = ($line =~ s/\\\\\"/\01/g);
  84   $escaped |= ($line =~ s/\\\'/\02/g);
  85   $escaped |= ($line =~ s/\\ /\03/g);
  86   $escaped |= ($line =~ s/\\\t/\04/g);
  87   $escaped |= ($line =~ s/\\\"/\05/g);
  88   $escaped |= ($line =~ s/\\\\/\06/g);
  89   $escaped |= ($line =~ s/\n/\07/g);
  90
  91   foreach my $part (grep(!/^\s*$/,
  92                          split(/(\"[^\"]+\"|\'[^\']+\'|\s+)/, $line))) {
  93     ## Remove enclosing double and single quotes
  94     $part =~ s/^"(.*)"$/$1/;
  95     $part =~ s/^'(.*)'$/$1/;
  96
  97     ## Put any escaped escaped characters back into the string, but
  98     ## processed to take out one of the escape sequences.
  99     if ($escaped) {
 100       $part =~ s/\01/\\"/g;
 101       $part =~ s/\02/\'/g;
 102       $part =~ s/\03/ /g;
 103       $part =~ s/\04/\t/g;
 104       $part =~ s/\05/\"/g;
 105       $part =~ s/\06/\\/g;
 106       $part =~ s/\07/\n/g;
 107     }
 108
 109     ## Push it onto the array
 110     push(@array, $part);
 111   }
 112
 113   return \@array;
 114 }
 115
 116
 117 sub crlf {
 118   #my $self = shift;
 119   return "\n";
 120 }
 121
 122
 123 sub windows_crlf {
 124   ## Windows and cygwin require a carriage return and line feed.
 125   ## However, at some point cygwin changed the way it does output and can
 126   ## be controlled through an environment variable.
 127   return ($^O eq 'MSWin32' ||
 128           ($^O eq 'cygwin' &&
 129            ($] < 5.008 || (defined $ENV{PERLIO} && $ENV{PERLIO} eq 'crlf'))) ?
 130            "\n" : "\r\n");
 131 }
 132
 133
 134 sub resolve_alias {
 135   #my $self = shift;
 136   #my $name = shift;
 137   return $_[1];
 138 }
 139
 140 sub fgrep {
 141   my($str, $array) = @_;
 142   foreach my $target (@$array) {
 143     return 1 if ($str eq $target);
 144   }
 145   return undef;
 146 }
 147
 148 sub merge {
 149   # Push each element of @$list on to @$into, unless it's already in @$into.
 150   my($into, $list) = @_;
 151   foreach my $in (@$list) {
 152     push(@$into, $in) if (!fgrep($in, $into));
 153   }
 154 }
 155
 156 1;