1# Copyright 2020 Free Software Foundation, Inc. 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 21namespace 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 {} 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. 31 variable counts 32 array set counts {} 33 foreach nm {paths duplicates} { 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 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 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 } 109 110 if [ _check_duplicates $message ] { 111 clone_output "DUPLICATE: $message" 112 } 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) 140 maybe_show_count "# of duplicate test names\t" \ 141 $counts(duplicates,$which) 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 {} { 148 variable all_test_names 149 variable counts 150 151 CheckTestNames::reset_vars 152 153 array unset all_test_names 154 foreach nm {paths duplicates} { 155 set counts($nm,count) 0 156 } 157 } 158} 159 160# Arrange for Dejagnu to call CheckTestNames::check for each test result. 161foreach 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. 167proc log_summary { args } { 168 eval "CheckTestNames::do_log_summary $args" 169} 170 171# Create new global reset_vars to replace Dejagnu's. 172proc reset_vars {} { 173 eval "CheckTestNames::do_reset_vars" 174} 175