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
|
#
# testlib.tcl --
#
# Test support routines. Some of these are based on routines provided with
# standard Tcl.
#------------------------------------------------------------------------------
# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
# Copyright 2002 ActiveState Corporation.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies. Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose. It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: testlib.tcl,v 1.4 2002/04/04 06:10:30 hobbs Exp $
#------------------------------------------------------------------------------
#
# Save the unknown command in a variable SAVED_UNKNOWN. To get it back, eval
# that variable.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import ::tcltest::*
}
package require Tclx 8.4
foreach need {
fchown fchmod flock fsync ftruncate msgcats posix_signals symlink
signal_restart truncate waitpid
} {
set ::tcltest::testConstraints(need_$need) [infox have_$need]
}
set ::tcltest::testConstraints(need_chmod) [llength [info commands chmod]]
if {[cequal $::tcl_platform(platform) "unix"]} {
set ::tcltest::testConstraints(isRoot) [cequal [id user] "root"]
set ::tcltest::testConstraints(isNotRoot) \
[expr {![cequal [id user] "root"]}]
}
# Genenerate a unique file record that can be verified. The record
# grows quite large to test the dynamic buffering in the file I/O.
proc GenRec {id} {
return [format "Key:%04d {This is a test of file I/O (%d)} KeyX:%04d %s" \
$id $id $id [replicate :@@@@@@@@: $id]]
}
#
# Routine to execute tests and compare to expected results.
#
proc Test {name description body int_result result} {
if {$int_result == 0} {
uplevel 1 [list test $name $description $body $result]
} elseif {$int_result == 1} {
uplevel 1 [list test $name $description \
"list \[catch {$body} msg\] \$msg" [list 1 $result]]
} else {
puts stderr "FIX OUTDATED TEST: $test_name $test_description"
}
}
# Proc to fork and exec child that loops until it gets a signal.
# Can optionally set its pgroup. Wait till child has actually execed or
# kill breaks on some systems (i.e. AIX). Windows is a drag, since the
# command line parsing is really dumb. Pass it in a file instead.
proc ForkLoopingChild {{setPGroup 0}} {
global tcl_platform
set childProg {
file delete CHILD.RUN
catch {while {1} {after 1000;update}}
exit 10
}
# Create semaphore (it also contains the program to run for windows).
set fh [open CHILD.RUN w]
puts $fh $childProg
close $fh
flush stdout
flush stderr
if {[cequal $tcl_platform(platform) unix]} {
set newPid [fork]
if {$newPid == 0} {
if $setPGroup {
id process group set
}
catch {execl $::tcltest::tcltest CHILD.RUN} msg
puts stderr "execl failed (ForkLoopingChild): $msg"
exit 1
}
}
if {[cequal $tcl_platform(platform) windows]} {
if $setPGroup {
error "setpgroup not supported on windows"
}
set newPid [execl $::tcltest::tcltest CHILD.RUN]
}
# Wait till the child is actually running.
while {[file exists CHILD.RUN]} {
sleep 1
}
return $newPid
}
#
# Create a file. If the directory doesn't exist, create it.
#
proc TestTouch file {
file mkdir [file dirname $file]
close [open $file w]
}
#
# Remove files and directories with out errors.
#
proc TestRemove args {
foreach f $args {
catch {file delete -force $f}
}
}
|
