function_test/Semantic_Analyser/cw.pl

   1 #!/usr/bin/perl -w
   2 ###############################################################################
   3 # Copyright (c) 2000-2015 Ericsson Telecom AB
   4 # All rights reserved. This program and the accompanying materials
   5 # are made available under the terms of the Eclipse Public License v1.0
   6 # which accompanies this distribution, and is available at
   7 # http://www.eclipse.org/legal/epl-v10.html
   8 ###############################################################################
   9 # Contributors:
  10 # Csaba Raduly - author
  11 # Jeno Balasko - Test, troubleshooting, bugfixes
  12
  13 use strict;
  14
  15 my $numtests; # Gotcha! If you assign a value here, it will take effect
  16                # _after_ the BEGIN block!
  17
  18 my %msg_hash;    # repository of expected messages
  19 # A key is an expected message regex.
  20 # A value is a hash reference:
  21 #     the key is the filename and line number combined with a ':'
  22 #     the value is an array reference;
  23 #        [0] is the number of times the message was found
  24 #            (this is initially zero and it's expected to become precisely 1)
  25 #        [1] is the number of times the message is expected to be found on that line
  26 #            (usually one)
  27 # Here's a Data::Dump of one entry in the hash:
  28 # '^In union field' => {
  29 #   'atr_not_on_record_SE.ttcn:4' => [0, 1],
  30 #   'b64_clash_SE.ttcn:24' => [0, 3],
  31 #   'aa_not_in_record_SE.ttcn:4' => [0, 1]
  32 # },
  33
  34 my $need_error = 0;
  35
  36 if ($] < 5.006) {
  37   # ancient perl, we must be on Solaris :(
  38   my @perlloc = qw( /proj/TTCN/Tools/perl-5.10.1/bin/perl /mnt/TTCN/Tools/perl-5.10.1/bin/perl );
  39   foreach (@perlloc) {
  40     if (-x $_) {
  41       #warn "Let's try with $_ instead";
  42       exec( $_, '-w', $0, @ARGV ) or die "That didn't work either: $!";
  43     }
  44   }
  45 }
  46 else
  47 {
  48   unless ($^C or scalar grep { $_ !~ /^-/; } @ARGV) {
  49     # Syntax check, or no arguments which look like filenames
  50     warn 'No arguments given';
  51     exit 0;
  52   }
  53
  54   $numtests = $^C; # If running under -c, pretend to have one test
  55
  56   #$DB::single = 1;
  57
  58   # Parse commandline; read each file and collect the expected error messages
  59   foreach my $arg (@ARGV) {
  60     if ($arg =~ /^-(.*)/) {
  61       next if (length $1); # dash followed by something: must be an option
  62       last; # dash on its own: end of "all" files, start of "out-of-date" files
  63     }
  64
  65     # now $arg should be a filename
  66
  67     if ($arg =~ /_S[WEY]\.(ttcn|asn1?)/) {
  68       $need_error = 1;
  69     }
  70
  71     open( TESTFILE, "< $arg" ) or die "open $arg: $!/$^E";
  72     my $current_lineno = 1;
  73     # Can't rely on $. because continuation lines need to pretend to be
  74     # at the same line as the first line ending in backslash.
  75     while (<TESTFILE>) {
  76       chomp;
  77       while ( s/\\$// ) { # line ends with backslash
  78         my $next_line = <TESTFILE>;
  79         last unless defined $next_line;
  80         chomp $next_line;
  81         $_ .= $next_line;
  82       }
  83       next unless s!//(.+?)//(\d*)!!;    # If //regex// not found, read another line
  84       my $rex_text = $1;
  85       my $multiplier = ($2 || 1);
  86
  87       $msg_hash{$rex_text}->{"$arg:$current_lineno"} = [0, $multiplier];
  88       ++$numtests;
  89
  90       redo; # there may be multiple regexes in the same line
  91     }
  92     continue {
  93       $current_lineno = $. + 1;
  94     } # next line
  95     close(TESTFILE) or die "close $arg: $!/$^E";
  96   }
  97
  98   #warn "Collected $numtests";
  99
 100   require Test::More;
 101   # If no regexes found, pretend to have one test.
 102   Test::More->import( tests => $numtests || 1 );
 103 }
 104
 105
 106
 107 # Something nobody expects
 108 use constant cardinal_jimenez => "Spanish Inquisition";
 109
 110 $ENV{TTCN3_DIR} ||= '../../Install';
 111 my $compiler = $ENV{TTCN3_DIR} . '/bin/compiler';
 112
 113 # Don't confuse Test::Harness
 114 my $quiet = exists $ENV{'HARNESS_ACTIVE'};
 115
 116 if ($0 =~ /SE\.t$/) {
 117   # If run as a .t, test a single file
 118   $0 =~ s!^t/!!; # remove the directory prefix, if any
 119   @ARGV = ( $0 . 'tcn' );
 120 }
 121
 122
 123 my $num_expected = scalar keys %msg_hash;
 124 if ($need_error and 0 == $num_expected) {
 125   die "No expected errors! Files with _S[WYE] are supposed to contain errors/warnings!";
 126 }
 127
 128 # Transfer messages from the hash to an array.
 129 # Hash keys must be strings, regexes don't work.
 130 # There is no such limitation for array elements.
 131 # There is only sequential access to the messages from this point.
 132 my @mess_ages;
 133 while (my ($key, $val) = each %msg_hash) {
 134   push @mess_ages, [ qr/$key/, $val ];
 135 }
 136
 137 my @unexpected_msgs;
 138
 139 # Empty the hash so hopefully nobody uses it
 140 %msg_hash = ();
 141 undef %msg_hash;
 142
 143 ####### run the compiler and filter the output #######
 144
 145 warn "$compiler @ARGV "  unless $quiet;
 146
 147 my $compiler_pid;
 148 eval {
 149 local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
 150 alarm 600; # seconds, maximum time to wait for the compiler
 151
 152 $compiler_pid = run_compiler ($compiler);
 153
 154 #use Data::Dumper;
 155 # DUMP DUMP DUMP DUMP DUMP DUMP DUMP DUMP DUMP DUMP DUMP DUMP
 156 #print ("After input: ", Dumper \ @mess_ages) if exists $ENV{CW_DUMP};
 157
 158 alarm 0;
 159 $_=0;
 160 }; #eval
 161
 162 if ( $_ ) {
 163   die ">>$_<<" unless $@ eq "alarm\n";   # propagate unexpected errors
 164   # timed out
 165   kill 'TERM', $compiler_pid;
 166   close( PIPE );
 167   die "Titan compiler timeout :(" ;
 168 }
 169 else {
 170   # didn't
 171 }
 172
 173 if ( close(PIPE) ) {
 174   # compiler exited with success
 175   # TO DO: fail if there _were_ error regexes
 176 }
 177 else {
 178   # compiler exited with nonzero
 179   if ($!) {
 180     die "close pipe: $!/$^E";
 181   }
 182   else {
 183     # TO DO: fail if there were no error regexes
 184   }
 185 }
 186
 187
 188 ####### Now check what we have found. #######
 189
 190 if ($num_expected == 0) {
 191   is (scalar @unexpected_msgs, $num_expected, "No messages")
 192 }
 193
 194 {
 195   foreach my $el (sort {$a->[0] cmp $b->[0]} (@mess_ages, @unexpected_msgs) ) {
 196     my $e  = $el->[0]; # regex
 197     my $hr = $el->[1]; # hash ref
 198
 199     foreach my $loc (sort keys %$hr) {
 200       my $found = $$hr{$loc};
 201       if ($found->[0] eq cardinal_jimenez) {
 202         fail("unexpected message: [$e]");
 203         print STDERR "$loc:error: unexpected message; [$e]\n"; # unless $quiet; # GCC-like error message
 204       }
 205       else {
 206         if( is( $found->[0], $found->[1], "Finding /$e/ at $loc" ) ) {} # do nothing
 207         else{
 208           my $reason = ($found->[0] == 0) ? "not found  message" : "found too many time";
 209           print STDERR "$loc:error: $reason; [$e]\n"; # unless $quiet;
 210         }
 211       }
 212     }    # foreach location
 213   }    # foreach message
 214 }
 215
 216 # Transfer all "unexpected" messages into expected messages in the TTCN-3/ASN.1 file
 217 if (exists $ENV{HACK}) {
 218   foreach my $arg (@ARGV) {
 219     next if $arg =~ /^-/;
 220 #warn "patching $arg";
 221     open( TESTFILE, '<' . $arg ) or die "open  $arg: $!/$^E";
 222     my @content = <TESTFILE>;
 223     close( TESTFILE )          or die "close $arg: $!/$^E";
 224     my $is_asn1 = $arg =~ /\.asn/;
 225
 226     chomp @content; # all lines
 227     s!//\s*(.+)$!/* $1 */! for @content;
 228
 229     foreach my $el ( @mess_ages ) {
 230       my $e  = $el->[0]; # regex
 231       my $hr = $el->[1]; # hash ref
 232       while (my ($loc, $found) = each %$hr) {
 233         if ($loc =~ /$arg/) {
 234           my $line = $loc;
 235           $line =~ s/.*://;
 236           print "found [$e] at $line  x $found->[0]\n";
 237           #print $content[$line -1]; # array is 0-based
 238           my $regex = $e;
 239           $regex =~ s/\(\?-\w+:(.+)\)/$1/;
 240           my $mult = ($found->[0] > 1) ? $found->[0]+1 : '';
 241           # This "+1" is an empirical hack----------^^
 242
 243           if ($is_asn1 and $content[$line -1] !~ m!--\t//!) {
 244             # If this is an ASN.1 file and this is the first time appending
 245             # to this particular line, append a '--' first,
 246             # because ASN.1 doesn't treat // as comment
 247             $content[$line -1] .= ' --';
 248           }
 249           $content[$line -1] .= "\t//$regex//$mult";
 250         }
 251       }
 252     }
 253     #
 254     open( TESTFILE, '>' . $arg . '3' ) or die "open  $arg: $!/$^E";
 255     local $, = "\n";
 256     print TESTFILE @content;
 257     close( TESTFILE ) or die "close $arg: $!/$^E";
 258 #    last;
 259   }
 260   exit 0;
 261 }
 262
 263 #############################################################################
 264
 265 sub run_compiler {
 266   my $compiler = shift;
 267
 268   my $c_pid = open( PIPE, "$compiler @ARGV 2>&1 1>/dev/null | " )
 269   #                                                           tee compiler.output.parsed |
 270     or die "open pipe: $!/$^E";
 271
 272   my $last_loc;
 273 INPUT: while (<PIPE>) {
 274
 275     #warn $. . \';\' . $_;
 276     chomp;
 277     my ( $loc, $error );
 278
 279     # Titan errors look like:
 280     # file (for messages applied directly to the module, e.g. circular import)
 281     # file:line
 282     # file:line.col
 283     # file:line.col-col
 284     # file:line.col-line.col
 285     # file:line:col (in GCC-mode)
 286     if (
 287       /^\s*
 288         (\S+?:\d+)            # file:line
 289         (?:                   # non-capturing group
 290         \. \d+                #   dot and the column number, or
 291         | \. \d+ - \d+        #   dot and two columns, or
 292         | \. \d+ - \d+ \. \d+ #   dot, column, dash, line, dot, column, or
 293         | \: \d+              #   GCC style, colon and column
 294         )?                    # maybe
 295         :                     # colon
 296         \s*                   # maybe some whitespace
 297         (.+)      # message
 298         /x
 299       )
 300     {
 301       $loc = $last_loc = $1;
 302       $error = $2;
 303
 304       #warn "loc=$1\nerr=$2\n";
 305     check:
 306       $error =~ s/note: //;    # compiler -i swallows "note". Compensate it here for -g
 307       my $found_some = 0;
 308
 309       # see if one of the "registered" errors matches
 310       foreach my $e ( @mess_ages ) {
 311         if ( $error =~ $e->[0] ) {
 312
 313           my ($found_loc) = $loc =~ /^\s*(\S+?:\d+)/;
 314
 315           if ( exists $e->[1]->{$found_loc} ) {
 316             ++$e->[1]->{$found_loc}->[0];
 317
 318             ++$found_some;    # the message was expected
 319           }
 320
 321           # else right message, wrong place
 322         }
 323       }
 324
 325       unless ($found_some) {
 326
 327         # Looks like an error but wasn\'t matched.
 328         # Sneak it into the list of expected messages
 329         # with a marker that says: "this was unexpected".
 330
 331         $error = quotemeta($error); # don\'t try to guess metacharacters, escape all non-word characters
 332         $error =~ s/\\(\s)/$1/g;    # but don\'t escape whitespace, readability suffers
 333
 334         push @unexpected_msgs, [ qr/^$error$/, { $loc => [ cardinal_jimenez, 0 ] }  ];
 335         # Don't bother checking if $error is already present (for another unexpected).
 336         # Duplicating the array element works just as well as finding the existing
 337         # array element and adding to its inner hash.
 338       }
 339     }    # if (it looks like an error message)
 340     elsif (/^\S*compiler\S*: ((?:error|warning): .*?[``](\S+)[''].*)/) { # redundant `' help nedit syntax highlight
 341       # mycompiler: error: Cannot recognize file `ASN1_Invalid_module_identifier-A.asn3\' ....
 342       $loc = "$2:1";   # assume it contains a `filename\' , pretend to be on the first line (eight????)
 343       $error = $1;
 344       goto check;
 345     }
 346     elsif (/^\s*(\S*: )?((?:warning|error|note): .+)/
 347       or   /^\s*(\S*: )(In .+)/)
 348     {       # an error/warning without line number
 349       my $fname = $1;
 350       if ( defined $fname ) {
 351         $fname =~ s/: //;
 352         $loc = "$fname:8"; #8: line number of the line containing "module"
 353       }
 354       else {
 355         $loc = $last_loc;
 356       }
 357       #$loc = defined($1) ? $1 : $last_loc; # guess that it belongs to the last seen line number
 358       #                   (usually a \'note\' from the error context)
 359       $error = $2;
 360       goto check;
 361     }
 362   }    # while
 363
 364   return $c_pid;
 365 }
 366 __END__
 367
 368 Compiler wrapper
 369 First, it reads the TTCN-3 files and extracts the expected messages.
 370 These are regular expressions delimited by // and //
 371 (because // is a comment in TTCN-3 and //xxx// looks somewhat like a sed/Perl/Javascript
 372 regular expression: /xxx/).
 373
 374 Next, it runs the compiler and checks for the expected messages in the output.