diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/utils.exp')
| -rw-r--r-- | contrib/bluegnu2.0.3/lib/utils.exp | 454 |
1 files changed, 0 insertions, 454 deletions
diff --git a/contrib/bluegnu2.0.3/lib/utils.exp b/contrib/bluegnu2.0.3/lib/utils.exp deleted file mode 100644 index 6ea6745..0000000 --- a/contrib/bluegnu2.0.3/lib/utils.exp +++ /dev/null @@ -1,454 +0,0 @@ -# Copyright (C) 92, 93, 94, 95, 1996 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@welcomehome.org) - -# -# 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 } { - 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 - } - } - } - } - } - } 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 } { - 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 -# -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 -# -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 testcase [file tail $testcase] - foreach ptn [lindex $runtests 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. -# -# This is useful when trying to do pattern matches on program output. -# Sites with particularily verbose os's may wish to override this in site.exp. -# -# We get loaded after site.exp so only define this if not already defined. -# - -if { [info procs prune_system_crud] == "" } { - proc prune_system_crud { system text } { - # This is from sun4's. Do it for all machines for now. - # The "\\1" is to try to preserve a "\n" but only if necessary. - regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text - - # This happens when compiling on Alpha OSF/1 with cc -g -O. - regsub -all "(^|\n)(\n*uopt: Warning: file not optimized; use -g3 if both optimization and debug wanted\n?)+" $text "\\1" text - - # This happens when compiling on Alpha OSF using gas. - regsub -all "(^|\n)(/usr/ucb/ld:\nWarning: Linking some objects which contain exception information sections\n\tand some which do not. This may cause fatal runtime exception handling\n\tproblems\[^\n\]*\n?)+" $text "\\1" text - - # This happens on SunOS with cc -g -O. - regsub -all "(^|\n)(cc: Warning: -O conflicts with -g. -O turned off.\n?)+" $text "\\1" text - - # This happens when using g++ on a DWARF system. - regsub -all "(^|\n)(cc1plus: warning: -g option not supported for C\\+\\+ on systems using the DWARF debugging format\n?)+" $text "\\1" text - - # It might be tempting to get carried away and delete blank lines, etc. - # Just delete *exactly* what we're ask to, and that's it. - return $text - } -} - -# -# 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 - - while { [gets ${file_a} line] != ${eof} } { - if [regexp "^#.*$" ${line}] { - continue - } else { - lappend list_a ${line} - } - } - close ${file_a} - - 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 { [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 "" - } -} - |