Move C++ internals to prefixed names in dejagnu.h

[dejagnu.git] / lib / utils.exp

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