aboutsummaryrefslogtreecommitdiff
path: root/lib/utils.exp
blob: 6c9ff98dec2429e15e422d024bc17501eb08b5f0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
# 2001, 2002, 2003, 2005 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 2 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 dir to look in, the next
#         is the pattern to match. It
#         defaults to *. Patterns are csh style
#   	  globbing rules
#     options: -all  search the tree recursively
#     returns: a list of dirs or NULL; the root directory is not returned.
#
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 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 { [string length $rootdir] == 0 || [string length $pattern] == 0 } {
	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 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 [file join $i $file]]} {
	    if {[file executable [file join $i $file]]} {
		return [file join $i $file]
	    } else {
		warning "[file join $i $file] exists but is not an executable"
	    }
	}
    }
    # not in path
    return 0
}

# Looks for occurrences of 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 {
		    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
# 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/baz*.c"
#
proc runtest_file_p { runtests testcase } {
    if {[string length [lindex $runtests 1]]} {
	foreach ptn [lindex $runtests 1] {
	    if {[string match "*/$ptn" $testcase]} {
		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]
        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}\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 ""
    }
}