]>
Commit | Line | Data |
---|---|---|
ed5ce4e0 MS |
1 | # Library of functions for dealing with DejaGNU, or which are otherwise |
2 | # generally useful for the DejaGNU tool stack. | |
3 | # | |
4 | # Author: Matthew Sachs <msachs@apple.com> | |
5 | # | |
6 | # Functions: | |
7 | # parseLogFile: See "sub parseLogFile" below for details. This function | |
8 | # returns a detailed parse of a DejaGNU log or sum file. | |
9 | # ispass: Takes a DejaGNU result (e.g. "PASS", "XPASS") and returns | |
10 | # true if and only if it is a passing result (PASS, XFAIL, or | |
11 | # KFAIL.) | |
12 | # | |
13 | # Copyright (c) 2006 Free Software Foundation. | |
14 | # | |
15 | # This file is part of GCC. | |
16 | # | |
17 | # GCC is free software; you can redistribute it and/or modify | |
18 | # it under the terms of the GNU General Public License as published by | |
3dfb41c5 | 19 | # the Free Software Foundation; either version 3, or (at your option) |
ed5ce4e0 MS |
20 | # any later version. |
21 | # | |
22 | # GCC is distributed in the hope that it will be useful, | |
23 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
24 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
25 | # GNU General Public License for more details. | |
26 | # | |
27 | # You should have received a copy of the GNU General Public License | |
28 | # along with GCC; see the file COPYING. If not, write to | |
29 | # the Free Software Foundation, 51 Franklin Street, Fifth Floor, | |
30 | # Boston, MA 02110-1301, USA. | |
31 | ||
32 | package dglib; | |
33 | ||
34 | use strict; | |
35 | use warnings; | |
36 | use Exporter; | |
37 | ||
38 | our @ISA = qw(Exporter); | |
39 | our @EXPORT = qw(ispass parseLogFile); | |
40 | ||
41 | use File::Basename; | |
42 | use POSIX qw(mktime); | |
43 | ||
44 | ||
45 | # Create a group hierarchy, returning the leaf node | |
46 | sub mkGroupPath { | |
47 | my($root, $groups, @newgroups) = @_; | |
48 | ||
49 | my $parent = $root; | |
50 | my $fullname = ""; | |
51 | foreach my $group(@newgroups) { | |
52 | $fullname .= "/" if $fullname; | |
53 | $fullname .= $group; | |
54 | if(exists($groups->{$fullname})) { | |
55 | $parent = $groups->{$fullname}; | |
56 | } else { | |
57 | my $newgroup = {name => $group, parent => $parent}; | |
58 | $groups->{$fullname} = $newgroup; | |
59 | $parent->{testgroup} ||= []; | |
60 | push @{$parent->{testgroup}}, $newgroup; | |
61 | $parent = $newgroup; | |
62 | } | |
63 | } | |
64 | ||
65 | return $parent; | |
66 | } | |
67 | ||
68 | # Extract information from DejaGNU log or sum files. | |
69 | # Options, if provided, should be a hashref with zero or more of the following keys: | |
70 | # gccdir: | |
71 | # Passing in the full path to the root of the gcc/testsuite directory | |
72 | # will help in the parsing, but if it isn't provided, it will be guessed. | |
73 | # diagnostics: | |
74 | # If set to 0, diagnostics will not be returned. This can save a lot | |
75 | # of memory if you are not using this information. | |
76 | # fullname: | |
77 | # If set to 0, the fullname key will not be included in tests. | |
78 | # Returns a hash with the following keys: | |
79 | # incomplete: 1 if the summary file appears truncated, otherwise 0 | |
80 | # diagnostics: List of (type, value) for any errors detected. Type can be ERROR, WARNING, or NOTE. | |
81 | # test: Array of root-level tests, with keys: | |
82 | # name: Name of the test, relative to the enclosing test group. | |
83 | # fullname: Fully-qualified name of the test. | |
84 | # result: DejaGNU result (PASS, FAIL, XPASS, &c) | |
85 | # detail: For multi-phase (e.g. compile/link/execute), this will be | |
86 | # the furthest phase which the test was able to attempt, | |
87 | # so if the result is FAIL and this is "link phase", the test | |
88 | # compiled but failed to link. This key may contain other | |
89 | # auxiliary data. | |
90 | # pseudotest: If 1, this test may not really exist; see "pseudotest" below. | |
91 | # testgroup: Array of root-level testgroups, with keys: | |
92 | # name: Name of the group. | |
93 | # parent: Parent test group. | |
94 | # test: As per above. | |
95 | # testgroup: Child test groups. | |
96 | # compiler: Version string from compiler used to run the tests (if detected) | |
97 | sub parseLogFile($;$) { | |
98 | my($logfile, $options) = @_; | |
99 | $options ||= {}; | |
100 | my $gccdir = $options->{gccdir} || ""; | |
101 | my $return_diags = exists($options->{diagnostics}) ? $options->{diagnostics} : 1; | |
102 | my $emit_fullname = exists($options->{fullname}) ? $options->{fullname} : 1; | |
103 | my $is_gdb = 0; | |
104 | my $gdbhack = ""; | |
105 | ||
106 | my %ret = (incomplete => 1, diagnostics => [], testgroup => []); | |
107 | my(%testindex, %groupindex); | |
108 | ||
109 | open(LOGFILE, $logfile) or die "Couldn't open log file $logfile: $!\n"; | |
110 | ||
111 | my($currgroup, $currtest, $lastrun); | |
112 | $currgroup = \%ret; | |
113 | ||
114 | my %monmap = (Jan => 0, Feb => 1, Mar => 2, Apr => 3, May => 4, Jun => 5, Jul => 6, Aug => 7, Sep => 8, Oct => 9, Nov => 10, Dec => 11); | |
115 | ||
116 | # We don't want gccdir matching on an empty string. | |
117 | $gccdir ||= "this will never match, or my name isn't Reginald St. Croix"; | |
118 | ||
119 | my $line = 1; | |
120 | while(<LOGFILE>) { | |
121 | chomp; | |
122 | s/\x{d}$//; #^M | |
123 | next if $_ eq ""; | |
124 | ||
125 | if(/^gcc version/) { | |
126 | $ret{compiler} = $_; | |
127 | } elsif(/^got a .* signal, interrupted by user /) { | |
128 | $ret{incomplete} = 2; | |
129 | } elsif(/^\s*=== gdb/) { | |
130 | $is_gdb = 1; | |
131 | # The log file from the GDB test suite is prone to have random crap | |
132 | # in front of test result lines, so we need to be looser about how | |
133 | # we parse those for GDB. | |
134 | $gdbhack = ".*"; | |
135 | } elsif(/^(Test Run By \S+ on|runtest completed at) ... (.{3}) (\d{1,2}) (\d{1,2}):(\d{1,2}):(\d{1,2}) (\d{4})/) { | |
136 | my $time = mktime($6, $5, $4, $3, $monmap{$2}, $7 - 1900); | |
137 | if($1 eq "runtest completed at") { | |
138 | $ret{end_time} = $time; | |
139 | } else { | |
140 | $ret{start_time} = $time; | |
141 | } | |
142 | } elsif(m<^Running (?!target )\Q$gccdir\E/?(\S+)> or m<^Running (?!target )\S*?((?:gcc|gdb|libstdc\+\+-v3)/testsuite/\S+)>) { | |
143 | # We keep track of the last "Running foo/bar/baz.exp" line because | |
144 | # some tests don't bother printing out the full paths of their files, | |
145 | # and this gives us the directory information. | |
146 | ||
147 | $lastrun = $1; | |
148 | $lastrun =~ s!/[^/]*/\.\.!!; # foo/bar/../baz -> foo/baz | |
149 | $currgroup = mkGroupPath(\%ret, \%groupindex, split(m!/!, $lastrun)); | |
150 | #$currgroup->{testfile} = $lastrun; | |
151 | } elsif(/^Executing on (.*?):(.*)/) { | |
152 | # Okay, if it's "Executing on host", it's a new | |
153 | # file. If it's "Executing on unix", it's probably | |
154 | # a test within the file -- an execution test, specifically -- | |
155 | # (makes sense, no?) But not always, sometimes we | |
156 | # see "Executing on unix" outside the context of a | |
157 | # file. | |
158 | ||
159 | # Try to pick out the gccdir-relative filename. | |
160 | # If we can't find it, it isn't really a new testfile, | |
161 | # but a derived file. | |
162 | my($exectype, $execwhat) = ($1, $2); | |
163 | next if $execwhat =~ /^dsymutil/; | |
164 | $execwhat =~ | |
165 | s!.*?\s\Q$gccdir\E/?(\S+).*!$1! or | |
166 | s!.*?/((?:gcc|gdb|libstdc\+\+-v3)/testsuite/\S+).*!$1! or | |
167 | $exectype = "unix"; | |
168 | ||
169 | if($exectype eq "host" or !$currgroup) { | |
170 | # New file | |
171 | ||
172 | my $nogroup = 0; | |
173 | if($execwhat =~ / /) { | |
174 | # We probably haven't parsed the file correctly. | |
175 | # Try getting it from $lastrun. | |
176 | ||
177 | $execwhat = dirname($lastrun) . "/" . basename($execwhat) if $lastrun and $execwhat; | |
178 | $execwhat =~ s/\s.*//; | |
179 | ||
180 | # At the end of each tool, it invokes "gcc -v" or "c++ -v" | |
181 | # as a test. We don't really want to treat this as a test. | |
182 | if($execwhat =~ m!/(gcc|c\+\+)$!) { | |
183 | undef $currtest; | |
184 | undef $currgroup; | |
185 | $nogroup = 1; | |
186 | } | |
187 | } | |
188 | ||
189 | if(!$nogroup) { | |
190 | undef $currtest; | |
191 | $execwhat =~ s!/[^/]*/\.\.!!; # foo/bar/../baz -> foo/baz | |
192 | ||
193 | if($lastrun) { | |
194 | my $lastbase = dirname($lastrun); | |
195 | my $basegroup = $execwhat; | |
196 | $basegroup =~ s!^\Q$lastbase\E/!!; | |
197 | $execwhat = "$lastrun/$basegroup"; | |
198 | } | |
199 | ||
200 | $currgroup = mkGroupPath(\%ret, \%groupindex, split(m!/!, $execwhat)); | |
201 | #$currgroup->{testfile} = $execwhat; | |
202 | } | |
203 | } else { | |
204 | # New test within current file | |
205 | ||
206 | $currtest = {}; | |
207 | } | |
208 | } elsif(/^# of/) { | |
209 | # This line appears should appear near the end of summary files. | |
210 | # If it doesn't, something went wrong. | |
211 | ||
212 | if($ret{incomplete} == 2) { | |
213 | #Ah, but we previously saw indication that we were killed via a signal. | |
214 | $ret{incomplete} = 1; | |
215 | } else { | |
216 | $ret{incomplete} = 0; | |
217 | } | |
218 | } elsif(/^testcase .* completed/) { | |
219 | # End of a .exp file | |
220 | undef $currtest; | |
221 | undef $currgroup; | |
222 | } elsif(/^$gdbhack(FAIL|PASS|UNRESOLVED|UNSUPPORTED|UNTESTED|XFAIL|XPASS|KFAIL|KPASS): (.*)/) { | |
223 | # If the currtest already has a name, that means we've already seen | |
224 | # its results, so what we have now is a new test. However, if we | |
225 | # haven't seen results for currtest yet, that means currtest just | |
226 | # has some diagnostics associated with it but no actual results, | |
227 | # so just use that one. | |
228 | undef $currtest if $currtest->{name}; | |
229 | ||
230 | my $phase = ""; # compile/link/execute | |
231 | my($test, $result) = ($2, $1); | |
232 | ||
233 | # Compile/(link/)execute combining | |
234 | if($test =~ /^(.*) compile\s*$/) { | |
235 | $test = "$1 compile,link,execute"; | |
236 | $phase = "compile"; | |
237 | } elsif($test =~ /^(.*)-(.*) (link|execute)\s*$/) { | |
238 | $test = "$1 compile,link,execute"; | |
239 | if($3 eq "link") { | |
240 | $phase = "link"; | |
241 | } else { | |
242 | $phase = "execute"; | |
243 | } | |
244 | } elsif($test =~ /(compile|compilation|execute|execution)/) { | |
245 | my $phasematch = $1; | |
246 | if($test =~ /^com/) { | |
247 | $phase = "compile"; | |
248 | } else { | |
249 | $phase = "execute"; | |
250 | } | |
251 | $test =~ s!\Q$phasematch\E!compile,execute!; | |
252 | } | |
253 | ||
254 | # gcov tests behave in non-standard fashion. | |
255 | my $failwhy = ""; | |
256 | $test =~ s/ gcov failed: (.*)// and $failwhy = $1; | |
257 | ||
258 | # And some other tests have random information after a colon :( | |
259 | # But for scan-assembler, this really is part of the name. | |
260 | if(!$is_gdb and $test !~ /scan-assembler/ and $test =~ s/:\s*(.+)//) { | |
261 | $failwhy = $1; | |
262 | } | |
263 | ||
264 | $test =~ s/\s*$//; | |
265 | $test =~ s/^\s*$//; | |
266 | ||
267 | # Sometimes there's a test which shows up as: | |
268 | # foo (test for excess errors) | |
269 | # foo (something else) | |
270 | # foo: error executing dg-final | |
271 | # if it runs, but just: | |
272 | # foo | |
273 | # if it doesn't. When we see the top form, we create a | |
274 | # "pseudotest" in the bottom form, so that comparisons | |
275 | # can be made. | |
276 | my $basetest = $test; | |
277 | $basetest =~ s/:? .*//; | |
278 | ||
279 | if(exists($testindex{$test}) and !$testindex{$test}->{pseudotest}) { | |
280 | $currtest = $testindex{$test}; | |
281 | if(ispass($currtest->{result})) { | |
282 | $currtest->{result} = $result; | |
283 | $currtest->{detail} = "$phase phase"; | |
284 | $currtest->{detail} .= "; $failwhy" if $failwhy; | |
285 | } | |
286 | } else { | |
287 | # This might have been created earlier as a pseudotest. | |
288 | # If so, overwrite it. | |
289 | $currtest ||= $testindex{$test} || {}; | |
290 | ||
291 | $currtest->{name} = basename($test); | |
292 | if($emit_fullname) { | |
293 | $currtest->{fullname} = ($currgroup->{name} || dirname($test)) . "/$currtest->{name}"; | |
294 | } | |
295 | my $grpname = $currgroup->{name} || ""; | |
296 | $currtest->{name} =~ s/^\s*\Q$grpname\E\s*//; | |
297 | $currtest->{name} =~ s/^: // if $is_gdb; | |
298 | # Sometimes there's a test at the root of the group. | |
299 | # For instance, you'll have: | |
300 | # FAIL: foo/bar.c (test for excess errors) | |
301 | # UNRESOLVED: foo/bar.c: couldn't open "bar.s": no such file or directory | |
302 | # In this case, groupname *is* the entire name, so the regex above will make the test name empty. | |
303 | # In this case, we actually want to use the parent group and make this a test within that group. | |
304 | my $orig_currgroup = $currgroup; | |
305 | if(!$currtest->{name}) { | |
306 | $currtest->{name} = $grpname; | |
307 | $currgroup = $currgroup->{parent}; | |
308 | $grpname = $currgroup->{name} || ""; | |
309 | } | |
310 | ||
311 | $currtest->{result} = $result; | |
312 | if($phase and $failwhy) { | |
313 | $currtest->{detail} = "$phase phase; $failwhy" if $phase; | |
314 | } elsif($phase) { | |
315 | $currtest->{detail} = "$phase phase"; | |
316 | } elsif($failwhy) { | |
317 | $currtest->{detail} = $failwhy; | |
318 | } | |
319 | ||
320 | $currgroup->{test} ||= []; | |
321 | push @{$currgroup->{test}}, $currtest; | |
322 | $testindex{$test} = $currtest; | |
323 | $currgroup = $orig_currgroup; | |
324 | ||
325 | if($basetest ne $test) { | |
326 | if(!exists($testindex{$basetest}) ) { | |
327 | my $btbase = basename($basetest); | |
328 | $testindex{$basetest} = { | |
329 | name => $btbase, | |
330 | result => $result, | |
331 | pseudotest => 1, | |
332 | fullname => $btbase | |
333 | }; | |
334 | if($emit_fullname) { | |
335 | $testindex{basetest}->{fullname} = ($currgroup->{name} || dirname($basetest)) . "/$btbase"; | |
336 | } | |
337 | push @{$currgroup->{parent}->{test}}, $testindex{$basetest}; | |
338 | } else { | |
339 | # Only let the base test pass if all the sub-tests pass | |
340 | $testindex{$basetest}->{result} = $result if !ispass($result); | |
341 | } | |
342 | } | |
343 | ||
344 | } | |
345 | } elsif(/^\s+=== .* Summary ===\s*$/) { | |
346 | undef $currgroup; | |
347 | undef $currtest; | |
348 | } | |
349 | ||
350 | my $severity; | |
351 | if(/^(ERROR|WARNING|NOTE): (.*)/) { | |
352 | $severity = $1; | |
353 | my $message = $2; | |
354 | ||
355 | if($message eq "program timed out.") { | |
356 | $currtest->{result} = "TIMEDOUT"; | |
357 | } elsif( | |
358 | $message =~ /can't read "(HOSTCC|libiconv)": no such variable/ or | |
359 | $message =~ /no files matched glob pattern/ or | |
360 | $message =~ /error executing dg-final: .*: no such file/ | |
361 | ) { | |
362 | $severity = "NOTE"; | |
363 | } | |
364 | } else { | |
365 | $severity = "logline"; | |
366 | } | |
367 | ||
368 | if($return_diags) { | |
369 | my $dobj; | |
370 | if($currtest) { | |
371 | $currtest->{diagnostics} ||= []; | |
372 | $dobj = $currtest->{diagnostics}; | |
373 | } elsif($currgroup) { | |
374 | $currgroup->{diagnostics} ||= []; | |
375 | $dobj = $currgroup->{diagnostics}; | |
376 | } else { | |
377 | $dobj = $ret{diagnostics}; | |
378 | } | |
379 | ||
380 | push @$dobj, {message => $_, severity => $severity, line => $line}; | |
381 | } | |
382 | } continue { | |
383 | $line++; | |
384 | } | |
385 | close LOGFILE; | |
386 | ||
387 | return %ret; | |
388 | } | |
389 | ||
390 | # Split a test into testdivs | |
391 | sub splitTest($$) { | |
392 | my($root, $test) = @_; | |
393 | ||
394 | $test->{fullname} =~ /^(\S+)\s*(.*)/; | |
395 | my($path, $descriptor) = ($1, $2); | |
396 | my @nodes = split(m!/!, $path); | |
397 | push @nodes, $descriptor if $descriptor; | |
398 | my $lastnode = pop @nodes; | |
399 | ||
400 | my $hash = $root; | |
401 | foreach (@nodes) { | |
402 | $hash->{testdiv} ||= {}; | |
403 | $hash = $hash->{testdiv}->{$_} ||= {}; | |
404 | } | |
405 | ||
406 | ||
407 | $hash->{test} ||= {}; | |
408 | $hash->{test}->{$lastnode} = $test; | |
409 | } | |
410 | ||
411 | ||
412 | # ==== Comparison ==== | |
413 | ||
414 | sub ispass($) { | |
415 | my $result = shift; | |
416 | ||
417 | if($result eq "PASS" or $result eq "XFAIL" or $result eq "KFAIL") { | |
418 | return 1; | |
419 | } else { | |
420 | return 0; | |
421 | } | |
422 | } | |
423 | ||
424 | 1; |