mirror of https://gitee.com/Nocallback/dejagnu.git
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
389 lines
9.5 KiB
389 lines
9.5 KiB
# Copyright (C) 1992-2019, 2020 Free Software Foundation, Inc.
|
|
#
|
|
# This file is part of DejaGnu.
|
|
#
|
|
# DejaGnu is free software; you can redistribute it and/or modify it
|
|
# under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# DejaGnu is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
# General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with DejaGnu; if not, write to the Free Software Foundation,
|
|
# Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1301, USA.
|
|
|
|
# This file was written by Rob Savoye. (rob@welcomehome.org)
|
|
|
|
# Most of the procedures found here mimic their UNIX counterpart.
|
|
# This file is sourced by runtest.exp, so they are usable by any test
|
|
# script.
|
|
|
|
|
|
# Gets the directories in a directory, or in a directory tree.
|
|
# args: the first is the directory to look in, the next is the
|
|
# glob pattern to match (default "*").
|
|
# options: -all search the tree recursively
|
|
# returns: a list of directories excluding the root directory
|
|
#
|
|
proc getdirs { args } {
|
|
if { [lindex $args 0] eq "-all" } {
|
|
set alldirs 1
|
|
set args [lrange $args 1 end]
|
|
} else {
|
|
set alldirs 0
|
|
}
|
|
|
|
set path [lindex $args 0]
|
|
if { [llength $args] > 1} {
|
|
set pattern [lindex $args 1]
|
|
} else {
|
|
set pattern "*"
|
|
}
|
|
verbose "Looking in $path for directories that match \"${pattern}\"" 3
|
|
set dirs [list]
|
|
foreach i [glob -nocomplain $path/$pattern] {
|
|
if {[file isdirectory $i]} {
|
|
switch -- "[file tail $i]" {
|
|
"testsuite" -
|
|
"config" -
|
|
"lib" -
|
|
".git" -
|
|
".svn" -
|
|
"CVS" -
|
|
"RCS" -
|
|
"SCCS" {
|
|
verbose "Ignoring directory [file tail $i]" 3
|
|
continue
|
|
}
|
|
default {
|
|
if {[file readable $i]} {
|
|
verbose "Found directory [file tail $i]" 3
|
|
lappend dirs $i
|
|
if { $alldirs } {
|
|
eval lappend dirs [getdirs -all $i $pattern]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return $dirs
|
|
}
|
|
|
|
|
|
# Given a base and a destination, return a relative file name that refers
|
|
# to the destination when used relative to the given base.
|
|
proc relative_filename { base destination } {
|
|
if { [file pathtype $base] ne "absolute" } {
|
|
set base [file normalize $base]
|
|
}
|
|
if { [file pathtype $destination] ne "absolute" } {
|
|
set destination [file normalize $destination]
|
|
}
|
|
|
|
set base [file split $base]
|
|
set destination [file split $destination]
|
|
|
|
verbose "base: \[[llength $base]\] $base" 3
|
|
verbose "destination: \[[llength $destination]\] $destination" 3
|
|
|
|
set basecount [llength $base]
|
|
for {set i 0} {$i < $basecount
|
|
&& [lindex $base $i] == [lindex $destination $i]} {incr i} {}
|
|
if { $i == $basecount } {
|
|
set tail [lrange $destination $i end]
|
|
} else {
|
|
set tail [lrange $destination $i end]
|
|
while { [incr i] <= $basecount } {
|
|
set tail [linsert $tail 0 ".."]
|
|
}
|
|
}
|
|
|
|
if { [llength $tail] == 0 } {
|
|
set result ""
|
|
} else {
|
|
set result [eval file join $tail]
|
|
}
|
|
verbose "result: $result" 3
|
|
return $result
|
|
}
|
|
|
|
|
|
# Finds paths of all non-directory files, recursively, whose names match
|
|
# a pattern. Certain directory name are not searched (see proc getdirs).
|
|
# rootdir - search in this directory and its subdirectories, recursively.
|
|
# pattern - specified with Tcl string match "globbing" rules.
|
|
# returns: a possibly empty list of pathnames.
|
|
#
|
|
proc find { rootdir pattern } {
|
|
set files [list]
|
|
if { $rootdir eq "" || $pattern eq "" } {
|
|
return $files
|
|
}
|
|
|
|
# find all the directories
|
|
set dirs [concat [getdirs -all $rootdir] $rootdir]
|
|
|
|
# find all the files in the directories that match the pattern
|
|
foreach i $dirs {
|
|
verbose "Looking in $i" 3
|
|
foreach match [glob -nocomplain $i/$pattern] {
|
|
if {![file isdirectory $match]} {
|
|
lappend files $match
|
|
verbose "Adding $match to file list" 3
|
|
}
|
|
}
|
|
}
|
|
|
|
return $files
|
|
}
|
|
|
|
|
|
# Search the path for a file. This is basically a version of the BSD
|
|
# Unix which(1) utility. This procedure depends on the shell
|
|
# environment variable $PATH. It returns 0 if $PATH does not exist or
|
|
# the binary is not in the path. If the binary is in the path, it
|
|
# returns the full path to the binary.
|
|
#
|
|
proc which { file } {
|
|
global env
|
|
|
|
# strip off any extraneous arguments (like flags to the compiler)
|
|
set file [lindex $file 0]
|
|
|
|
# if the filename has a path component, then the file must exist
|
|
if {[llength [file split $file]] > 1} {
|
|
verbose "Checking $file" 2
|
|
if {[file exists $file] && [file executable $file]} {
|
|
verbose "file $file is executable" 2
|
|
return [file normalize $file]
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
# Otherwise the file must exist in the PATH
|
|
if {[info exists env(PATH)]} {
|
|
set path [split $env(PATH) ":"]
|
|
} else {
|
|
return 0
|
|
}
|
|
|
|
foreach dir $path {
|
|
verbose "Checking $dir for $file" 3
|
|
set filename [file normalize [file join $dir $file]]
|
|
if {[file exists $filename]} {
|
|
if {[file executable $filename]} {
|
|
verbose "Choosing $filename" 2
|
|
return [file normalize $filename]
|
|
} else {
|
|
warning "file $filename exists but is not executable"
|
|
}
|
|
}
|
|
}
|
|
# not in path
|
|
return 0
|
|
}
|
|
|
|
# Looks for occurrences of a string in a file.
|
|
# return:list of lines that matched or empty string if none match.
|
|
# args: first arg is optional (e.g. -n)
|
|
# second is the filename,
|
|
# third is the pattern,
|
|
# fourth is any keyword options (e.g. line)
|
|
# options:
|
|
# -n - include line numbers like grep(1)
|
|
# line - synonum for -n
|
|
|
|
proc grep { args } {
|
|
set options [list]
|
|
if { [lindex $args 0] eq "-n" } {
|
|
lappend options "line"
|
|
set args [lrange $args 1 end]
|
|
}
|
|
|
|
set file [lindex $args 0]
|
|
set pattern [lindex $args 1]
|
|
|
|
verbose "Grepping $file for the pattern \"$pattern\"" 3
|
|
|
|
if { [llength $args] > 2 } {
|
|
set options [concat $options [lrange $args 2 end]]
|
|
}
|
|
set options [lsort -unique $options]
|
|
|
|
set i 0
|
|
set fd [open $file r]
|
|
while { [gets $fd cur_line] >= 0 } {
|
|
incr i
|
|
if {[regexp -- $pattern $cur_line match]} {
|
|
if {[llength $options] > 0} {
|
|
foreach opt $options {
|
|
switch -- $opt {
|
|
"line" {
|
|
lappend grep_out [concat $i $match]
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
lappend grep_out $match
|
|
}
|
|
}
|
|
}
|
|
close $fd
|
|
unset fd
|
|
unset i
|
|
if {![info exists grep_out]} {
|
|
set grep_out ""
|
|
}
|
|
return $grep_out
|
|
}
|
|
|
|
#
|
|
# Remove elements based on patterns. elements are delimited by spaces.
|
|
# pattern is the pattern to look for using glob style matching
|
|
# lst is the list to check against
|
|
# returns the new list
|
|
#
|
|
proc prune { lst pattern } {
|
|
set tmp {}
|
|
foreach i $lst {
|
|
verbose "Checking pattern \"$pattern\" against $i" 3
|
|
if {![string match $pattern $i]} {
|
|
lappend tmp $i
|
|
} else {
|
|
verbose "Removing element $i from list" 3
|
|
}
|
|
}
|
|
return $tmp
|
|
}
|
|
|
|
|
|
# Check if a testcase should be run or not
|
|
#
|
|
# RUNTESTS is a copy of global `runtests'.
|
|
#
|
|
# This proc hides the details of global `runtests' from the test scripts, and
|
|
# implements uniform handling of "script arguments" where those arguments are
|
|
# file names (eg, "foo.c" in make check RUNTESTFLAGS="bar.exp=foo.c").
|
|
# "glob" style expressions are supported as well as multiple files (with
|
|
# spaces between them).
|
|
# Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3*.c bar/baz*.c"
|
|
#
|
|
proc runtest_file_p { runtests testcase } {
|
|
if {[lindex $runtests 1] ne ""} {
|
|
foreach ptn [lindex $runtests 1] {
|
|
if {[string match "*/$ptn" $testcase]} {
|
|
return 1
|
|
}
|
|
if {[string match $ptn $testcase]} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
return 1
|
|
}
|
|
|
|
|
|
# Compares two files line-by-line just like the Unix diff(1) utility.
|
|
#
|
|
# Returns 1 if the files match,
|
|
# 0 if there was a file error,
|
|
# -1 if they did not match.
|
|
#
|
|
proc diff { file_1 file_2 } {
|
|
set eof -1
|
|
set differences 0
|
|
|
|
if {[file exists $file_1]} {
|
|
set file_a [open $file_1 r]
|
|
fconfigure $file_a -encoding binary
|
|
} else {
|
|
warning "$file_1 doesn't exist"
|
|
return 0
|
|
}
|
|
|
|
if {[file exists $file_2]} {
|
|
set file_b [open $file_2 r]
|
|
fconfigure $file_b -encoding binary
|
|
} else {
|
|
warning "$file_2 doesn't exist"
|
|
return 0
|
|
}
|
|
|
|
verbose "# Diff'ing: $file_1 $file_2" 1
|
|
|
|
set list_a ""
|
|
while { [gets $file_a line] != $eof } {
|
|
if {[regexp "^#.*$" $line]} {
|
|
continue
|
|
} else {
|
|
lappend list_a $line
|
|
}
|
|
}
|
|
close $file_a
|
|
|
|
set list_b ""
|
|
while { [gets $file_b line] != $eof } {
|
|
if {[regexp "^#.*$" $line]} {
|
|
continue
|
|
} else {
|
|
lappend list_b $line
|
|
}
|
|
}
|
|
close $file_b
|
|
|
|
for { set i 0 } { $i < [llength $list_a] } { incr i } {
|
|
set line_a [lindex $list_a $i]
|
|
set line_b [lindex $list_b $i]
|
|
|
|
if {$line_a ne $line_b} {
|
|
verbose -log "line #$i" 2
|
|
verbose -log "\< $line_a" 2
|
|
verbose -log "\> $line_b" 2
|
|
set differences -1
|
|
}
|
|
}
|
|
|
|
if { $differences == -1 || [llength $list_a] != [llength $list_b] } {
|
|
verbose "Files not the same" 2
|
|
set differences -1
|
|
} else {
|
|
verbose "Files are the same" 2
|
|
set differences 1
|
|
}
|
|
return $differences
|
|
}
|
|
|
|
|
|
# Set an environment variable
|
|
#
|
|
proc setenv { var val } {
|
|
global env
|
|
set env($var) $val
|
|
}
|
|
|
|
# Unset an environment variable
|
|
#
|
|
proc unsetenv { var } {
|
|
global env
|
|
unset env($var)
|
|
}
|
|
|
|
|
|
# Get a value from an environment variable
|
|
#
|
|
proc getenv { var } {
|
|
global env
|
|
if {[info exists env($var)]} {
|
|
return $env($var)
|
|
} else {
|
|
return ""
|
|
}
|
|
}
|
|
|