Tcl Source Code

Check-in [4b77647298]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Add another suppress rule for valgrind, factor test code into tests/tcltests.tcl, and constrained a some tests in the valgrind case.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-6-branch
Files: files | file ages | folders
SHA3-256: 4b776472981fbce4b8dbd9474696ff24ce60e94d3655cf8079ffd49bd975f71a
User & Date: pooryorick 2018-06-22 15:10:04
Context
2018-06-23
14:18
Add a test for no generation of a string representation when comparing with the empty string. check-in: b7e3852c22 user: pooryorick tags: core-8-6-branch
2018-06-22
15:10
Add another suppress rule for valgrind, factor test code into tests/tcltests.tcl, and constrained a ... check-in: 4b77647298 user: pooryorick tags: core-8-6-branch
2018-06-21
22:44
merge pyk-tcltest-exit check-in: 83da1d215d user: pooryorick tags: core-8-6-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to tests/all.tcl.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package prefer latest
package require Tcl 8.5-
package require tcltest 2.2
namespace import tcltest::*

configure {*}$argv -testdir [file dirname [file dirname [file normalize [
    info script]/...]]]

if {[singleProcess]} {
    interp debug {} -frame 1
}

runAllTests
proc exit args {}






|










9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package prefer latest
package require Tcl 8.5-
package require tcltest 2.2
namespace import -force ::tcltest::*

configure {*}$argv -testdir [file dirname [file dirname [file normalize [
    info script]/...]]]

if {[singleProcess]} {
    interp debug {} -frame 1
}

runAllTests
proc exit args {}

Changes to tests/chanio.test.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
    variable msg
    variable expected

    ::tcltest::loadTestedCommands
    catch [list package require -exact Tcltest [info patchlevel]]
    
    testConstraint testchannel      [llength [info commands testchannel]]
    testConstraint exec             [llength [info commands exec]]
    testConstraint openpipe         1
    testConstraint fileevent        [llength [info commands fileevent]]
    testConstraint fcopy            [llength [info commands fcopy]]
    testConstraint testfevent       [llength [info commands testfevent]]
    testConstraint testchannelevent [llength [info commands testchannelevent]]
    testConstraint testmainthread   [llength [info commands testmainthread]]
    testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

    # You need a *very* special environment to do some tests.  In particular,
    # many file systems do not support large-files...
    testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

    # some tests can only be run is umask is 2 if "umask" cannot be run, the
    # tests will be skipped.






<

<
<



<







35
36
37
38
39
40
41

42


43
44
45

46
47
48
49
50
51
52
    variable msg
    variable expected

    ::tcltest::loadTestedCommands
    catch [list package require -exact Tcltest [info patchlevel]]
    
    testConstraint testchannel      [llength [info commands testchannel]]

    testConstraint openpipe         1


    testConstraint testfevent       [llength [info commands testfevent]]
    testConstraint testchannelevent [llength [info commands testchannelevent]]
    testConstraint testmainthread   [llength [info commands testmainthread]]


    # You need a *very* special environment to do some tests.  In particular,
    # many file systems do not support large-files...
    testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

    # some tests can only be run is umask is 2 if "umask" cannot be run, the
    # tests will be skipped.

Changes to tests/io.test.

32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
    variable i
    variable n
    variable v
    variable msg
    variable expected

testConstraint testchannel      [llength [info commands testchannel]]
testConstraint exec             [llength [info commands exec]]
testConstraint openpipe         1
testConstraint fileevent        [llength [info commands fileevent]]
testConstraint fcopy            [llength [info commands fcopy]]
testConstraint testfevent       [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread   [llength [info commands testmainthread]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint testobj		[llength [info commands testobj]]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

# some tests can only be run is umask is 2






<

<
<



<







32
33
34
35
36
37
38

39


40
41
42

43
44
45
46
47
48
49
    variable i
    variable n
    variable v
    variable msg
    variable expected

testConstraint testchannel      [llength [info commands testchannel]]

testConstraint openpipe         1


testConstraint testfevent       [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread   [llength [info commands testmainthread]]

testConstraint testobj		[llength [info commands testobj]]

# You need a *very* special environment to do some tests.  In
# particular, many file systems do not support large-files...
testConstraint largefileSupport [expr {$::tcl_platform(os) ne "Darwin"}]

# some tests can only be run is umask is 2

Changes to tests/ioCmd.test.

16
17
18
19
20
21
22
23


24
25
26
27
28
29
30
31
32
33
34
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
....
3829
3830
3831
3832
3833
3834
3835










3836
3837
3838
3839
3840
3841
3842
3843
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]



# Custom constraints used in this file
testConstraint fcopy		[llength [info commands fcopy]]
testConstraint testchannel	[llength [info commands testchannel]]
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

#----------------------------------------------------------------------

test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
................................................................................
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} unixOrPc {
    list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
................................................................................

# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

rename track {}
# cleanup










foreach file [list test1 test2 test3 test4] {
    removeFile $file
}
# delay long enough for background processes to finish
after 500
removeFile test5
cleanupTests
return







>
>

<

<







 







|







 







>
>
>
>
>
>
>
>
>
>








16
17
18
19
20
21
22
23
24
25
26

27

28
29
30
31
32
33
34
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
....
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

package require tcltests

# Custom constraints used in this file

testConstraint testchannel	[llength [info commands testchannel]]


#----------------------------------------------------------------------

test iocmd-1.1 {puts command} {
   list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
................................................................................
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
    list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} {
    list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}

test iocmd-12.1 {POSIX open access modes: RDONLY} {
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f "Two lines: this one"
................................................................................

# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

rename track {}
# cleanup


# Eliminate valgrind "still reachable" reports on outstanding "Detached"
# structures in the detached list which stem from PipeClose2Proc not waiting
# around for background processes to complete, meaning that previous calls to
# Tcl_ReapDetachedProcs might not have had a chance to reap all processes.
after 10
exec [info nameofexecutable] << {}


foreach file [list test1 test2 test3 test4] {
    removeFile $file
}
# delay long enough for background processes to finish
after 500
removeFile test5
cleanupTests
return

Changes to tests/platform.test.

6
7
8
9
10
11
12

13
14
15
16
17
18
19
..
63
64
65
66
67
68
69
70



71
72
73
74
75
76
77
#
# Copyright (c) 1999 by Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2


namespace eval ::tcl::test::platform {
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::test
    namespace import ::tcltest::cleanupTests

    # This is not how [variable] works. See TIP 276.
................................................................................
    -match regexp \
    -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}

# The platform package makes very few promises, but does promise that the
# format of string it produces consists of two non-empty words separated by a
# hyphen.
package require platform
test platform-4.1 {format of platform::identify result} -match regexp -body {



    platform::identify
} -result {^([^-]+-)+[^-]+$}
test platform-4.2 {format of platform::generic result} -match regexp -body {
    platform::generic
} -result {^([^-]+-)+[^-]+$}

# cleanup






>







 







|
>
>
>







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#
# Copyright (c) 1999 by Scriptics Corporation
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
package require tcltests

namespace eval ::tcl::test::platform {
    namespace import ::tcltest::testConstraint
    namespace import ::tcltest::test
    namespace import ::tcltest::cleanupTests

    # This is not how [variable] works. See TIP 276.
................................................................................
    -match regexp \
    -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}

# The platform package makes very few promises, but does promise that the
# format of string it produces consists of two non-empty words separated by a
# hyphen.
package require platform
test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body {
    # [identify] may attempt to [exec] dpkg-architecture, which may not exist,
    # in which case fork will not be followed by exec, and valgrind will issue
    # "still reachable" reports.
    platform::identify
} -result {^([^-]+-)+[^-]+$}
test platform-4.2 {format of platform::generic result} -match regexp -body {
    platform::generic
} -result {^([^-]+-)+[^-]+$}

# cleanup

Changes to tests/tcltest.test.

904
905
906
907
908
909
910

911

912
913
914
915
916
917
918
919
920
921
922





923
924
925
926
927
928
929
	set ::tcltest::loadFile $oldf
    }
}
removeFile load.tcl

# [interpreter]
test tcltest-13.1 {interpreter} {

    -setup {

	set old $::tcltest::tcltest
	set ::tcltest::tcltest tcltest
    }
    -body {
	set f1 [interpreter]
	set f2 [interpreter tclsh]
	set f3 [interpreter]
	list $f1 $f2 $f3
    }
    -result {tcltest tclsh tclsh}
    -cleanup {





	set ::tcltest::tcltest $old
    }
}

# -singleproc, [singleProcess]
set spd [makeDirectory singleprocdir]
makeFile {






>

>











>
>
>
>
>







904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
	set ::tcltest::loadFile $oldf
    }
}
removeFile load.tcl

# [interpreter]
test tcltest-13.1 {interpreter} {
    -constraints notValgrind 
    -setup {
	#to do:  Why is $::tcltest::tcltest being saved and restored here?
	set old $::tcltest::tcltest
	set ::tcltest::tcltest tcltest
    }
    -body {
	set f1 [interpreter]
	set f2 [interpreter tclsh]
	set f3 [interpreter]
	list $f1 $f2 $f3
    }
    -result {tcltest tclsh tclsh}
    -cleanup {
	# writing ::tcltest::tcltest triggers a trace that sets up the stdio
	# constraint, which involves a call to [exec] that might fail after
	# "fork" and before "exec", in which case the forked process will not
	# have a chance to clean itself up before exiting, which causes
	# valgrind to issue numerous "still reachable" reports. 
	set ::tcltest::tcltest $old
    }
}

# -singleproc, [singleProcess]
set spd [makeDirectory singleprocdir]
makeFile {

Changes to tests/tcltests.tcl.

1
2
3
4
5
6





7
#! /usr/bin/env tclsh

# Some tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]






testConstraint notValgrind [expr {![testConstraint valgrind]}]

|
|
<

>
>
>
>
>
|
1
2
3
4

5
6
7
8
9
10
11
#! /usr/bin/env tclsh

package require tcltest 2.2
namespace import -force ::tcltest::*


testConstraint exec          [llength [info commands exec]]
testConstraint fcopy         [llength [info commands fcopy]]
testConstraint fileevent     [llength [info commands fileevent]]
testConstraint thread        [
    expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint notValgrind   [expr {![testConstraint valgrind]}]

Changes to tests/thread.test.

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
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.


#  when thread::release is used, -wait is passed in order allow the thread to
#  be fully finalized, which avoids valgrind "still reachable" reports.
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.2
    namespace import -force ::tcltest::*
}

package require tcltests

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testthread command

testConstraint testthread [expr {[info commands testthread] ne {}}]

# Some tests require the Thread package

testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]

# Some tests may not work under valgrind

testConstraint notValgrind [expr {![testConstraint valgrind]}]

set threadSuperKillScript {
    rename catch ""
    rename while ""
    rename unknown ""
    rename update ""
    thread::release






<
<
<
<










<
<
<
<
<
<
<







10
11
12
13
14
15
16




17
18
19
20
21
22
23
24
25
26







27
28
29
30
31
32
33
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.


#  when thread::release is used, -wait is passed in order allow the thread to
#  be fully finalized, which avoids valgrind "still reachable" reports.





package require tcltests

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

# Some tests require the testthread command

testConstraint testthread [expr {[info commands testthread] ne {}}]









set threadSuperKillScript {
    rename catch ""
    rename while ""
    rename unknown ""
    rename update ""
    thread::release

Changes to tools/valgrind_suppress.

19
20
21
22
23
24
25










26
27
28
29
30
31
32
}

{
   TclpDlopen/load
   Memcheck:Leak
   match-leak-kinds: reachable
   fun:calloc










   ...
   fun:dlopen
   fun:TclpDlopen
}

{
   TclpGetGrNam/__nss_next2/calloc






>
>
>
>
>
>
>
>
>
>







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
}

{
   TclpDlopen/load
   Memcheck:Leak
   match-leak-kinds: reachable
   fun:calloc
   ...
   fun:dlopen
   fun:TclpDlopen
}

{
   TclpDlopen/load
   Memcheck:Leak
   match-leak-kinds: reachable
   fun:malloc
   ...
   fun:dlopen
   fun:TclpDlopen
}

{
   TclpGetGrNam/__nss_next2/calloc