1 | #!/usr/bin/perl -w
|
---|
2 |
|
---|
3 | # This perl script takes one or multiple source directories as parameter and
|
---|
4 | # will generate the list of ttcn files contained in these directories and their
|
---|
5 | # subdirectories. Then it will detect which TTCN-3 tools are installed one the
|
---|
6 | # system and try to compile the files with each of them.
|
---|
7 | #
|
---|
8 | # Three tools are supported so far: Telelogic Tester, MessageMagic and TTworkbench
|
---|
9 | #
|
---|
10 | # The console display the result of the compilation of each tool (success or
|
---|
11 | # not) and filters its output to only display the lines reporting errors or
|
---|
12 | # warnings. The full output of each tool is saved in a separate file
|
---|
13 | # (output.[toolname].txt).
|
---|
14 |
|
---|
15 |
|
---|
16 |
|
---|
17 | # regular expression used to identify which files are TTCN-3 files
|
---|
18 | $TTCN_FILENAME_PATTERN = "\\.ttcn?\$";
|
---|
19 |
|
---|
20 |
|
---|
21 | #######################################################################
|
---|
22 | # An abstract class representing a TTCN-3 tool
|
---|
23 | package TTCN3Tool;
|
---|
24 |
|
---|
25 | # constructor
|
---|
26 | #
|
---|
27 | # name name of the tool
|
---|
28 | sub new
|
---|
29 | {
|
---|
30 | my ($class, $name) = @_;
|
---|
31 | return bless {name => $name}, $class;
|
---|
32 | }
|
---|
33 |
|
---|
34 | # report that this tool was detected on this system
|
---|
35 | #
|
---|
36 | # dir directory in which the tool is installed
|
---|
37 | #
|
---|
38 | # Note: this function should be called from the constructors of the
|
---|
39 | # derived classes, it should be called at most once
|
---|
40 | #
|
---|
41 | # Note2: the directory is then stored in the {dir} attribute
|
---|
42 | sub detected
|
---|
43 | {
|
---|
44 | my ($self, $dir) = @_;
|
---|
45 | $self->{dir} = ::get_abs_path ($dir);
|
---|
46 |
|
---|
47 | printf "Detected %-24s in %s\n", $self->{name}, $dir;
|
---|
48 | }
|
---|
49 |
|
---|
50 | # tell if this tool was detected on the system
|
---|
51 | sub is_detected
|
---|
52 | {
|
---|
53 | my ($self) = @_;
|
---|
54 | return defined $self->{dir};
|
---|
55 | }
|
---|
56 |
|
---|
57 | # Check if the file given as parameter is executable, then store
|
---|
58 | # this parameter in the {cmd} attribute. This command should be
|
---|
59 | # the file to be executed to call the compiler.
|
---|
60 | #
|
---|
61 | # cmd path of the executable
|
---|
62 | #
|
---|
63 | sub try_cmd
|
---|
64 | {
|
---|
65 | my ($self, $cmd) = @_;
|
---|
66 |
|
---|
67 | # safety check because we store the name of the command here
|
---|
68 | $self->is_detected &&
|
---|
69 | die "TTCN3Tool::try_cmd must not be called after the tool has been detected";
|
---|
70 |
|
---|
71 | $self->{cmd} = ::get_abs_path ($cmd);
|
---|
72 |
|
---|
73 | return -X $cmd;
|
---|
74 | }
|
---|
75 |
|
---|
76 | # Generate the name of the output file where the output of the compiler will be
|
---|
77 | # stored. This function currently generates: "output.<name>.txt"
|
---|
78 | #
|
---|
79 | # Note: the name of the compiler is mangled to avoid having strange
|
---|
80 | # characters in the result
|
---|
81 | #
|
---|
82 | sub output_file_name
|
---|
83 | {
|
---|
84 | $_ = shift->{name};
|
---|
85 |
|
---|
86 | s/[^A-Z0-9]/_/ig;
|
---|
87 |
|
---|
88 | $_ = "output.$_.txt";
|
---|
89 |
|
---|
90 | if (defined $OUTPUT_DIR) {
|
---|
91 | $_ = "$OUTPUT_DIR\\$_";
|
---|
92 | }
|
---|
93 | }
|
---|
94 |
|
---|
95 | # Public interface to execute the compiler
|
---|
96 | #
|
---|
97 | # This function execute the command generated by the analyse_cmd() function
|
---|
98 | # (normally implemented in the derived classes) and store the output into
|
---|
99 | # the output file given by the function output_file_name().
|
---|
100 | #
|
---|
101 | # The output is also duplicated on the console. However, in order to simplify
|
---|
102 | # the output, it is filtered so that only the lines reporting errors are
|
---|
103 | # displayed on the console.
|
---|
104 | #
|
---|
105 | # The filter is implemented by the match_error() function. Since this filter is
|
---|
106 | # compiler-dependent, it is normally reimplemented in the derived classes.
|
---|
107 | #
|
---|
108 | # @files list of the TTCN-3 input files
|
---|
109 | #
|
---|
110 | # return true if the analysis was successful
|
---|
111 | #
|
---|
112 | sub analyse
|
---|
113 | {
|
---|
114 | my $self = shift;
|
---|
115 |
|
---|
116 | # print "Executing: ", $self->analyse_cmd(@_), "\n";
|
---|
117 |
|
---|
118 | unless (open CMD, $self->analyse_cmd(@_)." 2>&1 |") {
|
---|
119 | print "Error: cannot execute command: ", $self->analyse_cmd(@_), "\n";
|
---|
120 | return undef;
|
---|
121 | }
|
---|
122 |
|
---|
123 | unless (open OUT, '>'.$self->output_file_name) {
|
---|
124 | print "Error: cannot open output file: ", $self->output_file_name, "\n";
|
---|
125 | return undef;
|
---|
126 | }
|
---|
127 |
|
---|
128 | while (<CMD>) {
|
---|
129 | # display only the errors on the console
|
---|
130 | $self->match_error ($_) && print "\t$_";
|
---|
131 |
|
---|
132 | # write everything into the output file
|
---|
133 | print OUT $_;
|
---|
134 | }
|
---|
135 |
|
---|
136 | return (close OUT) && (close CMD);
|
---|
137 | }
|
---|
138 |
|
---|
139 | # default filter to be used by the analyse() function
|
---|
140 | #
|
---|
141 | # By default all the lines are displayed on the console.
|
---|
142 | #
|
---|
143 | sub match_error
|
---|
144 | {
|
---|
145 | return 1;
|
---|
146 | }
|
---|
147 |
|
---|
148 | ########################################################################
|
---|
149 | # A driver class for controlling the TTCN-3 tool IBM Telelogic Tester
|
---|
150 | package TTCN3Tool::TelelogicTester;
|
---|
151 | @ISA = qw(TTCN3Tool);
|
---|
152 |
|
---|
153 | # Constructor
|
---|
154 | #
|
---|
155 | # This function will detect the latest version of the compiler installed on the
|
---|
156 | # system in the default path (c:\program files\telelogic)
|
---|
157 | sub new
|
---|
158 | {
|
---|
159 | $self = TTCN3Tool::new (shift, "Telelogic Tester");
|
---|
160 |
|
---|
161 | # find the newest telelogic tester version installed on the system
|
---|
162 | my $dir = ::find_newest_version_in_dir ("c:\\program files\\telelogic", "^(TAU_)?Tester_"); #ori
|
---|
163 | #my $dir = ::find_newest_version_in_dir ("c:\\program files\\telelogic\\TAU_4.2sdsfd"); ## needs to be adjusted """
|
---|
164 |
|
---|
165 | if ((defined $dir) && ($self->try_cmd ("$dir\\bin\\t3cg.exe"))) {
|
---|
166 | $self->detected($dir);
|
---|
167 | }
|
---|
168 | return $self;
|
---|
169 | }
|
---|
170 |
|
---|
171 | # generate the command line to run the compiler
|
---|
172 | sub analyse_cmd
|
---|
173 | {
|
---|
174 | my $self = shift;
|
---|
175 |
|
---|
176 | return "\"$self->{cmd}\" -D -F -a @_";
|
---|
177 | }
|
---|
178 |
|
---|
179 | # match one error line in the compiler output
|
---|
180 | sub match_error
|
---|
181 | {
|
---|
182 | shift;
|
---|
183 | /: (Error|Warning)/;
|
---|
184 | }
|
---|
185 |
|
---|
186 |
|
---|
187 | ########################################################################
|
---|
188 | # A driver class for controlling the TTCN-3 tool TestingTech TTworkbench
|
---|
189 | package TTCN3Tool::TTworkbench;
|
---|
190 | @ISA = qw(TTCN3Tool);
|
---|
191 |
|
---|
192 | # Constructor
|
---|
193 | #
|
---|
194 | # This function will detect the compiler installed on the system in the default
|
---|
195 | # path (c:\program files\TTworkbenchBasic)
|
---|
196 | sub new
|
---|
197 | {
|
---|
198 | $self = TTCN3Tool::new (shift, "TTworkbench");
|
---|
199 |
|
---|
200 | foreach my $dir ("c:\\program files\\ttworkbenchbasic118") #TODO: maybe add other directories to search
|
---|
201 | {
|
---|
202 | if ($self->try_cmd ("$dir\\TTthree.bat")) {
|
---|
203 | $self->detected ($dir);
|
---|
204 | last;
|
---|
205 | }
|
---|
206 | }
|
---|
207 | return $self;
|
---|
208 | }
|
---|
209 |
|
---|
210 | # generate the command line to run the compiler
|
---|
211 | sub analyse_cmd
|
---|
212 | {
|
---|
213 | my $self = shift;
|
---|
214 |
|
---|
215 | # TTworkbench needs to know the list of sub-directories where our files
|
---|
216 | # are located
|
---|
217 | my %subdirs=();
|
---|
218 | foreach (@_) {
|
---|
219 | if (/^(.*\\)[^\\]+/) {
|
---|
220 | $subdirs{$1} = 1;
|
---|
221 | } else {
|
---|
222 | $subdirs{"."} = 1;
|
---|
223 | }
|
---|
224 | }
|
---|
225 |
|
---|
226 | # TTworkbench needs to know one or more root module id so as to know
|
---|
227 | # what shall be compiled in these subdirectories
|
---|
228 | #
|
---|
229 | # Note: the compiler does not support files whose basename does not
|
---|
230 | # match the module id that they contain -> so we can afford just
|
---|
231 | # using the basename of our files
|
---|
232 | #
|
---|
233 | # Note2: we do not know which module is the root one, so we give the
|
---|
234 | # full list of modules
|
---|
235 | my @modules=();
|
---|
236 | foreach (@_) {
|
---|
237 | if (/^.*\\([^\\.]+)\.[a-z0-9]+$/i) {
|
---|
238 | push @modules, $1;
|
---|
239 | } else {
|
---|
240 | die "error: cannot extract a module name form the file: $_";
|
---|
241 | }
|
---|
242 | }
|
---|
243 |
|
---|
244 | return "\"$self->{cmd}\" --clean --dry-run --continue --use-bigint --rebuild --strict-standard-compliance enforce --verbosity warning "
|
---|
245 | . join (" -P ", "", keys %subdirs)." @modules";
|
---|
246 | }
|
---|
247 |
|
---|
248 | # match one error line in the compiler output
|
---|
249 | sub match_error
|
---|
250 | {
|
---|
251 | shift;
|
---|
252 | /^(error|warning|failure):/;
|
---|
253 | }
|
---|
254 |
|
---|
255 | ########################################################################
|
---|
256 | # A driver class for controlling the TTCN-3 tool OpenTTCN Tester
|
---|
257 | #
|
---|
258 | # warning: this class has not yet been validated
|
---|
259 | #
|
---|
260 | package TTCN3Tool::OpenTTCNTester;
|
---|
261 | @ISA = qw(TTCN3Tool);
|
---|
262 |
|
---|
263 | sub new
|
---|
264 | {
|
---|
265 | $self = TTCN3Tool::new (shift, "OpenTTCN Tester");
|
---|
266 |
|
---|
267 | foreach my $dir ("c:\\program files\\OpenTTCN\\Tester3") #TODO: maybe add other directories to search
|
---|
268 | {
|
---|
269 | if ($self->try_cmd ("$dir\\bin\\importer3.exe")) {
|
---|
270 | $self->detected ($dir);
|
---|
271 | last;
|
---|
272 | }
|
---|
273 | }
|
---|
274 | return $self;
|
---|
275 | }
|
---|
276 |
|
---|
277 | ########################################################################
|
---|
278 | # A driver class for controlling the TTCN-3 tool Elvior MessageMagic
|
---|
279 | package TTCN3Tool::MessageMagic;
|
---|
280 | @ISA = qw(TTCN3Tool);
|
---|
281 |
|
---|
282 | sub new
|
---|
283 | {
|
---|
284 | $self = TTCN3Tool::new (shift, "Message Magic");
|
---|
285 |
|
---|
286 | # find the newest telelogic tester version installed on the system
|
---|
287 | my $dir = ::find_newest_version_in_dir ("c:\\program files\\elvior", "^MessageMagic5");
|
---|
288 |
|
---|
289 | if ((defined $dir) && ($self->try_cmd ("$dir\\mmttcncp.exe"))) {
|
---|
290 | $self->detected($dir);
|
---|
291 | }
|
---|
292 | return $self;
|
---|
293 | }
|
---|
294 |
|
---|
295 | # generate the command line to run the compiler
|
---|
296 | sub analyse_cmd
|
---|
297 | {
|
---|
298 | shift;
|
---|
299 |
|
---|
300 | # MessageMagic must be executed from its directory to be able to locate the license
|
---|
301 |
|
---|
302 | # transform the file names into absolute file names
|
---|
303 | my $cwd = ::cwd();
|
---|
304 | my @files = ();
|
---|
305 | foreach my $file (@_) {
|
---|
306 | push @files, ::get_abs_path ($file);
|
---|
307 | }
|
---|
308 |
|
---|
309 | return "cd \"$_->{dir}\" && mmttcncp.exe -l \"".(join ';', @files).'"';
|
---|
310 | }
|
---|
311 |
|
---|
312 | # match one error line in the compiler output
|
---|
313 | sub match_error
|
---|
314 | {
|
---|
315 | shift;
|
---|
316 | /\* Script.*: Line [0-9]+: /;
|
---|
317 | }
|
---|
318 |
|
---|
319 | package main;
|
---|
320 |
|
---|
321 | # List all the files matching a regular expression in a directory and
|
---|
322 | # recursively in all its subdirectories
|
---|
323 | #
|
---|
324 | # dir path of the directory to be scanned
|
---|
325 | # pattern regular expression to be used for selecting the files
|
---|
326 | #
|
---|
327 | # return an array containing the files that match the pattern
|
---|
328 | #
|
---|
329 | sub get_files_in_dir
|
---|
330 | {
|
---|
331 | my ($dir, $pattern) = @_;
|
---|
332 | my @result = ();
|
---|
333 |
|
---|
334 | (opendir "DIR$dir", "$dir") or die "cannot access directory $dir";
|
---|
335 | while ($_ = readdir "DIR$dir")
|
---|
336 | {
|
---|
337 | next if /^\.\.?$/;
|
---|
338 | my $file = "$dir\\$_";
|
---|
339 |
|
---|
340 | if ((-f $file) && ($file =~ /$pattern/i)) {
|
---|
341 | push @result, $file;
|
---|
342 | } elsif (-d $file) {
|
---|
343 | my @subdir_result = get_files_in_dir ($file, $pattern);
|
---|
344 | push @result, @subdir_result;
|
---|
345 | }
|
---|
346 | }
|
---|
347 | closedir "DIR$dir";
|
---|
348 |
|
---|
349 | return @result;
|
---|
350 | }
|
---|
351 |
|
---|
352 | # make a comparison of two version numbers
|
---|
353 | #
|
---|
354 | # This function compares separately the major an minor version numbers
|
---|
355 | sub cmp_version
|
---|
356 | {
|
---|
357 | my ($a, $b) = @_;
|
---|
358 |
|
---|
359 | my ($a_maj, $a_min, $b_maj, $b_min) = ($a, undef, $b, undef);
|
---|
360 | if ($a =~ /^([0-9a-z]+)[_.-]([0-9a-z].*)$/i) {
|
---|
361 | ($a_maj, $a_min) = ($1, $2);
|
---|
362 | }
|
---|
363 | if ($b =~ /^([0-9a-z]+)[_.-]([0-9a-z].*)$/i) {
|
---|
364 | ($b_maj, $b_min) = ($1, $2);
|
---|
365 | }
|
---|
366 | my $result = undef;
|
---|
367 | if (($a_maj =~ /^[0-9]/) && ($b_maj =~ /^[0-9]/)) {
|
---|
368 | # numeric comparison
|
---|
369 | # FIXME: this comparison ignores letters appended to the
|
---|
370 | # version: eg. 1.2.3a
|
---|
371 | $result = $a_maj <=> $b_maj;
|
---|
372 | } else {
|
---|
373 | # alphabetical comparison
|
---|
374 | $result = $a_maj cmp $b_maj;
|
---|
375 | }
|
---|
376 |
|
---|
377 | $result && return $result;
|
---|
378 |
|
---|
379 | if (defined $a_min) {
|
---|
380 | return (defined $b_min) ? cmp_version ($a_min, $b_min) : 1;
|
---|
381 | } else {
|
---|
382 | return (defined $b_min) ? -1 : 0;
|
---|
383 | }
|
---|
384 | }
|
---|
385 |
|
---|
386 | # Find the newest versionned subdir in a directory
|
---|
387 | #
|
---|
388 | # This function will check the names of the subdirectories located in dir and
|
---|
389 | # will select the one which has the highest version number in its suffix and that
|
---|
390 | # matches the pattern
|
---|
391 | #
|
---|
392 | # dir directory to be scanned
|
---|
393 | # pattern regular expression to detect the elegible subdirectories
|
---|
394 | #
|
---|
395 | # return the chosen subdirectory in the form "directory\\subdirectory"
|
---|
396 | sub find_newest_version_in_dir
|
---|
397 | {
|
---|
398 | my ($base_dir, $pattern) = @_;
|
---|
399 |
|
---|
400 | (opendir DIR, $base_dir) || return undef;
|
---|
401 |
|
---|
402 | my @subdirs = readdir DIR;
|
---|
403 | my $max_version = " ";
|
---|
404 | my $subdir = undef;
|
---|
405 | foreach (@subdirs) {
|
---|
406 | if ( (-d "$base_dir\\$_")
|
---|
407 | && ((!defined $pattern) || /$pattern/i)
|
---|
408 | && /([0-9]+([._][0-9]+)*)$/
|
---|
409 | && (cmp_version ($max_version, $1) < 0))
|
---|
410 | {
|
---|
411 | $max_version = $1;
|
---|
412 | $subdir = $_;
|
---|
413 | }
|
---|
414 | }
|
---|
415 | closedir DIR;
|
---|
416 |
|
---|
417 | return (defined $subdir ? "$base_dir\\$subdir" : undef);
|
---|
418 | }
|
---|
419 |
|
---|
420 | # Get the absolute path of the current working directory
|
---|
421 | sub cwd
|
---|
422 | {
|
---|
423 | (open CWD, "cmd.exe /C cd |") or die "Cannot run the interpreter cmd.exe";
|
---|
424 | $cwd = <CWD>;
|
---|
425 | $cwd =~ /^[A-Z]:/i || die;
|
---|
426 | chomp $cwd;
|
---|
427 | close CWD;
|
---|
428 | return $cwd;
|
---|
429 | }
|
---|
430 |
|
---|
431 | # Get the absolute path a file/directory
|
---|
432 | sub get_abs_path
|
---|
433 | {
|
---|
434 | my $path = shift;
|
---|
435 |
|
---|
436 | return (($path =~ /^[A-Z]:/i) ? "" : cwd()."\\" ) . $path;
|
---|
437 | }
|
---|
438 |
|
---|
439 |
|
---|
440 | ########################################################################
|
---|
441 | ### Beginning of the script ###
|
---|
442 |
|
---|
443 | # output directory for storing the results
|
---|
444 | $TTCN3Tool::OUTPUT_DIR = cwd();
|
---|
445 |
|
---|
446 | # generate the list of TTCN-3 files to be compiled
|
---|
447 | if (@ARGV == 1) {
|
---|
448 | # if there is only one directory given, then we chdir into
|
---|
449 | # this directory to have shorter file name
|
---|
450 | # (this is purely cosmetical)
|
---|
451 | $_ = $ARGV[0];
|
---|
452 | chdir $_ or die "Error: cannot chdir into '$_'\n";
|
---|
453 |
|
---|
454 | @ttcn_files = get_files_in_dir (".", $TTCN_FILENAME_PATTERN);
|
---|
455 | } else {
|
---|
456 | # otherwise we just use the full directory names
|
---|
457 | @ttcn_files = ();
|
---|
458 | foreach (@ARGV) {
|
---|
459 | -d or die "Error: there is no directory '$_'\n";
|
---|
460 | push @ttcn_files, get_files_in_dir ($_, $TTCN_FILENAME_PATTERN);
|
---|
461 | }
|
---|
462 | }
|
---|
463 |
|
---|
464 | @ttcn_files or die "usage: $0 sourcedir1 [sourcedir2 ...]\n";
|
---|
465 |
|
---|
466 | print "List of TTCN-3 source files: @ttcn_files\n\n";
|
---|
467 |
|
---|
468 |
|
---|
469 | # detect the tools installed on the system
|
---|
470 | my @tools = ();
|
---|
471 | foreach (
|
---|
472 | new TTCN3Tool::TelelogicTester,
|
---|
473 | # new TTCN3Tool::OpenTTCNTester, # FIXME: not supported yet (need a license)
|
---|
474 | new TTCN3Tool::MessageMagic,
|
---|
475 | new TTCN3Tool::TTworkbench
|
---|
476 | ) {
|
---|
477 | $_->is_detected && push @tools, $_;
|
---|
478 | }
|
---|
479 |
|
---|
480 | # execute each compiler
|
---|
481 | foreach (@tools)
|
---|
482 | {
|
---|
483 | print "\nAnalysing the ATS with $_->{name}...\n";
|
---|
484 | $_->analyse (@ttcn_files);
|
---|
485 | }
|
---|
486 |
|
---|
487 |
|
---|