lib/utils.exp

   1 # Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
   2 #
   3 # This file is part of DejaGnu.
   4 #
   5 # DejaGnu is free software: you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation, either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # DejaGnu is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 # General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with DejaGnu.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 # This file was written by Rob Savoye. (rob@welcomehome.org)
  19
  20 # Most of the procedures found here mimic their UNIX counterpart.
  21 # This file is sourced by runtest.exp, so they are usable by any test
  22 # script.
  23
  24
  25 # Gets the directories in a directory, or in a directory tree.
  26 #     args: the first is the directory to look in, the next is the
  27 #         glob pattern to match (default "*").
  28 #     options: -all  search the tree recursively
  29 #     returns: a list of directories excluding the root directory
  30 #
  31 proc getdirs { args } {
  32     if { [lindex $args 0] eq "-all" } {
  33         set alldirs 1
  34         set args [lrange $args 1 end]
  35     } else {
  36         set alldirs 0
  37     }
  38
  39     set path [lindex $args 0]
  40     if { [llength $args] > 1} {
  41         set pattern [lindex $args 1]
  42     } else {
  43         set pattern "*"
  44     }
  45     verbose "Looking in $path for directories that match \"${pattern}\"" 3
  46     set dirs [list]
  47     foreach i [glob -nocomplain $path/$pattern] {
  48         if {[file isdirectory $i]} {
  49             switch -- "[file tail $i]" {
  50                 "testsuite" -
  51                 "config" -
  52                 "lib" -
  53                 ".git" -
  54                 ".svn" -
  55                 "CVS" -
  56                 "RCS" -
  57                 "SCCS" {
  58                     verbose "Ignoring directory [file tail $i]" 3
  59                     continue
  60                 }
  61                 default {
  62                     if {[file readable $i]} {
  63                         verbose "Found directory [file tail $i]" 3
  64                         lappend dirs $i
  65                         if { $alldirs } {
  66                             eval lappend dirs [getdirs -all $i $pattern]
  67                         }
  68                     }
  69                 }
  70             }
  71         }
  72     }
  73
  74     return $dirs
  75 }
  76
  77
  78 # Given a base and a destination, return a relative file name that refers
  79 # to the destination when used relative to the given base.
  80 proc relative_filename { base destination } {
  81     if { [file pathtype $base] ne "absolute" } {
  82         set base [file normalize $base]
  83     }
  84     if { [file pathtype $destination] ne "absolute" } {
  85         set destination [file normalize $destination]
  86     }
  87
  88     set base [file split $base]
  89     set destination [file split $destination]
  90
  91     verbose "base: \[[llength $base]\] $base" 3
  92     verbose "destination: \[[llength $destination]\] $destination" 3
  93
  94     set basecount [llength $base]
  95     for {set i 0} {$i < $basecount
  96                    && [lindex $base $i] == [lindex $destination $i]} {incr i} {}
  97     if { $i == $basecount } {
  98         set tail [lrange $destination $i end]
  99     } else {
 100         set tail [lrange $destination $i end]
 101         while { [incr i] <= $basecount } {
 102             set tail [linsert $tail 0 ".."]
 103         }
 104     }
 105
 106     if { [llength $tail] == 0 } {
 107         set result ""
 108     } else {
 109         set result [eval file join $tail]
 110     }
 111     verbose "result: $result" 3
 112     return $result
 113 }
 114
 115
 116 # Finds paths of all non-directory files, recursively, whose names match
 117 # a pattern.  Certain directory name are not searched (see proc getdirs).
 118 #     rootdir - search in this directory and its subdirectories, recursively.
 119 #     pattern - specified with Tcl string match "globbing" rules.
 120 #     returns: a possibly empty list of pathnames.
 121 #
 122 proc find { rootdir pattern } {
 123     set files [list]
 124     if { $rootdir eq "" || $pattern eq "" } {
 125         return $files
 126     }
 127
 128     # find all the directories
 129     set dirs [concat [getdirs -all $rootdir] $rootdir]
 130
 131     # find all the files in the directories that match the pattern
 132     foreach i $dirs {
 133         verbose "Looking in $i" 3
 134         foreach match [glob -nocomplain $i/$pattern] {
 135             if {![file isdirectory $match]} {
 136                 lappend files $match
 137                 verbose "Adding $match to file list" 3
 138             }
 139         }
 140     }
 141
 142     return $files
 143 }
 144
 145
 146 # Search the path for a file. This is basically a version of the BSD
 147 # Unix which(1) utility. This procedure depends on the shell
 148 # environment variable $PATH. It returns 0 if $PATH does not exist or
 149 # the binary is not in the path. If the binary is in the path, it
 150 # returns the full path to the binary.
 151 #
 152 proc which { file } {
 153     global env
 154
 155     # strip off any extraneous arguments (like flags to the compiler)
 156     set file [lindex $file 0]
 157
 158     # if the filename has a path component, then the file must exist
 159     if {[llength [file split $file]] > 1} {
 160         verbose "Checking $file" 2
 161         if {[file exists $file] && [file executable $file]} {
 162             verbose "file $file is executable" 2
 163             return [file normalize $file]
 164         } else {
 165             return 0
 166         }
 167     }
 168
 169     # Otherwise the file must exist in the PATH
 170     if {[info exists env(PATH)]} {
 171         set path [split $env(PATH) ":"]
 172     } else {
 173         return 0
 174     }
 175
 176     foreach dir $path {
 177         verbose "Checking $dir for $file" 3
 178         set filename [file normalize [file join $dir $file]]
 179         if {[file exists $filename]} {
 180             if {[file executable $filename]} {
 181                 verbose "Choosing $filename" 2
 182                 return [file normalize $filename]
 183             } else {
 184                 warning "file $filename exists but is not executable"
 185             }
 186         }
 187     }
 188     # not in path
 189     return 0
 190 }
 191
 192 # Looks for occurrences of a string in a file.
 193 #     return:list of lines that matched or empty string if none match.
 194 #     args:  first arg is optional (e.g. -n)
 195 #            second is the filename,
 196 #            third is the pattern,
 197 #            fourth is any keyword options (e.g. line)
 198 #     options:
 199 #         -n  - include line numbers like grep(1)
 200 #       line  - synonum for -n
 201
 202 proc grep { args } {
 203     set options [list]
 204     if { [lindex $args 0] eq "-n" } {
 205         lappend options "line"
 206         set args [lrange $args 1 end]
 207     }
 208
 209     set file [lindex $args 0]
 210     set pattern [lindex $args 1]
 211
 212     verbose "Grepping $file for the pattern \"$pattern\"" 3
 213
 214     if { [llength $args] > 2 } {
 215         set options [concat $options [lrange $args 2 end]]
 216     }
 217     set options [lsort -unique $options]
 218
 219     set i 0
 220     set fd [open $file r]
 221     while { [gets $fd cur_line] >= 0 } {
 222         incr i
 223         if {[regexp -- $pattern $cur_line match]} {
 224             if {[llength $options] > 0} {
 225                 foreach opt $options {
 226                     switch -- $opt {
 227                         "line" {
 228                             lappend grep_out [concat $i $match]
 229                         }
 230                     }
 231                 }
 232             } else {
 233                 lappend grep_out $match
 234             }
 235         }
 236     }
 237     close $fd
 238     unset fd
 239     unset i
 240     if {![info exists grep_out]} {
 241         set grep_out ""
 242     }
 243     return $grep_out
 244 }
 245
 246 #
 247 # Remove elements based on patterns. elements are delimited by spaces.
 248 # pattern is the pattern to look for using glob style matching
 249 # lst is the list to check against
 250 # returns the new list
 251 #
 252 proc prune { lst pattern } {
 253     set tmp {}
 254     foreach i $lst {
 255         verbose "Checking pattern \"$pattern\" against $i" 3
 256         if {![string match $pattern $i]} {
 257             lappend tmp $i
 258         } else {
 259             verbose "Removing element $i from list" 3
 260         }
 261     }
 262     return $tmp
 263 }
 264
 265
 266 # Check if a testcase should be run or not
 267 #
 268 # RUNTESTS is a copy of global `runtests'.
 269 #
 270 # This proc hides the details of global `runtests' from the test scripts, and
 271 # implements uniform handling of "script arguments" where those arguments are
 272 # file names (eg, "foo.c" in make check RUNTESTFLAGS="bar.exp=foo.c").
 273 # "glob" style expressions are supported as well as multiple files (with
 274 # spaces between them).
 275 # Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3*.c bar/baz*.c"
 276 #
 277 proc runtest_file_p { runtests testcase } {
 278     if {[lindex $runtests 1] ne ""} {
 279         foreach ptn [lindex $runtests 1] {
 280             if {[string match "*/$ptn" $testcase]} {
 281                 return 1
 282             }
 283             if {[string match $ptn $testcase]} {
 284                 return 1
 285             }
 286         }
 287         return 0
 288     }
 289     return 1
 290 }
 291
 292
 293 # Compares two files line-by-line just like the Unix diff(1) utility.
 294 #
 295 # Returns 1 if the files match,
 296 #         0 if there was a file error,
 297 #         -1 if they did not match.
 298 #
 299 proc diff { file_1 file_2 } {
 300     set eof -1
 301     set differences 0
 302
 303     if {[file exists $file_1]} {
 304         set file_a [open $file_1 r]
 305         fconfigure $file_a -encoding binary
 306     } else {
 307         warning "$file_1 doesn't exist"
 308         return 0
 309     }
 310
 311     if {[file exists $file_2]} {
 312         set file_b [open $file_2 r]
 313         fconfigure $file_b -encoding binary
 314     } else {
 315         warning "$file_2 doesn't exist"
 316         return 0
 317     }
 318
 319     verbose "# Diff'ing: $file_1 $file_2" 1
 320
 321     set list_a ""
 322     while { [gets $file_a line] != $eof } {
 323         if {[regexp "^#.*$" $line]} {
 324             continue
 325         } else {
 326             lappend list_a $line
 327         }
 328     }
 329     close $file_a
 330
 331     set list_b ""
 332     while { [gets $file_b line] != $eof } {
 333         if {[regexp "^#.*$" $line]} {
 334             continue
 335         } else {
 336             lappend list_b $line
 337         }
 338     }
 339     close $file_b
 340
 341     for { set i 0 } { $i < [llength $list_a] } { incr i } {
 342         set line_a [lindex $list_a $i]
 343         set line_b [lindex $list_b $i]
 344
 345         if {$line_a ne $line_b} {
 346             verbose -log "line #$i" 2
 347             verbose -log "\< $line_a" 2
 348             verbose -log "\> $line_b" 2
 349             set differences -1
 350         }
 351     }
 352
 353     if { $differences == -1 || [llength $list_a] != [llength $list_b] } {
 354         verbose "Files not the same" 2
 355         set differences -1
 356     } else {
 357         verbose "Files are the same" 2
 358         set differences 1
 359     }
 360     return $differences
 361 }
 362
 363
 364 # Set an environment variable
 365 #
 366 proc setenv { var val } {
 367     global env
 368     set env($var) $val
 369 }
 370
 371 # Unset an environment variable
 372 #
 373 proc unsetenv { var } {
 374     global env
 375     unset env($var)
 376 }
 377
 378
 379 # Get a value from an environment variable
 380 #
 381 proc getenv { var } {
 382     global env
 383     if {[info exists env($var)]} {
 384         return $env($var)
 385     } else {
 386         return ""
 387     }
 388 }