function_test/Tools/SAtester.pl

   1 #!/usr/bin/perl -w
   2 ###############################################################################
   3 # Copyright (c) 2000-2014 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 ##
  10 ##  File       :  SAtester.pl
  11 ##  Description:  Tester utility for Semantic Analyser, TITAN
  12 ##  Written by :  Endre Szalai (Endre.Szalai@ericsson.com)
  13 ##
  14
  15 ## TODO: exit status always 0, investigate why; workaround: catch the notify
  16 ## printout from the compiler
  17
  18 require 5.6.1;
  19
  20 use strict;
  21 use Getopt::Long;
  22
  23 ###############################################################################
  24 ###                               Global Variables
  25 ###############################################################################
  26 # Whether to stop on test case failures (1) or not (0)
  27 my $sa_halt_on_errors = '';
  28 # Whether to list available test cases or not
  29 my $sa_list_TCs = 0;
  30 # Whether to show info or not
  31 my $sa_info = 0;
  32 # Whether to use matching in test case selection
  33 my $sa_tc_select = '';
  34 # Name of the logfile
  35 my $sa_logFile = '';
  36 my $sa_LOG;
  37 # Elapsed time in this session
  38 my $sessionTime;
  39 # Whether to show command line info or not
  40 my $sa_printHelp_cmd = 0;
  41 # Whether to show detailed info or not
  42 my $sa_printHelp_doc = 0;
  43 # Use function-test runtime or not
  44 my $sa_titanRuntime2 = 0;
  45 # Enable coverage or not
  46 my $sa_coverageEnabled = 0;
  47 # Files existed before a test case execution
  48 my %sa_existedFiles;
  49 # Store input TD files from which TCs are collected
  50 my @sa_scriptFiles;
  51 # Store information about the TCs to execute
  52 my @sa_tcList2Execute;
  53 # Store test case data
  54 my @sa_TCInfo;
  55 # Timeout for system calls in seconds
  56 my $sa_timeout = 30;
  57 # Max time to wait for a license, in multiple of 10 minutes
  58 my $max_cycles = 6;
  59 # Execution statistics
  60 # Number of TCs: PASSED, FAILED, ERROR verdicts,
  61 #                abnormally terminated, memory leaked
  62 my @sa_executionStatistics = (0, 0, 0, 0, 0);
  63 # Command to invoke the titan compiler
  64 my $sa_compilerCmd;
  65 # Command to invoke the titan Makefile generator
  66 my $sa_mfgenCmd;
  67 # Command to invoke the runtime execution
  68 my $sa_runtimeCmd;
  69 # commonly used regexps
  70 my $sa_re_TCheader = "\\n\\s*<\\s*TC\\s*-\\s*(.+?)\\s*>\\s*\\n";
  71 my $sa_re_MODULEheader = "\\n\\s*<\\s*MODULE\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s*>";
  72 my $sa_re_MODULEbody = "${sa_re_MODULEheader}\\s*(.+?)\\n\\s*<\\s*END_MODULE\\s*>";
  73 my $sa_re_RESULTheader = "\\n\\s*<\\s*RESULT\\s*(IF_PASS|IF_FAIL)?\\s*(LTRT|FTRT)?\\s*(POSITIVE|NEGATIVE)?\\s*(?:COUNT\\s+(\\d+))?.*?>";
  74 my $sa_re_RESULTbody = "${sa_re_RESULTheader}\\s*(.*?)\\s*\\n\\s*<\\s*END_RESULT\\s*>";
  75 my $sa_re_EXPECTEDbody = "\\s*<\\s*VERDICT_LEAF\\s+(PASS|FAIL)\\s*>\\s*";
  76 my $sa_re_MemoryLeak = "(?:unallocated\\s+blocks\\s*:\\s*)|(?:Memory\\s+leakage\\s+detected)";
  77 # separator for printouts
  78 my $sa_separator = "===============================================================\n";
  79
  80
  81 # Detailed info about the usage
  82 my $sa_detailedInfo = '
  83 Purpose
  84 -------
  85 The tester program was written especially for testing the semantic analyser
  86 functionality in TITAN. A generic test flow looks like:
  87 - generate input sources (TTCN-3 and/or ASN.1)
  88 - compile them with the TITAN compiler
  89 - check that the error messages are as expected (negative testing)
  90 - check that the modules are compiled both with TITAN and gcc
  91   (positive testing)
  92 Test cases and all information needed to execute them are stored in one file, in
  93 the Test Description files (*.script) in EDML format. The tester program uses
  94 this file to execute the test according to the flow described above in a fully
  95 automatic way..
  96 Unlike in a simple test method, where a test may be passed or failed, in
  97 regression test it might be important, why a test case is failed (e.g. due to a
  98 not yet implemented feature). Therefore, each test case may have two separate
  99 expected behaviour (called leaves later on). The first is the case when the test
 100 purpose is expected to work in a specific way (IF_PASS leaf). The other, when
 101 the test case is expected to fail, but why it fails is also interesting (IF_FAIL
 102 leaf). Each test case may have both leaves and a specific selector points out
 103 which leaf is expected to occur. This also means, that a test case passes, if
 104 the selected leaf is passed (which may be the IF_FAIL leaf). Therefore, the
 105 tester needs to check test cases that are failed, as only in those cases the
 106 current result is not as expected.
 107
 108 Features
 109 --------
 110 The tester program has the following features:
 111 1. Support for one-by-one and batched execution of test cases.
 112 2. Support for unlimited number of input modules: ASN.1,
 113 TTCN-3 and runtime config files for TITAN.
 114 3. Support for compilation of the modules using TITAN and
 115 GCC. It also supports single mode execution of the test suite.
 116 Makefile and test port files generation is automatic.
 117 5. Automatic cleanup after each test case.
 118 6. Flexible pattern matching for the test case printout using
 119 Perl regexps combined with different matching logic.
 120 7. Support for regression testing process.
 121
 122 Reference
 123 ---------
 124 For a list of command line options, execute the tester program with
 125 SAtester.pl -help
 126
 127 A test case structure in the EDML files looks like:
 128 test case block:
 129   <TC - test case name>
 130 compile block:
 131   [<COMPILE|COMPILEGCC|EXECUTE|EXECUTE_PARALLEL>]   (default is COMPILE)
 132 leaf selector block:
 133   <VERDICT_LEAF (PASS|FAIL)>
 134 module block(s):
 135   <MODULE TTCN|ASN|CFG modulename filename>
 136     ... text from here is written to the filename specified above ...
 137   <END_MODULE>
 138   ... several module sections may follow ...
 139 result block(s):
 140   <RESULT IF_PASS|IF_FAIL [POSITIVE|NEGATIVE|COUNT number]>   (default is POSITIVE)
 141     ... pattern in Perl regexp format ...
 142   <END_RESULT>
 143   ... several result sections may follow ...
 144
 145   <END_TC>
 146
 147 Each block header/footer must be single-line, i.e. newline is not allowed.
 148
 149 The compile block instructs the SAtester to:
 150   COMPILE    compile the modules using TITAN only
 151   COMPILEGCC compile the modules using TITAN and GCC afterwards
 152              (the Makefile is automatically generated)
 153   EXECUTE    after compilation, execute the executable test suite
 154              the first runtime configuration file is passed to TITAN
 155              (single mode execution)
 156   EXECUTE_PARALLEL  after compilation, execute the executable test suite
 157              (parallel mode execution)
 158 If any of the actions fail, the test case result will be "ERROR". This block is
 159 optional, the default value is COMPILE.
 160
 161 The leaf selector block helps the regression testing process, where not only the
 162 verdict itself, but the expected verdict is interesting. The value may be PASS
 163 or FAIL. The leaf selector selects which RESULT blocks to use when matching the
 164 printout from the compiler(s).
 165
 166 A module block instructs the SAtester to produce a source module
 167 or a runtime configuration file:
 168   TTCN       The module is treated as a TTCN-3 module
 169   ASN        The module is treated as an ASN.1 module
 170   CFG        The module is treated as a runtime configuration file
 171   modulename Name of the module
 172   filename   Name of the file to be produced
 173 The text within this section is written as is to "filename". You may specify as
 174 many modules as you need.
 175
 176 A result block instructs the SAtester how to check result as soon the actions in
 177 the compile block is finished successfully.
 178 Either:
 179   POSITIVE   Indicates a positive pattern match (i.e. =~ syntax in Perl)
 180              with the supplied pattern is needed to continue
 181   NEGATIVE   Indicates a negative pattern match (i.e. !~ syntax in Perl)
 182              with the supplied pattern is needed to continue
 183 Or:
 184   COUNT      Indicates that instead of a direct pattern match, perform
 185              a counting of the supplied pattern. If the number of pattern-
 186              matches equals to the supplied number in COUNT section, the
 187              execution continues
 188   POSITIVE or NEGATIVE can be used for simple pattern match, i.e. whether the
 189   pattern is present or not.
 190   COUNT can be used to detect that a pattern how many times are present.
 191 Result blocks are evaluated in the order of their appearence. If any of the
 192 result block is failed, the verdict will be "FAILED" and execution continues
 193 with the next test case (if any). Entries in the result header are optional, the
 194 default value is "POSITIVE".
 195
 196 Memory leak printouts are automatically detected. If one is found, the current
 197 verdict will be "FAIL".
 198
 199 Example
 200 -------
 201 //line comments are written for understanding only
 202
 203 // Name of the test case
 204 <TC - TTCN-3::Subtypes, list of values: Anytype>
 205 // compile with TITAN only
 206 <COMPILE>
 207 // "anytype" is not supported, so use the FAIL-leaf
 208 // in result matching
 209 <VERDICT_LEAF FAIL>
 210 // Specify one module
 211 <MODULE TTCN ModuleA ModuleA.ttcn>
 212 module ModuleA {
 213    type anytype MyType ( 10, 11.0, Nonexi, false );
 214 }
 215 <END_MODULE>
 216 // PASS-leaf of the result matching
 217 // used if VERDICT_LEAF is "PASS"
 218 // expecting exactly 1 "no imported or local definition nonexi"
 219 <RESULT IF_PASS COUNT 1>
 220 (?im)\berror\b.+?no.+?definition.+?nonexi
 221 <END_RESULT>
 222 // expecting exactly 1 "error", so no other error shall
 223 // occur than the previous error
 224 <RESULT IF_PASS COUNT 1>
 225 (?is)\berror\b
 226 <END_RESULT>
 227 // expecting a notification that no code is generated due
 228 // to the error
 229 <RESULT IF_PASS POSITIVE>
 230 (?im)\bnotify\b.+?\bcode\b.+?\bnot\b.+?\bgenerated\b
 231 <END_RESULT>
 232 // FAIL-leaf of the result matching
 233 // used if VERDICT_LEAF is "FAIL"
 234 // expecting exactly 1 "parse error"
 235 <RESULT IF_FAIL COUNT 1>
 236 (?im)parse.+?error
 237 <END_RESULT>
 238 // expecting exactly 1 "error", so no other error shall
 239 // occur than the parse error
 240 <RESULT IF_FAIL COUNT 1>
 241 (?is)\berror\b
 242 <END_RESULT>
 243 <END_TC>
 244
 245 Information about Perl regular expressions can be found at:
 246 www.perl.com
 247
 248 Guides
 249 ------
 250 1. Use the IF_FAIL leaf only, if the test case is expected to fail because of a
 251 missing functionality that will not be implemented in the current project. Using
 252 IF_FAIL leaves for limitations that are expected to disappear within a project
 253 is just an unnecessary overhead.
 254
 255 2. Whenever a TR is issued, this should be mentioned in the test case, within
 256 the source module where the error occured, e.g.
 257 <MODULE TTCN ModuleA ModuleA.ttcn>
 258 module ModuleA {
 259    // TR 623: length restriction of charstrings
 260    type record of charstring MyType7 length(0..666-Nonexi);
 261 }
 262 <END_MODULE>
 263
 264 3. Always expect a specific error message, but be a bit flexible in pattern
 265 matching. Always check that no other errors occured. E.g.:
 266 <RESULT IF_PASS COUNT 1>
 267 (?im)\berror\b.+?no.+?definition.+?nonexi
 268 <END_RESULT>
 269 <RESULT IF_PASS COUNT 1>
 270 (?is)\berror\b
 271 <END_RESULT>
 272 <RESULT IF_PASS POSITIVE>
 273 (?im)\bnotify\b.+?\bcode\b.+?\bnot\b.+?\bgenerated\b
 274 <END_RESULT>
 275 Note the non-case sensitive matching; that only 1 error is expected and that no
 276 code is expected to be generated.
 277
 278 Known issues
 279 ------------
 280 On cygwin, fork does not always work and Perl stops with an error like:
 281 264 [main] perl 2216 fork_copy: linked dll data/bss pass 0 failed,
 282 0x412000..0x412370, done 0, windows pid 1832, Win32 error 487
 283
 284 ';
 285
 286
 287
 288
 289 # easterEgg
 290 my $sa_egg = '
 291                      \\\\\\\\|////
 292                     \\\\  - -  //
 293                     #(  @ @  )#
 294                       \  o  /
 295                        \ * /
 296 ---------------------oOOo--oOOo-------------------------
 297        "Do or do not. There is no try." - Yoda
 298 ------------------------ooooO---Ooooo-------------------
 299                         (   )   (   )
 300                          \  |   |  /
 301                           (_|   |_)
 302     -- This amazing code was created by McHalls --
 303
 304 ';
 305
 306
 307 ###############################################################################
 308 ##                                  Subs
 309 ###############################################################################
 310 sub sa_commandLineInfo();
 311 sub sa_log($);
 312 sub sa_processArgs($);
 313 sub sa_processCommandLine();
 314 sub sa_readFile($);
 315 sub sa_writeFile($$);
 316 sub sa_collectTCs();
 317 sub sa_isInList(\@$);
 318 sub sa_getTCInfo(\@$$);
 319 sub sa_parseTCs();
 320 sub sa_writeModulesOfTC(\@);
 321 sub sa_deleteModulesOfTC(\@);
 322 sub sa_fetchExecutableName();
 323 sub sa_executeCommand($);
 324 sub sa_compileTC(\@);
 325 sub sa_printResult($$);
 326 sub sa_checkTCResult(\@$);
 327 sub sa_executeTCs();
 328
 329 # Print command line information
 330 sub sa_commandLineInfo () {
 331    sa_log("\nPerl utility to execute test cases for Semantic Analyser\n");
 332    sa_log("Contact: Endre Szalai (Endre.Szalai\@ericsson.com)\n");
 333    sa_log("Usage: SA_tester.pl\n");
 334    sa_log("       [-halt] [-list] [-help] [-doc] [-rt2] [-coverage]\n");
 335    sa_log("       [-select <pattern>]\n");
 336    sa_log("       [-timeout <timeout>]\n");
 337    sa_log("       [<TDfile1.script>] ... [<TDfileN.script>]\n");
 338    sa_log("       [\"<test case name1>\"] ... [\"<test case nameM>\"]\n");
 339    sa_log("       [-log <logfilename>]\n");
 340    sa_log("Where\n");
 341    sa_log(" -halt            halt on any errors\n");
 342    sa_log(" -list            list available test cases\n");
 343    sa_log(" -help            display command line parameters\n");
 344    sa_log(" -doc             display complete documentation\n");
 345    sa_log(" -rt2             use function-test runtime\n");
 346    sa_log(" -coverage        enable coverage");
 347    sa_log(" <pattern>        select test cases if pattern is present in the\n");
 348    sa_log("                  name of the test case\n");
 349    sa_log(" <timeout>        maximum execution time of a system call\n");
 350    sa_log("                  in seconds (default is $sa_timeout)\n");
 351    sa_log(" <logfilename>    name of the logfile\n");
 352    sa_log("                  NOTE: do NOT use the .log file extension !\n");
 353    sa_log(" <TDfile.script>  name of the TD file(s) to collect test cases from\n");
 354    sa_log(" <test case name> name of the test case(s) to execute\n");
 355    sa_log("If no TDfile(s) are defined, all script files from the current\n");
 356    sa_log("directory are considered.\n");
 357    sa_log("If no test cases are defined, all test cases from the script files\n");
 358    sa_log("are executed.\n\n");
 359 }
 360
 361 # Log entries
 362 sub sa_log($) {
 363    print $_[0];
 364    if (defined($sa_LOG)) { print $sa_LOG $_[0]; }
 365 }
 366
 367 # Process the command line
 368 sub sa_processArgs($) {
 369    if ($_[0] =~ /\.script$/m) { $sa_scriptFiles[scalar @sa_scriptFiles] = $_[0]; }
 370    else { $sa_tcList2Execute[scalar @sa_tcList2Execute] = $_[0]; }
 371 }
 372 sub sa_processCommandLine() {
 373
 374    die unless (GetOptions('halt'      => \$sa_halt_on_errors,
 375                           'list'      => \$sa_list_TCs,
 376                           'credit'    => \$sa_info,
 377                           'help'      => \$sa_printHelp_cmd,
 378                           'doc'       => \$sa_printHelp_doc,
 379                           'rt2'       => \$sa_titanRuntime2,
 380                           'coverage'  => \$sa_coverageEnabled,
 381                           'log=s'     => \$sa_logFile,
 382                           'timeout=s' => \$sa_timeout,
 383                           'select=s'  => \$sa_tc_select,
 384                           'maxcycle=s'=> \$max_cycles,
 385                           "<>"        => \&sa_processArgs));
 386    if ($sa_info) {print $sa_egg; exit(1);}
 387    if ($sa_logFile ne '') {
 388       die "Never use '.log' extension as TITAN's cleanup may remove it, specify a different name\n"
 389          unless ($sa_logFile !~ /.*\.log$/is);
 390       open ($sa_LOG, ">$sa_logFile") or die "Cannot open log file: '$sa_logFile': $!\n";}
 391    if ($sa_printHelp_cmd) {sa_commandLineInfo(); exit(1);}
 392    if ($sa_printHelp_doc) {sa_log ($sa_detailedInfo); exit(1);}
 393 }
 394
 395 # Read and return the content of a file
 396 sub sa_readFile($) {
 397    # $_[0] : name of the file
 398    my $Buffer;
 399    sa_log("Parsing file $_[0]...\n");
 400    open (TMP, "$_[0]") or die "Cannot open script file: '$_[0]': $!\n";
 401       read(TMP, $Buffer, -s "$_[0]");
 402    close (TMP);
 403    # remove carriage returns
 404    # Unix/windows: \n \r combo
 405    if ($Buffer =~ /\n/s) {$Buffer =~ s/\r//g;}
 406    # Mac: only \r
 407    else {$Buffer =~ s/\r/\n/g;}
 408    return $Buffer;
 409 }
 410
 411 # Write a file
 412 sub sa_writeFile($$) {
 413    # $_[0] : name of the file
 414    # $_[1] : content of the file
 415    sa_log("Flushing file $_[0]...\n");
 416    open (TMP, ">$_[0]") or die "Cannot open file: '$_[0]': $!\n";
 417       print(TMP $_[1]);
 418    close (TMP);
 419 }
 420
 421 # Checks whether a TC is on the list
 422 sub sa_isInList(\@$) {
 423    my $poi = $_[0];
 424    foreach my $val (@{$poi}) {
 425       if ($val eq $_[1]) {return 1;}
 426    }
 427    return 0;
 428 }
 429 # Collect test cases from command line and/or script files
 430 sub sa_collectTCs() {
 431    # No script files are defined, collect all script files from
 432    # current directory
 433    if (scalar @sa_scriptFiles == 0) {
 434       my @list = split (/\s/, `ls *.script`);
 435       foreach my $filename (@list) { $sa_scriptFiles[scalar @sa_scriptFiles] = $filename; }
 436    }
 437    # no test cases specified, collect from available script files
 438    if (scalar @sa_tcList2Execute == 0) {
 439       foreach my $filename (@sa_scriptFiles) {
 440          my $Buffer = sa_readFile($filename);
 441          while ($Buffer =~ s/^.*?${sa_re_TCheader}//s) {
 442             my $tcName = $1;
 443             if (sa_isInList(@sa_tcList2Execute,$tcName))
 444                 {sa_log( "WARNING: Test case name is not unique: '$tcName'\n");}
 445             # execute test case if match with pattern or no pattern available
 446             if ((not $sa_tc_select) or
 447                 ($sa_tc_select and ($tcName =~ /$sa_tc_select/))) {
 448                $sa_tcList2Execute[scalar @sa_tcList2Execute] = $tcName;
 449             }
 450          }
 451       }
 452    }
 453    my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute;
 454    my $nrOfScriptFiles = scalar @sa_scriptFiles;
 455    sa_log( "$sa_nrOfTCs2Execute test cases from $nrOfScriptFiles script files to be executed\n");
 456    my $tmp = ($sa_halt_on_errors) ? "halting on errors\n" : "ignoring errors\n";
 457    sa_log( "Mode: $tmp");
 458 }
 459
 460
 461 # Gather execution information according to:
 462 # [N] Nth test case
 463 #   [0] test case name
 464 #   [1] "COMPILE", "COMPILEGCC" or "EXECUTE"
 465 #   [2][N] Nth module
 466 #        [0] module type ("ASN", "TTCN" or "CFG")
 467 #        [1] module name (if ASN or TTCN)/execution mode (if CFG)
 468 #        [2] filename to use for the module
 469 #        [3] content of the module
 470 #   [3]{'PASS'|'FAIL'}[N] Nth result for expected result leaf PASS|FAIL
 471 #        [0] result type ("POSITIVE" or "NEGATIVE")
 472 #        [1] match expression
 473 #        [2] number of coccurances (if "COUNT" used in RESULT)
 474 #   [4] name of the source script file
 475 #   [5] expected test case result leaf selector (PASS, FAIL)
 476 #   [6] verdict of the TC
 477 #   [7] flag whether memory leak is detected or not (defined/not defined)
 478 #   [8] flag whether abnormal termination is detected or not (defined/not defined)
 479 sub sa_getTCInfo(\@$$) {
 480    my ($poi, $Buffer, $filename) = @_;
 481    my $tcidx = scalar @{$poi};
 482    if ($Buffer =~ s/${sa_re_TCheader}//s) { $poi->[$tcidx][0] = $1; }
 483    else { die "ERROR: Cannot find test case name in current block\n"; }
 484    if ($Buffer =~ s/<\s*EXECUTE\s*>//m) { $poi->[$tcidx][1] = 'EXECUTE'; }
 485    elsif ($Buffer =~ s/<\s*EXECUTE_PARALLEL\s*>//m) { $poi->[$tcidx][1] = 'EXECUTE_PARALLEL'; }
 486    elsif ($Buffer =~ s/<\s*COMPILEGCC\s*>//m) { $poi->[$tcidx][1] = 'COMPILEGCC'; }
 487    else { $poi->[$tcidx][1] = 'COMPILE'; }
 488    if ($Buffer =~ /${sa_re_EXPECTEDbody}/m) { $poi->[$tcidx][5] = $1; }
 489    else { $poi->[$tcidx][5] = 'PASS'; }
 490    my $idx = 0;
 491    while ($Buffer =~ s/${sa_re_MODULEbody}//s) {
 492       $poi->[$tcidx][2][$idx][0] = $1;
 493       $poi->[$tcidx][2][$idx][1] = $2;
 494       $poi->[$tcidx][2][$idx][2] = $3;
 495       $poi->[$tcidx][2][$idx][3] = $4;
 496       $idx++;
 497    }
 498    while ($Buffer =~ s/${sa_re_RESULTbody}//s) {
 499       my $expectedVerdict;
 500       if (defined($1)) {
 501          $expectedVerdict = ($1 eq 'IF_FAIL') ? 'FAIL':'PASS';
 502       } else { $expectedVerdict = 'PASS'; }
 503       my $idx = (defined($poi->[$tcidx][3]{$expectedVerdict}))
 504                ? scalar @{$poi->[$tcidx][3]{$expectedVerdict}} : 0;
 505       if (defined($2)) {
 506         # Skip matching strings intended for the load-test run-time when
 507         # "-rt2" is used.  Vice versa.
 508         if ($2 eq 'LTRT' and $sa_titanRuntime2
 509             or $2 eq 'FTRT' and not $sa_titanRuntime2) { next; }
 510       }
 511       if (defined($3)) {
 512          $poi->[$tcidx][3]{$expectedVerdict}[$idx][0] = ($3 ne '') ? $3 : 'POSITIVE';}
 513       else {$poi->[$tcidx][3]{$expectedVerdict}[$idx][0] = 'POSITIVE';}
 514       if (defined($4)) { $poi->[$tcidx][3]{$expectedVerdict}[$idx][2] = $4; }
 515       $poi->[$tcidx][3]{$expectedVerdict}[$idx][1] = $5;
 516       eval { '' =~ /$poi->[$tcidx][3]{$expectedVerdict}[$idx][1]/ };
 517       if ($@) {
 518          sa_log("In file $filename, test case '$poi->[$tcidx][0]'\n");
 519          sa_log "  Syntax error in provided pattern:\n  $poi->[$tcidx][3]{$expectedVerdict}[$idx][1]\n$@\n";
 520          exit(1);
 521       }
 522    }
 523    $poi->[$tcidx][4] = $filename;
 524    $poi->[$tcidx][6] = 'NONE';
 525 }
 526 # Parse test case data
 527 sub sa_parseTCs() {
 528    # give only a list of the test cases
 529    if ($sa_list_TCs) {
 530       sa_log( "Collected test cases:\n");
 531       my $idx = 1;
 532       # collect test case data from all specified script files
 533       foreach my $filename (@sa_scriptFiles) {
 534          my $Buffer = sa_readFile($filename);
 535          while ($Buffer =~ s/^.*?(${sa_re_TCheader}.+?<END_TC>)//s) {
 536             sa_getTCInfo(@sa_TCInfo, $1, $filename);
 537          }
 538       }
 539       foreach my $poi (@sa_TCInfo) {
 540          sa_log( "$idx.  '$poi->[0]'     \n");
 541          sa_log( "    source:$poi->[4];   leaf:$poi->[5]\n");
 542          $idx++;
 543       }
 544       exit(1);
 545    }
 546    foreach my $filename (@sa_scriptFiles) {
 547       my $Buffer = sa_readFile($filename);
 548       while ($Buffer =~ s/^.*?(${sa_re_TCheader}.+?<END_TC>)//s) {
 549          if (not sa_isInList(@sa_tcList2Execute,$2)) { next; }
 550          sa_getTCInfo(@sa_TCInfo, $1, $filename);
 551       }
 552    }
 553 }
 554
 555 # Writes the modules of the TC
 556 sub sa_writeModulesOfTC(\@) {
 557    my $root = $_[0];
 558    foreach my $poi (@{$root->[2]}) {
 559       open(TMP, "> $poi->[2]") or die "Can't create file '$poi->[2]': $!\n";
 560       sa_log("Module $poi->[1] (file $poi->[2]):\n");
 561       sa_log("$poi->[3]\n");
 562       print TMP $poi->[3] . "\n";
 563       close (TMP);
 564    }
 565 }
 566 # Deletes the files(modules) of the TC
 567 sub sa_deleteModulesOfTC(\@) {
 568    my $root = $_[0];
 569    sa_log( "Cleanup... ");
 570    if (-f 'Makefile') {
 571     my $makefile;
 572     `make clean 2>&1`;
 573    $makefile = sa_readFile('Makefile');
 574    while ($makefile =~ s/^(\s*USER_SOURCES\s*=\s*)(\w+\.cc)/$1/im) {
 575       if (not exists($sa_existedFiles{$2})) {
 576          if (unlink $2) {sa_log( "$2 ");}
 577       }
 578    }
 579    while ($makefile =~ s/^(\s*USER_HEADERS\s*=\s*)(\w+\.hh)/$1/im) {
 580       if (not exists($sa_existedFiles{$2})) {
 581          if (unlink $2) {sa_log( "$2 ");}
 582       }
 583    }
 584    }
 585    if (unlink "Makefile") {sa_log( "Makefile ");}
 586    foreach my $poi (@{$root->[2]}) {
 587       if (unlink $poi->[2]) {sa_log( "$poi->[2] ");}
 588       # remove possible generated code
 589       if ($poi->[0] eq 'TTCN') {
 590          if (unlink "$poi->[1].cc") {sa_log( "$poi->[1].cc ");}
 591          if (unlink "$poi->[1].hh") {sa_log( "$poi->[1].hh ");}
 592       } else {
 593          my $tmp = $poi->[1];
 594          $tmp =~ s/\-/_/g;
 595          if (unlink "$tmp.cc") {sa_log( "$tmp.cc ");}
 596          if (unlink "$tmp.hh") {sa_log( "$tmp.hh ");}
 597       }
 598    }
 599    sa_log("\n");
 600 }
 601
 602 # Fetch the executable name from Makefile
 603 sub sa_fetchExecutableName() {
 604    my $makefile = sa_readFile('Makefile');
 605    if ($makefile =~ /^\s*EXECUTABLE\s*=\s*(\w+)/im) { return $1; }
 606    die "ERROR: Executable name is not found in generated Makefile\n";
 607 }
 608
 609 # Perform a system call
 610 # return value: (status, output)
 611 # status = 0 on success
 612 # status = 1 on command timeout
 613 # status = 2 on abnormal termination
 614 # output: collected printout from the process
 615 sub sa_executeCommand($) {
 616    # Silly Perl does not allow to capture STDERR, only STDOUT.
 617    # As a workaround, ask the shell to redirect STDERR to STDOUT.
 618    # It's OK until TITAN writes everything to STDERR (as it is today)
 619    my $command = "$_[0] 2>&1";
 620    my $subRes = "";
 621    my $pid;
 622    my $exitStatus = 0;
 623    sa_log( "$_[0]\n");
 624    # run as a separate Perl program to be able to use timeout
 625    eval {
 626       local $SIG{ALRM} = sub { die "timeout\n" }; # NB: \n required
 627       alarm $sa_timeout; # send an alarm signal in specified time
 628       # call via exec to be able to catch the exit status
 629       # (without exec, the shell always return with 0 exit status)
 630       $pid = open(TMP, "exec $command |");
 631       die "ERROR: Cannot fork: $!\n" unless ($pid);
 632          while (<TMP>) { $subRes .= $_; }
 633       close(TMP);
 634       $exitStatus = $? & 128; # whether core dump occured
 635       alarm 0;
 636    };
 637    sa_log("$subRes\n");
 638    if ($@) { # an error occured (thought, not only at timeout)
 639       sa_log("\nSoftly killing forked process $pid\n");
 640       kill 1, $pid;
 641       sa_log("ERROR: system call '$command' is not finished within $sa_timeout seconds\n");
 642       return (1, $subRes);
 643    }
 644    if ($exitStatus) { # core dump occured
 645       sa_log("\nERROR: system call '$command' is terminated abnormally\n");
 646       return (2, $subRes);
 647    }
 648    return (0, $subRes);
 649 }
 650
 651 # Compile the stuff now
 652 # return value: (status, output)
 653 # status = 0 on success
 654 # status = 1 on ERROR
 655 # status = 2 on test case FAIL (compiler related ERROR)
 656 sub sa_compileTC(\@) {
 657    my $root = $_[0];
 658    my $modules2compile = '';
 659    my $configFile = '';
 660    my $subRes = '';
 661    my $res;
 662    my $cycles = 0;
 663    foreach my $poi (@{$root->[2]}) {
 664       if ($poi->[0] eq "CFG") {$configFile = $poi->[2]; next;}
 665       $modules2compile .= " $poi->[2]";
 666    }
 667    if ($modules2compile eq '') {
 668       sa_log( "WARNING: test case '$root->[0]' does not contain any modules, skipping\n");
 669       return (1, '');
 670    }
 671    sa_log( "Compiling sources...\n");
 672    my $runtimeOption = '';
 673    if ($sa_titanRuntime2) { $runtimeOption = '-R'; }
 674    do {
 675       if ($cycles) { sleep(60 * 10); }
 676       $cycles++;
 677       ($res, $subRes) = sa_executeCommand("$sa_compilerCmd $runtimeOption $modules2compile");
 678       # Purify message, when no floating license available. Sleep for a while
 679       # and retry.
 680       # -continue-without-license=yes
 681    } while (($subRes =~ /\-continue\-without\-license\=yes/mi) and ($cycles <= $max_cycles));
 682    if ($res) { return (2, $subRes); }
 683    my $resultBuffer = $subRes;
 684    if ($root->[1] eq "COMPILE") { return (0, $resultBuffer); }
 685
 686    sa_log( "Generating test port skeletons...\n");
 687    ($res, $subRes) = sa_executeCommand("$sa_compilerCmd $runtimeOption -t -f $modules2compile");
 688    if ($res) { return (1, $subRes); }
 689    $resultBuffer .= $subRes;
 690
 691    sa_log( "Generating Makefile...\n");
 692    ($res, $subRes) = sa_executeCommand("$sa_mfgenCmd $runtimeOption -s -f $modules2compile *.cc*");
 693    if ($res) { return (1, $subRes); }
 694    $resultBuffer .= $subRes;
 695    if (not (-e 'Makefile')) {
 696       sa_log( "ERROR: Makefile could not be generated\n");
 697       sa_log ($subRes);
 698       return (1, $subRes);
 699    }
 700    if ($root->[1] eq "EXECUTE_PARALLEL") {
 701      sa_log("Patching Makefile for parallel mode...\n");
 702      my $Buffer = sa_readFile('Makefile');
 703      $Buffer =~ s/^\s*TTCN3_LIB\s*=\s*(ttcn3\S*)\s*$/TTCN3_LIB = $1-parallel/im;
 704      unlink 'Makefile';
 705      sa_writeFile('Makefile', $Buffer);
 706    }
 707    sa_log("Building...\n");
 708    my $coverage_args = $sa_coverageEnabled ? "CXXFLAGS=\"-fprofile-arcs -ftest-coverage -g\" LDFLAGS=\"-fprofile-arcs -ftest-coverage -g -lgcov\"" : "";
 709    ($res, $subRes) = sa_executeCommand("make " . $coverage_args);
 710    if ($res) { return (1, $subRes); }
 711    $resultBuffer .= $subRes;
 712    my $exeName = sa_fetchExecutableName();
 713    if (not (-e $exeName)) {
 714       sa_log( "ERROR: GCC compilation error, no executable produced ('$exeName')\n");
 715       if ($sa_halt_on_errors) {
 716         sa_log( "\nTest execution interrupted (no cleanup).\n\n");
 717         exit(1);
 718       }
 719
 720       return (1, $subRes);
 721    }
 722    if ($root->[1] eq "COMPILEGCC") { return (0, $resultBuffer); }
 723
 724    # go on with execution
 725    sa_log("Fetched executable name: $exeName\n");
 726    if ($root->[1] eq "EXECUTE") {
 727                 sa_log( "Executing in single mode...\n");
 728                 if ($configFile eq '') {
 729               sa_log( "ERROR: No runtime config file is specified in the test case\n");
 730               return (1, $subRes);
 731            }
 732            ($res, $subRes) = sa_executeCommand("./$exeName $configFile");
 733            if ($res) { return (1, $subRes); }
 734            $resultBuffer .= $subRes;
 735            return (0, $resultBuffer);
 736    } else {
 737            sa_log( "Executing in parallel mode...\n");
 738            if ($configFile eq '') {
 739              ($res, $subRes) = sa_executeCommand("$sa_runtimeCmd $exeName");
 740            } else {
 741              ($res, $subRes) = sa_executeCommand("$sa_runtimeCmd $exeName $configFile");
 742            }
 743            if ($res) { return (1, $subRes); }
 744            $resultBuffer .= $subRes;
 745            return (0, $resultBuffer);
 746    }
 747 }
 748
 749
 750 # Print a test case result
 751 # $_[0] name of the test case
 752 # $_[1] verdict
 753 sub sa_printResult($$) {
 754    sa_log( "\nTest case '$_[0]'   \n  '$_[1]'\n".$sa_separator);
 755 }
 756
 757 # Check test case result based on RESULT lists
 758 sub sa_checkTCResult(\@$) {
 759    my ($root, $resultBuffer) = @_;
 760    my $result = 'PASS';
 761    my $expectedResult = $root->[5];
 762    if (not defined($root->[3])) {
 763       sa_log( "ERROR: No RESULT section in test case '$root->[0]'\n");
 764       sa_printResult($root->[0], 'ERROR');
 765       $root->[6] = 'ERROR';
 766       return;
 767    }
 768    foreach my $poi (@{$root->[3]{$expectedResult}}) {
 769       # match with each result
 770       if ($poi->[1] !~ /\S/) {next;}
 771       if (($poi->[0] eq 'POSITIVE') and defined($poi->[2])) { # counter match
 772          my $counter = 0;
 773          my $tmpBuf = $resultBuffer;
 774          while ($tmpBuf =~ s/$poi->[1]//) { $counter++; }
 775          if ($counter != $poi->[2]) {
 776             sa_log( "Failing at counting: pattern '$poi->[1]'\nexpected '$poi->[2]' times, found '$counter' times\n");
 777             $result = 'FAIL'; last;
 778          } else { sa_log("Passed matching pattern (counting $counter times): '$poi->[1]'\n"); }
 779       } else { # simple pattern match
 780          if ($poi->[0] eq 'POSITIVE') {
 781             if ($resultBuffer !~ /$poi->[1]/si) {
 782                sa_log( "Failing at pattern (expected, not found):\n$poi->[1]\n");
 783                $result = 'FAIL'; last;
 784             } else { sa_log("Passed matching pattern (expected): '$poi->[1]'\n"); }
 785          } else { # NEGATIVE
 786             if ($resultBuffer =~ /$poi->[1]/si) {
 787                sa_log( "Failing at pattern (not expected but found):\n$poi->[1]\n");
 788                $result = 'FAIL'; last;
 789             } else { sa_log("Passed matching pattern (not expected): '$poi->[1]'\n"); }
 790          }
 791       }
 792    }
 793    # Check if there is any memory leak in compiler
 794    if ($resultBuffer =~ /${sa_re_MemoryLeak}/mi) {
 795       sa_log( "WARNING: Memory leak detected in compiler, setting verdict to 'FAIL'\n");
 796       $root->[7] = 'memory leak detected';
 797       $result = 'FAIL';
 798    }
 799    sa_printResult($root->[0], $result);
 800    if ($sa_halt_on_errors and ($result ne 'PASS')) {
 801       sa_log( "\nTest execution interrupted (no cleanup).\n\n");
 802       exit(1);
 803    }
 804    $root->[6] = $result;
 805 }
 806
 807 # Execute test cases
 808 sub sa_executeTCs() {
 809    my $flag;
 810    # Log general info
 811    sa_log($sa_separator);
 812    sa_log("Date     : " . `date`);
 813    sa_log("User     : " . `whoami`);
 814    if (defined($ENV{HOST})) {
 815       sa_log("Host     : $ENV{HOST}\n");
 816    } else {
 817       sa_log("Host     : <unknown>\n");
 818    }
 819    sa_log("Platform : " . `uname -a`);
 820    sa_log("g++      : " . `which g++ | grep g++`);
 821    sa_log("g++ vers.: " . `g++ -dumpversion`);
 822    if (defined($ENV{TTCN3_DIR})) {
 823       sa_log( "compiler : $sa_compilerCmd\n");
 824       sa_log( "TTCN3_DIR: $ENV{TTCN3_DIR}\n");
 825    } else {
 826       sa_log( "compiler : " . `which compiler | grep compiler`);
 827       sa_log( "TTCN3_DIR: <undefined>\n");
 828    }
 829    sa_log("Location : $ENV{PWD}\n");
 830    sa_log( `$sa_compilerCmd -v 2>&1` . "\n");
 831    my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute;
 832    my $sa_nrOfTCs2Executed = 1;
 833    # test case execution
 834    foreach my $poi (@sa_TCInfo) {
 835       sa_log ("\n\n$sa_separator  Executing test case: '$poi->[0]'\n");
 836       sa_log ("  leaf: $poi->[5] ; mode: $poi->[1] ; source: $poi->[4] ;");
 837       sa_log (" index: $sa_nrOfTCs2Executed of $sa_nrOfTCs2Execute\n$sa_separator");
 838       opendir(DIR, '.') || die "can't opendir '.': $!";
 839          foreach my $f (readdir(DIR)) { $sa_existedFiles{$f} = $f; }
 840       closedir DIR;
 841       sa_writeModulesOfTC(@{$poi});
 842       my ($res, $resultBuffer) = sa_compileTC(@{$poi});
 843       if ($res == 1) { # error
 844          sa_printResult($poi->[0], 'ERROR');
 845          $poi->[6] = 'ERROR';
 846          next;
 847       } elsif ($res == 2) { # compiler hanged or terminated abnormally
 848          sa_printResult($poi->[0], 'FAIL');
 849          $poi->[6] = 'FAIL';
 850          $poi->[8] = 'hanged or abnormal termination';
 851          next;
 852       }
 853       # Check result now
 854       sa_checkTCResult(@{$poi}, $resultBuffer);
 855       sa_deleteModulesOfTC(@{$poi});
 856       $sa_nrOfTCs2Executed++;
 857    }
 858
 859    sa_log("\n\n$sa_separator");
 860
 861    $flag = 0;
 862    sa_log("The following test cases passed:\n");
 863    sa_log("================================\n");
 864    foreach my $poi (@sa_TCInfo) {
 865       if ($poi->[6] eq 'PASS') {
 866          sa_log(" [$poi->[4]]: '$poi->[0]'   \n");
 867          $sa_executionStatistics[0]++;
 868          $flag = 1;
 869       }
 870    }
 871    if (not $flag) { sa_log(" None.\n"); }
 872
 873    $flag = 0;
 874    sa_log("The following test cases failed:\n");
 875    sa_log("================================\n");
 876    foreach my $poi (@sa_TCInfo) {
 877       if ($poi->[6] eq 'FAIL') {
 878          sa_log(" [$poi->[4]]: '$poi->[0]'   \n");
 879          $sa_executionStatistics[1]++;
 880          $flag = 1;
 881       }
 882    }
 883    if (not $flag) { sa_log(" None.\n"); }
 884
 885    $flag = 0;
 886    sa_log("The following test cases are inconclusive:\n");
 887    sa_log("==========================================\n");
 888    foreach my $poi (@sa_TCInfo) {
 889       if ($poi->[6] eq 'ERROR') {
 890          sa_log(" [$poi->[4]]: '$poi->[0]'   \n");
 891          $sa_executionStatistics[2]++;
 892          $flag = 1;
 893       }
 894    }
 895    if (not $flag) { sa_log(" None.\n"); }
 896
 897    $flag = 0;
 898    sa_log("\nMemory leak detected in the following test cases:\n");
 899    foreach my $poi (@sa_TCInfo) {
 900       if (defined($poi->[7])) {
 901          sa_log(" [$poi->[4]]: '$poi->[0]'   \n");
 902          $sa_executionStatistics[4]++;
 903          $flag = 1;
 904       }
 905    }
 906    if (not $flag) { sa_log(" None.\n"); }
 907
 908    $flag = 0;
 909    sa_log("\nAbnormal termination occured during the following test cases:\n");
 910    foreach my $poi (@sa_TCInfo) {
 911       if (defined($poi->[8])) {
 912          sa_log(" [$poi->[4]]: '$poi->[0]'   \n");
 913          $sa_executionStatistics[3]++;
 914          $flag = 1;
 915       }
 916    }
 917    if (not $flag) { sa_log(" None.\n"); }
 918
 919    my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute;
 920    my $nrOfScriptFiles = scalar @sa_scriptFiles;
 921    sa_log("\n\n$sa_separator");
 922    sa_log("$sa_nrOfTCs2Execute test cases from $nrOfScriptFiles script files were executed\n");
 923    sa_log("Total number of executed test cases: $sa_nrOfTCs2Execute\n");
 924    sa_log("  PASSED                 test cases: $sa_executionStatistics[0]\n");
 925    sa_log("  FAILED                 test cases: $sa_executionStatistics[1]\n");
 926    sa_log("  INCONCLUSIVE           test cases: $sa_executionStatistics[2]\n");
 927    sa_log("  Abnormally terminated  test cases: $sa_executionStatistics[3]\n");
 928    sa_log("  Memory leaked          test cases: $sa_executionStatistics[4]\n");
 929    if ($sa_nrOfTCs2Execute != $sa_executionStatistics[0] + $sa_executionStatistics[1] +
 930        $sa_executionStatistics[2]) { sa_log( "INTERNAL ERROR: Statistics mismatch\n"); }
 931
 932    if (defined($sa_LOG)) {sa_log("Session saved to log file '$sa_logFile'\n");}
 933    return ($sa_nrOfTCs2Execute==$sa_executionStatistics[0]);
 934 }
 935
 936 ###############################################################################
 937 ##                                   M A I N
 938 ###############################################################################
 939
 940 $sessionTime = time();
 941 $sa_compilerCmd = (defined $ENV{TTCN3_DIR}) ?
 942                   "$ENV{TTCN3_DIR}/bin/compiler" : 'compiler';
 943 $sa_mfgenCmd = (defined $ENV{TTCN3_DIR}) ?
 944                 "$ENV{TTCN3_DIR}/bin/ttcn3_makefilegen" : 'ttcn3_makefilegen';
 945 $sa_runtimeCmd = (defined $ENV{TTCN3_DIR}) ?
 946                   "$ENV{TTCN3_DIR}/bin/ttcn3_start" : 'ttcn3_start';
 947 sa_processCommandLine();
 948 sa_collectTCs();
 949 sa_parseTCs();
 950 my $isAllPassed = sa_executeTCs();
 951 $sessionTime = time() - $sessionTime;
 952 sa_log("Elapsed time in this session: $sessionTime seconds\n");
 953 if (defined($sa_LOG)) { close $sa_LOG; }
 954 exit($isAllPassed?0:1);