URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [dejagnu/] [lib/] [utils.exp] - Blame information for rev 1765

Details | Compare with Previous | View Log


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

Browse

Tools

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [dejagnu/] [lib/] [utils.exp] - Blame information for rev 1765

Line No.	Rev	Author	Line
1	578	markom	`# Copyright (C) 92, 93, 94, 95, 96, 97, 98, 1999 Free Software Foundation, Inc.`
2
3			`# This program is free software; you can redistribute it and/or modify`
4			`# it under the terms of the GNU General Public License as published by`
5			`# the Free Software Foundation; either version 2 of the License, or`
6			`# (at your option) any later version.`
7			`#`
8			`# This program is distributed in the hope that it will be useful,`
9			`# but WITHOUT ANY WARRANTY; without even the implied warranty of`
10			`# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
11			`# GNU General Public License for more details.`
12			`#`
13			`# You should have received a copy of the GNU General Public License`
14			`# along with this program; if not, write to the Free Software`
15			`# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.`
16
17			`# Please email any bugs, comments, and/or additions to this file to:`
18			`# bug-dejagnu@prep.ai.mit.edu`
19
20			`# This file was written by Rob Savoye. (rob@cygnus.com)`
21
22			`#`
23			`# Most of the procedures found here mimic their unix counter-part.`
24			`# This file is sourced by runtest.exp, so they are usable by any test case.`
25			`#`
26
27			`#`
28			`# Gets the directories in a directory`
29			`# args: the first is the dir to look in, the next`
30			`# is the pattern to match. It`
31			`# defaults to *. Patterns are csh style`
32			`# globbing rules`
33			`# returns: a list of dirs or NULL`
34			`#`
35			`proc getdirs { args } {`
36			`if { [lindex $args 0] == "-all" } {`
37			`set alldirs 1`
38			`set args [lrange $args 1 end]`
39			`} else {`
40			`set alldirs 0`
41			`}`
42
43			`set path [lindex $args 0]`
44			`if { [llength $args] > 1} {`
45			`set pattern [lindex $args 1]`
46			`} else {`
47			`set pattern "*"`
48			`}`
49			`verbose "Looking in ${path} for directories that match \"${pattern}\"" 3`
50			`catch "glob ${path}/${pattern}" tmp`
51			`if { ${tmp} != "" } {`
52			`foreach i ${tmp} {`
53			`if [file isdirectory $i] {`
54			`switch -- "[file tail $i]" {`
55			`"testsuite" -`
56			`"config" -`
57			`"lib" -`
58			`"CVS" -`
59			`"RCS" -`
60			`"SCCS" {`
61			`verbose "Ignoring directory [file tail $i]" 3`
62			`continue`
63			`}`
64			`default {`
65			`if [file readable $i] {`
66			`verbose "Found directory [file tail $i]" 3`
67			`lappend dirs $i`
68			`if { $alldirs } {`
69			`eval lappend dirs [getdirs -all $i $pattern]`
70			`}`
71			`}`
72			`}`
73			`}`
74			`}`
75			`}`
76			`} else {`
77			`perror "$tmp"`
78			`return ""`
79			`}`
80
81			`if ![info exists dirs] {`
82			`return ""`
83			`} else {`
84			`return $dirs`
85			`}`
86			`}`
87
88			`#`
89			`# Finds all the files recursively`
90			`# rootdir - this is the directory to start the search`
91			`# from. This is and all subdirectories are search for`
92			`# filenames. Directory names are not included in the`
93			`# list, but the filenames have path information.`
94			`# pattern - this is the pattern to match. Patterns are csh style`
95			`# globbing rules.`
96			`# returns: a list or a NULL.`
97			`#`
98			`proc find { rootdir pattern } {`
99			`# first find all the directories`
100			`set dirs "$rootdir "`
101			`while 1 {`
102			`set tmp $rootdir`
103			`set rootdir ""`
104			`if [string match "" $tmp] {`
105			`break`
106			`}`
107			`foreach i $tmp {`
108			`set j [getdirs $i]`
109			`if ![string match "" $j] {`
110			`append dirs "$j "`
111			`set rootdir $j`
112			`unset j`
113			`} else {`
114			`set rootdir ""`
115			`}`
116			`}`
117			`set tmp ""`
118			`}`
119
120			`# find all the files that match the pattern`
121			`foreach i $dirs {`
122			`verbose "Looking in $i" 3`
123			`set tmp [glob -nocomplain $i/$pattern]`
124			`if { [llength $tmp] != 0 } {`
125			`foreach j $tmp {`
126			`if ![file isdirectory $j] {`
127			`lappend files $j`
128			`verbose "Adding $j to file list" 3`
129			`}`
130			`}`
131			`}`
132			`}`
133
134			`if ![info exists files] {`
135			`lappend files ""`
136			`}`
137			`return $files`
138			`}`
139
140			`#`
141			`# Search the path for a file. This is basically a version`
142			`# of the BSD-unix which utility. This procedure depends on`
143			`# the shell environment variable $PATH. It returns 0 if $PATH`
144			`# does not exist or the binary is not in the path. If the`
145			`# binary is in the path, it returns the full path to the binary.`
146			`#`
147			`proc which { file } {`
148			`global env`
149
150			`# strip off any extraneous arguments (like flags to the compiler)`
151			`set file [lindex $file 0]`
152
153			`# if it exists then the path must be OK`
154			`# ??? What if $file has no path and "." isn't in $PATH?`
155			`if [file exists $file] {`
156			`return $file`
157			`}`
158			`if [info exists env(PATH)] {`
159			`set path [split $env(PATH) ":"]`
160			`} else {`
161			`return 0`
162			`}`
163
164			`foreach i $path {`
165			`verbose "Checking against $i" 3`
166			`if [file exists $i/$file] {`
167			`if [file executable $i/$file] {`
168			`return $i/$file`
169			`} else {`
170			`warning "$i/$file exists but is not an executable"`
171			`}`
172			`}`
173			`}`
174			`# not in path`
175			`return 0`
176			`}`
177
178			`#`
179			`# Looks for a string in a file.`
180			`# return:list of lines that matched or NULL if none match.`
181			`# args: first arg is the filename,`
182			`# second is the pattern,`
183			`# third are any options.`
184			`# Options: line - puts line numbers of match in list`
185			`#`
186			`proc grep { args } {`
187
188			`set file [lindex $args 0]`
189			`set pattern [lindex $args 1]`
190
191			`verbose "Grepping $file for the pattern \"$pattern\"" 3`
192
193			`set argc [llength $args]`
194			`if { $argc > 2 } {`
195			`for { set i 2 } { $i < $argc } { incr i } {`
196			`append options [lindex $args $i]`
197			`append options " "`
198			`}`
199			`} else {`
200			`set options ""`
201			`}`
202
203			`set i 0`
204			`set fd [open $file r]`
205			`while { [gets $fd cur_line]>=0 } {`
206			`incr i`
207			`if [regexp -- "$pattern" $cur_line match] {`
208			`if ![string match "" $options] {`
209			`foreach opt $options {`
210			`case $opt in {`
211			`"line" {`
212			`lappend grep_out [concat $i $match]`
213			`}`
214			`}`
215			`}`
216			`} else {`
217			`lappend grep_out $match`
218			`}`
219			`}`
220			`}`
221			`close $fd`
222			`unset fd`
223			`unset i`
224			`if ![info exists grep_out] {`
225			`set grep_out ""`
226			`}`
227			`return $grep_out`
228			`}`
229
230			`#`
231			`# Remove elements based on patterns. elements are delimited by spaces.`
232			`# pattern is the pattern to look for using glob style matching`
233			`# list is the list to check against`
234			`# returns the new list`
235			`#`
236			`proc prune { list pattern } {`
237			`set tmp {}`
238			`foreach i $list {`
239			`verbose "Checking pattern \"$pattern\" against $i" 3`
240			`if ![string match $pattern $i] {`
241			`lappend tmp $i`
242			`} else {`
243			`verbose "Removing element $i from list" 3`
244			`}`
245			`}`
246			`return $tmp`
247			`}`
248
249			`#`
250			`# Attempt to kill a process that you started on the local machine.`
251			`#`
252			`proc slay { name } {`
253			`set in [open [concat "\|ps"] r]`
254			`while {[gets $in line]>-1} {`
255			`if ![string match "expectslay*" $line] {`
256			`if [string match "$name" $line] {`
257			`set pid [lindex $line 0]`
258			`catch "exec kill -9 $pid]"`
259			`verbose "Killing $name, pid = $pid\n"`
260			`}`
261			`}`
262			`}`
263			`close $in`
264			`}`
265
266			`#`
267			`# Convert a relative path to an absolute one on the local machine.`
268			`#`
269			`proc absolute { path } {`
270			`if [string match "." $path] {`
271			`return [pwd]`
272			`}`
273
274			`set basedir [pwd]`
275			`cd $path`
276			`set path [pwd]`
277			`cd $basedir`
278			`return $path`
279			`}`
280
281			`#`
282			`# Source a file and trap any real errors. This ignores extraneous`
283			`# output. returns a 1 if there was an error, otherwise it returns 0.`
284			`#`
285			`proc psource { file } {`
286			`global errorInfo`
287			`global errorCode`
288
289			`unset errorInfo`
290			`if [file exists $file] {`
291			`catch "source $file"`
292			`if [info exists errorInfo] {`
293			`send_error "ERROR: errors in $file\n"`
294			`send_error "$errorInfo"`
295			`return 1`
296			`}`
297			`}`
298			`return 0`
299			`}`
300
301			`#`
302			`# Check if a testcase should be run or not`
303			`#`
304			# RUNTESTS is a copy of global `runtests'.
305			`#`
306			# This proc hides the details of global `runtests' from the test scripts, and
307			`# implements uniform handling of "script arguments" where those arguments are`
308			`# file names (ie: the "foo" in make check RUNTESTFLAGS="bar.exp=foo").`
309			`# "glob" style expressions are supported as well as multiple files (with`
310			`# spaces between them).`
311			`# Eg: RUNTESTFLAGS="bar.exp=foo1.c foo2.c foo3.c bar.c"`
312			`#`
313			`proc runtest_file_p { runtests testcase } {`
314			`if [string length [lindex $runtests 1]] {`
315			`set basename [file tail $testcase]`
316			`foreach ptn [lindex $runtests 1] {`
317			`if [string match $ptn $basename] {`
318			`return 1`
319			`}`
320			`if [string match $ptn $testcase] {`
321			`return 1`
322			`}`
323			`}`
324			`return 0`
325			`}`
326			`return 1`
327			`}`
328
329			`#`
330			`# Delete various system verbosities from TEXT on SYSTEM`
331			`#`
332			`# An example is:`
333			`# ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9`
334			`#`
335			`# SYSTEM is typical $target_triplet or $host_triplet.`
336			`#`
337
338			`#`
339			`# Compares two files line-by-line`
340			`# returns 1 it the files match,`
341			`# returns 0 if there was a file error,`
342			`# returns -1 if they didn't match.`
343			`#`
344			`proc diff { file_1 file_2 } {`
345			`set eof -1`
346			`set differences 0`
347
348			`if [file exists ${file_1}] {`
349			`set file_a [open ${file_1} r]`
350			`} else {`
351			`warning "${file_1} doesn't exist"`
352			`return 0`
353			`}`
354
355			`if [file exists ${file_2}] {`
356			`set file_b [open ${file_2} r]`
357			`} else {`
358			`warning "${file_2} doesn't exist"`
359			`return 0`
360			`}`
361
362			`verbose "# Diff'ing: ${file_1} ${file_2}\n" 1`
363
364			`set list_a ""`
365			`while { [gets ${file_a} line] != ${eof} } {`
366			`if [regexp "^#.*$" ${line}] {`
367			`continue`
368			`} else {`
369			`lappend list_a ${line}`
370			`}`
371			`}`
372			`close ${file_a}`
373
374			`set list_b ""`
375			`while { [gets ${file_b} line] != ${eof} } {`
376			`if [regexp "^#.*$" ${line}] {`
377			`continue`
378			`} else {`
379			`lappend list_b ${line}`
380			`}`
381			`}`
382			`close ${file_b}`
383			`for { set i 0 } { $i < [llength $list_a] } { incr i } {`
384			`set line_a [lindex ${list_a} ${i}]`
385			`set line_b [lindex ${list_b} ${i}]`
386
387			`# verbose "\t${file_1}: ${i}: ${line_a}\n" 3`
388			`# verbose "\t${file_2}: ${i}: ${line_b}\n" 3`
389			`if [string compare ${line_a} ${line_b}] {`
390			`verbose "line #${i}\n" 2`
391			`verbose "\< ${line_a}\n" 2`
392			`verbose "\> ${line_b}\n" 2`
393
394			`send_log "line #${i}\n"`
395			`send_log "\< ${line_a}\n"`
396			`send_log "\> ${line_b}\n"`
397
398			`set differences -1`
399			`}`
400			`}`
401
402			`if { $differences == -1 \|\| [llength ${list_a}] != [llength ${list_b}] } {`
403			`verbose "Files not the same" 2`
404			`set differences -1`
405			`} else {`
406			`verbose "Files are the same" 2`
407			`set differences 1`
408			`}`
409			`return ${differences}`
410			`}`
411
412			`#`
413			`# Set an environment variable`
414			`#`
415			`proc setenv { var val } {`
416			`global env`
417
418			`set env($var) $val`
419			`}`
420
421			`#`
422			`# Unset an environment variable`
423			`#`
424			`proc unsetenv { var } {`
425			`global env`
426			`unset env($var)`
427			`}`
428
429			`#`
430			`# Get a value from an environment variable`
431			`#`
432			`proc getenv { var } {`
433			`global env`
434
435			`if [info exists env($var)] {`
436			`return $env($var)`
437			`} else {`
438			`return ""`
439			`}`
440			`}`
441