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