Geek Gadgets 1/ADE-1.bin/ade-bin/lib/dejagnu/utils.exp

Text File | 1996-10-12 | 6.7 KB | 272 lines

# Copyright (C) 1992, 1993 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:
# [e-mail]

# This file was written by Rob Savoye. ([e-mail])

#
# 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.
#

#
# getdirs -- 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 then {
    set pattern [lindex $args 1]
    } else {
    set pattern "*"
    }
    verbose "Looking in $path for directories that match \"$pattern\"" 3
    catch "glob $path/$pattern" tmp
    if ![string match "" $tmp] then {
    foreach i $tmp {
        if [file isdirectory $i] then {
                if [file readable $i] then {
            lappend dirs $i
                }
        }
    }
    } else {
    perror "$tmp"
    return ""
    }

    if ![info exists dirs] then {
    return ""
    } else {
    return $dirs
    }
}

#
# find -- 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] then { break }
    foreach i $tmp {
        set j [getdirs $i]
        if ![string match "" $j] then {
        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\n" 3
    set tmp [glob -nocomplain $i/$pattern]
    if [llength $tmp]!=0 then {
        foreach j $tmp {
        if ![file isdirectory $j] then {
            lappend files $j
            verbose "Adding $j to file list" 3
        }
        }
    }
    }

    if ![info exists files] then {
    lappend files ""
    }
    return $files
}

#
# which -- 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
    if [file exists $file] then {
    return $file
    }
    if [info exists env(PATH)] then {
    set path [split $env(PATH) ":"]
    } else {
    return 0
    }

    foreach i $path {
    verbose "Checking against $i" 3
    if [file exists $i/$file] then {
        if [file executable $i/$file] then {
        return $i/$file
        } else {
        warning "$i/$file exists but is not an executable"
        }
    }
    }
    # not in path
    return 0
}

#
# grep -- 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 then {
    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] then {
        if ![string match "" $options] then {
        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] then {
    set grep_out ""
    }
    return $grep_out
}

#
# prune -- 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] then {
        lappend tmp $i
    } else {
        verbose "Removing element $i from list" 3
    }
    }
    return $tmp
}

#
# slay -- 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] then {
        if [string match "*$name*" $line] then {
        set pid [lindex $line 0]
        catch "exec kill -9 $pid]"
        verbose "Killing $name, pid = $pid\n"
        }
    }
    }
    close $in
}

#
# absolute -- convert a relative path to an absolute one
#
proc absolute { path } {
    if [string match "." $path] then {
        return [pwd]
    }

    set basedir [pwd]
    cd $path
    set path [pwd]
    cd $basedir
    return $path
}

#
# psource -- 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

    if [file exists $file] then {
    catch "source $file"
    if [info exists errorInfo] then {
        send_error "ERROR: errors in $file\n"
        send_error "$errorInfo"
        return 1
    }
    }
    return 0
}