gdb/testsuite/lib/check-test-names.exp

   1 # Copyright 2020-2022 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
  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 {}
  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 is a well-formed test name.
  97     proc _check_well_formed_name { message } {
  98         if { [regexp \n $message]} {
  99             warning "Newline in test name"
 100         }
 101     }
 102
 103     # Check if MESSAGE contains either the source path or the build path.
 104     # This will result in test names that can't easily be compared between
 105     # different runs of GDB.
 106     #
 107     # Any offending test names cause the corresponding count to be
 108     # incremented, and an extra message to be printed into the log
 109     # file.
 110     proc check { message } {
 111         set message [ _strip_status $message ]
 112
 113         if [ _check_paths $message ] {
 114             clone_output "PATH: $message"
 115         }
 116
 117         if [ _check_duplicates $message ] {
 118             clone_output "DUPLICATE: $message"
 119         }
 120
 121         _check_well_formed_name $message
 122     }
 123
 124     # If COUNT is greater than zero, disply PREFIX followed by COUNT.
 125     proc maybe_show_count { prefix count } {
 126         if { $count > 0 } {
 127             clone_output "$prefix$count"
 128         }
 129     }
 130
 131     # Rename Dejagnu's log_summary procedure, and create do_log_summary to
 132     # replace it.  We arrange to have do_log_summary called later.
 133     rename ::log_summary log_summary
 134     proc do_log_summary { args } {
 135         variable counts
 136
 137         # If ARGS is the empty list then we don't want to pass a single
 138         # empty string as a parameter here.
 139         eval "CheckTestNames::log_summary $args"
 140
 141         if { [llength $args] == 0 } {
 142             set which "count"
 143         } else {
 144             set which [lindex $args 0]
 145         }
 146
 147         maybe_show_count "# of paths in test names\t" \
 148             $counts(paths,$which)
 149         maybe_show_count "# of duplicate test names\t" \
 150             $counts(duplicates,$which)
 151     }
 152
 153     # Rename Dejagnu's reset_vars procedure, and create do_reset_vars to
 154     # replace it.  We arrange to have do_reset_vars called later.
 155     rename ::reset_vars reset_vars
 156     proc do_reset_vars {} {
 157         variable all_test_names
 158         variable counts
 159
 160         CheckTestNames::reset_vars
 161
 162         array unset all_test_names
 163         foreach nm {paths duplicates} {
 164             set counts($nm,count) 0
 165         }
 166     }
 167 }
 168
 169 # Arrange for Dejagnu to call CheckTestNames::check for each test result.
 170 foreach nm {pass fail xfail kfail xpass kpass unresolved untested \
 171                 unsupported} {
 172     set local_record_procs($nm) "CheckTestNames::check"
 173 }
 174
 175 # Create new global log_summary to replace Dejagnu's.
 176 proc log_summary { args } {
 177     eval "CheckTestNames::do_log_summary $args"
 178 }
 179
 180 # Create new global reset_vars to replace Dejagnu's.
 181 proc reset_vars {} {
 182     eval "CheckTestNames::do_reset_vars"
 183 }