Commit | Line | Data |
---|---|---|
3666a048 | 1 | # Copyright 2020-2021 Free Software Foundation, Inc. |
34584c09 AB |
2 | |
3 | # This program is free software; you can redistribute it and/or modify | |
4 | # it under the terms of the GNU General Public License as published by | |
5 | # the Free Software Foundation; either version 3 of the License, or | |
6 | # (at your option) any later version. | |
7 | # | |
8 | # This program is distributed in the hope that it will be useful, | |
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | # GNU General Public License for more details. | |
12 | # | |
13 | # You should have received a copy of the GNU General Public License | |
14 | # along with this program. If not, see <http://www.gnu.org/licenses/>. | |
15 | ||
16 | # This library provides some protection against the introduction of | |
17 | # tests that include either the source of build paths in the test | |
18 | # name. When a test includes the path in its test name it is harder | |
19 | # to compare results between two runs of GDB from different trees. | |
20 | ||
21 | namespace eval ::CheckTestNames { | |
d30dcd12 AB |
22 | # An associative array of all test names to the number of times each |
23 | # name is seen. Used to detect duplicate test names. | |
24 | variable all_test_names | |
25 | array set all_test_names {} | |
26 | ||
27 | # An associative array of counts of tests that either include a path in | |
28 | # their test name, or have a duplicate test name. There are two counts | |
29 | # for each issue, 'count', which counts occurrences within a single | |
30 | # variant run, and 'total', which counts across all variants. | |
34584c09 AB |
31 | variable counts |
32 | array set counts {} | |
d30dcd12 | 33 | foreach nm {paths duplicates} { |
34584c09 AB |
34 | set counts($nm,count) 0 |
35 | set counts($nm,total) 0 | |
36 | } | |
37 | ||
38 | # Increment the count, and total count for TYPE. | |
39 | proc inc_count { type } { | |
40 | variable counts | |
41 | ||
42 | incr counts($type,count) | |
43 | incr counts($type,total) | |
44 | } | |
45 | ||
46 | # Check if MESSAGE contains a build or source path, if it does increment | |
47 | # the relevant counter and return true, otherwise, return false. | |
48 | proc _check_paths { message } { | |
49 | global srcdir objdir | |
50 | ||
51 | foreach path [list $srcdir $objdir] { | |
52 | if { [ string first $path $message ] >= 0 } { | |
53 | # Count each test just once. | |
54 | inc_count paths | |
55 | return true | |
56 | } | |
57 | } | |
58 | ||
59 | return false | |
60 | } | |
61 | ||
d30dcd12 AB |
62 | # Check if MESSAGE is a duplicate, if it is then increment the |
63 | # duplicates counter and return true, otherwise, return false. | |
64 | proc _check_duplicates { message } { | |
65 | variable all_test_names | |
66 | ||
67 | # Initialise a count, or increment the count for this test name. | |
68 | if {![info exists all_test_names($message)]} { | |
69 | set all_test_names($message) 0 | |
70 | } else { | |
71 | if {$all_test_names($message) == 0} { | |
72 | inc_count duplicates | |
73 | } | |
74 | incr all_test_names($message) | |
75 | return true | |
76 | } | |
77 | ||
78 | return false | |
79 | } | |
80 | ||
34584c09 AB |
81 | # Remove the leading Dejagnu status marker from MESSAGE, and |
82 | # return the remainder of MESSAGE. A status marker is something | |
83 | # like 'PASS: '. It is assumed that MESSAGE does contain such a | |
84 | # marker. If it doesn't then MESSAGE is returned unmodified. | |
85 | proc _strip_status { message } { | |
86 | # Find the position of the first ': ' string. | |
87 | set pos [string first ": " $message] | |
88 | if { $pos > -1 } { | |
89 | # The '+ 2' is so we skip the ': ' we found above. | |
90 | return [string range $message [expr $pos + 2] end] | |
91 | } | |
92 | ||
93 | return $message | |
94 | } | |
95 | ||
96 | # Check if MESSAGE contains either the source path or the build path. | |
97 | # This will result in test names that can't easily be compared between | |
98 | # different runs of GDB. | |
99 | # | |
100 | # Any offending test names cause the corresponding count to be | |
101 | # incremented, and an extra message to be printed into the log | |
102 | # file. | |
103 | proc check { message } { | |
104 | set message [ _strip_status $message ] | |
105 | ||
106 | if [ _check_paths $message ] { | |
107 | clone_output "PATH: $message" | |
108 | } | |
d30dcd12 AB |
109 | |
110 | if [ _check_duplicates $message ] { | |
111 | clone_output "DUPLICATE: $message" | |
112 | } | |
34584c09 AB |
113 | } |
114 | ||
115 | # If COUNT is greater than zero, disply PREFIX followed by COUNT. | |
116 | proc maybe_show_count { prefix count } { | |
117 | if { $count > 0 } { | |
118 | clone_output "$prefix$count" | |
119 | } | |
120 | } | |
121 | ||
122 | # Rename Dejagnu's log_summary procedure, and create do_log_summary to | |
123 | # replace it. We arrange to have do_log_summary called later. | |
124 | rename ::log_summary log_summary | |
125 | proc do_log_summary { args } { | |
126 | variable counts | |
127 | ||
128 | # If ARGS is the empty list then we don't want to pass a single | |
129 | # empty string as a parameter here. | |
130 | eval "CheckTestNames::log_summary $args" | |
131 | ||
132 | if { [llength $args] == 0 } { | |
133 | set which "count" | |
134 | } else { | |
135 | set which [lindex $args 0] | |
136 | } | |
137 | ||
138 | maybe_show_count "# of paths in test names\t" \ | |
139 | $counts(paths,$which) | |
d30dcd12 AB |
140 | maybe_show_count "# of duplicate test names\t" \ |
141 | $counts(duplicates,$which) | |
34584c09 AB |
142 | } |
143 | ||
144 | # Rename Dejagnu's reset_vars procedure, and create do_reset_vars to | |
145 | # replace it. We arrange to have do_reset_vars called later. | |
146 | rename ::reset_vars reset_vars | |
147 | proc do_reset_vars {} { | |
d30dcd12 | 148 | variable all_test_names |
34584c09 AB |
149 | variable counts |
150 | ||
151 | CheckTestNames::reset_vars | |
152 | ||
10c381b5 | 153 | array unset all_test_names |
d30dcd12 | 154 | foreach nm {paths duplicates} { |
34584c09 AB |
155 | set counts($nm,count) 0 |
156 | } | |
157 | } | |
158 | } | |
159 | ||
160 | # Arrange for Dejagnu to call CheckTestNames::check for each test result. | |
161 | foreach nm {pass fail xfail kfail xpass kpass unresolved untested \ | |
162 | unsupported} { | |
163 | set local_record_procs($nm) "CheckTestNames::check" | |
164 | } | |
165 | ||
166 | # Create new global log_summary to replace Dejagnu's. | |
167 | proc log_summary { args } { | |
168 | eval "CheckTestNames::do_log_summary $args" | |
169 | } | |
170 | ||
171 | # Create new global reset_vars to replace Dejagnu's. | |
172 | proc reset_vars {} { | |
173 | eval "CheckTestNames::do_reset_vars" | |
174 | } |