contrib/bluegnu2.0.3/lib/utils.exp - dejagnu - Git at Google

 # 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 ""
     }
 }
	# 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 "expectslay*" $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 ""
	}
	}