lib/utils.exp - dejagnu - Git at Google

 # 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 ""
     }
 }
	# 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 ""
	}
	}