diff options
Diffstat (limited to 'lib/utils.exp')
| -rw-r--r-- | lib/utils.exp | 441 |
1 files changed, 441 insertions, 0 deletions
diff --git a/lib/utils.exp b/lib/utils.exp new file mode 100644 index 0000000..565f18e --- /dev/null +++ b/lib/utils.exp @@ -0,0 +1,441 @@ +# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc. + +# This program 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 2 of the License, or +# (at your option) any later version. +# +# This program 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 this program; if not, write to the Free Software +# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +# Please email any bugs, comments, and/or additions to this file to: +# bug-dejagnu@prep.ai.mit.edu + +# This file was written by Rob Savoye. (rob@cygnus.com) + +# +# Most of the procedures found here mimic their unix counter-part. +# This file is sourced by runtest.exp, so they are usable by any test case. +# + +# +# Gets the directories in a directory +# args: the first is the dir to look in, the next +# is the pattern to match. It +# defaults to *. Patterns are csh style +# globbing rules +# returns: a list of dirs or NULL +# +proc getdirs { args } { + if { [lindex $args 0] == "-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 + catch "glob ${path}/${pattern}" tmp + if { ${tmp} != "" } { + foreach i ${tmp} { + if [file isdirectory $i] { + switch -- "[file tail $i]" { + "testsuite" - + "config" - + "lib" - + "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] + } + } + } + } + } + } + } else { + perror "$tmp" + return "" + } + + if ![info exists dirs] { + return "" + } else { + return $dirs + } +} + +# +# Finds all the files recursively +# rootdir - this is the directory to start the search +# from. This is and all subdirectories are search for +# filenames. Directory names are not included in the +# list, but the filenames have path information. +# pattern - this is the pattern to match. Patterns are csh style +# globbing rules. +# returns: a list or a NULL. +# +proc find { rootdir pattern } { + # first find all the directories + set dirs "$rootdir " + while 1 { + set tmp $rootdir + set rootdir "" + if [string match "" $tmp] { + break + } + foreach i $tmp { + set j [getdirs $i] + if ![string match "" $j] { + append dirs "$j " + set rootdir $j + unset j + } else { + set rootdir "" + } + } + set tmp "" + } + + # find all the files that match the pattern + foreach i $dirs { + verbose "Looking in $i" 3 + set tmp [glob -nocomplain $i/$pattern] + if { [llength $tmp] != 0 } { + foreach j $tmp { + if ![file isdirectory $j] { + lappend files $j + verbose "Adding $j to file list" 3 + } + } + } + } + + if ![info exists files] { + lappend files "" + } + return $files +} + +# +# Search the path for a file. This is basically a version +# of the BSD-unix which 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 it exists then the path must be OK + # ??? What if $file has no path and "." isn't in $PATH? + if [file exists $file] { + return $file + } + if [info exists env(PATH)] { + set path [split $env(PATH) ":"] + } else { + return 0 + } + + foreach i $path { + verbose "Checking against $i" 3 + if [file exists $i/$file] { + if [file executable $i/$file] { + return $i/$file + } else { + warning "$i/$file exists but is not an executable" + } + } + } + # not in path + return 0 +} + +# +# Looks for a string in a file. +# return:list of lines that matched or NULL if none match. +# args: first arg is the filename, +# second is the pattern, +# third are any options. +# Options: line - puts line numbers of match in list +# +proc grep { args } { + + set file [lindex $args 0] + set pattern [lindex $args 1] + + verbose "Grepping $file for the pattern \"$pattern\"" 3 + + set argc [llength $args] + if { $argc > 2 } { + for { set i 2 } { $i < $argc } { incr i } { + append options [lindex $args $i] + append options " " + } + } else { + set options "" + } + + set i 0 + set fd [open $file r] + while { [gets $fd cur_line]>=0 } { + incr i + if [regexp -- "$pattern" $cur_line match] { + if ![string match "" $options] { + foreach opt $options { + case $opt in { + "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 +# list is the list to check against +# returns the new list +# +proc prune { list pattern } { + set tmp {} + foreach i $list { + 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 +} + +# +# Attempt to kill a process that you started on the local machine. +# +proc slay { name } { + set in [open [concat "|ps"] r] + while {[gets $in line]>-1} { + if ![string match "*expect*slay*" $line] { + if [string match "*$name*" $line] { + set pid [lindex $line 0] + catch "exec kill -9 $pid]" + verbose "Killing $name, pid = $pid\n" + } + } + } + close $in +} + +# +# Convert a relative path to an absolute one on the local machine. +# +proc absolute { path } { + if [string match "." $path] { + return [pwd] + } + + set basedir [pwd] + cd $path + set path [pwd] + cd $basedir + return $path +} + +# +# Source a file and trap any real errors. This ignores extraneous +# output. returns a 1 if there was an error, otherwise it returns 0. +# +proc psource { file } { + global errorInfo + global errorCode + + unset errorInfo + if [file exists $file] { + catch "source $file" + if [info exists errorInfo] { + send_error "ERROR: errors in $file\n" + send_error "$errorInfo" + return 1 + } + } + return 0 +} + +# +# 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 (ie: the "foo" in make check RUNTESTFLAGS="bar.exp=foo"). +# "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*.c" +# +proc runtest_file_p { runtests testcase } { + if [string length [lindex $runtests 1]] { + set basename [file tail $testcase] + foreach ptn [lindex $runtests 1] { + if [string match $ptn $basename] { + return 1 + } + if [string match $ptn $testcase] { + return 1 + } + } + return 0 + } + return 1 +} + +# +# Delete various system verbosities from TEXT on SYSTEM +# +# An example is: +# ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9 +# +# SYSTEM is typical $target_triplet or $host_triplet. +# + +# +# Compares two files line-by-line +# returns 1 it the files match, +# returns 0 if there was a file error, +# returns -1 if they didn't 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] + } else { + warning "${file_1} doesn't exist" + return 0 + } + + if [file exists ${file_2}] { + set file_b [open ${file_2} r] + } else { + warning "${file_2} doesn't exist" + return 0 + } + + verbose "# Diff'ing: ${file_1} ${file_2}\n" 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}] + +# verbose "\t${file_1}: ${i}: ${line_a}\n" 3 +# verbose "\t${file_2}: ${i}: ${line_b}\n" 3 + if [string compare ${line_a} ${line_b}] { + verbose "line #${i}\n" 2 + verbose "\< ${line_a}\n" 2 + verbose "\> ${line_b}\n" 2 + + send_log "line #${i}\n" + send_log "\< ${line_a}\n" + send_log "\> ${line_b}\n" + + 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 "" + } +} + |