#!/usr/bin/perl -w ############################################################################### # Copyright (c) 2000-2016 Ericsson Telecom AB # All rights reserved. This program and the accompanying materials # are made available under the terms of the Eclipse Public License v1.0 # which accompanies this distribution, and is available at # http://www.eclipse.org/legal/epl-v10.html ############################################################################### ## ## File : SAtester.pl ## Description: Tester utility for Semantic Analyser, TITAN ## Written by : Endre Szalai (Endre.Szalai@ericsson.com) ## ## TODO: exit status always 0, investigate why; workaround: catch the notify ## printout from the compiler require 5.6.1; use strict; use Getopt::Long; ############################################################################### ### Global Variables ############################################################################### # Whether to stop on test case failures (1) or not (0) my $sa_halt_on_errors = ''; # Whether to list available test cases or not my $sa_list_TCs = 0; # Whether to show info or not my $sa_info = 0; # Whether to use matching in test case selection my $sa_tc_select = ''; # Name of the logfile my $sa_logFile = ''; my $sa_LOG; # Elapsed time in this session my $sessionTime; # Whether to show command line info or not my $sa_printHelp_cmd = 0; # Whether to show detailed info or not my $sa_printHelp_doc = 0; # Use function-test runtime or not my $sa_titanRuntime2 = 0; # Enable coverage or not my $sa_coverageEnabled = 0; # Files existed before a test case execution my %sa_existedFiles; # Store input TD files from which TCs are collected my @sa_scriptFiles; # Store information about the TCs to execute my @sa_tcList2Execute; # Store test case data my @sa_TCInfo; # Timeout for system calls in seconds my $sa_timeout = 30; # Max time to wait for a license, in multiple of 10 minutes my $max_cycles = 6; # Execution statistics # Number of TCs: PASSED, FAILED, ERROR verdicts, # abnormally terminated, memory leaked my @sa_executionStatistics = (0, 0, 0, 0, 0); # Command to invoke the titan compiler my $sa_compilerCmd; # Command to invoke the titan Makefile generator my $sa_mfgenCmd; # Command to invoke the runtime execution my $sa_runtimeCmd; # commonly used regexps my $sa_re_TCheader = "\\n\\s*<\\s*TC\\s*-\\s*(.+?)\\s*>\\s*\\n"; my $sa_re_MODULEheader = "\\n\\s*<\\s*MODULE\\s+(\\S+)\\s+(\\S+)\\s+(\\S+)\\s*>"; my $sa_re_MODULEbody = "${sa_re_MODULEheader}\\s*(.+?)\\n\\s*<\\s*END_MODULE\\s*>"; my $sa_re_RESULTheader = "\\n\\s*<\\s*RESULT\\s*(IF_PASS|IF_FAIL)?\\s*(LTRT|FTRT)?\\s*(POSITIVE|NEGATIVE)?\\s*(?:COUNT\\s+(\\d+))?.*?>"; my $sa_re_RESULTbody = "${sa_re_RESULTheader}\\s*(.*?)\\s*\\n\\s*<\\s*END_RESULT\\s*>"; my $sa_re_EXPECTEDbody = "\\s*<\\s*VERDICT_LEAF\\s+(PASS|FAIL)\\s*>\\s*"; my $sa_re_MemoryLeak = "(?:unallocated\\s+blocks\\s*:\\s*)|(?:Memory\\s+leakage\\s+detected)"; # separator for printouts my $sa_separator = "===============================================================\n"; # Detailed info about the usage my $sa_detailedInfo = ' Purpose ------- The tester program was written especially for testing the semantic analyser functionality in TITAN. A generic test flow looks like: - generate input sources (TTCN-3 and/or ASN.1) - compile them with the TITAN compiler - check that the error messages are as expected (negative testing) - check that the modules are compiled both with TITAN and gcc (positive testing) Test cases and all information needed to execute them are stored in one file, in the Test Description files (*.script) in EDML format. The tester program uses this file to execute the test according to the flow described above in a fully automatic way.. Unlike in a simple test method, where a test may be passed or failed, in regression test it might be important, why a test case is failed (e.g. due to a not yet implemented feature). Therefore, each test case may have two separate expected behaviour (called leaves later on). The first is the case when the test purpose is expected to work in a specific way (IF_PASS leaf). The other, when the test case is expected to fail, but why it fails is also interesting (IF_FAIL leaf). Each test case may have both leaves and a specific selector points out which leaf is expected to occur. This also means, that a test case passes, if the selected leaf is passed (which may be the IF_FAIL leaf). Therefore, the tester needs to check test cases that are failed, as only in those cases the current result is not as expected. Features -------- The tester program has the following features: 1. Support for one-by-one and batched execution of test cases. 2. Support for unlimited number of input modules: ASN.1, TTCN-3 and runtime config files for TITAN. 3. Support for compilation of the modules using TITAN and GCC. It also supports single mode execution of the test suite. Makefile and test port files generation is automatic. 5. Automatic cleanup after each test case. 6. Flexible pattern matching for the test case printout using Perl regexps combined with different matching logic. 7. Support for regression testing process. Reference --------- For a list of command line options, execute the tester program with SAtester_XML.pl -help A test case structure in the EDML files looks like: test case block: compile block: [] (default is COMPILE) leaf selector block: module block(s): ... text from here is written to the filename specified above ... ... several module sections may follow ... result block(s): (default is POSITIVE) ... pattern in Perl regexp format ... ... several result sections may follow ... Each block header/footer must be single-line, i.e. newline is not allowed. The compile block instructs the SAtester_XML to: COMPILE compile the modules using TITAN only COMPILEGCC compile the modules using TITAN and GCC afterwards (the Makefile is automatically generated) EXECUTE after compilation, execute the executable test suite the first runtime configuration file is passed to TITAN (single mode execution) EXECUTE_PARALLEL after compilation, execute the executable test suite (parallel mode execution) If any of the actions fail, the test case result will be "ERROR". This block is optional, the default value is COMPILE. The leaf selector block helps the regression testing process, where not only the verdict itself, but the expected verdict is interesting. The value may be PASS or FAIL. The leaf selector selects which RESULT blocks to use when matching the printout from the compiler(s). A module block instructs the SAtester_XML to produce a source module or a runtime configuration file: TTCN The module is treated as a TTCN-3 module ASN The module is treated as an ASN.1 module CFG The module is treated as a runtime configuration file modulename Name of the module filename Name of the file to be produced The text within this section is written as is to "filename". You may specify as many modules as you need. A result block instructs the SAtester_XML how to check result as soon the actions in the compile block is finished successfully. Either: POSITIVE Indicates a positive pattern match (i.e. =~ syntax in Perl) with the supplied pattern is needed to continue NEGATIVE Indicates a negative pattern match (i.e. !~ syntax in Perl) with the supplied pattern is needed to continue Or: COUNT Indicates that instead of a direct pattern match, perform a counting of the supplied pattern. If the number of pattern- matches equals to the supplied number in COUNT section, the execution continues POSITIVE or NEGATIVE can be used for simple pattern match, i.e. whether the pattern is present or not. COUNT can be used to detect that a pattern how many times are present. Result blocks are evaluated in the order of their appearence. If any of the result block is failed, the verdict will be "FAILED" and execution continues with the next test case (if any). Entries in the result header are optional, the default value is "POSITIVE". Memory leak printouts are automatically detected. If one is found, the current verdict will be "FAIL". Example ------- //line comments are written for understanding only // Name of the test case // compile with TITAN only // "anytype" is not supported, so use the FAIL-leaf // in result matching // Specify one module module ModuleA { type anytype MyType ( 10, 11.0, Nonexi, false ); } // PASS-leaf of the result matching // used if VERDICT_LEAF is "PASS" // expecting exactly 1 "no imported or local definition nonexi" (?im)\berror\b.+?no.+?definition.+?nonexi // expecting exactly 1 "error", so no other error shall // occur than the previous error (?is)\berror\b // expecting a notification that no code is generated due // to the error (?im)\bnotify\b.+?\bcode\b.+?\bnot\b.+?\bgenerated\b // FAIL-leaf of the result matching // used if VERDICT_LEAF is "FAIL" // expecting exactly 1 "parse error" (?im)parse.+?error // expecting exactly 1 "error", so no other error shall // occur than the parse error (?is)\berror\b Information about Perl regular expressions can be found at: www.perl.com Guides ------ 1. Use the IF_FAIL leaf only, if the test case is expected to fail because of a missing functionality that will not be implemented in the current project. Using IF_FAIL leaves for limitations that are expected to disappear within a project is just an unnecessary overhead. 2. Whenever a TR is issued, this should be mentioned in the test case, within the source module where the error occured, e.g. module ModuleA { // TR 623: length restriction of charstrings type record of charstring MyType7 length(0..666-Nonexi); } 3. Always expect a specific error message, but be a bit flexible in pattern matching. Always check that no other errors occured. E.g.: (?im)\berror\b.+?no.+?definition.+?nonexi (?is)\berror\b (?im)\bnotify\b.+?\bcode\b.+?\bnot\b.+?\bgenerated\b Note the non-case sensitive matching; that only 1 error is expected and that no code is expected to be generated. Known issues ------------ On cygwin, fork does not always work and Perl stops with an error like: 264 [main] perl 2216 fork_copy: linked dll data/bss pass 0 failed, 0x412000..0x412370, done 0, windows pid 1832, Win32 error 487 '; # easterEgg my $sa_egg = ' \\\\\\\\|//// \\\\ - - // #( @ @ )# \ o / \ * / ---------------------oOOo--oOOo------------------------- "Do or do not. There is no try." - Yoda ------------------------ooooO---Ooooo------------------- ( ) ( ) \ | | / (_| |_) -- This amazing code was created by McHalls -- '; ############################################################################### ## Subs ############################################################################### sub sa_commandLineInfo(); sub sa_log($); sub sa_processArgs($); sub sa_processCommandLine(); sub sa_readFile($); sub sa_writeFile($$); sub sa_collectTCs(); sub sa_isInList(\@$); sub sa_getTCInfo(\@$$); sub sa_parseTCs(); sub sa_writeModulesOfTC(\@); sub sa_deleteModulesOfTC(\@); sub sa_fetchExecutableName(); sub sa_executeCommand($); sub sa_compileTC(\@); sub sa_printResult($$); sub sa_checkTCResult(\@$); sub sa_executeTCs(); # Print command line information sub sa_commandLineInfo () { sa_log("\nPerl utility to execute test cases for Semantic Analyser\n"); sa_log("Contact: Endre Szalai (Endre.Szalai\@ericsson.com)\n"); sa_log("Usage: SA_tester.pl\n"); sa_log(" [-halt] [-list] [-help] [-doc] [-rt2] [-coverage]\n"); sa_log(" [-select ]\n"); sa_log(" [-timeout ]\n"); sa_log(" [] ... []\n"); sa_log(" [\"\"] ... [\"\"]\n"); sa_log(" [-log ]\n"); sa_log("Where\n"); sa_log(" -halt halt on any errors\n"); sa_log(" -list list available test cases\n"); sa_log(" -help display command line parameters\n"); sa_log(" -doc display complete documentation\n"); sa_log(" -rt2 use function-test runtime\n"); sa_log(" -coverage enable coverage"); sa_log(" select test cases if pattern is present in the\n"); sa_log(" name of the test case\n"); sa_log(" maximum execution time of a system call\n"); sa_log(" in seconds (default is $sa_timeout)\n"); sa_log(" name of the logfile\n"); sa_log(" NOTE: do NOT use the .log file extension !\n"); sa_log(" name of the TD file(s) to collect test cases from\n"); sa_log(" name of the test case(s) to execute\n"); sa_log("If no TDfile(s) are defined, all script files from the current\n"); sa_log("directory are considered.\n"); sa_log("If no test cases are defined, all test cases from the script files\n"); sa_log("are executed.\n\n"); } # Log entries sub sa_log($) { print $_[0]; if (defined($sa_LOG)) { print $sa_LOG $_[0]; } } # Process the command line sub sa_processArgs($) { if ($_[0] =~ /\.script$/m) { $sa_scriptFiles[scalar @sa_scriptFiles] = $_[0]; } else { $sa_tcList2Execute[scalar @sa_tcList2Execute] = $_[0]; } } sub sa_processCommandLine() { die unless (GetOptions('halt' => \$sa_halt_on_errors, 'list' => \$sa_list_TCs, 'credit' => \$sa_info, 'help' => \$sa_printHelp_cmd, 'doc' => \$sa_printHelp_doc, 'rt2' => \$sa_titanRuntime2, 'coverage' => \$sa_coverageEnabled, 'log=s' => \$sa_logFile, 'timeout=s' => \$sa_timeout, 'select=s' => \$sa_tc_select, 'maxcycle=s'=> \$max_cycles, "<>" => \&sa_processArgs)); if ($sa_info) {print $sa_egg; exit(1);} if ($sa_logFile ne '') { die "Never use '.log' extension as TITAN's cleanup may remove it, specify a different name\n" unless ($sa_logFile !~ /.*\.log$/is); open ($sa_LOG, ">$sa_logFile") or die "Cannot open log file: '$sa_logFile': $!\n";} if ($sa_printHelp_cmd) {sa_commandLineInfo(); exit(1);} if ($sa_printHelp_doc) {sa_log ($sa_detailedInfo); exit(1);} } # Read and return the content of a file sub sa_readFile($) { # $_[0] : name of the file my $Buffer; sa_log("Parsing file $_[0]...\n"); open (TMP, "$_[0]") or die "Cannot open script file: '$_[0]': $!\n"; read(TMP, $Buffer, -s "$_[0]"); close (TMP); # remove carriage returns # Unix/windows: \n \r combo if ($Buffer =~ /\n/s) {$Buffer =~ s/\r//g;} # Mac: only \r else {$Buffer =~ s/\r/\n/g;} return $Buffer; } # Write a file sub sa_writeFile($$) { # $_[0] : name of the file # $_[1] : content of the file sa_log("Flushing file $_[0]...\n"); open (TMP, ">$_[0]") or die "Cannot open file: '$_[0]': $!\n"; print(TMP $_[1]); close (TMP); } # Checks whether a TC is on the list sub sa_isInList(\@$) { my $poi = $_[0]; foreach my $val (@{$poi}) { if ($val eq $_[1]) {return 1;} } return 0; } # Collect test cases from command line and/or script files sub sa_collectTCs() { # No script files are defined, collect all script files from # current directory if (scalar @sa_scriptFiles == 0) { my @list = split (/\s/, `ls *.script`); foreach my $filename (@list) { $sa_scriptFiles[scalar @sa_scriptFiles] = $filename; } } # no test cases specified, collect from available script files if (scalar @sa_tcList2Execute == 0) { foreach my $filename (@sa_scriptFiles) { my $Buffer = sa_readFile($filename); #replacing tmp keywords with actual files' content my $replacementFile = 'XSD.txt'; my $replacementFile2 = 'UsefulTtcn3Types.txt'; my $xsdKey = "xsd_tmp_keyword"; my $usefulKey = "usefultypes_tmp_keyword"; my $replacement = sa_readFile($replacementFile); my $replacement2 = sa_readFile($replacementFile2); $Buffer =~ s/$xsdKey/$replacement/g; $Buffer =~ s/$usefulKey/$replacement2/g; #sa_log("buffer: $Buffer \n"); #megcsinalja replacet csak valahol nem replacelt hasznalja ! while ($Buffer =~ s/^.*?${sa_re_TCheader}//s) { my $tcName = $1; if (sa_isInList(@sa_tcList2Execute,$tcName)) {sa_log( "WARNING: Test case name is not unique: '$tcName'\n");} # execute test case if match with pattern or no pattern available if ((not $sa_tc_select) or ($sa_tc_select and ($tcName =~ /$sa_tc_select/))) { $sa_tcList2Execute[scalar @sa_tcList2Execute] = $tcName; } } } } my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute; my $nrOfScriptFiles = scalar @sa_scriptFiles; sa_log( "$sa_nrOfTCs2Execute test cases from $nrOfScriptFiles script files to be executed\n"); my $tmp = ($sa_halt_on_errors) ? "halting on errors\n" : "ignoring errors\n"; sa_log( "Mode: $tmp"); } # Gather execution information according to: # [N] Nth test case # [0] test case name # [1] "COMPILE", "COMPILEGCC" or "EXECUTE" # [2][N] Nth module # [0] module type ("ASN", "TTCN" or "CFG") # [1] module name (if ASN or TTCN)/execution mode (if CFG) # [2] filename to use for the module # [3] content of the module # [3]{'PASS'|'FAIL'}[N] Nth result for expected result leaf PASS|FAIL # [0] result type ("POSITIVE" or "NEGATIVE") # [1] match expression # [2] number of coccurances (if "COUNT" used in RESULT) # [4] name of the source script file # [5] expected test case result leaf selector (PASS, FAIL) # [6] verdict of the TC # [7] flag whether memory leak is detected or not (defined/not defined) # [8] flag whether abnormal termination is detected or not (defined/not defined) sub sa_getTCInfo(\@$$) { my ($poi, $Buffer, $filename) = @_; my $tcidx = scalar @{$poi}; if ($Buffer =~ s/${sa_re_TCheader}//s) { $poi->[$tcidx][0] = $1; } else { die "ERROR: Cannot find test case name in current block\n"; } if ($Buffer =~ s/<\s*EXECUTE\s*>//m) { $poi->[$tcidx][1] = 'EXECUTE'; } elsif ($Buffer =~ s/<\s*EXECUTE_PARALLEL\s*>//m) { $poi->[$tcidx][1] = 'EXECUTE_PARALLEL'; } elsif ($Buffer =~ s/<\s*COMPILEGCC\s*>//m) { $poi->[$tcidx][1] = 'COMPILEGCC'; } else { $poi->[$tcidx][1] = 'COMPILE'; } if ($Buffer =~ /${sa_re_EXPECTEDbody}/m) { $poi->[$tcidx][5] = $1; } else { $poi->[$tcidx][5] = 'PASS'; } my $idx = 0; while ($Buffer =~ s/${sa_re_MODULEbody}//s) { $poi->[$tcidx][2][$idx][0] = $1; $poi->[$tcidx][2][$idx][1] = $2; $poi->[$tcidx][2][$idx][2] = $3; $poi->[$tcidx][2][$idx][3] = $4; $idx++; } while ($Buffer =~ s/${sa_re_RESULTbody}//s) { my $expectedVerdict; if (defined($1)) { $expectedVerdict = ($1 eq 'IF_FAIL') ? 'FAIL':'PASS'; } else { $expectedVerdict = 'PASS'; } my $idx = (defined($poi->[$tcidx][3]{$expectedVerdict})) ? scalar @{$poi->[$tcidx][3]{$expectedVerdict}} : 0; if (defined($2)) { # Skip matching strings intended for the load-test run-time when # "-rt2" is used. Vice versa. if ($2 eq 'LTRT' and $sa_titanRuntime2 or $2 eq 'FTRT' and not $sa_titanRuntime2) { next; } } if (defined($3)) { $poi->[$tcidx][3]{$expectedVerdict}[$idx][0] = ($3 ne '') ? $3 : 'POSITIVE';} else {$poi->[$tcidx][3]{$expectedVerdict}[$idx][0] = 'POSITIVE';} if (defined($4)) { $poi->[$tcidx][3]{$expectedVerdict}[$idx][2] = $4; } $poi->[$tcidx][3]{$expectedVerdict}[$idx][1] = $5; eval { '' =~ /$poi->[$tcidx][3]{$expectedVerdict}[$idx][1]/ }; if ($@) { sa_log("In file $filename, test case '$poi->[$tcidx][0]'\n"); sa_log " Syntax error in provided pattern:\n $poi->[$tcidx][3]{$expectedVerdict}[$idx][1]\n$@\n"; exit(1); } } $poi->[$tcidx][4] = $filename; $poi->[$tcidx][6] = 'NONE'; } # Parse test case data sub sa_parseTCs() { # give only a list of the test cases if ($sa_list_TCs) { sa_log( "Collected test cases:\n"); my $idx = 1; # collect test case data from all specified script files foreach my $filename (@sa_scriptFiles) { my $Buffer = sa_readFile($filename); #replacing tmp keywords with actual files' content my $replacementFile = 'XSD.txt'; my $replacementFile2 = 'UsefulTtcn3Types.txt'; my $xsdKey = "xsd_tmp_keyword"; my $usefulKey = "usefultypes_tmp_keyword"; my $replacement = sa_readFile($replacementFile); my $replacement2 = sa_readFile($replacementFile2); $Buffer =~ s/$xsdKey/$replacement/g; $Buffer =~ s/$usefulKey/$replacement2/g; while ($Buffer =~ s/^.*?(${sa_re_TCheader}.+?)//s) { sa_getTCInfo(@sa_TCInfo, $1, $filename); } } foreach my $poi (@sa_TCInfo) { sa_log( "$idx. '$poi->[0]' \n"); sa_log( " source:$poi->[4]; leaf:$poi->[5]\n"); $idx++; } exit(1); } foreach my $filename (@sa_scriptFiles) { my $Buffer = sa_readFile($filename); #replacing tmp keywords with actual files' content my $replacementFile = 'XSD.txt'; my $replacementFile2 = 'UsefulTtcn3Types.txt'; my $xsdKey = "xsd_tmp_keyword"; my $usefulKey = "usefultypes_tmp_keyword"; my $replacement = sa_readFile($replacementFile); my $replacement2 = sa_readFile($replacementFile2); $Buffer =~ s/$xsdKey/$replacement/g; $Buffer =~ s/$usefulKey/$replacement2/g; while ($Buffer =~ s/^.*?(${sa_re_TCheader}.+?)//s) { if (not sa_isInList(@sa_tcList2Execute,$2)) { next; } sa_getTCInfo(@sa_TCInfo, $1, $filename); } } } # Writes the modules of the TC sub sa_writeModulesOfTC(\@) { my $root = $_[0]; foreach my $poi (@{$root->[2]}) { open(TMP, "> $poi->[2]") or die "Can't create file '$poi->[2]': $!\n"; sa_log("Module $poi->[1] (file $poi->[2]):\n"); sa_log("$poi->[3]\n"); print TMP $poi->[3] . "\n"; close (TMP); } } # Deletes the files(modules) of the TC sub sa_deleteModulesOfTC(\@) { my $root = $_[0]; sa_log( "Cleanup... "); if (-f 'Makefile') { my $makefile; `make clean 2>&1`; $makefile = sa_readFile('Makefile'); while ($makefile =~ s/^(\s*USER_SOURCES\s*=\s*)(\w+\.cc)/$1/im) { if (not exists($sa_existedFiles{$2})) { if (unlink $2) {sa_log( "$2 ");} } } while ($makefile =~ s/^(\s*USER_HEADERS\s*=\s*)(\w+\.hh)/$1/im) { if (not exists($sa_existedFiles{$2})) { if (unlink $2) {sa_log( "$2 ");} } } } if (unlink "Makefile") {sa_log( "Makefile ");} foreach my $poi (@{$root->[2]}) { if (unlink $poi->[2]) {sa_log( "$poi->[2] ");} # remove possible generated code if ($poi->[0] eq 'TTCN') { if (unlink "$poi->[1].cc") {sa_log( "$poi->[1].cc ");} if (unlink "$poi->[1].hh") {sa_log( "$poi->[1].hh ");} } else { my $tmp = $poi->[1]; $tmp =~ s/\-/_/g; if (unlink "$tmp.cc") {sa_log( "$tmp.cc ");} if (unlink "$tmp.hh") {sa_log( "$tmp.hh ");} } } sa_log("\n"); } # Fetch the executable name from Makefile sub sa_fetchExecutableName() { my $makefile = sa_readFile('Makefile'); if ($makefile =~ /^\s*EXECUTABLE\s*=\s*(\w+)/im) { return $1; } die "ERROR: Executable name is not found in generated Makefile\n"; } # Perform a system call # return value: (status, output) # status = 0 on success # status = 1 on command timeout # status = 2 on abnormal termination # output: collected printout from the process sub sa_executeCommand($) { # Silly Perl does not allow to capture STDERR, only STDOUT. # As a workaround, ask the shell to redirect STDERR to STDOUT. # It's OK until TITAN writes everything to STDERR (as it is today) my $command = "$_[0] 2>&1"; my $subRes = ""; my $pid; my $exitStatus = 0; sa_log( "$_[0]\n"); # run as a separate Perl program to be able to use timeout eval { local $SIG{ALRM} = sub { die "timeout\n" }; # NB: \n required alarm $sa_timeout; # send an alarm signal in specified time # call via exec to be able to catch the exit status # (without exec, the shell always return with 0 exit status) $pid = open(TMP, "exec $command |"); die "ERROR: Cannot fork: $!\n" unless ($pid); while () { $subRes .= $_; } close(TMP); $exitStatus = $? & 128; # whether core dump occured alarm 0; }; sa_log("$subRes\n"); if ($@) { # an error occured (thought, not only at timeout) sa_log("\nSoftly killing forked process $pid\n"); kill 1, $pid; sa_log("ERROR: system call '$command' is not finished within $sa_timeout seconds\n"); return (1, $subRes); } if ($exitStatus) { # core dump occured sa_log("\nERROR: system call '$command' is terminated abnormally\n"); return (2, $subRes); } return (0, $subRes); } # Compile the stuff now # return value: (status, output) # status = 0 on success # status = 1 on ERROR # status = 2 on test case FAIL (compiler related ERROR) sub sa_compileTC(\@) { my $root = $_[0]; my $modules2compile = ''; my $configFile = ''; my $subRes = ''; my $res; my $cycles = 0; foreach my $poi (@{$root->[2]}) { if ($poi->[0] eq "CFG") {$configFile = $poi->[2]; next;} $modules2compile .= " $poi->[2]"; } if ($modules2compile eq '') { sa_log( "WARNING: test case '$root->[0]' does not contain any modules, skipping\n"); return (1, ''); } sa_log( "Compiling sources...\n"); my $runtimeOption = ''; if ($sa_titanRuntime2) { $runtimeOption = '-R'; } do { if ($cycles) { sleep(60 * 10); } $cycles++; ($res, $subRes) = sa_executeCommand("$sa_compilerCmd $runtimeOption $modules2compile"); # Purify message, when no floating license available. Sleep for a while # and retry. # -continue-without-license=yes } while (($subRes =~ /\-continue\-without\-license\=yes/mi) and ($cycles <= $max_cycles)); if ($res) { return (2, $subRes); } my $resultBuffer = $subRes; if ($root->[1] eq "COMPILE") { return (0, $resultBuffer); } sa_log( "Generating test port skeletons...\n"); ($res, $subRes) = sa_executeCommand("$sa_compilerCmd $runtimeOption -t -f $modules2compile"); if ($res) { return (1, $subRes); } $resultBuffer .= $subRes; sa_log( "Generating Makefile...\n"); ($res, $subRes) = sa_executeCommand("$sa_mfgenCmd $runtimeOption -s -f $modules2compile *.cc*"); if ($res) { return (1, $subRes); } $resultBuffer .= $subRes; if (not (-e 'Makefile')) { sa_log( "ERROR: Makefile could not be generated\n"); sa_log ($subRes); return (1, $subRes); } if ($root->[1] eq "EXECUTE_PARALLEL") { sa_log("Patching Makefile for parallel mode...\n"); my $Buffer = sa_readFile('Makefile'); $Buffer =~ s/^\s*TTCN3_LIB\s*=\s*(ttcn3\S*)\s*$/TTCN3_LIB = $1-parallel/im; unlink 'Makefile'; sa_writeFile('Makefile', $Buffer); } sa_log("Building...\n"); my $coverage_args = $sa_coverageEnabled ? "CXXFLAGS=\"-fprofile-arcs -ftest-coverage -g\" LDFLAGS=\"-fprofile-arcs -ftest-coverage -g -lgcov\"" : ""; ($res, $subRes) = sa_executeCommand("make " . $coverage_args); if ($res) { return (1, $subRes); } $resultBuffer .= $subRes; my $exeName = sa_fetchExecutableName(); if (not (-e $exeName)) { sa_log( "ERROR: GCC compilation error, no executable produced ('$exeName')\n"); if ($sa_halt_on_errors) { sa_log( "\nTest execution interrupted (no cleanup).\n\n"); exit(1); } return (1, $subRes); } if ($root->[1] eq "COMPILEGCC") { return (0, $resultBuffer); } # go on with execution sa_log("Fetched executable name: $exeName\n"); if ($root->[1] eq "EXECUTE") { sa_log( "Executing in single mode...\n"); if ($configFile eq '') { sa_log( "ERROR: No runtime config file is specified in the test case\n"); return (1, $subRes); } ($res, $subRes) = sa_executeCommand("./$exeName $configFile"); if ($res) { return (1, $subRes); } $resultBuffer .= $subRes; return (0, $resultBuffer); } else { sa_log( "Executing in parallel mode...\n"); if ($configFile eq '') { ($res, $subRes) = sa_executeCommand("$sa_runtimeCmd $exeName"); } else { ($res, $subRes) = sa_executeCommand("$sa_runtimeCmd $exeName $configFile"); } if ($res) { return (1, $subRes); } $resultBuffer .= $subRes; return (0, $resultBuffer); } } # Print a test case result # $_[0] name of the test case # $_[1] verdict sub sa_printResult($$) { sa_log( "\nTest case '$_[0]' \n '$_[1]'\n".$sa_separator); } # Check test case result based on RESULT lists sub sa_checkTCResult(\@$) { my ($root, $resultBuffer) = @_; my $result = 'PASS'; my $expectedResult = $root->[5]; if (not defined($root->[3])) { sa_log( "ERROR: No RESULT section in test case '$root->[0]'\n"); sa_printResult($root->[0], 'ERROR'); $root->[6] = 'ERROR'; return; } foreach my $poi (@{$root->[3]{$expectedResult}}) { # match with each result if ($poi->[1] !~ /\S/) {next;} if (($poi->[0] eq 'POSITIVE') and defined($poi->[2])) { # counter match my $counter = 0; my $tmpBuf = $resultBuffer; while ($tmpBuf =~ s/$poi->[1]//) { $counter++; } if ($counter != $poi->[2]) { sa_log( "Failing at counting: pattern '$poi->[1]'\nexpected '$poi->[2]' times, found '$counter' times\n"); $result = 'FAIL'; last; } else { sa_log("Passed matching pattern (counting $counter times): '$poi->[1]'\n"); } } else { # simple pattern match if ($poi->[0] eq 'POSITIVE') { if ($resultBuffer !~ /$poi->[1]/si) { sa_log( "Failing at pattern (expected, not found):\n$poi->[1]\n"); $result = 'FAIL'; last; } else { sa_log("Passed matching pattern (expected): '$poi->[1]'\n"); } } else { # NEGATIVE if ($resultBuffer =~ /$poi->[1]/si) { sa_log( "Failing at pattern (not expected but found):\n$poi->[1]\n"); $result = 'FAIL'; last; } else { sa_log("Passed matching pattern (not expected): '$poi->[1]'\n"); } } } } # Check if there is any memory leak in compiler if ($resultBuffer =~ /${sa_re_MemoryLeak}/mi) { sa_log( "WARNING: Memory leak detected in compiler, setting verdict to 'FAIL'\n"); $root->[7] = 'memory leak detected'; $result = 'FAIL'; } sa_printResult($root->[0], $result); if ($sa_halt_on_errors and ($result ne 'PASS')) { sa_log( "\nTest execution interrupted (no cleanup).\n\n"); exit(1); } $root->[6] = $result; } # Execute test cases sub sa_executeTCs() { my $flag; # Log general info sa_log($sa_separator); sa_log("Date : " . `date`); sa_log("User : " . `whoami`); if (defined($ENV{HOST})) { sa_log("Host : $ENV{HOST}\n"); } else { sa_log("Host : \n"); } sa_log("Platform : " . `uname -a`); sa_log("g++ : " . `which g++ | grep g++`); sa_log("g++ vers.: " . `g++ -dumpversion`); if (defined($ENV{TTCN3_DIR})) { sa_log( "compiler : $sa_compilerCmd\n"); sa_log( "TTCN3_DIR: $ENV{TTCN3_DIR}\n"); } else { sa_log( "compiler : " . `which compiler | grep compiler`); sa_log( "TTCN3_DIR: \n"); } sa_log("Location : $ENV{PWD}\n"); sa_log( `$sa_compilerCmd -v 2>&1` . "\n"); my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute; my $sa_nrOfTCs2Executed = 1; # test case execution foreach my $poi (@sa_TCInfo) { sa_log ("\n\n$sa_separator Executing test case: '$poi->[0]'\n"); sa_log (" leaf: $poi->[5] ; mode: $poi->[1] ; source: $poi->[4] ;"); sa_log (" index: $sa_nrOfTCs2Executed of $sa_nrOfTCs2Execute\n$sa_separator"); opendir(DIR, '.') || die "can't opendir '.': $!"; foreach my $f (readdir(DIR)) { $sa_existedFiles{$f} = $f; } closedir DIR; sa_writeModulesOfTC(@{$poi}); my ($res, $resultBuffer) = sa_compileTC(@{$poi}); if ($res == 1) { # error sa_printResult($poi->[0], 'ERROR'); $poi->[6] = 'ERROR'; next; } elsif ($res == 2) { # compiler hanged or terminated abnormally sa_printResult($poi->[0], 'FAIL'); $poi->[6] = 'FAIL'; $poi->[8] = 'hanged or abnormal termination'; next; } # Check result now sa_checkTCResult(@{$poi}, $resultBuffer); sa_deleteModulesOfTC(@{$poi}); $sa_nrOfTCs2Executed++; } sa_log("\n\n$sa_separator"); $flag = 0; sa_log("The following test cases passed:\n"); sa_log("================================\n"); foreach my $poi (@sa_TCInfo) { if ($poi->[6] eq 'PASS') { sa_log(" [$poi->[4]]: '$poi->[0]' \n"); $sa_executionStatistics[0]++; $flag = 1; } } if (not $flag) { sa_log(" None.\n"); } $flag = 0; sa_log("The following test cases failed:\n"); sa_log("================================\n"); foreach my $poi (@sa_TCInfo) { if ($poi->[6] eq 'FAIL') { sa_log(" [$poi->[4]]: '$poi->[0]' \n"); $sa_executionStatistics[1]++; $flag = 1; } } if (not $flag) { sa_log(" None.\n"); } $flag = 0; sa_log("The following test cases are inconclusive:\n"); sa_log("==========================================\n"); foreach my $poi (@sa_TCInfo) { if ($poi->[6] eq 'ERROR') { sa_log(" [$poi->[4]]: '$poi->[0]' \n"); $sa_executionStatistics[2]++; $flag = 1; } } if (not $flag) { sa_log(" None.\n"); } $flag = 0; sa_log("\nMemory leak detected in the following test cases:\n"); foreach my $poi (@sa_TCInfo) { if (defined($poi->[7])) { sa_log(" [$poi->[4]]: '$poi->[0]' \n"); $sa_executionStatistics[4]++; $flag = 1; } } if (not $flag) { sa_log(" None.\n"); } $flag = 0; sa_log("\nAbnormal termination occured during the following test cases:\n"); foreach my $poi (@sa_TCInfo) { if (defined($poi->[8])) { sa_log(" [$poi->[4]]: '$poi->[0]' \n"); $sa_executionStatistics[3]++; $flag = 1; } } if (not $flag) { sa_log(" None.\n"); } my $sa_nrOfTCs2Execute = scalar @sa_tcList2Execute; my $nrOfScriptFiles = scalar @sa_scriptFiles; sa_log("\n\n$sa_separator"); sa_log("$sa_nrOfTCs2Execute test cases from $nrOfScriptFiles script files were executed\n"); sa_log("Total number of executed test cases: $sa_nrOfTCs2Execute\n"); sa_log(" PASSED test cases: $sa_executionStatistics[0]\n"); sa_log(" FAILED test cases: $sa_executionStatistics[1]\n"); sa_log(" INCONCLUSIVE test cases: $sa_executionStatistics[2]\n"); sa_log(" Abnormally terminated test cases: $sa_executionStatistics[3]\n"); sa_log(" Memory leaked test cases: $sa_executionStatistics[4]\n"); if ($sa_nrOfTCs2Execute != $sa_executionStatistics[0] + $sa_executionStatistics[1] + $sa_executionStatistics[2]) { sa_log( "INTERNAL ERROR: Statistics mismatch\n"); } if (defined($sa_LOG)) {sa_log("Session saved to log file '$sa_logFile'\n");} return ($sa_nrOfTCs2Execute==$sa_executionStatistics[0]); } ############################################################################### ## M A I N ############################################################################### $sessionTime = time(); $sa_compilerCmd = (defined $ENV{TTCN3_DIR}) ? "$ENV{TTCN3_DIR}/bin/compiler" : 'compiler'; $sa_mfgenCmd = (defined $ENV{TTCN3_DIR}) ? "$ENV{TTCN3_DIR}/bin/ttcn3_makefilegen" : 'ttcn3_makefilegen'; $sa_runtimeCmd = (defined $ENV{TTCN3_DIR}) ? "$ENV{TTCN3_DIR}/bin/ttcn3_start" : 'ttcn3_start'; sa_processCommandLine(); sa_collectTCs(); sa_parseTCs(); my $isAllPassed = sa_executeTCs(); $sessionTime = time() - $sessionTime; sa_log("Elapsed time in this session: $sessionTime seconds\n"); if (defined($sa_LOG)) { close $sa_LOG; } exit($isAllPassed?0:1);