Subversion Repositories or1k

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