1 # Copyright 2020-2021 Free Software Foundation, Inc.
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.
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.
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/>.
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.
21 namespace eval ::CheckTestNames {
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 {}
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.
33 foreach nm {paths duplicates} {
34 set counts($nm,count) 0
35 set counts($nm,total) 0
38 # Increment the count, and total count for TYPE.
39 proc inc_count { type } {
42 incr counts($type,count)
43 incr counts($type,total)
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 } {
51 foreach path [list $srcdir $objdir] {
52 if { [ string first $path $message ] >= 0 } {
53 # Count each test just once.
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
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
71 if {$all_test_names($message) == 0} {
74 incr all_test_names($message)
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]
89 # The '+ 2' is so we skip the ': ' we found above.
90 return [string range $message [expr $pos + 2] end]
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.
100 # Any offending test names cause the corresponding count to be
101 # incremented, and an extra message to be printed into the log
103 proc check { message } {
104 set message [ _strip_status $message ]
106 if [ _check_paths $message ] {
107 clone_output "PATH: $message"
110 if [ _check_duplicates $message ] {
111 clone_output "DUPLICATE: $message"
115 # If COUNT is greater than zero, disply PREFIX followed by COUNT.
116 proc maybe_show_count { prefix count } {
118 clone_output "$prefix$count"
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 } {
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"
132 if { [llength $args] == 0 } {
135 set which [lindex $args 0]
138 maybe_show_count "# of paths in test names\t" \
139 $counts(paths,$which)
140 maybe_show_count "# of duplicate test names\t" \
141 $counts(duplicates,$which)
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 {} {
148 variable all_test_names
151 CheckTestNames::reset_vars
153 array unset all_test_names
154 foreach nm {paths duplicates} {
155 set counts($nm,count) 0
160 # Arrange for Dejagnu to call CheckTestNames::check for each test result.
161 foreach nm {pass fail xfail kfail xpass kpass unresolved untested \
163 set local_record_procs($nm) "CheckTestNames::check"
166 # Create new global log_summary to replace Dejagnu's.
167 proc log_summary { args } {
168 eval "CheckTestNames::do_log_summary $args"
171 # Create new global reset_vars to replace Dejagnu's.
173 eval "CheckTestNames::do_reset_vars"