Tk Source Code

Changes On Branch simplify_test_file_init_for_singleproc_1
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki
Patch Side-by-Side Diff

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

Changes In Branch simplify_test_file_init_for_singleproc_1 Excluding Merge-Ins

This is equivalent to a diff from 6242b4c1 to 9d2978c1

2025-08-14
00:24
Merge trunk check-in: 9362b96a user: kevin_walzer tags: tka11y
2025-08-13
18:50
Merge trunk Leaf check-in: 9d2978c1 user: erikleunissen tags: simplify_test_file_init_for_singleproc_1
17:48
Let this branch test at Github CI check-in: f94ecbca user: erikleunissen tags: simplify_test_file_init_for_singleproc_1
14:05
Merge 9.1 Leaf check-in: d797be61 user: jan.nijtmans tags: revised_text, tip-466
14:04
Merge 9.0 Leaf check-in: 6242b4c1 user: jan.nijtmans tags: trunk, main
13:14
More "8.7" elimination Leaf check-in: 8fdacebf user: jan.nijtmans tags: core-9-0-branch
2025-08-12
12:10
Version -> 9.1a1 check-in: 958f82a6 user: jan.nijtmans tags: trunk, main

Changes to .github/workflows/linux-build.yml. 
1
2
3
4
5
6

7
8
9
10
11
12
13

1
2
3
4
5
6
7
8
9
10
11
12
13
14







+








name: Linux
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
defaults:
  run:
    shell: bash
︙
Changes to .github/workflows/mac-build.yml. 
1
2
3
4
5
6

7
8
9
10
11
12
13

1
2
3
4
5
6
7
8
9
10
11
12
13
14







+








name: macOS
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:
︙
Changes to .github/workflows/win-build.yml. 
1
2
3
4
5
6

7
8
9
10
11
12
13

1
2
3
4
5
6
7
8
9
10
11
12
13
14







+








name: Windows
on:
  push:
    branches:
    - "main"
    - "core-9-0-branch"
    - "simplify_test_file_init_for_singleproc_1"
    tags:
    - "core-**"
permissions:
  contents: read
env:
  ERROR_ON_FAILURES: 1
jobs:
︙
Changes to tests/all.tcl. 
1
2
3
4

5
6
7
8
9
10
11



12
13



















14


15
16
17
18
19
20
21
























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




-
+







+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
+

-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# all.tcl --
#
# This file contains a top-level script to run all of the Tk
# tests.  Execute it by invoking "source all.tcl" when running tktest
# tests. Execute it by invoking "source all.tcl" when running tktest
# in this directory.
#
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# REQUIREMENTS
#
package require tk ;# This is the Tk test suite; fail early if no Tk!
package require tcltest 2.2

#
# TCLTEST CONFIGURATION
#

# Set defaults for the Tk test suite
tcltest::configure -singleproc 1

# Handle command line parameters
if {[expr {[llength $argv] & 1}]} {
    return -code error "the number of command line parameters must be even (name - value pairs)"
}
set fixedOptions [list -testdir -loadfile]
foreach {key value} $argv {
    if {$key in $fixedOptions} {
	return -code error "option \"$key\" is not user-configurable for the Tk test suite"
    }
}
unset fixedOptions
tcltest::configure {*}$argv

# Set tcltest options that are not user-configurable for the Tk test suite
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
    [file join [tcltest::testsDirectory] main.tcl]
tcltest::configure -singleproc 1
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
encoding system utf-8
if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1}
if {[tcltest::configure -singleproc]} {
    #
    # All test files are evaluated in the current interpreter. We need to load
    # the file main.tcl only once.
    #
    source [file join [tcltest::testsDirectory] main.tcl]
} else {
    #
    # Each test file is evaluated in a separate process/interpreter. Each testfile
    # needs to load the file main.tcl into its interpreter.
    #
    tcltest::configure -loadfile \
	[file join [tcltest::testsDirectory] main.tcl]
}

#
# RUN ALL TESTS
#

# Note: the environment variable ERROR_ON_FAILURES is set by Github CI
if {[tcltest::runAllTests] && [info exists env(ERROR_ON_FAILURES)]} {
    exit 1
}
Changes to tests/bell.test. 
1
2
3
4
5
6
7


















8

9
10
11









12
13
14
15
16
17
18

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


-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out Tk's "bell" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1998-2000 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bell-1.1 {bell command} -body {
    bell a
} -returnCodes error -result {bad option "a": must be -displayof or -nice}

test bell-1.2 {bell command} -body {
    bell a b
︙
44
45
46
47
48
49
50
51




52
53

67
68
69
70
71
72
73
74
75
76
77
78
79










+
+
+
+

-

    after 200
    bell -displayof .
    after 200
    bell -nice
    after 200
    bell
} -result {}

#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/bgerror.test. 
1
2
3
4
5
6
7























8

9
10
11









12
13
14
15
16
17
18

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


-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the bgerror command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Some testing of the default error dialog would be needed too, but that's
# not easy at all to emulate.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bgerror-1.1 {bgerror / tkerror compat} -setup {
    set errRes {}
    proc tkerror {err} {
	global errRes;
	set errRes $err;
    }
︙
53
54
55
56
57
58
59
60

61
62
63
64
65



66
67

81
82
83
84
85
86
87

88





89
90
91
92









-
+
-
-
-
-
-
+
+
+

-

    after 0 {error err3}
    update
    return $errRes;
} -cleanup {
    catch {rename tkerror {}}
} -result {err1}


#
# some testing of the default error dialog
# would be needed too, but that's not easy at all
# to emulate.

# cleanup
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/bind.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+
+













+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+










-
-
-
-
-
-
-
-
+
+
+








# This file is a Tcl script to test out Tk's "bind" and "bindtags"
# commands plus the procedures in tkBind.c.  It is organized in the
# commands plus the procedures in tkBind.c.
# standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

tk useinputmethods 0

toplevel .t -width 100 -height 50
wm geom .t +0+0
update idletasks

foreach p [event info] {event delete $p}
foreach event [bind Test] {
    bind Test $event {}
}
foreach event [bind all] {
    bind all $event {}
}

# move the mouse pointer away of the testing area
# otherwise some spurious events may pollute the tests
toplevel .top
wm geometry .top 50x50-50-50
update
event generate .top <Button-1> -warp 1
controlPointerWarpTiming
destroy .top

#
# LOCAL UTILITY PROCS
#

proc testKey {window event type mods} {
    global keyInfo numericKeysym
    set keyInfo {}
    set numericKeysym {}
    bind $window <Key> {
	set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k]
	set numericKeysym %N
    }
    focus -force $window
    update
    event generate $window $event
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    set save $keyInfo
    set keyInfo {}
    set injectcmd [list testinjectkeyevent $type $numericKeysym]
    foreach {option} $mods {
	lappend injectcmd $option
    }
    eval $injectcmd
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    if {$save != $keyInfo} {
	return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo"
    }
    return pass
}

proc testKeyWithMods {window keysym type} {
    set result [testKey $window "<$keysym>" $type {}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-$keysym>" $type {-shift}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Option-$keysym>" $type {-option}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}]
    if {$result != {pass}} {
	return $result
    }
    return pass
}

proc unsetBindings {} {
    bind all <Enter> {}
    bind Test <Enter> {}
    bind Toplevel <Enter> {}
    bind xyz <Enter> {}
    bind {a b} <Enter> {}
    bind .t <Enter> {}
}

# move the mouse pointer away of the testing area
# otherwise some spurious events may pollute the tests
toplevel .top
wm geometry .top 50x50-50-50
update
event generate .top <Button-1> -warp 1
controlPointerWarpTiming
destroy .top
#
# TESTS
#

test bind-1.1 {bind command} -body {
    bind
} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
test bind-1.2 {bind command} -body {
    bind a b c d
} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}
︙
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972

6991
6992
6993
6994
6995
6996
6997


















































6998
6999
7000
7001
7002
7003
7004








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








	    lappend res $dim
	}
    }
    set res
} -cleanup {
} -result {ok ok ok ok}

set keyInfo {}
set numericKeysym {}
proc testKey {window event type mods} {
    global keyInfo numericKeysym
    set keyInfo {}
    set numericKeysym {}
    bind $window <Key> {
	set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k]
	set numericKeysym %N
    }
    focus -force $window
    update
    event generate $window $event
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    set save $keyInfo
    set keyInfo {}
    set injectcmd [list testinjectkeyevent $type $numericKeysym]
    foreach {option} $mods {
	lappend injectcmd $option
    }
    eval $injectcmd
    if {$keyInfo == {}} {
	vwait keyInfo
    }
    if {$save != $keyInfo} {
	return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo"
    }
    return pass
}
proc testKeyWithMods {window keysym type} {
    set result [testKey $window "<$keysym>" $type {}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-$keysym>" $type {-shift}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Option-$keysym>" $type {-option}]
    if {$result != {pass}} {
	return $result
    }
    set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}]
    if {$result != {pass}} {
	return $result
    }
    return pass
}
test bind-35.0 {Generated and real key events agree} -constraints {aqua} -body {
    foreach k {o O F2 Home Right Greek_sigma Greek_ALPHA} {
	set result [testKeyWithMods . $k press]
	if {$result != "pass"} {
	    return $result
	}
    }
︙
7096
7097
7098
7099
7100
7101
7102



7103

7104
7105
7106
7107
7108
7109
7110

7128
7129
7130
7131
7132
7133
7134
7135
7136
7137

7138
7139

7140
7141
7142
7143
7144








+
+
+
-
+

-






    event generate .c <B1-Motion>
    event generate .c <ButtonRelease-1>
    event generate .c <B1-Motion>
} -cleanup {
    destroy .c
} -returnCodes ok -result {}  ; # shall not crash (assertion failed)

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return

# vi:set ts=4 sw=4 et:
# Local Variables:
# mode: tcl
# End:
Changes to tests/bitmap.test. 
1
2

3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17
18
19

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkBitmap.c.  It is organized in the standard white-box fashion for
# tkBitmap.c.
# Tcl tests.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints {
    testbitmap
} -body {
    set x gray25
    lindex $x 0
    button .b -bitmap $x
︙
104
105
106
107
108
109
110
111
112




113
114

127
128
129
130
131
132
133


134
135
136
137
138









-
-
+
+
+
+

-

    set y bogus
    return $result
} -cleanup {
    rename copy {}
    destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/border.test. 
1
2

3
4
5
6
7


















8

9
10
11









12
13
14
15
16
17
18

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


-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkBorder.c.  It is organized in the standard fashion for Tcl tests.
# tkBorder.c.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints {
    testborder
} -body {
    set x orange
    lindex $x 0
    button .b1 -bg $x -text .b1
︙
192
193
194
195
196
197
198
199
200




201
202

216
217
218
219
220
221
222


223
224
225
226
227









-
-
+
+
+
+

-

} -result {sunken}
test border-4.7 {Tk_GetReliefFromObj - error} -body {
    button .b -relief upanddown
} -cleanup {
    destroy .b
} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/busy.test. 
1

2
3
4


5
6


7
8
9
















10
11

12
13
14
15





16



17
18
19
20
21
22
23


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

-
+

-
-
+
+
-

+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
-
-
-
-
+
+
+
+
+
-
+
+
+








# Tests for the tk busy command.
# This file is a Tcl script to test out the tk busy command.
#
# This file contains a collection of tests for one or more of the Tk built-in
# commands. Sourcing this file runs the tests and generates output for errors.
# Copyright © 1998-2000 Jos Decoster. All rights reserved.

# No output means no errors were found.
#
# TESTFILE INITIALIZATION
#
# Copyright © 1998-2000 Jos Decoster. All rights reserved.

package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
namespace import -force tcltest::test

# There's currently no way to test the actual grab effect, per se, in an
# automated test. Therefore, this test suite only covers the interface to the
}

# Ensure a pristine initial window state
resetWindows

# grab command (ie, error messages, etc.)
#
# TESTS
#

test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body {
    tk busy
} -result {wrong # args: should be "tk busy options ?arg ...?"}

test busy-2.1 {tk busy hold} -returnCodes error -body {
    tk busy hold
︙
500
501
502
503
504
505
506
507




508
509

516
517
518
519
520
521
522

523
524
525
526
527









-
+
+
+
+

-

test busy-8.3 {tk busy busywindow with a nonexisting widget} -body {
    tk busy .
    tk busy busywindow .nonExistingWidget
} -cleanup {
    tk busy forget .
} -result {}


#
# TESTFILE CLEANUP
#

::tcltest::cleanupTests
return
Changes to tests/button.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+








# This file is a Tcl script to test labels, buttons, checkbuttons, and
# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).  It is
# radiobuttons in Tk (i.e., all the widgets defined in tkButton.c).
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import button image

imageInit

#
# TESTS
#

test button-1.1 {configuration option: "activebackground" for label} -setup {
    label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
    pack .l
    update
} -body {
    .l configure -activebackground #012345
︙
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689

2698
2699
2700
2701
2702
2703
2704

2705
2706
2707
2708
2709
2710
2711








-








} -body {
    .c configure -padx 0 -pady 0 -wraplength 0
    list [.c cget -padx] [.c cget -pady] [.c cget -borderwidth] [.c cget -highlightthickness] [.c cget -wraplength]
} -cleanup {
    destroy .c
} -result {0 0 0 0 0}

# ex-tests 3.*
test button-2.1 {ButtonCreate - not enough arguments} -body {
    button
} -returnCodes error -result {wrong # args: should be "button pathName ?-option value ...?"}

test button-2.2 {ButtonCreate procedure - setting label class} -body {
    label .x
    winfo class .x
︙
2718
2719
2720
2721
2722
2723
2724
2725

2726
2727
2728
2729
2730
2731
2732

2740
2741
2742
2743
2744
2745
2746

2747
2748
2749
2750
2751
2752
2753
2754








-
+








} -result {Button}

test button-2.7 {ButtonCreate - bad window name} -body {
    button foo
} -cleanup {
    destroy foo
} -returnCodes error -result {bad window path name "foo"}
######### test ex 3.8

test button-2.8 {ButtonCreate procedure - error in default option value} -body {
    option add *funny.background bogus
    button .funny
} -cleanup {
    option clear
    destroy .funny
} -returnCodes error -result {unknown color name "bogus"}
︙
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771

2771
2772
2773
2774
2775
2776
2777

2778
2779
2780
2781
2782
2783
2784

2785
2786
2787
2788
2789
2790
2791








-







-








} -returnCodes error -result {unknown option "-gorp"}
test button-2.11 {ButtonCreate procedure - option error} -body {
    catch {button .x -gorp foo}
    winfo exists .x
}  -cleanup {
    destroy .x
} -result 0
######### ex 3.10
test button-2.12 {ButtonCreate procedure - return value} -body {
    set x [button .abcd]
    return $x
} -cleanup {
    destroy .abcd
} -result {.abcd}

######### ex 4.*
test button-3.1 {ButtonWidgetCmd - too few arguments} -body {
    button .b
    .b
} -cleanup {
    destroy .b
} -returnCodes error -result {wrong # args: should be ".b option ?arg ...?"}
test button-3.2 {ButtonWidgetCmd - bad option name} -body {
︙
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849

2855
2856
2857
2858
2859
2860
2861

2862
2863
2864
2865
2866
2867
2868








-








test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body {
    radiobutton .r
    .r cget -onvalue
} -cleanup {
    destroy .r
} -returnCodes error -result {unknown option "-onvalue"}

# ex 4.6
test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body {
    button .b -highlightthickness 3
    lindex [.b configure -highlightthickness] 4
} -cleanup {
    destroy .b
}  -result 3
test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body {
︙
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111

3116
3117
3118
3119
3120
3121
3122

3123
3124
3125
3126
3127
3128
3129








-








    destroy .r
    trace remove variable radiovar write bogusTrace
} -match glob -result {{*trace aborted
    while executing
*
".r select"} red}

# ex 4.43
test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body {
    label .l
    .l toggle
} -cleanup {
    destroy .l
} -returnCodes error -result {bad option "toggle": must be cget or configure}
test button-3.47 {ButtonWidgetCmd procedure, "toggle" option} -body {
︙
3246
3247
3248
3249
3250
3251
3252
3253

3254
3255
3256
3257
3258
3259
3260

3264
3265
3266
3267
3268
3269
3270

3271
3272
3273
3274
3275
3276
3277
3278








-
+








    set y From-y
    .b configure -textvariable y
    set x New
    lindex [.b configure -text] 4
} -cleanup {
    destroy .b
} -result {From-y}
test button-5.4 {ConfigureButton - variable trace} -body {  ;# ex 6.2a
test button-5.4 {ConfigureButton - variable trace} -body {
    checkbutton .c -variable x
    set x 1
    set y 1
    .c configure -textvariable y
    set x 0
    .c toggle
    return $y
︙
4004
4005
4006
4007
4008
4009
4010
4011

4012
4013
4014
4015
4016
4017
4018
4019
4020
4021

4022
4023
4024
4025
4026
4027
4028

4029
4030
4031
4032
4033
4034

4035
4036
4037
4038








-
+





-





    pack .b
    bind .b <Configure> {unset var}
    update
    destroy .b
} {}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
testutils forget button image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/canvImg.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+






+
+
+
-
+
+




+
+
+








# This file is a Tcl script to test out the procedures in tkCanvImg.c,
# which implement canvas "image" items.  It is organized in the standard
# which implement canvas "image" items.
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#
# Canvas used in every test case of the whole file
# For every test case of the whole file
#
canvas .c
pack .c
update

#
# TESTS
#

test canvImg-1.1 {options for image items} -body {
    .c create image 50 50 -anchor nw -tags i1
    .c itemconfigure i1 -anchor
} -cleanup {
    .c delete all
} -result {-anchor {} {} center nw}
︙
382
383
384
385
386
387
388
389
390





391
392
393

394
395
396
397
398
399
400

408
409
410
411
412
413
414


415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430








-
-
+
+
+
+
+



+








    .c delete all
    .c create image 50 100 -tags i1
    update
    .c create rect 55 110 65 115 -width 1 -outline black -fill white
    update
} -result {}


# image used in 8.* test cases
#
# COMMON TEST SETUP
#
# For tests canvImg-8.*
#
if {[testConstraint testImageType]} {
    image create test foo
}

test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup {
	.c create image 50 100 -image foo -tags image -anchor nw
	.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
} -body {
	.c coords rect 50 70 80 81
	.c gettags [.c find closest 70 90]
} -cleanup {
︙
549
550
551
552
553
554
555




556
557
558
559
560
561
562

579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596








+
+
+
+








	.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {}
} -body {
	.c coords rect {*}{60 70 71 111}
	.c gettags [.c find closest {*}{70 110}]
} -cleanup {
	.c delete all
} -result {rect}

#
# COMMON TEST CLEANUP
#
.c delete all

test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c gettags [.c find overlapping 60 0 70 99]
} -cleanup {
	.c delete all
︙
707
708
709
710
711
712
713




714
715
716
717
718
719
720
721
722
723
724

741
742
743
744
745
746
747
748
749
750
751
752
753
754

755
756
757
758
759
760
761








+
+
+
+



-








} -result {}
test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c gettags [.c find enclosed 50 100 80 114]
} -cleanup {
	.c delete all
} -result {}

#
# COMMON TEST SETUP
#
if {[testConstraint testImageType]} {
	image delete foo
}


test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup {
    .c delete all
	image create test foo
} -body {
    .c create image 50 100 -image foo -tags image -anchor nw
    .c scale image 25 0 2.0 1.5
︙
800
801
802
803
804
805
806
807

808
809
810
811
812
813
814
815
816
817

837
838
839
840
841
842
843

844
845
846
847
848
849

850
851
852
853








-
+





-





    return $z
} -cleanup {
    .c delete all
    image delete foo2
} -result {{foo2 display 0 0 80 60}}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/canvMoveto.test. 
1
2
3
4
5
6
7
8


















9

10
11
12









13
14
15




16
17
18
19
20
21
22

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









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+



+
+
+
+








# This file is a Tcl script to test out the canvas "moveto" command. It is
# derived from canvRect.test.
#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2004 Neil McKay.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -tag {test rect1}
.c create rectangle 40 40 90 100 -tag {test rect2}

#
# TESTS
#

test canvMoveto-1.1 {Bad args handling for "moveto" command} -body {
    .c moveto test
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
test canvMoveto-1.2 {Bad args handling for "moveto" command} -body {
    .c moveto rect
} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"}
︙
41
42
43
44
45
46
47
48
49
50





51
52
53
54
55
56

69
70
71
72
73
74
75



76
77
78
79
80
81

82
83
84
85








-
-
-
+
+
+
+
+

-





} {150 150 222 232}
test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} {
    .c moveto test 200 150
    .c moveto test {} 200
    .c bbox test
} {200 200 272 282}

.c delete withtag all

# cleanup
#
# TESTFILE CLEANUP
#

.c delete withtag all
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/canvPs.test. 
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

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









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+






+
+
+
-
+
+
+
+
+
+








# This file is a Tcl script to test out procedures to write postscript
# for canvases to files and channels. It exercises the procedure
# TkCanvPostscriptCmd in generic/tkCanvPs.c
#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TESTS
#
# canvas used in 1.* and 2.* test cases

#
# COMMON TEST SETUP
#
# For tests canvas-1.* and canvas-2.*
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
.c create rectangle 20 20 80 80 -fill red
pack .c
update

test canvPs-1.1 {test writing to a file} -constraints {
    unixOrWin
︙
130
131
132
133
134
135
136
137
138





139
140
141
142
143
144
145

158
159
160
161
162
163
164


165
166
167
168
169
170
171
172
173
174
175
176








-
-
+
+
+
+
+








	    set status broken
    }
    set status
} -cleanup {
    removeFile foo.ps
    removeFile bar.ps
} -result ok
destroy .c


#
# COMMON TEST CLEANUP
#
destroy .c

test canvPs-3.1 {test ps generation with an embedded window} -setup {
    set bar [makeFile {} bar.ps]
    file delete $bar
} -body {
    pack [canvas .c -width 200 -height 200 -background white]
    .c create rect 20 20 150 150 -tags rect0 -dash . -width 2
︙
200
201
202
203
204
205
206
207

208
209
210
211
212
213
214
215
216
217
218
219

231
232
233
234
235
236
237

238
239
240
241
242
243
244
245

246
247
248
249








-
+







-





    .c create image 50 50 -image ::tk::icons::information
    .c postscript
} -cleanup {
    destroy .c
} -returnCodes ok -match glob -result *

#
# CLEANUP
# TESTFILE CLEANUP
#

unset -nocomplain foo bar
imageFinish
testutils forget image
deleteWindows
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/canvRect.test. 
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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+




+
+
+
+
+
+
+
-
+
+

+








# This file is a Tcl script to test out the procedures in tkRectOval.c,
# which implement canvas "rectangle" and "oval" items.  It is organized
# which implement canvas "rectangle" and "oval" items.
# in the standard fashion for Tcl tests.
#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

# Canvas used in every test case of the whole file
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
# For every test case of the whole file
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update

#
# TESTS
#

#
# COMMON TEST SETUP
#
# Rectangle used in canvRect-1.* tests
# For tests canvRect-1.*
#
.c create rectangle 20 20 80 80 -tag test

test canvRect-1.1 {configuration options: good value for -fill} -body {
    .c itemconfigure test -fill #ff0000
    list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4]
} -result {{#ff0000} #ff0000}
test canvRect-1.2 {configuration options: bad value for -fill} -body {
    .c itemconfigure test -fill non-existent
} -returnCodes error -result {unknown color name "non-existent"}
︙
50
51
52
53
54
55
56
57
58





59
60
61
62
63
64
65

82
83
84
85
86
87
88


89
90
91
92
93
94
95
96
97
98
99
100








-
-
+
+
+
+
+








test canvRect-1.9 {configuration options: good value for -width} -body {
    .c itemconfigure test -width 6.0
    list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4]
} -result {6.0 6.0}
test canvRect-1.10 {configuration options: bad value for -width} -body {
    .c itemconfigure test -width abc
} -returnCodes error -result {expected screen distance but got "abc"}
.c delete withtag all


#
# COMMON TEST CLEANUP
#
.c delete withtag all

test canvRect-2.1 {CreateRectOval procedure} -body {
    .c create rect
} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"}
test canvRect-2.2 {CreateRectOval procedure} -body {
    .c create oval x y z
} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3}
︙
82
83
84
85
86
87
88
89
90





91
92
93
94
95
96
97

117
118
119
120
121
122
123


124
125
126
127
128
129
130
131
132
133
134
135








-
-
+
+
+
+
+








	    lappend result [format %.1f $element]
    }
    set result
} -result {1.0 2.0 3.0 4.0}
test canvRect-2.8 {CreateRectOval procedure} -body {
    .c create rectangle 1 2 3 4 -gorp foo
} -returnCodes error -result {unknown option "-gorp"}
.c delete withtag all


#
# COMMON TEST CLEANUP
#
.c delete withtag all

test canvRect-3.1 {RectOvalCoords procedure} -body {
    .c create rectangle 10 20 30 40 -tags x
    set result {}
    foreach element [.c coords x] {
	    lappend result [format %.1f $element]
    }
︙
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

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








+
+
+
+
+
+
+


-
-
-
-
-
-
+





-
+








    .c bbox x
} -cleanup {
    .c delete withtag all
} -result {5 15 35 45}

# I can't come up with any good tests for DeleteRectOval.

test canvRect-5.1.1 {ComputeRectOvalBbox procedure} -constraints nonwin -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 20 15 10 5
    .c bbox x
} -cleanup {
    .c delete withtag all
} -result {10 5 20 15}
# On Windows the bbox of rectangle items is 1 pixel larger at each border due
# to the "bloat" implemented in ComputeRectOvalBbox() in case -outline is {}
if {[tk windowingsystem] eq "win32"} {
    set result_5_1 {9 4 21 16}
} else {
    set result_5_1 {10 5 20 15}
}
test canvRect-5.1 {ComputeRectOvalBbox procedure} -body {
test canvRect-5.1.2 {ComputeRectOvalBbox procedure} -constraints win32 -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 20 15 10 5
    .c bbox x
} -cleanup {
    .c delete withtag all
} -result $result_5_1
} -result {9 4 21 16}
test canvRect-5.2 {ComputeRectOvalBbox procedure} -body {
    .c create rectangle 10 20 30 40 -tags x -width 1 -outline {}
    .c coords x 10 20 30 10
    .c itemconfigure x -width 1 -outline red
    .c bbox x
} -cleanup {
    .c delete withtag all
︙
459
460
461
462
463
464
465
466
467
468
469
470
471



472


499
500
501
502
503
504
505






506
507
508
509
510








-
-
-
-
-
-
+
+
+

+

restore showpage

%%Trailer
end
%%EOF
}

# cleanup
cleanupTests
return



#
# TESTFILE CLEANUP
#

cleanupTests
Changes to tests/canvText.test. 
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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



-
-

+








# This file is a Tcl script to test out the procedures in tkCanvText.c,
# which implement canvas "text" items.  It is organized in the standard
# which implement canvas "text" items.
# fashion for Tcl tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

# Canvas used in 1.* - 17.* tests
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvas-1.* - 17.*
#
canvas .c -width 400 -height 300 -bd 2 -relief sunken
pack .c
update

# Item used in 1.*  tests
.c create text 20 20 -tag test

test canvText-1.1 {configuration options: good value for "anchor"} -body {
    .c itemconfigure test -anchor nw
    list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor]
} -result {nw nw}
test canvasText-1.2 {configuration options: bad value for "anchor"} -body {
    .c itemconfigure test -anchor xyz
} -returnCodes error -result {bad anchor "xyz": must be n, ne, e, se, s, sw, w, nw, or center}
︙
86
87
88
89
90
91
92
93
94





95
96
97
98
99
100
101

112
113
114
115
116
117
118


119
120
121
122
123
124
125
126
127
128
129
130








-
-
+
+
+
+
+








    .c itemconfigure test -angle 390
    set result [.c itemcget test -angle]
    .c itemconfigure test -angle -30
    lappend result [.c itemcget test -angle]
    .c itemconfigure test -angle -360
    lappend result [.c itemcget test -angle]
} -result {30.0 330.0 0.0}
.c delete test


#
# COMMON TEST CLEANUP
#
.c delete test

test canvText-2.1 {CreateText procedure: args} -body {
    .c create text
} -returnCodes error -result {wrong # args: should be ".c create text coords ?arg ...?"}
test canvText-2.2 {CreateText procedure: args} -body {
    .c create text xyz 0
} -cleanup {
︙
374
375
376
377
378
379
380
381
382


383
384
385

386
387
388

389
390
391
392
393
394
395

403
404
405
406
407
408
409


410
411



412
413
414
415
416
417
418
419
420
421
422
423








-
-
+
+
-
-
-
+



+








    .c itemconfig test -font $font -text 0
    expr {[.c itemconfig test -anchor center; .c bbox test] \
	      eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"}
} -cleanup {
    .c delete test
} -result 1


#.c delete test
#
# COMMON TEST SETUP
#.c create text 20 20 -tag test
#focus -force .c
#.c focus test
#
focus .c
.c focus test
.c itemconfig test -text "abcd\nefghi\njklmnopq"

test canvText-7.1 {DisplayText procedure: stippling} -body {
    .c create text 20 20 -tag test
    .c itemconfig test -stipple gray50
    update
    .c itemconfig test -stipple {}
    update
} -cleanup {
︙
581
582
583
584
585
586
587



588


589

590
591
592
593
594
595
596

609
610
611
612
613
614
615
616
617
618

619
620
621
622
623
624
625
626
627
628
629








+
+
+
-
+
+

+








} -body {
    .c itemconfig test -text "abcdefg"
    .c icursor test 3
    .c insert test 4 "xyz"
    .c index test insert
} -result 3

#
# COMMON TEST SETUP
#
# Item used in 9.* tests
# For tests canvasText-9.*
#
.c create text 20 20 -tag test

test canvText-9.1 {TextInsert procedure: before beginning/after end} -body {
    # Can't test this because GetTextIndex filters out those numbers.
} -result {}
test canvText-9.2 {TextInsert procedure: start > end} -body {
    .c itemconfig test -text "abcdefg"
    .c dchars test 4 2
    .c itemcget test -text
︙
682
683
684
685
686
687
688
689
690





691
692
693
694
695
696
697

715
716
717
718
719
720
721


722
723
724
725
726
727
728
729
730
731
732
733








-
-
+
+
+
+
+








} -result 2
test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body {
    .c itemconfig test -text "abcdefghijk"
    .c icursor test 5
    .c dchars test 7 9
    .c index test insert
} -result 5
.c delete test


#
# COMMON TEST CLEANUP
#
.c delete test

test canvText-10.1 {TextToPoint procedure} -body {
    .c create text 0 0 -tag test
    .c itemconfig test -text 0 -anchor center
    .c index test @0,0
} -cleanup {
	.c delete test
︙
981
982
983
984
985
986
987



988

989
990

1017
1018
1019
1020
1021
1022
1023
1024
1025
1026

1027
1028









+
+
+
-
+

-

    .c select clear
    .c select from $id 0
    .c select to $id 8 ; update    ;  # used to crash on X11 (--disable-xft build only)
} -cleanup {
    destroy .c
} -result {}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return
Changes to tests/canvWind.test. 
1
2

3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17
18
19

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in tkCanvWind.c,
# which implement canvas "window" items.  It is organized in the standard
# which implement canvas "window" items.
# fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup {
    destroy .t
} -body {
    toplevel .t
    canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \
	    -relief sunken -xscrollincrement 1 -yscrollincrement 1 \
︙
151
152
153
154
155
156
157



158

159
160

174
175
176
177
178
179
180
181
182
183

184
185









+
+
+
-
+

-

    bind .t.c.f <Configure> {destroy .t.c.f}
    .t.c coords $id 60 60 ;  # was crashing
    update
} -cleanup {
    destroy .t
} -result {}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return
Changes to tests/canvas.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+





+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in tkCanvas.c, which
# implements generic code for canvases. It is organized in the standard
# implements generic code for canvases.
# fashion for Tcl tests.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

# NOTE
#
# This test file is woefully incomplete. At present, only a few of the
# features are tested.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#
# XXX - This test file is woefully incomplete. At present, only a few of the
# features are tested.

# Canvas used in 1.* test cases

proc kill_canvas {w} {
    destroy $w
    pack [canvas $w -height 200 -width 200] -fill both -expand yes
    update idle
    $w create rectangle 80 80 120 120 -fill blue -tags blue
    # bind a button press to re-build the canvas
    $w bind blue <ButtonRelease-1> [subst {
	[lindex [info level 0] 0] $w
	append ::x ok
    }]
}

proc matchPixels {pixels expected} {
    set matched 1
    foreach pline $pixels eline $expected {
	foreach ppixel $pline epixel $eline {
	    if {$ppixel != $epixel} {
		set matched 0
		break
	    }
	}
    }
    return $matched
}

#
# TESTS
#

#
# COMMON TEST SETUP
#
# For tests canvas-1.*
#
canvas .c
pack .c
update

test canvas-1.1 {configuration options: good value for "background"} -body {
    .c configure -background #ff0000
    .c cget -background
︙
187
188
189
190
191
192
193
194
195
196







197
198
199
200
201
202
203

246
247
248
249
250
251
252



253
254
255
256
257
258
259
260
261
262
263
264
265
266








-
-
-
+
+
+
+
+
+
+








    .c configure -gorp foo
} -returnCodes error -match glob -result {*}
test canvas-1.47 {configure throws error on bad option} -body {
    catch {.c configure -gorp foo}
    .c create rect 10 10 100 100
    .c configure -gorp foo
} -returnCodes error -match glob -result {*}
catch {destroy .c}

# Canvas used in 2.* test cases

#
# COMMON TEST SETUP
#
# For tests canvas-2.*
#
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \
	-highlightthickness 0
pack .c
update

test canvas-2.1 {CanvasWidgetCmd, bind option} -body {
    set i [.c create rect 10 10 100 100]
︙
235
236
237
238
239
240
241
242
243
244







245
246
247
248
249
250
251

298
299
300
301
302
303
304



305
306
307
308
309
310
311
312
313
314
315
316
317
318








-
-
-
+
+
+
+
+
+
+








    .c raise aline noline
    .c raise bline aline
    .c lower aline noline
    .c lower bline aline
} -cleanup {
    .c delete aline
} -result {}
catch {destroy .c}

# Canvas used in 3.* test cases

#
# COMMON TEST SETUP
#
# For tests canvas-3.*
#
catch {destroy .c}
canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \
	-borderwidth 0 -highlightthickness 0
pack .c
update

test canvas-3.1 {CanvasWidgetCmd, yview option} -body {
    .c configure -xscrollincrement 40 -yscrollincrement 5
︙
261
262
263
264
265
266
267




268
269
270
271
272
273
274

328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345








+
+
+
+








    .c yview moveto 0
    update
    set x [list [.c yview]]
    .c yview scroll 2 units
    update
    lappend x [.c yview]
} -result {{0.0 0.5} {0.1 0.6}}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-4.1 {ButtonEventProc procedure} -setup {
    deleteWindows
    set x {}
} -body {
    canvas .c1 -bg #543210
︙
283
284
285
286
287
288
289



290


291
292
293
294
295
296
297

354
355
356
357
358
359
360
361
362
363

364
365
366
367
368
369
370
371
372








+
+
+
-
+
+








    canvas .c1
    rename .c1 {}
    list [info command .c*] [winfo children .]
} -cleanup {
    destroy .c1
} -result {{} {}}

#
# COMMON TEST SETUP
#
# Canvas used in 6.* test cases
# For tests canvas-6.*
#
canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \
	-borderwidth 2 -highlightthickness 3
pack .c
update

test canvas-6.1 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 0 -yscrollincrement 0
︙
326
327
328
329
330
331
332




333
334
335
336
337
338
339

401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418








+
+
+
+








    .c canvasx 0
} -result {215.0}
test canvas-6.5 {CanvasSetOrigin procedure} -body {
    .c configure -xscrollincrement 20 -yscrollincrement 10
    .c yview moveto 1.0
    .c canvasy 0
} -result {55.0}

#
# COMMON TEST CLEANUP
#
deleteWindows

test canvas-7.1 {canvas widget vs hidden commands} -setup {
    canvas .c
} -body {
    interp hide {} .c
    destroy .c
︙
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

667
668
669
670
671
672
673












674
675
676
677
678
679
680








-
-
-
-
-
-
-
-
-
-
-
-








    incr val
    # qx has type double and no string representation
    .c scale all $val 0 1 1
    # qx has now type MMRep and no string representation
    incr val
} -result 12

# procedure used in 13.1 test case
proc kill_canvas {w} {
    destroy $w
    pack [canvas $w -height 200 -width 200] -fill both -expand yes
    update idle
    $w create rectangle 80 80 120 120 -fill blue -tags blue
    # bind a button press to re-build the canvas
    $w bind blue <ButtonRelease-1> [subst {
	[lindex [info level 0] 0] $w
	append ::x ok
    }]
}
test canvas-13.1 {canvas delete during event, SF bug-228024} -body {
    kill_canvas .c
    set ::x {}
    # do this many times to improve chances of triggering the crash
    for {set i 0} {$i < 30} {incr i} {
	event generate .c <Button-1> -x 100 -y 100
	event generate .c <ButtonRelease-1> -x 100 -y 100
︙
779
780
781
782
783
784
785




786
787
788
789
790
791
792

846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863








+
+
+
+








    destroy .c
    canvas .c
} -body {
    set id [.c create poly {0 0 50 50 100 50}]
    .c insert $id end {200 200}
    .c coords $id
} -result {0.0 0.0 50.0 50.0 100.0 50.0 200.0 200.0}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-16.1 {arc coords check} -setup {
    canvas .c
} -body {
    set id [.c create arc {0 10 20 30} -start 33]
    .c itemcget $id -start
︙
1041
1042
1043
1044
1045
1046
1047



1048

1049
1050
1051
1052
1053
1054
1055

1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130








+
+
+

+








    set res [list [.c gettags 1]]
    .c dtag 1 tagA
    lappend res [.c gettags 1]
} -cleanup {
    destroy .c
} -result {{tagA tagA tagA tagA tagA tagA} {}}

#
# COMMON TEST CLEANUP
#
destroy .c

test canvas-21.1 {canvas rotate} -setup {
    pack [canvas .c]
} -body {
    .c create line 50 50 50 100 100 100
    .c rotate all 75 75 90
    lmap c [.c coords all] {format %.2f $c}
} -cleanup {
︙
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251

1299
1300
1301
1302
1303
1304
1305














1306
1307
1308
1309
1310
1311
1312








-
-
-
-
-
-
-
-
-
-
-
-
-
-








    list [lmap c [.c coords all] {format %.2f $c}] \
	[lmap o {} {.c itemcget all $o}] \
	[.c bbox all]
} -cleanup {
    destroy .c
} -result {{50.00 150.00} {} {25 125 50 150}}

# Procedure used in test cases 23.1 23.2 23.3
proc matchPixels {pixels expected} {
    set matched 1
    foreach pline $pixels eline $expected {
	foreach ppixel $pline epixel $eline {
	    if {$ppixel != $epixel} {
		set matched 0
		break
	    }
	}
    }
    return $matched
}

test canvas-23.1 {canvas image} -setup {
    canvas .c
    image create photo testimage
} -body  {
    .c configure -background #c0c0c0 -scrollregion {0 0 9 9}
    .c create rectangle 0 0 0 9 -fill #000080 -outline #000080
    .c image testimage
︙
1313
1314
1315
1316
1317
1318
1319
1320

1321
1322
1323
1324
1325
1326
1327
1328
1329
1330

1374
1375
1376
1377
1378
1379
1380

1381
1382
1383
1384
1385
1386

1387
1388
1389
1390








-
+





-





	{#c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0 #c0c0c0}}
} -cleanup {
    destroy .c
    image delete testimage
} -result 1

#
# CLEANUP
# TESTFILE CLEANUP
#

imageCleanup
testutils forget image
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/choosedir.test. 
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


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

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+



-

-
+

-
-
-
-
-


















+
+
+
-
+

-
+

+
-
+


-
-
-
-
+
+
+
+
+








# This file is a Tcl script to test out Tk's "tk_chooseDir" and
# This file is a Tcl script to test out Tk's "tk_chooseDir".
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#----------------------------------------------------------------------
#
# Procedures needed by this test file
# LOCAL UTILITY PROCS
#
#----------------------------------------------------------------------

proc ToEnterDirsByKey {parent dirs} {
    after 100 [list EnterDirsByKey $parent $dirs]
}

proc EnterDirsByKey {parent dirs} {
    if {$parent == "."} {
	set w .__tk_choosedir
    } else {
	set w $parent.__tk_choosedir
    }
    upvar ::tk::dialog::file::__tk_choosedir data

    foreach dir $dirs {
	$data(ent) delete 0 end
	$data(ent) insert 0 $dir
	update
	SendButtonPress $parent ok mouse
	after 50
    }
}

proc ToEnterDirsByKey {parent dirs} {
    after 100 [list EnterDirsByKey $parent $dirs]
}
#----------------------------------------------------------------------

#
# The test suite proper
# COMMON TEST SETUP
#
set parent .
#----------------------------------------------------------------------

# Make a dir for us to rely on for tests
set real [makeDirectory choosedirTest]
set dir [file dirname $real]
set fake [file join $dir non-existant]

set parent .
set fake [file join [file dirname $real] non-existant]

#
# TESTS
#

test choosedir-1.1 {tk_chooseDirectory command} -body {
    tk_chooseDirectory -initialdir
} -returnCodes error -result {value for "-initialdir" missing}
test choosedir-1.2 {tk_chooseDirectory command} -body {
    tk_chooseDirectory -mustexist
} -returnCodes error -result {value for "-mustexist" missing}
︙
132
133
134
135
136
137
138
139

140
141

142
143
144
145

150
151
152
153
154
155
156

157
158
159
160
161
162
163









-
+


+



-

} -body {
    ToEnterDirsByKey $parent [list "" $real $real]
    tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \
	    -parent $parent
} -result $real

#
# CLEANUP
# TESTFILE CLEANUP
#

unset fake parent real
removeDirectory choosedirTest
testutils forget dialog
cleanupTests
return
Changes to tests/clipboard.test. 
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

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


-
+
-





+

-
-
-
-
-
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+








-
+
+
+








# This file is a Tcl script to test out Tk's clipboard management code,
# especially the "clipboard" command.  It is organized in the standard
# especially the "clipboard" command.
# fashion for Tcl tests.
#
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTES
#
# Note: Multiple display clipboard handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#

#################################################################
# * Multiple display clipboard handling will only be tested if the environment
#   variable TK_ALT_DISPLAY is set to an alternate display.
# * Some of these tests may fail if another application is grabbing the
#   clipboard (e.g. an X server, or a VNC viewer)

#
# TESTFILE INITIALIZATION
#

# Note that some of these tests may fail if another application #
# is grabbing the clipboard (e.g. an X server, or a VNC viewer) #
#################################################################

package require tcltest 2.2
if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# COMMON TEST SETUP
#

# set up a very large buffer to test INCR retrievals
set longValue ""
foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# Now we start the main body of the test code
#
# TESTS
#

test clipboard-1.1 {ClipboardHandler procedure} -setup {
    clipboard clear
} -body {
    clipboard append "test"
    clipboard get
} -cleanup {
︙
355
356
357
358
359
360
361
362

363
364
365
366
367
368
369
370
371

377
378
379
380
381
382
383

384
385
386
387
388

389
390
391
392








-
+




-





    clipboard append -type
	selection get -selection CLIPBOARD
} -cleanup {
    clipboard clear
} -result {-type}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget child
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/clrpick.test. 
1
2
3
4
5
6
7


















8

9
10
11





12
13
14




15
16
17
18
19
20
21

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


-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+



+
+
+
+








# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# LOCAL TEST CONSTRAINTS
#

if {[testConstraint defaultPseudocolor8]} {
    # let's soak up a bunch of colors...so that
    # machines with small color palettes still fail.
    # some tests will be skipped if there are no more colors
    set numcolors 32
    testConstraint colorsLeftover 1
︙
42
43
44
45
46
47
48



































49
50
51
52
53
54
55

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








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	.c delete $i
	incr i
    }
    destroy .c
} else {
    testConstraint colorsLeftover 1
}

#
# LOCAL UTILITY PROCS
#

proc ChooseColorByKey {parent r g b} {
    set w .__tk__color
    upvar ::tk::dialog::color::[winfo name $w] data

    update
    $data(red,entry)   delete 0 end
    $data(green,entry) delete 0 end
    $data(blue,entry)  delete 0 end

    $data(red,entry)   insert 0 $r
    $data(green,entry) insert 0 $g
    $data(blue,entry)  insert 0 $b

    # Manually force the refresh of the color values instead
    # of counting on the timing of the event stream to change
    # the values for us.
    tk::dialog::color::HandleRGBEntry $w

    SendButtonPress . ok mouse
}

proc ToChooseColorByKey {parent r g b} {
    if {! $::dialogIsNative} {
	after 200 ChooseColorByKey . $r $g $b
    }
}

#
# TESTS
#

test clrpick-1.1 {tk_chooseColor command} -body {
    tk_chooseColor -foo
} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title}

test clrpick-1.2 {tk_chooseColor command } -body {
    tk_chooseColor -initialcolor
︙
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

131
132
133
134
135
136
137



























138
139
140
141
142
143
144








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








test clrpick-1.6 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor badbadbaadcolor
} -returnCodes error -result {unknown color name "badbadbaadcolor"}
test clrpick-1.7 {tk_chooseColor command} -body {
    tk_chooseColor -initialcolor ##badbadbaadcolor
} -returnCodes error -result {invalid color name "##badbadbaadcolor"}

proc ToChooseColorByKey {parent r g b} {
    if {! $::dialogIsNative} {
	after 200 ChooseColorByKey . $r $g $b
    }
}

proc ChooseColorByKey {parent r g b} {
    set w .__tk__color
    upvar ::tk::dialog::color::[winfo name $w] data

    update
    $data(red,entry)   delete 0 end
    $data(green,entry) delete 0 end
    $data(blue,entry)  delete 0 end

    $data(red,entry)   insert 0 $r
    $data(green,entry) insert 0 $g
    $data(blue,entry)  insert 0 $b

    # Manually force the refresh of the color values instead
    # of counting on the timing of the event stream to change
    # the values for us.
    tk::dialog::color::HandleRGBEntry $w

    SendButtonPress . ok mouse
}

test clrpick-2.1 {tk_chooseColor command} -constraints {
    nonUnixUserInteraction colorsLeftover
} -setup {
    set verylongstring [string repeat longstring: 100]
} -body {
    ToPressButton . ok
    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \
︙
156
157
158
159
160
161
162
163

164
165
166
167
168

187
188
189
190
191
192
193

194
195
196
197
198









-
+




-

    after 50 {set ::scr [winfo screen .__tk__color]}
    ToPressButton . cancel
    tk_chooseColor -parent .
    set ::scr
} -result [winfo screen .]

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests
return
Changes to tests/cluster.test. 
1
2

3
4
5
6
7
8


















9

10
11
12





13



14
15



16
17
18
19
20
21
22

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+


+
+
+








# This file is a Tcl script to test the [::tk::startOf|endOf]* functions in
# tk.tcl and tkIcu.c.  It is organized in the standard fashion for Tcl tests.
# tk.tcl and tkIcu.c.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#
testConstraint needsICU [expr {[catch {info body ::tk::startOfCluster}]}]

#
# TESTS
#

test cluster-1.0 {::tk::startOfCluster} -body {
    ::tk::startOfCluster é -1
} -result {}
test cluster-1.1 {::tk::startOfCluster} -body {
    ::tk::startOfCluster é 0
} -result 0
︙
237
238
239
240
241
242
243
244




245
246

263
264
265
266
267
268
269
270
271
272
273
274
275










+
+
+
+

-

} -returnCodes 1 -result {wrong # args: should be "::tk::endOfWord str start ?locale?"}
test cluster-8.5 {::tk::wordBreakBefore} -body {
    ::tk::wordBreakBefore a b c d
} -returnCodes 1 -result {wrong # args: should be "::tk::wordBreakBefore str start ?locale?"}
test cluster-8.6 {::tk::wordBreakAfter} -body {
    ::tk::wordBreakAfter a b c d
} -returnCodes 1 -result {wrong # args: should be "::tk::wordBreakAfter str start ?locale?"}

#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/cmds.test. 
1
2

3
4
5
6
7


















8

9
10
11





12



13




14
15
16
17
18
19
20

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


-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+

+
+
+
+








# This file is a Tcl script to test the procedures in the file
# tkCmds.c.  It is organized in the standard fashion for Tcl tests.
# tkCmds.c.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#
update

#
# TESTS
#

test cmds-1.1 {tkwait visibility, argument errors} -body {
    tkwait visibility
} -returnCodes error -result {wrong # args: should be "tkwait variable|visibility|window name"}
test cmds-1.2 {tkwait visibility, argument errors} -body {
    tkwait visibility foo bar
} -returnCodes error -result {wrong # args: should be "tkwait variable|visibility|window name"}
︙
49
50
51
52
53
54
55
56
57




58
59
60

76
77
78
79
80
81
82


83
84
85
86
87










-
-
+
+
+
+

-
-

    after 100 {set x deleted; destroy .f}
    catch {tkwait visibility .f.b}
    return $x
} -cleanup {
    destroy .f
} -result {deleted}


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/color.test. 
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

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


-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+






-








# This file is a Tcl script to test out the procedures in the file
# tkColor.c.  It is organized in the standard fashion for Tcl tests.
# tkColor.c.
#
# Copyright © 1995-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

#
# LOCAL UTILITY PROCS
#

# c255  -
# Given a list of red, green, and blue intensities, scale them
# down to a 0-255 range.
#
# Arguments:
# vals -	List of intensities.

proc c255 {vals} {
    list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \
	    [expr {[lindex $vals 2]/256}]
}

# closest -
# Given intensities between 0 and 255, return the closest intensities
# that the server can provide.
#
# Arguments:
# w -		Window in which to lookup color
# r, g, b -	Desired intensities, between 0 and 255.

proc closest {w r g b} {
    set vals [winfo rgb $w [cname $r $g $b]]
    list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
	    [expr [lindex $vals 2]/256]
}

# cname --
# Returns a proper name for a color, given its intensities.
#
# Arguments:
# r, g, b -	Intensities on a 0-255 scale.

proc cname {r g b} {
    format #%02x%02x%02x $r $g $b
}
proc cname4 {r g b} {
    format #%04x%04x%04x $r $g $b
}
︙
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

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








-
-
-

-
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-










-
+
















+
+
+
+








	    $c create rectangle [expr 10*$x] [expr 20*$y] \
		    [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
		    -fill $color
	}
    }
}

# closest -
# Given intensities between 0 and 255, return the closest intensities
# that the server can provide.
#
# Arguments:
# w -		Window in which to lookup color
# r, g, b -	Desired intensities, between 0 and 255.

# LOCAL TEST CONSTRAINTS
proc closest {w r g b} {
    set vals [winfo rgb $w [cname $r $g $b]]
    list [expr [lindex $vals 0]/256] [expr [lindex $vals 1]/256] \
	    [expr [lindex $vals 2]/256]
}

#
# c255  -
# Given a list of red, green, and blue intensities, scale them
# down to a 0-255 range.
#
# Arguments:
# vals -	List of intensities.

proc c255 {vals} {
    list [expr {[lindex $vals 0]/256}] [expr {[lindex $vals 1]/256}] \
	    [expr {[lindex $vals 2]/256}]
}

# -- WARNING (SB, 6.4.2017) --
#
# The if block below looks _very_ outdated. It didn't get any
# substantial changes as far back as the fossil history goes. It might
# be from a time, when 256 color was the best you could get! :-o.
#
# The problem is, on machines with a fancy 24 truecolor display, the
# 'colorsFree' constraint doesn't get set, turning off pretty much every test
# in this file.

#
if {[testConstraint pseudocolor8]} {
    toplevel .t -visual {pseudocolor 8} -colormap new
    wm geom .t +0+0
    mkColors .t.c 40 6 0 0 0 0 6 0 0 0 40
    pack .t.c
    update

    testConstraint colorsFree [colorsFree .t.c 101 233 17]

    if {[testConstraint colorsFree]} {
	mkColors .t.c2 20 1 250 0 0 -10 0 0 0 0 0
	pack .t.c2
	testConstraint colorsFree [expr {![colorsFree .t.c]}]
    }
    destroy .t.c .t.c2
}

#
# TESTS
#

test color-1.1 {Tk_AllocColorFromObj - converting internal reps} colorsFree {
    set x green
    lindex $x 0
    destroy .b1
    button .b1 -foreground $x -text .b1
    lindex $x 0
︙
286
287
288
289
290
291
292
293
294

295
296

297
298

299
300
301

318
319
320
321
322
323
324


325


326
327
328
329
330
331









-
-
+
-
-
+


+


-

    lappend result [testcolor purple]
    set y bogus
    set result
} -cleanup {
    rename copy {}
} -result {{{1 3}} {{1 2}} {{1 1}} {}}

destroy .t

#
#
# CLEANUP
# TESTFILE CLEANUP
#

destroy .t
testutils forget colors
cleanupTests
return
Changes to tests/config.test. 
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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+














-
+
+
+
+
+
+
+








# This file is a Tcl script to test the procedures in tkConfig.c,
# which comprise the new new option configuration system.  It is
# which comprise the new new option configuration system.
# organized in the standard "white-box" fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc killTables {} {
    # Note: it's important to delete chain2 before chain1, because
    # chain2 depends on chain1.  If chain1 is deleted first, the
    # delete of chain2 will crash.
    deleteWindows
    foreach t {alltypes chain3 chain2 chain1 configerror internal
	    new notenoughparams twowindows} {
	    while {[testobjconfig info $t] != ""} {
		testobjconfig delete $t
	    }
    }
}


#
# TESTS
#

#
# COMMON TEST SETUP
#
option clear
deleteWindows
if {[testConstraint testobjconfig]} {
    killTables
}

test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints {
︙
1187
1188
1189
1190
1191
1192
1193
1194



1195
1196
1197

1198
1199
1200
1201
1202
1203
1204

1216
1217
1218
1219
1220
1221
1222

1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236








-
+
+
+



+








test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body {
    testobjconfig alltypes .b
    .b cget -synonym
} -cleanup {
    killTables
} -result red


#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    testobjconfig alltypes .a
}

test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body {
    .a configure -color green -rel sunken
     list [.a cget -color] [.a cget -relief]
} -result {green sunken}
test config-7.2 {Tk_SetOptions - bogus option name} -constraints {
    testobjconfig
} -body {
︙
1275
1276
1277
1278
1279
1280
1281




1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292

1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320

1321
1322
1323
1324
1325
1326
1327








+
+
+
+



-








} -body {
    catch {.a configure -custom bad}
    return $errorInfo
} -result {expected good value, got "BAD"
    (processing "-custom" option)
    invoked from within
".a configure -custom bad"}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints {
    testobjconfig
} -body {
    testobjconfig alltypes .a
    .a csave -color green -color black -color blue \
	-color #ffff00 -color #ff00ff -color bogus \
︙
1555
1556
1557
1558
1559
1560
1561




1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572

1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603

1604
1605
1606
1607
1608
1609
1610








+
+
+
+



-








    testobjconfig
} -body {
    catch {destroy .fpp}
    testobjconfig internal .foo
    .foo configure -custom "foobar"
    destroy .foo
} -result {}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body {
    testobjconfig alltypes .foo
    .foo configure -anchor e
    .foo configure -anchor
} -cleanup {
    destroy .foo
︙
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601




1602

1603
1604

1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622




1623

1624
1625

1626
1627
1628
1629
1630
1631
1632

1628
1629
1630
1631
1632
1633
1634





1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656





1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672








-
-
-
-
-
+
+
+
+

+


+













-
-
-
-
-
+
+
+
+

+


+








} -result {{-boolean boolean Boolean {} {}} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-stringtable2 StringTable2 stringTable2 two two} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief {} {}} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor center center} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}}
test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body {
    testobjconfig chain2 .foo -one asdf -three xyzzy
    .foo configure
} -cleanup {
    destroy .foo
} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}}
if {[testConstraint testobjconfig]} {
    killTables
}



#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    killTables
    testobjconfig alltypes .a
}

test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body {
    lindex [.a configure] end
} -result {-synonym -color}
test config-11.2 {GetConfigList - null database names} -constraints {
    testobjconfig
} -body {
    .a configure -justify
} -result {-justify {} {} left left}
test config-11.3 {GetConfigList - null default and current value} -constraints {
    testobjconfig
} -body {
    .a configure -relief
} -result {-relief relief Relief {} {}}
if {[testConstraint testobjconfig]} {
    killTables
}



#
# COMMON TEST SETUP
#
if {[testConstraint testobjconfig]} {
    killTables
    testobjconfig internal .a
}

test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body {
    .a configure -boolean 0
    .a cget -boolean
} -result 0
test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body {
    .a configure -integer 1247
    .a cget -integer
︙
1700
1701
1702
1703
1704
1705
1706




1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717

1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753

1754
1755
1756
1757
1758
1759
1760








+
+
+
+



-








} -body {
    .a configure -string {} -color {} -font {} -bitmap {} -border {} \
	    -cursor {} -window {} -custom {}
    list [.a cget -string] [.a cget -color] [.a cget -font] \
	    [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \
	    [.a cget -window] [.a cget -custom]
} -result {{} {} {} {} {} {} {} {}}

#
# COMMON TEST CLEANUP
#
if {[testConstraint testobjconfig]} {
    killTables
}


test config-13.1 {proper cleanup of options with widget destroy} -body {
    button .w -cursor crosshair
    destroy .w
} -result {}
test config-13.2 {proper cleanup of options with widget destroy} -body {
    canvas .w -cursor crosshair
︙
1913
1914
1915
1916
1917
1918
1919
1920
1921




1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935

1956
1957
1958
1959
1960
1961
1962


1963
1964
1965
1966
1967
1968
1969
1970
1971

















-
-
+
+
+
+





-
-
-
-
-
-
-
-
-

	::foo::checkbutton .a
	::foo::checkbutton .b
	}
    ]
    destroy .a .b
} -result {}


# cleanup
#
# TESTFILE CLEANUP
#

deleteWindows
if {[testConstraint testobjconfig]} {
    killTables
}
cleanupTests
return
Changes to tests/constraints.tcl.
︙
11
12
13
14
15
16
17

18
19
20
21
22
23
24

11
12
13
14
15
16
17
18
19
20
21
22
23
24
25








+









#
# WINDOWING SYSTEM AND DISPLAY
#
testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
testConstraint x11 [expr {[tk windowingsystem] eq "x11"}]
testConstraint win32 [expr {[tk windowingsystem] eq "win32"}]
testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}]
testConstraint aquaOrWin32 [expr {
    ([tk windowingsystem] eq "win32") || [testConstraint aqua]
}]
testConstraint haveDISPLAY [expr {[info exists env(DISPLAY)] && [testConstraint x11]}]
testConstraint altDisplay  [info exists env(TK_ALT_DISPLAY)]
︙
Changes to tests/cursor.test. 
1
2

3
4
5
6
7
8


















9

10
11
12
13










14
15
16
17
18
19
20

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkCursor.c.  It is organized in the standard white-box fashion for
# tkCursor.c.
# Tcl tests.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows


#
# LOCAL UTILITY PROCS
#

# Tests 2.3 and 2.4 need a helper file with a very specific name and
# controlled format.
proc setWincur {wincurName} {
	upvar $wincurName wincur
	set wincur(data_octal) {
	    000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
︙
43
44
45
46
47
48
49



50
51
52
53
54
55
56

66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82








+
+
+








	foreach wincur(num) $wincur(data_octal) {
	    append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
	}
	set wincur(dir) [makeDirectory {dir with spaces}]
	set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
}

#
# TESTS
#

test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints {
    testcursor
} -body {
    set x watch
    lindex $x 0
    button .b -cursor $x
︙
835
836
837
838
839
840
841
842
843
844




845
846

861
862
863
864
865
866
867



868
869
870
871
872









-
-
-
+
+
+
+

-

	button .b -text wait
} -body {
	.b configure -cursor wait
} -cleanup {
	destroy .b
} -result {}

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

# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/dialog.test. 
1
2
3
4




















5
6
7





8
9
10




11
12
13
14
15
16
17

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


-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+



+
+
+
+








# This file is a Tcl script to test out Tk's "tk_dialog" command.
# It is organized in the standard fashion for Tcl tests.

package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# TESTS
#

test dialog-1.1 {tk_dialog command} -body {
    tk_dialog
} -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"}
test dialog-1.2 {tk_dialog command} -body {
    tk_dialog foo foo foo foo foo
} -returnCodes error -result {bad window path name "foo"}
︙
57
58
59
60
61
62
63
64

65
66
67
68
69

80
81
82
83
84
85
86

87
88
89
90
91









-
+




-

    after cancel $x
    return $res
} -cleanup {
    destroy .b
} -result -1

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests
return
Changes to tests/embed.test. 
1
2
3
4
5
6


















7

8
9
10
11









12
13
14
15
16
17
18

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







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out embedded Windows.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test embed-1.1 {Tk_UseWindow procedure, bad window identifier} -setup {
    deleteWindows
} -body {
    toplevel .t -use xyz
} -cleanup {
    deleteWindows
︙
77
78
79
80
81
82
83
84
85


86
87

88


100
101
102
103
104
105
106


107
108


109
110
111








-
-
+
+
-
-
+

+

} -body {
    frame .container
    toplevel .embd -use [winfo id .container]
} -cleanup {
    deleteWindows
} -returnCodes error -result {window ".container" doesn't have -container option set}


cleanupTests
#
# TESTFILE CLEANUP
return

#

cleanupTests
Changes to tests/entry.test. 
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


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

-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+






+
+
+








# This file is a Tcl script to test entry widgets in Tk.  It is
# This file is a Tcl script to test entry widgets in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Gathered comments about lacks
# Still need to write tests for EntryBlinkProc, EntryFocusProc,
# EntryTextVarProc, EntryScanTo and EntrySelectTo, DisplayEntry, EventuallyRedraw.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry scroll

#
# COMMON TEST SETUP
#

foreach i {1 2 3} {
    set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V]
}
set cy [font metrics {Courier -12} -linespace]

#
# TESTS
#

test entry-1.1 {configuration option: "background" for entry} -setup {
    entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
    pack .e ; update idletasks
    update
} -body {
    .e configure -background #ff0000
︙
2847
2848
2849
2850
2851
2852
2853
2854

2855
2856
2857
2858
2859
2860
2861

2879
2880
2881
2882
2883
2884
2885

2886
2887
2888
2889
2890
2891
2892
2893








-
+








    pack .e ; update idletasks
    update
    list [.e index @7] [.e index @8]
} -cleanup {
    destroy .e
} -result {0 1}

# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
# Still need to write tests for EntryScanTo and EntrySelectTo.


test entry-14.1 {EntryFetchSelection procedure} -body {
    entry .e
    .e insert end "This is a test string"
    .e select from 1
    .e select to 18
︙
3592
3593
3594
3595
3596
3597
3598
3599

3600
3601
3602
3603
3604
3605
3606
3607
3608

3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619

3624
3625
3626
3627
3628
3629
3630

3631









3632
3633
3634
3635
3636
3637
3638
3639
3640
3641

3642








-
+
-
-
-
-
-
-
-
-
-
+









-


    event generate .e <<NextWord>>  ; # shall move insert to index end
    .e delete 0 insert
    lappend res [.e get]
} -cleanup {
    destroy .e
} -result {{} {}}


#
# Gathered comments about lacks
# XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
# and EntryTextVarProc.
# No tests for DisplayEntry.
# XXX Still need to write tests for EntryScanTo and EntrySelectTo.
# No tests for EventuallyRedraw

#
# CLEANUP
# TESTFILE CLEANUP
#

# option clear
foreach i {1 2 3} {
    unset validateCmd$i
}
unset i
testutils forget entry scroll
cleanupTests
return
Changes to tests/event.test. 
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


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

-
+
-






-
+
-
-
-
-
-
+
+



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+








# This file is a Tcl script to test the code in tkEvent.c.  It is
# This file is a Tcl script to test the code in tkEvent.c.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
# NOTE
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

# XXX This test file is woefully incomplete.  Right now it only tests
#
# This test file is woefully incomplete.  Right now it only tests
# a few of the procedures in tkEvent.c.  Please add more tests whenever
# possible.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# _get_selection --
#
#    Return selection only if owned by the given widget
#
proc _get_selection {widget} {
    if {[string compare $widget [selection own]] != 0} {
	return ""
    }
    if {[catch {selection get} sel]} {
	return ""
    }
    return $sel
}

# _init_keypress_lookup --
#
# Setup table used to query key events.

#    Setup table used to query key events.
#
proc _init_keypress_lookup {} {
    global keypress_lookup

    # Characters with meaning to Tcl...
    array set keypress_lookup [list \
	    -    minus \
	    >    greater \
︙
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

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








-
-
-
-
-
-
-
-
-
-
-
-
-
+
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+




















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+






+
+
-
-
+
+










+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	    \}   braceright \
	    " "  space \
	    \xA0 nobreakspace \
	    "\n" Return \
	    "\t" Tab]
}

# Lookup an event in the keypress table.
# For example:
# Q -> Q
# ; -> semicolon
# > -> greater
# Delete -> Delete
# Escape -> Escape

proc _keypress_lookup {char} {
    global keypress_lookup

    if {! [info exists keypress_lookup]} {
	_init_keypress_lookup
# _keypress --
    }

#
    if {$char == ""} {
	error "empty char"
    }

    if {[info exists keypress_lookup($char)]} {
	return $keypress_lookup($char)
    } else {
	return $char
    }
}

# Lookup and generate a pair of Key and KeyRelease events

#    Lookup and generate a pair of Key and KeyRelease events
#
proc _keypress {win key} {
    set keysym [_keypress_lookup $key]

    # Force focus to the window before delivering
    # each event so that a window manager using
    # a focus follows mouse will not steal away
    # the focus if the mouse is moved around.

    if {[focus] != $win} {
	focus -force $win
    }
    event generate $win <Key-$keysym>
    pause 50
    if {[focus] != $win} {
	focus -force $win
    }
    event generate $win <KeyRelease-$keysym>
    pause 50
}

# _keypress_lookup --
#
#    Lookup an event in the keypress table.
#
#    For example:
#	 Q -> Q
#	 ; -> semicolon
#	 > -> greater
#	 Delete -> Delete
#	 Escape -> Escape
#
proc _keypress_lookup {char} {
    global keypress_lookup

    if {! [info exists keypress_lookup]} {
	_init_keypress_lookup
    }

    if {$char == ""} {
	error "empty char"
    }

    if {[info exists keypress_lookup($char)]} {
	return $keypress_lookup($char)
    } else {
	return $char
    }
}

# _keypress_string --
#
# Call _keypress for each character in the given string

#    Call _keypress for each character in the given string
#
proc _keypress_string {win string} {
    foreach letter [split $string ""] {
	_keypress $win $letter
    }
}

# _text_ind_to_x_y --
#
# Helper proc to convert index to x y position

#    Helper proc to convert index to x y position
#
proc _text_ind_to_x_y {text ind} {
    set bbox [$text bbox $ind]
    if {[llength $bbox] != 4} {
	error "got bbox \{$bbox\} from $text, index $ind"
    }
    foreach {x1 y1 width height} $bbox break
    set middle_y [expr {$y1 + ($height / 2)}]
    return [list $x1 $middle_y]
}

proc create_and_pack_frames {{w {}}} {
    frame $w.f1 -bg blue -width 200 -height 200
    pack propagate $w.f1 0
    frame $w.f1.f2 -bg yellow -width 100 -height 100
    pack $w.f1.f2 $w.f1 -side bottom -anchor se
    update idletasks
}
# Return selection only if owned by the given widget

proc _get_selection {widget} {
    if {[string compare $widget [selection own]] != 0} {
	return ""

# setup_win_mousepointer --
#
#    Position the window and the mouse pointer as an initial state for some tests.
#    The so-called "pointer window" is the $w window that will now contain the mouse pointer.
#
proc setup_win_mousepointer {w} {
    wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1*
    toplevel $w
    pack propagate $w 0
    wm geometry $w 300x300+100+100
    tkwait visibility $w
    update; # service remaining screen drawing events (e.g. <Expose>)
    set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]]
    event generate $w <Motion> -warp 1 -x 250 -y 250
    if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} {
	waitForWindowEvent $w <Enter>
    } else {
	controlPointerWarpTiming
    }
}
    if {[catch {selection get} sel]} {
	return ""
    }
    return $sel
}

# Begining of the actual tests

# waitForWindowEvent --
#
#    This proc is intended to overcome latency of windowing system
#    notifications when toplevel windows are involved. These latencies vary
#    considerably with the window manager in use, with the system load,
#    with configured scheduling priorities for processes, etc ...
#    Waiting for the corresponding window events evades the trouble that is
#    associated with the alternative: waiting or halting the Tk process for a
#    fixed amount of time (using "after ms"). With the latter strategy it's
#    always a gamble how much waiting time is enough on an end user's system.
#    It also leads to long fixed waiting times in order to be on the safe side.
#
proc waitForWindowEvent {w event {timeout 1000}} {

    variable _windowEvent

    # Use counter as a unique ID to prevent subsequent waits
    # from interfering with each other.
    set counter [incr _windowEvent(counter)]
    set _windowEvent($counter) 1
    set savedBinding [bind $w $event]
    bind $w $event [list +waitForWindowEvent.signal $counter]
    set afterID [after $timeout [list set _windowEvent($counter) -1]]
    vwait _windowEvent($counter)
    set late [expr {$_windowEvent($counter) == -1}]
    bind $w $event $savedBinding
    unset _windowEvent($counter)
    if {$late} {
	puts stderr "wait for $event event on $w timed out (> $timeout ms)"
    } else {
	after cancel $afterID
    }
}

# waitForWindowEvent.signal--
#
#    Helper proc that records the triggering of a window event.
#
proc waitForWindowEvent.signal {counter} {
    incr ::_windowEvent($counter)
}

#
# TESTS
#

test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup {
	deleteWindows
    set x {}
} -body {
    button .b -text Test
    pack .b
︙
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
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

971
972
973
974
975
976
977





























































978
979
980
981
982
983
984








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








    deleteWindows ; # destroy all children of ".", this already includes .top1
    if {$iconified} {
	wm deiconify .
	update
    }
} -result {.top1}

proc waitForWindowEvent {w event {timeout 1000}} {
# This proc is intended to overcome latency of windowing system
# notifications when toplevel windows are involved. These latencies vary
# considerably with the window manager in use, with the system load,
# with configured scheduling priorities for processes, etc ...
# Waiting for the corresponding window events evades the trouble that is
# associated with the alternative: waiting or halting the Tk process for a
# fixed amount of time (using "after ms"). With the latter strategy it's
# always a gamble how much waiting time is enough on an end user's system.
# It also leads to long fixed waiting times in order to be on the safe side.

    variable _windowEvent

    # Use counter as a unique ID to prevent subsequent waits
    # from interfering with each other.
    set counter [incr _windowEvent(counter)]
    set _windowEvent($counter) 1
    set savedBinding [bind $w $event]
    bind $w $event [list +waitForWindowEvent.signal $counter]
    set afterID [after $timeout [list set _windowEvent($counter) -1]]
    vwait _windowEvent($counter)
    set late [expr {$_windowEvent($counter) == -1}]
    bind $w $event $savedBinding
    unset _windowEvent($counter)
    if {$late} {
	puts stderr "wait for $event event on $w timed out (> $timeout ms)"
    } else {
	after cancel $afterID
    }
}
proc waitForWindowEvent.signal {counter} {
# Helper proc that records the triggering of a window event.
    incr ::_windowEvent($counter)
}

proc create_and_pack_frames {{w {}}} {
    frame $w.f1 -bg blue -width 200 -height 200
    pack propagate $w.f1 0
    frame $w.f1.f2 -bg yellow -width 100 -height 100
    pack $w.f1.f2 $w.f1 -side bottom -anchor se
    update idletasks
}

proc setup_win_mousepointer {w} {
# Position the window and the mouse pointer as an initial state for some tests.
# The so-called "pointer window" is the $w window that will now contain the mouse pointer.
    wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1*
    toplevel $w
    pack propagate $w 0
    wm geometry $w 300x300+100+100
    tkwait visibility $w
    update; # service remaining screen drawing events (e.g. <Expose>)
    set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]]
    event generate $w <Motion> -warp 1 -x 250 -y 250
    if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} {
	waitForWindowEvent $w <Enter>
    } else {
	controlPointerWarpTiming
    }
}

test event-9.11 {pointer window container = parent} -setup {
    setup_win_mousepointer .one
    wm withdraw .one
    create_and_pack_frames .one
    wm deiconify .one
    tkwait visibility .one.f1.f2
    pause 200; # needed for Windows
︙
1165
1166
1167
1168
1169
1170
1171



1172

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190

1215
1216
1217
1218
1219
1220
1221
1222
1223
1224

1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240











+
+
+
-
+















-
-
-

    set result
} -cleanup {
    bind all <Leave> {}
    bind all <Enter> {}
    unset result
} -result {|}

#
# TESTFILE CLEANUP
#
# cleanup

# macOS sometimes has trouble deleting the test window,
# causing a failure in focus.test.
pause 200;
deleteWindows
update
unset -nocomplain keypress_lookup
rename _init_keypress_lookup {}
rename _keypress_lookup {}
rename _keypress {}
rename _text_ind_to_x_y {}
rename _get_selection {}
rename create_and_pack_frames {}
rename setup_win_mousepointer {}

cleanupTests
return
Changes to tests/filebox.test. 
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

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


-
+
-





-
-
-
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
-
-
-
+
+
+
-
-
+
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
-
-
+



-

-
+

-
-
-
-
-
-
-








# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
# "tk_getSaveFile" commands. It is organized in the standard fashion
# "tk_getSaveFile" commands.
# for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

#
# Import utility procs for specific functional areas
testutils import dialog

test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
    # MacOS type that is too long

# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
    regsub -all "\0" $res {\\0}
} {1 {bad Macintosh file type "\0\0\0\0\0"}}
test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    # MacOS type that is too short, but looks ok in utf (4 bytes).

    set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
    tcltest::loadTestedCommands
}

    regsub -all "\0" $msg {\\0} msg
    list $x $msg
# Ensure a pristine initial window state
} {1 {bad Macintosh file type "\0\0"}}
# The next test must actually open a file dialog window, but it does
# not require human interaction to close the dialog because the Aqua
# port of tktest automatically closes every file dialog after a short
# timeout when tests are being run.
test fileDialog-0.3 {GetFileName: file types: bad filetype} \
-constraints aqua \
-body {
    # Checks for the Aqua crash reported in ticket 080a28104.
resetWindows

# Import utility procs for specific functional areas
    set filename [tk_getOpenFile -filetypes {
	{"Invalid extension" {x.y}}
	{"All files" {*}}
    }]
} \
-result {}
testutils import dialog

set tk_strictMotif_old $tk_strictMotif

#----------------------------------------------------------------------
#
# Procedures needed by this test file
# LOCAL UTILITY PROCS
#
#----------------------------------------------------------------------

proc ToEnterFileByKey {parent fileName fileDir} {
    if {! $::dialogIsNative} {
	after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
    }
}

proc EnterFileByKey {parent fileName fileDir} {
    global tk_strictMotif
    if {$parent == "."} {
	set w .__tk_filedialog
    } else {
	set w $parent.__tk_filedialog
︙
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

56
57
58
59
60
61
62


63
64
65
66
67
68

69


70
71





72
73
74
75
76
77
78








-
-
+
+
+
+
+
+
-

-
-
+
+
-
-
-
-
-








	$data(ent) insert 0 $fileName
    }

    update
    SendButtonPress $parent ok mouse
}

#----------------------------------------------------------------------
#
proc ToEnterFileByKey {parent fileName fileDir} {
    if {! $::dialogIsNative} {
	after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
    }
}

# The test suite proper
#
#----------------------------------------------------------------------

# COMMON TEST SETUP
#
if {$tcl_platform(platform) == "unix"} {
    set modes "0 1"
} else {
    set modes 1
}

set unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -command, -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile,notAqua) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
set unknownOptionsMsg(tk_getSaveFile,aqua) {bad option "-foo": must be -command, -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -message, -parent, -title, or -typevariable}

set tmpFile "filebox.tmp"
︙
113
114
115
116
117
118
119


120
121
122
123
124
125
126
127
















































128
129
130
131
132
133
134

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








+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








    }
    3 {
	{"Text files"		{.txt .doc}	TEXT}
	{"Foo"			{""}		TEXT}
    }
}

set parent .
set verylongstring [string repeat longstring: 16]
foreach mode $modes {
    #
    # Test both the motif version and the "tk" version of the file dialog
    # box on Unix.
    #
    # Note that this means that test names are unusually complex.
    #


#
# TESTS
#

test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
    # MacOS type that is too long

    set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
    regsub -all "\0" $res {\\0}
} {1 {bad Macintosh file type "\0\0\0\0\0"}}
test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
    # MacOS type that is too short, but looks ok in utf (4 bytes).

    set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
    regsub -all "\0" $msg {\\0} msg
    list $x $msg
} {1 {bad Macintosh file type "\0\0"}}
# The next test must actually open a file dialog window, but it does
# not require human interaction to close the dialog because the Aqua
# port of tktest automatically closes every file dialog after a short
# timeout when tests are being run.
test fileDialog-0.3 {GetFileName: file types: bad filetype} \
-constraints aqua \
-body {
    # Checks for the Aqua crash reported in ticket 080a28104.
    set filename [tk_getOpenFile -filetypes {
	{"Invalid extension" {x.y}}
	{"All files" {*}}
    }]
} \
-result {}

# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
# Note that this means that test names are unusually complex.
#
if {$tcl_platform(platform) eq "unix"} {
    set modes "0 1"
} else {
    set modes 1
}
foreach mode $modes {

    #
    # COMMON TEST SETUP
    #
    set addedExtensions {}
    if {$tcl_platform(platform) == "unix"} {
	set tk_strictMotif $mode
	# Extension adding is only done when using the non-motif file
	# box with an extension-less filename
	if {!$mode} {
	    set addedExtensions {NONE {} .txt .txt}
︙
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

190
191
192
193
194
195
196













197
198
199
200
201
202
203
204
205
206
207
208
209
210
211








-
-
-
-
-
-
-
-
-
-
-
-
-





+
+
+








    test filebox-1.5-$mode "tk_getOpenFile command" -body {
	tk_getOpenFile -parent foo.bar
    } -returnCodes error -result {bad window path name "foo.bar"}
    test filebox-1.6-$mode "tk_getOpenFile command" -body {
	tk_getOpenFile -filetypes {Foo}
    } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}

    set parent .

    set verylongstring longstring:
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring
    set verylongstring $verylongstring$verylongstring
    # set verylongstring $verylongstring$verylongstring
    # set verylongstring $verylongstring$verylongstring
    # set verylongstring $verylongstring$verylongstring
    # set verylongstring $verylongstring$verylongstring
    # set verylongstring $verylongstring$verylongstring

    test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	ToPressButton $parent cancel
	tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
    } ""

    #
    # COMMON TEST SETUP
    #
    set fileName $tmpFile
    set fileDir [tcltest::temporaryDirectory]
    set pathName [file join $fileDir $fileName]

    test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	ToPressButton $parent ok
	set choice [tk_getOpenFile -title "Press Ok" \
︙
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249








250
251
252
253
254
255
256

249
250
251
252
253
254
255








256
257
258
259
260
261
262
263
264
265
266
267
268
269
270








-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+








		-parent .t1 -initialdir $fileDir \
		-initialfile $fileName]
    } -result [list $pathName $pathName $pathName] -cleanup {
	destroy .t1
	destroy .t2
    }

test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body {
    #ToPressButton $parent cancel
    set filename [tk_getOpenFile -filetypes {
	{"Invalid extension" {x.y}}
	{"All files" {*}}
     }]
     } -result {}
}
    test fileDialog-2.7-$mode {"tk_getOpenFile: bad extension" -body {
	#ToPressButton $parent cancel
	set filename [tk_getOpenFile -filetypes {
	    {"Invalid extension" {x.y}}
	    {"All files" {*}}
	}]
	} -result {}
    }

    foreach x [lsort -integer [array names filters]] {
	test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
	    ToPressButton $parent ok
	    set choice [tk_getOpenFile -title "Press Ok" \
		    -filetypes $filters($x) -parent $parent \
		    -initialfile $fileName -initialdir $fileDir]
︙
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295

295
296
297
298
299
300
301

302
303
304
305
306
307
308








-








    test filebox-4.1.2-$mode "tk_getSaveFile command" -constraints aqua -body {
	tk_getSaveFile -foo
    } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)

    catch {tk_getSaveFile -foo 1} msg
    regsub -all ,      $msg "" options
    regsub \"-foo\" $options "" options

    foreach option $options {
	if {[string index $option 0] eq "-"} {
	    test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
		tk_getSaveFile $option
	    } -returnCodes error -result "value for \"$option\" missing"
	}
    }
︙
311
312
313
314
315
316
317



318
319
320
321
322
323
324

324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340








+
+
+








    } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}

    test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
	ToPressButton $parent cancel
	tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
    } ""

    #
    # COMMON TEST SETUP
    #
    set fileName "12x 455"
    set fileDir [pwd]
    set pathName [file join [pwd] $fileName]

    test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
	ToPressButton $parent ok
	set choice [tk_getSaveFile -title "Press Ok" \
︙
438
439
440
441
442
443
444
445

446
447
448
449
450
451
452

454
455
456
457
458
459
460

461
462
463
464
465
466
467









-
+






-

    # The rest of the tests need to be executed on Unix only.
    # They test whether the dialog box widgets were implemented correctly.
    # These tests are not
    # needed on the other platforms because they use native file dialogs.
}

#
# CLEANUP
# TESTFILE CLEANUP
#

set tk_strictMotif $tk_strictMotif_old
removeFile filebox.tmp
testutils forget dialog
cleanupTests
return
Changes to tests/focus.test. 
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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+




-
-
+
+
-
-
+
-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
-
-
-
-
-
+
+
+
+








# This file is a Tcl script to test out the "focus" command and the
# other procedures in the file tkFocus.c.  It is organized in the
# other procedures in the file tkFocus.c.
# standard fashion for Tcl tests.
#
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

if {[tk windowingsystem] eq "aqua"} {
    childTkInterp childInterp
#
# LOCAL UTILITY PROCS
}

#
proc focusSetup {} {
    destroy .t
    toplevel .t
    wm geom .t +0+0
    foreach i {b1 b2 b3 b4} {
	button .t.$i -text .t.$i -relief raised -bd 2
	pack .t.$i
    }

    tkwait visibility .t.b4
}
proc focusSetupAlt {} {
    global env
    destroy .alt
    toplevel .alt -screen $env(TK_ALT_DISPLAY)
    foreach i {a b c d} {
	button .alt.$i -text .alt.$i -relief raised -bd 2
	pack .alt.$i
    }
    tkwait visibility .alt.d
}


# The following procedure ensures that there is no input focus
# focusClear --
#
#    Ensures that there is no input focus in this application.  It does it by
# in this application.  It does it by arranging for another
# application to grab the focus.  The "after" and "update" stuff
# is needed to wait long enough for pending actions to get through
# the X server and possibly also the window manager.

#    arranging for another application to grab the focus.  The "after" and
#    "update" stuff is needed to wait long enough for pending actions to get
#    through the X server and possibly also the window manager.
#
if {[tk windowingsystem] eq "aqua"} {
    proc focusClear {} {
	childInterp eval {
	    focus -force .
	    set i 0
	    while {[focus] != "."} {
		after 100
︙
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

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








+
+
+
+
+
+
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+



+
+
+
+
+
+
+
+
+
+
+
+
+
+









-
-
-
-
-
+
+
+
+
+
+
+








    proc focusClear {} {
	childTkProcess eval {after 200; focus -force .; update}
	after 400
	update
    }
}

proc focusSetup {} {
    destroy .t
    toplevel .t
    wm geom .t +0+0
    foreach i {b1 b2 b3 b4} {
	button .t.$i -text .t.$i -relief raised -bd 2
	pack .t.$i

# Button used in some tests in the whole test file
button .b -text .b -relief raised -bd 2
pack .b

# Make sure the window manager knows who has focus
    }
    tkwait visibility .t.b4
}

proc focusSetupAlt {} {
    global env
    destroy .alt
    toplevel .alt -screen $env(TK_ALT_DISPLAY)
    foreach i {a b c d} {
	button .alt.$i -text .alt.$i -relief raised -bd 2
	pack .alt.$i
    }
    tkwait visibility .alt.d
}

catch {fixfocus}

#
# COMMON TEST SETUP
#

# childTkProcess exit will be after 4.3 test
childTkProcess create
update

if {[tk windowingsystem] eq "aqua"} {
    childTkInterp childInterp
}

focusSetup
if {[testConstraint altDisplay]} {
    focusSetupAlt
}

# Button used in some tests in the whole test file
button .b -text .b -relief raised -bd 2
pack .b

bind all <FocusIn> {
    append focusInfo "in %W %d\n"
}
bind all <FocusOut> {
    append focusInfo "out %W %d\n"
}
bind all <Key> {
    append focusInfo "press %W %K"
}
focusSetup
if {[testConstraint altDisplay]} {
    focusSetupAlt
}


# Make sure the window manager knows who has focus
catch {fixfocus}

#
# TESTS
#

test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body {
    focusClear
    after 100
    focus
} -result {}
test focus-1.2 {Tk_FocusCmd procedure} -constraints {
︙
240
241
242
243
244
245
246
247



248

249
250
251
252
253
254
255

272
273
274
275
276
277
278

279
280
281
282
283
284
285
286
287
288
289
290








-
+
+
+

+








    update
    focus -lastfor .t.b2
} -result {.t}
test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body {
    focus -unknown
} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor}


#
# COMMON TEST SETUP
#
focusSetup

test focus-2.1 {TkFocusFilterEvent procedure} -constraints {
    unix nonPortable testwrapper
} -body {
    focusClear
    focus -force .b
    focusSetup
    update
︙
611
612
613
614
615
616
617




618
619
620
621
622
623
624

646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663








+
+
+
+








} -body {
    focusSetup
    focus -force .t.b2
    update
    destroy .t.b2
    focus
} -result {.t}

#
# COMMON TEST CLEANUP
#
childTkProcess exit


# I don't know how to test most of the remaining procedures of this file
# explicitly;  they've already been exercised by the preceding tests.

# Test 5.1 fails (before and after update)
︙
634
635
636
637
638
639
640




641
642
643
644
645

646
647
648
649
650
651
652
653
654

673
674
675
676
677
678
679
680
681
682
683
684
685
686
687

688
689

690
691
692
693
694
695
696








+
+
+
+




-
+

-








    lappend result [focus]
    focus .t.b2
    update
    lappend result [focus]
} -cleanup {
    childTkProcess exit
} -result {.t {} {}}

#
# COMMON TEST CLEANUP
#
destroy .t
bind all <FocusIn> {}
bind all <FocusOut> {}
bind all <Key> {}

fixfocus

fixfocus
test focus-6.1 {miscellaneous - embedded application in same process} -constraints {
    unix  testwrapper
} -setup {
    eval interp delete [interp slaves]
} -body {
    toplevel .t
    wm geometry .t +0+0
︙
796
797
798
799
800
801
802
803

804
805
806
807
808
809
810
811
812

838
839
840
841
842
843
844

845
846
847
848
849
850
851
852
853









-
+








-

	focus -force .l;  # This line segfaulted *with xvfb*
	set res Reached
    }
    crashit
} -result {Reached}

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
testutils forget child
cleanupTests
if {[tk windowingsystem] eq "aqua"} {
    interp delete childInterp
}
return
Changes to tests/focusTcl.test. 
1
2
3

4
5
6
7
8
9


















10

11
12

13
14
15
16





17



18
19
20
21
22
23
24

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



-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
-
-
-
-
+
+
+
+
+
-
+
+
+








# This file is a Tcl script to test out the features of the script
# file focus.tcl, which includes the procedures tk_focusNext and
# tk_focusPrev, among other things.  This file is organized in the
# tk_focusPrev, among other things.
# standard fashion for Tcl tests.
#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
namespace import -force tcltest::test

option add *takeFocus 1
option add *highlightThickness 2
}

# Ensure a pristine initial window state
resetWindows

. configure -takefocus 1 -highlightthickness 2
#
# LOCAL UTILITY PROCS
#

proc setup1 w {
    if {$w == "."} {
	set w ""
    }
    foreach i {a b c d} {
	destroy $w.$i
︙
44
45
46
47
48
49
50











51
52
53
54
55
56
57

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








+
+
+
+
+
+
+
+
+
+
+








	destroy $w.$i
    }
    foreach i {x y z} {
	destroy $w.b.$i
    }
}

#
# COMMON TEST SETUP
#

option add *takeFocus 1
option add *highlightThickness 2
. configure -takefocus 1 -highlightthickness 2

#
# TESTS
#

test focusTcl-1.1 {tk_focusNext procedure, no children} -body {
    tk_focusNext .
} -result {.}

test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body {
    setup1 .
︙
259
260
261
262
263
264
265



266
267
268
269
270
271
272
273

274
275
276
277
278
279
280

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








+
+
+








+








test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body {
    setup1 .
    tk_focusPrev .a
} -cleanup {
    cleanup1 .
} -result {.}

#
# COMMON TEST SETUP
#

deleteWindows
setup1 .
toplevel .t
wm geom .t +0+0
toplevel .t2
wm geom .t2 -0+0
raise .t .a

test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup {
    deleteWindows
} -body {
    setup1 .
    toplevel .t
    wm geom .t +0+0
    toplevel .t2
︙
469
470
471
472
473
474
475



476
477
478
479
480
481
482
483
484
485

503
504
505
506
507
508
509
510
511
512
513
514
515


516












+
+
+



-
-

-
-
-
-

    bind Frame <Key> {foo}
    list [tk_focusNext .] [tk_focusNext .a]
} -cleanup {
    cleanup1 .
    bind Frame <Key> {}
} -result {.a .b}

#
# TESTFILE CLEANUP
#

. configure -takefocus 0 -highlightthickness 0
option clear

# cleanup
cleanupTests
return
Changes to tests/font.test. 
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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+












+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+








-
-
-
-
-
-
-
+
+
-
-
-
-
-
-
-
-
+








# This file is a Tcl script to test out Tk's "font" command
# plus the procedures in tkFont.c.  It is organized in the
# plus the procedures in tkFont.c.
# standard white-box fashion for Tcl tests.
#
# Copyright © 1996-1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

set defaultfontlist [font names]
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc clearnondefaultfonts {} {
    foreach afont [getnondefaultfonts] {
	font delete $afont
    }
}

proc csetup {{str ""}} {
    focus -force .t.c
    .t.c dchars text 0 end
    .t.c insert text 0 $str
    .t.c focus text
}

proc getnondefaultfonts {} {
    global defaultfontlist
    set nondeffonts [list ]
    foreach afont [font names] {
	if {$afont ni $defaultfontlist} {
	    lappend nondeffonts $afont
	}
    }
    set nondeffonts
}

proc psfontname {name} {
	destroy .t.c
	canvas .t.c -closeenough 0
	.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
	pack .t.c
	update
    set a [.t.c itemcget text -font]
    .t.c itemconfig text -text "We need text" -font $name
    set post [.t.c postscript]
    .t.c itemconfig text -font $a
    set end [string first "findfont" $post]
    incr end -2
    set post [string range $post [expr $end-70] $end]
    set start [string first "gsave" $post]
	destroy .t.c
    return [string range $post [expr $start+7] end]
}
proc clearnondefaultfonts {} {
    foreach afont [getnondefaultfonts] {
	font delete $afont
    }

#
# COMMON TEST SETUP
#

set defaultfontlist [font names]

switch [tk windowingsystem] {
    x11		{set fixed "TkFixedFont"}
    win32	{set fixed "courier 12"}
    aqua	{set fixed "monaco 9"}
}

deleteWindows
# Toplevel used (in some tests) of the whole file
toplevel .t
wm geom .t +0+0
update idletasks

switch [tk windowingsystem] {
    x11		{set fixed "TkFixedFont"}
    win32	{set fixed "courier 12"}
    aqua	{set fixed "monaco 9"}
}


#
# TESTS
# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1
proc csetup {{str ""}} {
    focus -force .t.c
    .t.c dchars text 0 end
    .t.c insert text 0 $str
    .t.c focus text
}

#

test font-1.1 {TkFontPkgInit} -setup {
    catch {interp delete foo}
} -body {
    interp create foo
    foo eval {
	load {} Tk
︙
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904

918
919
920
921
922
923
924



















925
926
927
928
929
930
931








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








} -body {
    button .t.w1 -text abc
    entry .t.w2 -text abcd
    update
    destroy .t.w1 .t.w2
} -result {}


# Procedure used in 21.* tests
proc psfontname {name} {
	destroy .t.c
	canvas .t.c -closeenough 0
	.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
	pack .t.c
	update
    set a [.t.c itemcget text -font]
    .t.c itemconfig text -text "We need text" -font $name
    set post [.t.c postscript]
    .t.c itemconfig text -font $a
    set end [string first "findfont" $post]
    incr end -2
    set post [string range $post [expr $end-70] $end]
    set start [string first "gsave" $post]
	destroy .t.c
    return [string range $post [expr $start+7] end]
}
test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints {
	unix
} -body {
    set x [font actual {{itc avant garde} 10} -family]
    if {[string match *avant*garde $x]} {
		psfontname "{itc avant garde} 10"
    } else {
︙
1477
1478
1479
1480
1481
1482
1483
1484
1485






1486
1487
1488
1489
1490
1491
1492

1493
1494
1495
1496
1497
1498
1499

1504
1505
1506
1507
1508
1509
1510


1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531








-
-
+
+
+
+
+
+







+








    .t.t tag config sel -underline 1
    .t.t tag add sel 1.0 end
    update
} -cleanup {
    destroy .t.t
} -result {}


# Data used in 24.* tests
#
# COMMON TEST SETUP
#
# For tests font-24.*
#

destroy .t.l
label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \
	-text "0" -font "Courier -12"
pack .t.l
update
set ax [winfo reqwidth .t.l]
set ay [winfo reqheight .t.l]

test font-24.1 {Tk_ComputeTextLayout: empty string} -body {
    .t.l config -text ""
} -result {}
test font-24.2 {Tk_ComputeTextLayout: simple string} -body {
    .t.l config -text "000"
    update
    list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \
︙
1604
1605
1606
1607
1608
1609
1610




1611
1612
1613
1614
1615
1616
1617

1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653








+
+
+
+








    lappend x [expr {[winfo reqheight .t.l] eq $ay}]
    .t.l config -text "0000\n"
    update
    lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}]
    lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}]
    set x
} -result {1 1 1 1}

#
# COMMON TEST CLEANUP
#
destroy .t.l

test font-24.15 {Tk_ComputeTextLayout: justification} -setup {
    set x {}
    destroy .t.c
    canvas .t.c -closeenough 0
    .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
︙
1639
1640
1641
1642
1643
1644
1645
1646
1647





1648
1649
1650
1651
1652

1653
1654
1655
1656
1657
1658
1659

1675
1676
1677
1678
1679
1680
1681


1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699








-
-
+
+
+
+
+





+








} -body {
    .t.f config -text foo
    .t.f config -text boo
} -cleanup {
    destroy .t.f
} -result {}


# Canvas created for tests: 26.*
#
# COMMON TEST SETUP
#
# For tests font-26.*
#
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup {
    destroy .t.f
    pack [label .t.f]
    update
} -body {
    .t.f config -text foo
} -cleanup {
︙
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687








1688
1689
1690

1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705








1706
1707
1708
1709
1710

1711
1712
1713
1714
1715
1716
1717

1718
1719
1720
1721
1722
1723
1724



1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746





1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767








-
-
-
+
+
+
+
+
+
+
+



+










-
-
-
-
-
+
+
+
+
+
+
+
+





+








    .t.c select to text 2
} -result {}
test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body {
    csetup "000\t00"
    .t.c select from text 4
    .t.c select to text 4
} -result {}
destroy .t.c

#  Label used in 27.* tests

#
# COMMON TEST SETUP
#
# For tests font-27.*
#

destroy .t.c
destroy .t.f
pack [label .t.f]
update

test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body {
    .t.f config -text "foo" -underline {}
} -result {}
test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body {
    .t.f config -text "000          00000" -wrap [expr $ax*7] -under 10
} -result {}
test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body {
    .t.f config -text "000          00000" -wrap [expr $ax*7] -under 5
    .t.f config -wrap 0 -underline {}
} -result {}
destroy .t.f



# Canvas created for tests: 28.*

#
# COMMON TEST SETUP
#
# For tests font-28.*
#

destroy .t.f
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-28.1 {Tk_PointToChar procedure: above all lines} -body {
    csetup "000"
    .t.c index text @-1,0
} -result 0
test font-28.2 {Tk_PointToChar procedure: no chars} -body {
    # After fixing the following bug:
    #
︙
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769








1770
1771
1772

1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797








1798
1799
1800
1801
1802

1803
1804
1805
1806
1807
1808
1809

1809
1810
1811
1812
1813
1814
1815




1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847





1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868








-
-
-
-
+
+
+
+
+
+
+
+



+




















-
-
-
-
-
+
+
+
+
+
+
+
+





+








    .t.c itemconfig text -width 0
    return $x
} -result 3
test font-28.11 {Tk_PointToChar procedure: below all chunks} -body {
    csetup "000 0000000"
    .t.c index text @0,1000000
} -result 11
destroy .t.c


#  Label used in 29.* tests

#
# COMMON TEST SETUP
#
# For tests font-29.*
#

destroy .t.c
destroy .t.f
pack [label .t.f]
update

test font-29.1 {Tk_CharBBox procedure: index < 0} -body {
    .t.f config -text "000" -underline {}
} -result {}
test font-29.2 {Tk_CharBBox procedure: loop} -body {
    .t.f config -text "000\t000\t000\t000" -underline 9
} -result {}
test font-29.3 {Tk_CharBBox procedure: special char} -body {
    .t.f config -text "000\t000\t000" -underline 7
} -result {}
test font-29.4 {Tk_CharBBox procedure: normal char} -body {
    .t.f config -text "000" -underline 1
} -result {}
test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body {
    .t.f config -text "0    0000" -wrap [expr $ax*4] -under 2
    .t.f config -wrap 0
} -result {}
test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body {
    .t.f config -text "0    0000" -wrap [expr $ax*4] -under 3
    .t.f config -wrap 0
} -result {}
destroy .t.f



# Canvas created for tests: 30.*

#
# COMMON TEST SETUP
#
# For tests font-30.*
#

destroy .t.f
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body {
    csetup "000\n000\n000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x 0 -y 0
    return $x
︙
1858
1859
1860
1861
1862
1863
1864




1865

1866
1867
1868
1869
1870
1871
1872

1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936








+
+
+
+

+








    event generate .t.c <Leave>
    event generate .t.c <Enter> -x [expr $ax*5] -y $ay
    .t.c itemconfig text -width 0
    return $x
} -cleanup {
    bind all <Enter> {}
} -result {}

#
# COMMON TEST SETUP
#
.t.c itemconfig text -justify center

test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body {
    csetup "0\n000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x 0 -y 0
    return $x
︙
1919
1920
1921
1922
1923
1924
1925
1926
1927




1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940






1941
1942
1943
1944
1945

1946
1947
1948
1949
1950
1951
1952

1983
1984
1985
1986
1987
1988
1989


1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002




2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021








-
-
+
+
+
+









-
-
-
-
+
+
+
+
+
+





+








    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x $ax -y $ay
    return $x
} -cleanup {
	bind all <Enter> {}
} -result 3
.t.c itemconfig text -justify left
test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body {

test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -setup {
    .t.c itemconfig text -justify left
} -body {
    csetup "000"
    .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]}
    set x {}
    event generate .t.c <Leave>
    event generate .t.c <Enter> -x $ax -y 0
    return $x
} -cleanup {
    bind all <Enter> {}
} -result 1
destroy .t.c


# Canvas created for tests 31.*

#
# COMMON TEST SETUP
#
# For tests font-31.*
#
destroy .t.c
canvas .t.c -closeenough 0
.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
pack .t.c
update

test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body {
    csetup "000\n000\n000"
    .t.c find overlapping 0 0 0 0
} -result [.t.c find withtag text]
test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body {
    csetup "000\t000\t000"
    .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0
︙
1976
1977
1978
1979
1980
1981
1982
1983
1984





1985
1986
1987
1988
1989
1990
1991

2045
2046
2047
2048
2049
2050
2051


2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063








-
-
+
+
+
+
+








    # Coordinates of the rectangle to check can be hardcoded:
    # The goal of this test is to check whether the overlap detection algorithm
    # works when the rectangle is entirely included in a chunk of the text layout.
    # The text has been rotated 90 degrees around it's upper left corner,
    # so it's enough to check with a small rectangle with small negative y coords.
    .t.c find overlapping 5 -7 7 -5
} -result 1
destroy .t.c


#
# COMMON TEST CLEANUP
#
destroy .t.c

test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup {
    destroy .t.c
    canvas .t.c -closeenough 0
    .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12"
    pack .t.c
    update
︙
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572



2573


2632
2633
2634
2635
2636
2637
2638






2639
2640
2641
2642
2643








-
-
-
-
-
-
+
+
+

+

    apply $check $l
    set results
} -cleanup {
    destroy $l
    unset -nocomplain ::results
} -result {{1 1} {1 1} {1 1} {1 1}}

# cleanup
cleanupTests
return



#
# TESTFILE CLEANUP
#

cleanupTests
Changes to tests/fontchooser.test. 
1
2
3
4


















5

6
7





8
9
10
11
12
13





14




15
16
17
18
19
20
21

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





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
+
+
+
+






+
+
+
+
+
-
+
+
+
+








# Test the "tk::fontchooser" command
#
# Copyright © 2008 Pat Thoyts

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

set applyFontCmd [list set testDialogFont]

#
# LOCAL TEST CONSTRAINTS
#
catch {tk fontchooser -invalidOption}
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]
# -------------------------------------------------------------------------

#
# TESTS
#

test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser -z
} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show}

test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser configure -z
︙
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

74
75
76
77
78
79
80

81
82
83
84
85
86

87
88
89
90
91
92
93








-






-








    tk fontchooser configure -visible
} -result 0

test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body {
    tk fontchooser configure -visible 1
} -match glob -result {*}

# -------------------------------------------------------------------------
#
# The remaining tests in this file are only relevant for the script
# implementation. They can be tested by sourcing the script file but
# the Tk tests are run with -singleproc 1 and doing this affects the
# result of later attempts to test the native implementations.
#
testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]]

test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body {
    testDialog launch {
	tk::fontchooser::Configure -title "Hello"
	tk::fontchooser::Show
    }
    testDialog onDisplay {
︙
157
158
159
160
161
162
163
164

165
166
167
168
169
170
171
172
173
174
175

184
185
186
187
188
189
190

191
192
193
194
195
196

197
198
199
200
201








-
+





-






test fontchooser-5.1 {fontchooser multiple configure} -constraints {scriptImpl} -body {
    tk fontchooser configure -title TestTitle -command foo
    tk fontchooser configure -command bar
    tk fontchooser configure -title
} -result {TestTitle}

#
# CLEANUP
# TESTFILE CLEANUP
#

unset applyFontCmd
testutils forget dialog
cleanupTests
return

# Local Variables:
# mode: tcl
# indent-tabs-mode: nil
# End:
Changes to tests/frame.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+















-

-
+

-
-
-
-
-








# This file is a Tcl script to test out the "frame", "labelframe" and
# "toplevel" commands of Tk.  It is organized in the standard fashion for Tcl
# "toplevel" commands of Tk.
# tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

#
# LOCAL UTILITY PROCS
#

# optnames --
#
# Returns the option names out of a list of option details.
#
# Arguments:
# options -		The option detail list.
proc optnames {options} {
    lsort [lmap desc $options {lindex $desc 0}]
}

# uniq --
#
# Returns the unique items of a list in the order they first appear.
#
# Arguments:
# list -		The list to uniq-ify.
proc uniq {list} {
    set d {}
    foreach item $list {
	dict set d $item {}
    }
    return [dict keys $d]
}

# optnames --
#
# Returns the option names out of a list of option details.
# TESTS
#
# Arguments:
# options -		The option detail list.
proc optnames {options} {
    lsort [lmap desc $options {lindex $desc 0}]
}

test frame-1.1 {frame configuration options} -setup {
    deleteWindows
} -body {
    frame .f -class NewFrame
    .f configure -class
} -cleanup {
︙
137
138
139
140
141
142
143



144
145

146
147
148
149
150
151
152

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183








+
+
+


+








    }
    frame .g {*}$opts
} -cleanup {
    destroy .f .g
    deleteWindows
} -result .g

#
# COMMON TEST SETUP
#
destroy .f
frame .f

test frame-1.13 {frame configuration options} -body {
    .f configure -background #ff0000
    lindex [.f configure -background] 4
} -cleanup {
    .f configure -background [lindex [.f configure -background] 3]
} -result "#ff0000"
test frame-1.14 {frame configuration options} -body {
︙
262
263
264
265
266
267
268




269
270
271
272
273
274
275

293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310








+
+
+
+








    lindex [.f configure -width] 4
} -cleanup {
    .f configure -width [lindex [.f configure -width] 3]
} -result 32
test frame-1.39 {frame configuration options} -body {
    .f configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-2.1 {toplevel configuration options} -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -class NewClass
    wm geometry .t +0+0
︙
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

424
425
426
427
428
429
430




431
432
433
434
435
436
437
438

439
440
441
442
443
444
445
446








-
-
-
-








-
+








test frame-2.14 {toplevel configuration options} -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -visual who_knows?
} -returnCodes error -cleanup {
    deleteWindows
} -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}
set expectedScreen ""
if {[tcltest::testConstraint haveDISPLAY]} {
    set expectedScreen [list -screen screen Screen {} $env(DISPLAY)]
}
test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen
} -cleanup {
    deleteWindows
} -result $expectedScreen
} -result [expr {[tcltest::testConstraint haveDISPLAY]?[list -screen screen Screen {} $env(DISPLAY)]:""}]
test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup {
    deleteWindows
} -body {
    toplevel .t -width 200 -height 100 -screen $env(DISPLAY)
    wm geometry .t +0+0
    .t configure -screen another
} -returnCodes error -cleanup {
︙
444
445
446
447
448
449
450



451
452
453
454

455
456
457
458
459
460
461

475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496








+
+
+




+








    }
    toplevel .g {*}$opts
} -cleanup {
    destroy .f .g
    deleteWindows
} -result .g

#
# COMMON TEST SETUP
#
destroy .t
toplevel .t -width 300 -height 150
wm geometry .t +0+0
update

test frame-2.20 {toplevel configuration options} -body {
    .t configure -background #ff0000
    lindex [.t configure -background] 4
} -result "#ff0000"
test frame-2.21 {toplevel configuration options} -body {
    .t configure -background non-existent
} -returnCodes error -result {unknown color name "non-existent"}
︙
532
533
534
535
536
537
538




539
540
541
542
543
544
545

567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584








+
+
+
+








test frame-2.42 {toplevel configuration options} -body {
    .t configure -width 32
    lindex [.t configure -width] 4
} -result 32
test frame-2.43 {toplevel configuration options} -body {
    .t configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .t

test frame-3.1 {TkCreateFrame procedure} -returnCodes error -body {
    frame
} -result {wrong # args: should be "frame pathName ?-option value ...?"}
test frame-3.2 {TkCreateFrame procedure} -setup {
    deleteWindows
︙
634
635
636
637
638
639
640





641
642
643
644
645
646

647
648
649
650
651
652
653

673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698








+
+
+
+
+






+








    list [expr {[winfo rootx .x] - [winfo rootx .t]}] \
	    [expr {[winfo rooty .x] - [winfo rooty .t]}] \
	    [winfo width .t] [winfo height .t]
} -cleanup {
    destroy .t
    option clear
} -result {0 0 140 300}

#
# COMMON TEST SETUP
#

# The tests below require specific display characteristics (i.e. that they are
# run on a pseudocolor display of depth 8).  Even so, they are non-portable:
# some machines don't seem to ever run out of colors.
if {[testConstraint defaultPseudocolor8]} {
    eatColors .t1
}

test frame-3.11 {TkCreateFrame procedure} -constraints {
    defaultPseudocolor8 nonPortable
} -setup {
    destroy .t
} -body {
    toplevel .t -width 300 -height 200 -bg #475601
    wm geometry .t +0+0
︙
786
787
788
789
790
791
792




793
794
795

796
797
798
799
800
801
802

831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852








+
+
+
+



+








    toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343
    wm geometry .t +0+0
    update
    colorsFree .t 131 131 131
} -cleanup {
    destroy .t
} -result 1

#
# COMMON TEST CLEANUP
#
if {[testConstraint defaultPseudocolor8]} {
    destroy .t1
}

test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup {
    deleteWindows
} -body {
    toplevel .t
    wm geometry .t +0+0
    update
    set result "[winfo reqwidth .t] [winfo reqheight .t]"
︙
829
830
831
832
833
834
835



836

837
838
839
840
841
842
843

879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897








+
+
+

+








    deleteWindows
} -body {
    list [frame .f -width 200 -height 100] [winfo exists .f]
} -cleanup {
    deleteWindows
} -result {.f 1}

#
# COMMON TEST SETUP
#
frame .f -highlightcolor black

test frame-5.1 {FrameWidgetCommand procedure} -body {
    .f
} -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"}
test frame-5.2 {FrameWidgetCommand procedure, cget option} -body {
    .f cget
} -returnCodes error -result {wrong # args: should be ".f cget option"}
test frame-5.3 {FrameWidgetCommand procedure, cget option} -body {
︙
874
875
876
877
878
879
880




881
882
883
884
885
886
887

928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945








+
+
+
+








} -returnCodes error -result {value for "-height" missing}
test frame-5.12 {FrameWidgetCommand procedure} -body {
    .f swizzle
} -returnCodes error -result {bad option "swizzle": must be cget or configure}
test frame-5.13 {FrameWidgetCommand procedure, configure option} -body {
    optnames [. configure]
} -result {-background -backgroundimage -bd -bg -bgimg -borderwidth -class -colormap -container -cursor -height -highlightbackground -highlightcolor -highlightthickness -menu -padx -pady -relief -screen -takefocus -tile -use -visual -width}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-6.1 {ConfigureFrame procedure} -setup {
    deleteWindows
} -body {
    frame .f -width 150
    list [winfo reqwidth .f] [winfo reqheight .f]
︙
1172
1173
1174
1175
1176
1177
1178





1179
1180

1181
1182
1183
1184
1185
1186
1187

1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251








+
+
+
+
+


+








    deleteWindows
} -body {
    labelframe .f
    .f configure -container 1
} -returnCodes error -cleanup {
    deleteWindows
} -result {can't modify -container option after widget is created}

#
# COMMON TEST SETUP
#

destroy .f
labelframe .f

test frame-13.10 {labelframe configuration options} -body {
    .f configure -background #ff0000
    lindex [.f configure -background] 4
} -cleanup {
    .f configure -background [lindex [.f configure -background] 3]
} -result "#ff0000"
test frame-13.11 {labelframe configuration options} -body {
︙
1336
1337
1338
1339
1340
1341
1342




1343
1344
1345
1346
1347
1348
1349

1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417








+
+
+
+








    lindex [.f configure -width] 4
} -cleanup {
    .f configure -width [lindex [.f configure -width] 3]
} -result 32
test frame-13.44 {labelframe configuration options} -body {
    .f configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}

#
# COMMON TEST CLEANUP
#
destroy .f

test frame-14.1 {labelframe labelwidget option} -setup {
    deleteWindows
} -body {
    # Test that label is moved in stacking order
    label .l -text Mupp -font {helvetica 8}
︙
1727
1728
1729
1730
1731
1732
1733
1734

1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747

1795
1796
1797
1798
1799
1800
1801

1802
1803
1804
1805
1806
1807
1808
1809
1810

1811
1812
1813
1814








-
+








-





    return [uniq $result]
} -cleanup {
    deleteWindows
    catch {image delete gorp}
} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}}

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
apply {cmds {foreach cmd $cmds {rename $cmd {}}}} {
    uniq optnames
}
testutils forget colors
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/geometry.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+
+












+
+
+
+








# This file is a Tcl script to test the procedures in the file
# tkGeometry.c (generic support for geometry managers).  It is
# tkGeometry.c (generic support for geometry managers).
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows


#
# COMMON TEST SETUP
#

wm geometry . 300x300
raise .
update

frame .f -bd 2 -relief raised
frame .f.f -bd 2 -relief sunken
frame .f.f.f -bd 2 -relief raised
button .b1 -text .b1
button .b2 -text .b2
button .b3 -text .b3
button .f.f.b4 -text .b4

#
# TESTS
#

test geometry-1.1 {Tk_ManageGeometry procedure} -setup {
	foreach w {.f .f.f .f.f.f .b1 .b2 .b3} {
	place forget $w
    }
} -body {
    place .b1 -x 120 -y 80
︙
275
276
277
278
279
280
281
282
283




284
285
286

302
303
304
305
306
307
308


309
310
311
312
313










-
-
+
+
+
+

-
-

    wm deiconify .t
    update
    winfo ismapped .t.quit
} -cleanup {
    destroy .t
} -result 1


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/get.test. 
1
2

3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17
18
19

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkGet.c.  It is organized in the standard fashion for Tcl
# tkGet.c.
# white-box tests.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test get-1.1 {Tk_GetAnchorFromObj} -setup {
    button .b
} -body {
    .b configure -anchor n
    .b cget -anchor
} -cleanup {
︙
127
128
129
130
131
132
133




134
135
136
137
138

150
151
152
153
154
155
156
157
158
159
160
161
162
163










+
+
+
+



-
-

test get-2.4 {Tk_GetJustifyFromObj - error} -setup {
    button .b
} -body {
    .b configure -justify stupid
} -cleanup {
    destroy .b
} -returnCodes error -result {bad justification "stupid": must be left, right, or center}

#
# TESTFILE CLEANUP
#

# cleanup
cleanupTests
return
Changes to tests/grab.test. 
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

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



-
-
-
-



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+







+
+
+
+








# Tests for the grab command.
#
# This file contains a collection of tests for one or more of the Tk
# built-in commands.  Sourcing this file runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1998-2000 Ajuba Solutions.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# The macOS test module includes the testpressbutton command to simulate a
# mouse button press event by injecting events into the NSApplication
# event queue.  On other platforms there is currently no way to test
# the actual grab effect, per se, in an automated test.  Therefore,
# this test suite only covers the interface to the grab command (ie,
# error messages, etc.) on platforms other than macOS.

#
# TESTS
#

test grab-1.1 {Tk_GrabObjCmd} -body {
    grab
} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"}
test grab-1.2 {Tk_GrabObjCmd} -body {
    rename grab grabTest1.2
    grabTest1.2
︙
207
208
209
210
211
212
213
214
215
216






227
228
229
230
231
232
233



234
235
236
237
238








-
-
-
+
+
+
+
+

    testpressbutton 250 250
    update
    return $result
} -cleanup {
    grab release .f
} -result {inside outside : outside : inside outside :}

cleanupTests
return

#
# TESTFILE CLEANUP
#

cleanupTests
Changes to tests/grid.test. 
1

2
3
4
5
6
7


















8

9
10
11





12






13
14
15
16




17
18
19
20
21
22
23


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

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+
+
+
+
-
-
-
-
+
+
+
+








# This file is a Tcl script to test out the *NEW* "grid" command of Tk. It is
# This file is a Tcl script to test out the *NEW* "grid" command of Tk.
# (almost) organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# grid_reset --
#
# helper routine to return "." to a sane state after a test.
# The variable GRID_VERBOSE can be used to "look" at the result of one or all
# of the tests

#    Helper routine to return "." to a sane state after a test.
#    The variable GRID_VERBOSE can be used to "look" at the result of one or all
#    of the tests
#
proc grid_reset {{test ?} {top .}} {
    global GRID_VERBOSE
    if {[info exists GRID_VERBOSE]} {
	if {$GRID_VERBOSE eq "" || $GRID_VERBOSE eq $test} {
	    puts -nonewline "grid test $test: "
	    flush stdout
	    gets stdin
︙
32
33
34
35
36
37
38




39
40
41
42





43
44
45
46
47
48
49

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








+
+
+
+



-
+
+
+
+
+








    for {set i 0} {$i <= $rows} {incr i} {
	grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform ""
    }
    grid propagate . 1
    grid anchor . nw
    update
}

#
# COMMON TEST SETUP
#

grid_reset 0.0
wm geometry . {}


#
# TESTS
#

test grid-1.1 {basic argument checking} -body {
    grid
} -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"}
test grid-1.2 {basic argument checking} -body {
    grid foo bar
} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, content, forget, info, location, propagate, remove, rowconfigure, or size}
test grid-1.3 {basic argument checking} -body {
︙
789
790
791
792
793
794
795
796

797
798
799
800
801

802
803
804
805
806

807
808
809
810
811
812
813
814
815
816
817
818
819
820
821




822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844




845
846
847
848
849
850
851
852
853
854
855
856
857

822
823
824
825
826
827
828

829
830
831
832
833

834
835
836
837
838

839
840
841
842
843
844
845
846
847
848
849
850
851
852
853

854
855
856
857
858
859
860
861
862
863
864

865
866
867
868
869
870
871
872
873
874
875
876
877
878

879
880
881
882
883
884
885
886
887

888
889
890
891
892
893
894








-
+




-
+




-
+














-
+
+
+
+







-














-
+
+
+
+





-








    grid .f.f
    append res [grid columnconfigure .f {.f.f} -weight 1]
    append res [grid columnconfigure .f {.f.f 1} -weight 1]
    append res [grid columnconfigure .f {2 .f.f} -weight 1]
    destroy .f
    return $res
} -cleanup {
    grid_reset 10.35
    grid_reset 10.32
} -result {}
test grid-10.33 {column/row configure} -body {
    grid columnconfigure . all
} -cleanup {
    grid_reset 10.36
    grid_reset 10.33
} -returnCodes error -result {expected integer but got "all" (when retrieving options only integer indices are allowed)}
test grid-10.34 {column/row configure} -body {
    grid columnconfigure . 100000
} -cleanup {
    grid_reset 10.37
    grid_reset 10.34
} -result {-minsize 0 -pad 0 -uniform {} -weight 0}
test grid-10.35 {column/row configure} -body {
    # This is a test for bug 1423666 where a column >= 10000 caused
    # a crash in layout.  The update is needed to reach the layout stage.
    # Test different combinations of row/column overflow
    frame .f
    set res {}
    lappend res [catch {grid .f -row 10 -column 9999} msg] $msg ; update
    lappend res [catch {grid .f -row 9999 -column 10} msg] $msg ; update
    lappend res [catch {grid .f -columnspan 2 -column 9998} msg] $msg ; update
    lappend res [catch {grid .f -rowspan 2 -row 9998} msg] $msg ; update
    lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update
    lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update
    return $res
} -cleanup {destroy .f} -result [lrange {
} -cleanup {
    destroy .f
    grid_reset 10.35
} -result [lrange {
    1 {column out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {row out of bounds}
} 0 end]
grid_reset 10.38
test grid-10.36 {column/row configure} -body {
    # Additional tests for row/column overflow
    frame .f
    frame .g
    set res {}
    grid .f -row 9998 -column 0
    lappend res [catch {grid ^ -in .} msg] $msg  ; update
    lappend res [catch {grid .g} msg] $msg  ; update
    grid forget .f .g
    lappend res [catch {grid .f - -column 9998} msg] $msg ; update
    grid forget .f .g
    lappend res [catch {eval grid [string repeat " x " 9999] .f} msg] $msg
    update
    return $res
} -cleanup {destroy .f .g} -result [lrange {
} -cleanup {
    destroy .f .g
    grid_reset 10.36
} -result [lrange {
    1 {row out of bounds}
    1 {row out of bounds}
    1 {column out of bounds}
    1 {column out of bounds}
} 0 end]
grid_reset 10.39

# auto-placement tests
test grid-11.1 {default widget placement} -body {
    grid ^
} -cleanup {
    grid_reset 11.1
} -returnCodes error -result {can't use '^', can't find container window}
︙
1156
1157
1158
1159
1160
1161
1162
1163
1164


1165
1166
1167
1168
1169
1170
1171

1193
1194
1195
1196
1197
1198
1199


1200
1201
1202
1203
1204
1205
1206
1207
1208








-
-
+
+








} -returnCodes error -result {bad window path name ".bad"}
test grid-13.4 {-in} -body {
    frame .f -bg red
    toplevel .top
    grid .f -in .top
} -cleanup {
    grid_reset 13.3
} -returnCodes error -result {can't put ".f" inside ".top"}
destroy .top
    destroy .top
} -returnCodes error -result {can't put ".f" inside ".top"}
test grid-13.5 {-ipadx} -body {
    frame .f -width 20 -height 20 -highlightthickness 0 -bg red
    grid .f -ipadx x
} -cleanup {
    grid_reset 13.4
} -returnCodes error -result {bad ipadx value "x": must be positive screen distance}
test grid-13.6 {-ipadx} -body {
︙
1965
1966
1967
1968
1969
1970
1971
1972

1973
1974
1975
1976
1977
1978
1979
1980
1981




1982
1983
1984
1985
1986
1987
1988
1989




1990
1991
1992
1993
1994
1995
1996
1997
1998




1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011




2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022



2023
2024
2025

2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041



2042
2043
2044
2045
2046
2047
2048

2002
2003
2004
2005
2006
2007
2008

2009
2010
2011
2012
2013
2014
2015



2016
2017
2018
2019
2020
2021
2022
2023
2024



2025
2026
2027
2028
2029
2030
2031
2032
2033
2034



2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048



2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061


2062
2063
2064
2065
2066

2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081


2082
2083
2084
2085
2086
2087
2088
2089
2090
2091








-
+






-
-
-
+
+
+
+





-
-
-
+
+
+
+






-
-
-
+
+
+
+










-
-
-
+
+
+
+









-
-
+
+
+


-
+














-
-
+
+
+








} -result [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \
	   {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \
	   {37 60 225 150}]

test grid-22.1 {remove: basic argument checking} {
    list [catch {grid remove foo} msg] $msg
} {1 {bad window path name "foo"}}
test grid-22.2 {remove} {
test grid-22.2 {remove} -body {
    button .c
    grid [button .b]
    set a [grid content .]
    grid remove .b .c
    lappend a [grid content .]
    return $a
} {.b {}}
grid_reset 22.2
test grid-22.3 {remove} {
} -cleanup {
    grid_reset 22.2
} -result {.b {}}
test grid-22.3 {remove} -body {
    button .c
    grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns
    grid remove .c
    grid .c -row 0 -column 0
    grid info .c
} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns}
grid_reset 22.3
test grid-22.3.1 {remove} {
} -cleanup {
    grid_reset 22.3
} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns}
test grid-22.3.1 {remove} -body {
    frame .a
    button .c
    grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
    grid remove .c
    grid .c -row 0 -column 0
    grid info .c
} {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
grid_reset 22.3.1
test grid-22.4 {remove, calling Tk_UnmaintainGeometry} {
} -cleanup {
    grid_reset 22.3.1
} -result {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
test grid-22.4 {remove, calling Tk_UnmaintainGeometry} -body {
    frame .f -bd 2 -relief raised
    place .f -x 10 -y 20 -width 200 -height 100
    frame .f2 -width 50 -height 30 -bg red
    grid .f2 -in .f
    update
    set x [winfo ismapped .f2]
    grid remove .f2
    place .f -x 30
    update
    lappend x [winfo ismapped .f2]
} {1 0}
grid_reset 22.4
test grid-22.5 {remove} {
} -cleanup {
    grid_reset 22.4
} -result {1 0}
test grid-22.5 {remove} -body {
    frame .a
    button .c
    grid .c -in .a -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns
    grid remove .c
    # If .a was destroyed while remembered by the removed .c, make sure it
    # is ignored.
    destroy .a
    grid .c -row 0 -column 0
    grid info .c
} {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}
grid_reset 22.5
} -cleanup {
    grid_reset 22.5
} -result {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns}

test grid-23 {grid configure -in leaked from previous container window - bug
	      6aea69fccbb266b7f0437686379fbe5b55442958} {
	      6aea69fccbb266b7f0437686379fbe5b55442958} -body {
    frame .f
    frame .g
    pack .f .g
    text .t
    grid .t -in .f
    pack forget .f
    update
    grid .t -in .g
    # .t is now managed by .g; following lines must have no effect on .t
    pack .f
    update
    pack forget .f
    update
    winfo ismapped .t ; # must return 1
} 1
grid_reset 23
} -cleanup {
    grid_reset 23
} -result 1

test grid-24.1 {<<NoManagedChild>> fires on last grid forget} -setup {
    global A
    unset -nocomplain A
} -body {
    grid [frame .1]
    update
︙
2150
2151
2152
2153
2154
2155
2156
2157
2158





2159
2160
2161
2162
2163
2164

2193
2194
2195
2196
2197
2198
2199


2200
2201
2202
2203
2204
2205

2206
2207
2208
2209








-
-
+
+
+
+
+

-





    grid forget .1
    update
    info exists A
} -cleanup {
    bind . <<NoManagedChild>> {}
    grid_reset 24.8
} -result 0

# cleanup

#
# TESTFILE CLEANUP
#

cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/image.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+






+
+
+








# This file is a Tcl script to test out the "image" command and the
# other procedures in the file tkImage.c.  It is organized in the
# other procedures in the file tkImage.c.
# standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

# Canvas used in some tests in the whole file
canvas .c -highlightthickness 2
pack .c
update

#
# TESTS
#

test image-1.1 {Tk_ImageCmd procedure, "create" option} -body {
    image
} -returnCodes error -result {wrong # args: should be "image option ?args?"}
test image-1.2 {Tk_ImageCmd procedure, "create" option} -body {
    image gorp
} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}
︙
585
586
587
588
589
590
591
592

593
594
595
596
597
598
599
600
601
602
603

611
612
613
614
615
616
617

618
619
620
621
622
623
624

625
626
627
628








-
+






-





    lappend x [.c bbox i1] [imageNames]
} -cleanup {
    .c delete all
    imageCleanup
} -result {10 10 20 20 foo {} {10 10 30 30} foo}

#
# CLEANUP
# TESTFILE CLEANUP
#

destroy .c
imageFinish
testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/imgBmap.test. 
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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+




+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out images of type "bitmap" (i.e.,
# the procedures in the file tkImgBmap.c).  It is organized in the
# the procedures in the file tkImgBmap.c).
# standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#

proc bgerror msg {
    global errMsg
    set errMsg $msg
}

#
# COMMON TEST SETUP
#

set data1 {#define foo_width 16
#define foo_height 16
#define foo_x_hot 3
#define foo_y_hot 3
static unsigned char foo_bits[] = {
   0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81,
︙
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50




51
52
53
54
55
56
57

66
67
68
69
70
71
72










73
74
75
76
77
78
79
80
81
82
83








-
-
-
-
-
-
-
-
-
-
+
+
+
+








       0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81,
       0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff};
}
makeFile $data1 foo.bm
makeFile $data2 foo2.bm

imageCleanup
#canvas .c
#pack .c
#update
#image create bitmap i1
#.c create image 200 100 -image i1
update
proc bgerror msg {
    global errMsg
    set errMsg $msg
}

#
# TESTS
#

test imageBmap-1.1 {options for bitmap images} -body {
    image create bitmap i1 -background #123456
    lindex [i1 configure -background] 4
} -cleanup {
	image delete i1
} -result {#123456}
︙
116
117
118
119
120
121
122
123
124





125
126
127
128
129
130
131

142
143
144
145
146
147
148


149
150
151
152
153
154
155
156
157
158
159
160








-
-
+
+
+
+
+








    image create bitmap i1 -file foo.bm -maskfile foo2.bm
    lindex [i1 configure -maskfile] 4
} -result foo2.bm
test imageBmap-1.12 {options for bitmap images} -body {
    list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \
	    [string tolower $msg]
} -result {1 {couldn't read bitmap file "bogus": no such file or directory}}
rename bgerror {}


#
# COMMON TEST CLEANUP
#
rename bgerror {}

test imageBmap-2.1 {ImgBmapCreate procedure} -setup {
    imageCleanup
} -body {
    list [catch {image create bitmap -gorp dum} msg] $msg [imageNames]
} -result {1 {unknown option "-gorp"} {}}
test imageBmap-2.2 {ImgBmapCreate procedure} -setup {
︙
342
343
344
345
346
347
348
349
350
351







352
353
354

355
356
357
358
359
360
361

371
372
373
374
375
376
377



378
379
380
381
382
383
384
385

386
387
388
389
390
391
392
393
394








-
-
-
+
+
+
+
+
+
+

-

+








    makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm
    image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}
test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body {
    makeFile {   } foo3.bm
    image create bitmap i1 -file foo3.bm
} -returnCodes error -result {format error in bitmap data}
removeFile foo3.bm



#
# COMMON TEST SETUP
#
# For tests imageBmap-7.*
#
removeFile foo3.bm
imageCleanup
# Image used in 7.* tests
image create bitmap i1

test imageBmap-7.1 {ImgBmapCmd procedure} -body {
    i1
} -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"}
test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} -body {
    i1 cget
} -returnCodes error -result {wrong # args: should be "i1 cget option"}
test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} -body {
︙
380
381
382
383
384
385
386
387




388
389
390
391
392
393
394

413
414
415
416
417
418
419

420
421
422
423
424
425
426
427
428
429
430








-
+
+
+
+








} -returnCodes error -result {unknown option "-gorp"}
test imageBmap-7.9 {ImgBmapCmd procedure} -body {
    i1 configure -foreground #221100 -background
} -returnCodes error -result {value for "-background" missing}
test imageBmap-7.10 {ImgBmapCmd procedure} -body {
    i1 gorp
} -returnCodes error -result {bad option "gorp": must be cget or configure}
# Clean it up after use!!

#
# COMMON TEST CLEANUP
#
imageCleanup

test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup {
    destroy .c
    pack [canvas .c]
    update
} -body {
︙
439
440
441
442
443
444
445




446
447
448
449
450
451
452
453
454
455
456

475
476
477
478
479
480
481
482
483
484
485
486
487
488

489
490
491
492
493
494
495








+
+
+
+



-








    .c create image 50 100 -image i1 -tags i1.1
    i1 configure -foreground bogus
    update
} -cleanup {
    image delete i1
    destroy .c
} -result {}

#
# COMMON TEST CLEANUP
#
if {[info exists bgerror]} {
    rename bgerror {}
}


test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup {
    destroy .c
    pack [canvas .c]
    update
} -body {
    imageCleanup
︙
507
508
509
510
511
512
513
514

515
516
517
518
519
520
521
522
523
524
525
526
527

546
547
548
549
550
551
552

553
554
555
556
557
558
559
560

561
562
563
564
565








-
+







-






test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body {
    image create bitmap i2 -file foo.bm -maskfile foo2.bm
    rename i2 {}
    list [expr {"i2" in [imageNames]}] [catch {i2 foo} msg] $msg
} -result {0 1 {invalid command name "i2"}}

#
# CLEANUP
# TESTFILE CLEANUP
#

removeFile foo.bm
removeFile foo2.bm
imageFinish
testutils forget image
cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Changes to tests/imgListFormat.test. 
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

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



-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+




-
-
+
+
+








# This file is a Tcl script to test out the default image data format
# ("list format") implementend in the file tkImgListFormat.c.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 2017 Simon Bachmann
# All rights reserved.
#
# Author: Simon Bachmann ([email protected])

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TEST INITIALIZATION
#

set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]

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

#
# TESTS
#

test imgListFormat-1.1 {ParseFormatOptions: default values} -setup {
    image create photo photo1
} -body {
    photo1 put {{red green} {blue black}}
    lindex [photo1 data] 1 1
} -cleanup {
︙
633
634
635
636
637
638
639
640

641
642
643
644
645
646

657
658
659
660
661
662
663

664
665
666
667
668
669









-
+





-

} -body {
    photo1 put {#1111 #1111#1}
} -cleanup {
    imageCleanup
} -returnCodes error -result {invalid color name "#1111#1"}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
testutils forget image
cleanupTests
return
Changes to tests/imgPNG.test. 
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

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


-
+
-







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+








# This file is a Tcl script to test out the code in tkImgFmtPNG.c, which reads
# and write PNG-format image files for photo widgets. The files is organized
# and write PNG-format image files for photo widgets.
# in the standard fashion for Tcl tests.
#
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 1998 Willem van Schaik (images only)
# Copyright © 2008 Donal K. Fellows
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

namespace eval png {
    variable encoded
    # Key names are from the names of the source images, which come from
    #    http://www.schaik.com/pngsuite/pngsuite.html
    # The exception is "BadX", which is used to test handling badly compressed
    # images.
︙
1062
1063
1064
1065
1066
1067
1068





1069
1070
1071
1072
1073
1074
1075

1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103








+
+
+
+
+








r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC"
    dpi100aspect2
"iVBORw0KGgoAAAANSUhEUgAAAAIAAAACCAIAAAD91JpzAAAACXBIWXMAAA9hAAAewgEw8YEEAAAA
FklEQVR4nGP4+vXrP11lJgYGhj9xSQAzOwXsETZ69QAAAABJRU5ErkJggg=="
	}

# $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08)

#
# TESTS
#

test imgPNG-1.1 {reading basic images; grayscale} -setup {
    catch {rename foo ""}
} -body {
    image create photo foo -data $encoded(basn0g08)
    list [image width foo] [image height foo]
} -cleanup {
    rename foo ""
︙
1126
1127
1128
1129
1130
1131
1132
1133

1134
1135
1136
1137
1138
1139
1140

1154
1155
1156
1157
1158
1159
1160

1161
1162
1163
1164
1165
1166
1167
1168








-
+








    image create photo i1 -data $encoded(dpi100aspect2)
    i1 cget -metadata
} -cleanup {
    image delete i1
} -result {DPI 99.9998 aspect 2.0}

test imgPNG-4.2 {file image with metadata} -setup {
    set path [file join [configure -tmpdir] test.png]
    set path [file join [tcltest::configure -tmpdir] test.png]
    set h [open $path "WRONLY BINARY CREAT"]
    puts -nonewline $h [binary decode base64 $encoded(dpi100aspect2)]
    close $h
} -body {
    image create photo i1 -file $path
    i1 cget -metadata
} -cleanup {
︙
1151
1152
1153
1154
1155
1156
1157
1158

1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172

1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184

1179
1180
1181
1182
1183
1184
1185

1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199

1200
1201
1202
1203
1204
1205
1206

1207
1208
1209
1210
1211








-
+













-
+






-






    i1 cget -metadata
} -cleanup {
    image delete i1
} -result {DPI 99.9998 aspect 2.0}

test imgPNG-4.4 {file output with metadata} -setup {
    image create photo i1 -data $encoded(dpi100aspect2)
    set path [file join [configure -tmpdir] test.png]
    set path [file join [tcltest::configure -tmpdir] test.png]
} -body {
    i1 write $path -format png
    image delete i1
    image create photo i1 -file $path
    i1 cget -metadata
} -cleanup {
    image delete i1
    file delete $path
} -result {DPI 99.9998 aspect 2.0}

}

#
# CLEANUP
# TESTFILE CLEANUP
#

namespace delete png
imageFinish
testutils forget image
cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Changes to tests/imgPPM.test. 
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

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



-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+









+
+
+
+








# This file is a Tcl script to test out the code in tkImgFmtPPM.c,
# which reads and write PPM-format image files for photo widgets.
# The files is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# LOCAL UTILITY PROCS
#

# Note that we do not use [tcltest::makeFile] because it is
# only suitable for text files
proc put {file data} {
    set f [open $file w]
    fconfigure $f -translation lf
    puts -nonewline $f $data
    close $f
}

#
# TESTS
#

test imgPPM-1.1 {FileReadPPM procedure} -body {
    put test.ppm "P6\n0 256\n255\nabcdef"
    image create photo p1 -file test.ppm
} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0}
test imgPPM-1.2 {FileReadPPM procedure} -body {
    put test.ppm "P6\n-2 256\n255\nabcdef"
︙
226
227
228
229
230
231
232
233

234
235
236
237
238
239
240
241
242
243
244

253
254
255
256
257
258
259

260
261
262
263
264
265
266

267
268
269
270








-
+






-





    ppm put "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789"
    list [image width ppm] [image height ppm]
} -cleanup {
    image delete ppm
} -result {5 4}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
catch {file delete test.ppm}
testutils forget image
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/imgPhoto.test. 
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

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


-
+
-









+

-
+









-
-








# This file is a Tcl script to test out the "photo" image type and the other
# procedures in the file tkImgPhoto.c. It is organized in the standard fashion
# procedures in the file tkImgPhoto.c.
# for Tcl tests.
#
# Copyright © 1994 The Australian National University
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2002-2008 Donal K. Fellows
# All rights reserved.
#
# Author: Paul Mackerras ([email protected])

# NOTES
#
# This file is somewhat caothic: the order of the tests does not
# This file is somewhat chaotic: the order of the tests does not
# really follow the order of the corresponding functions in
# tkImgPhoto.c. Probably, because early versions had only a few tests
# and over time test cases were added in bits and pieces.
# To be noted, also, that this file is not complete: large portions of
# code in tkImgPhoto.c have no test coverage.
#
# To help keeping the overview, the table below lists where to find
# tests for each of the functions in tkImgPhoto.c. The function are
# listed in the order as they appear in the source file.
#

#
# Function name                         Tests for function
#--------------------------------------------------------------------------
# PhotoFormatThreadExitProc             no tests
# Tk_Create*PhotoImageFormat            no tests
# ImgPhotoCreate                        imgPhoto-2.*
# ImgPhotoCmd                           imgPhoto-4.*, imgPhoto-17.*
︙
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

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








-
+
-

-
-












-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+














-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+









+
+
+








# ImgGetPhoto:                          no tests
# Tk_PhotoGetImage                      no tests
# ImgPostscriptPhoto                    no tests
# Tk_PhotoGetMetadata:                  imgPhoto-21.*
# Tk_PhotoSetMetadata:                  imgPhoto-22.*
#--------------------------------------------------------------------------
#

#
#
# Some tests are not specific to a function in tkImgPhoto.c. They are:
#

#
# Test name(s)          Description
#--------------------------------------------------------------------------
# imgPhoto-5.*          Do not really belong to this file. ImgPhotoGet and
#                       ImgPhotoFree are defined in tkImgPhInstance.c.
# imgPhoto-6.*          Do not really belong to this file. ImgPhotoDisplay
#                       is defined in tkImgPhInstance.c.
# imgPhoto-7.*          Do not really belong to this file. ImgPhotoFree is
#                       defined in tkImgPhInstance.c.
# imgPhoto-13.*         Tests for separation in different interpreters
# imgPhoto-14.*         Test GIF format. Would belong to imgGIF.test
#                       - which does not exist.
#

package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

#
# LOCAL UTILITY PROCS
#

proc checkImgTrans {img} {
    set result {}
    foreachPixel $img x y {
	if {[$img transparency get $x $y]} {
	    lappend result $x,$y
	}
    }
    return $result
}

proc checkImgTransLoop {img script1 script2} {
    set result {}
    foreachPixel $img x y {
	eval $script1
	lappend result {*}[checkImgTrans $img]
	append result :
	eval $script2
	lappend result {*}[checkImgTrans $img]
	append result .
    }
    return $result
}

#
# Used for imgPhoto-4.65 - imgPhoto-4.73
#
proc foreachPixel {img xVar yVar script} {
    upvar 1 $xVar x $yVar y
    set width [image width $img]
    set height [image height $img]
    for {set x 0} {$x<$width} {incr x} {
	for {set y 0} {$y<$height} {incr y} {
	    uplevel 1 $script
	}
    }
}
proc checkImgTrans {img} {
    set result {}
    foreachPixel $img x y {
	if {[$img transparency get $x $y]} {
	    lappend result $x,$y
	}

    }
    return $result
}
proc checkImgTransLoop {img script1 script2} {
    set result {}
    foreachPixel $img x y {
	eval $script1
	lappend result {*}[checkImgTrans $img]
	append result :
	eval $script2
	lappend result {*}[checkImgTrans $img]
	append result .
    }
    return $result
}
#
# COMMON TEST SETUP
#

imageInit
set README [makeFile {
    README -- Tk test suite design document.
} README-imgPhoto]

set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm]
set transpTeapotPhotoFile [file join [file dirname [info script]] teapotTransparent.png]

#
# TESTS
#

test imgPhoto-1.1 {options for photo images} -body {
    image create photo photo1 -width 79 -height 83
    list [photo1 cget -width] [photo1 cget -height] \
	[image width photo1] [image height photo1]
} -cleanup {
    image delete photo1
︙
2094
2095
2096
2097
2098
2099
2100



2101


2102
2103
2104
2105
2106
2107
2108

2121
2122
2123
2124
2125
2126
2127
2128
2129
2130

2131
2132
2133
2134
2135
2136
2137
2138
2139








+
+
+
-
+
+








} -body {
    photo1 configure -metadata {}
    photo1 cget -metadata
} -cleanup {
    catch {image delete photo1}
} -result {}

#
# COMMON TEST SETUP
#
# 23.x GIF images with metadata
# For tests imgPhoto-23.* : GIF images with metadata
#

# The following gif core data is used by the following data.
# N.B. this is the same image as test imgPhoto-18.10

# size 16x16, global color table size: 8
set gifstart "GIF89a\x10\x00\x10\x00\xc2\x07\x00"
# color table
︙
2130
2131
2132
2133
2134
2135
2136
2137

2138
2139
2140
2141
2142
2143
2144

2161
2162
2163
2164
2165
2166
2167

2168
2169
2170
2171
2172
2173
2174
2175








-
+









test imgPhoto-23.2 {GIF file comment before image data (-file)} -setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend
    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts -nonewline $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {
︙
2163
2164
2165
2166
2167
2168
2169
2170

2171
2172
2173
2174
2175
2176
2177

2194
2195
2196
2197
2198
2199
2200

2201
2202
2203
2204
2205
2206
2207
2208








-
+








test imgPhoto-23.4 {GIF comment after image data (-file)} -setup {
    set data $::gifstart
    append data $::gifdata
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifend
    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {
︙
2200
2201
2202
2203
2204
2205
2206
2207

2208
2209
2210
2211
2212
2213
2214

2231
2232
2233
2234
2235
2236
2237

2238
2239
2240
2241
2242
2243
2244
2245








-
+








    # Append a comment extension block with data "1234"
    append data "\x21\xfe\x04" "1234" "\x0"
    append data $::gifdata
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifend
    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -file $path
    gif1 cget -metadata
} -cleanup {
︙
2238
2239
2240
2241
2242
2243
2244
2245

2246
2247
2248
2249
2250
2251
2252

2269
2270
2271
2272
2273
2274
2275

2276
2277
2278
2279
2280
2281
2282
2283








-
+








-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict
    image create photo gif1 -file $path -metadata $metadataDict
︙
2279
2280
2281
2282
2283
2284
2285
2286

2287
2288
2289
2290
2291
2292
2293

2310
2311
2312
2313
2314
2315
2316

2317
2318
2319
2320
2321
2322
2323
2324








-
+








-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict
︙
2321
2322
2323
2324
2325
2326
2327
2328

2329
2330
2331
2332
2333
2334
2335

2352
2353
2354
2355
2356
2357
2358

2359
2360
2361
2362
2363
2364
2365
2366








-
+








-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict
︙
2364
2365
2366
2367
2368
2369
2370
2371

2372
2373
2374
2375
2376
2377
2378

2395
2396
2397
2398
2399
2400
2401

2402
2403
2404
2405
2406
2407
2408
2409








-
+








-setup {
    set data $::gifstart
    # Append a comment extension block with data "ABCD"
    append data "\x21\xfe\x04" "ABCD" "\x0"
    # Trailer
    append data $::gifdata $::gifend

    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
    set h [open $path "WRONLY BINARY CREAT"]
    puts $h $data
    close $h
} -body {
    image create photo gif1 -data "$::gifstart$::gifdata$::gifend"
    set metadataDict [dict create A 1]
    set metadataDict2 $metadataDict
︙
2403
2404
2405
2406
2407
2408
2409
2410

2411
2412
2413
2414
2415
2416
2417

2434
2435
2436
2437
2438
2439
2440

2441
2442
2443
2444
2445
2446
2447
2448








-
+








} -cleanup {
    catch {image delete gif1}
} -match glob -result {*ABCD*}

test imgPhoto-23.17 {output file with comment (from -metadata property)}\
-setup {
    set data $::gifstart$::gifdata$::gifend
    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
} -body {
    image create photo gif1 -data $data
    gif1 configure -metadata [dict create comment ABCD]
    gif1 write $path -format gif
    image delete gif1
    image create photo gif1 -file $path
    dict get [gif1 cget -metadata] comment
︙
2434
2435
2436
2437
2438
2439
2440
2441

2442
2443
2444
2445
2446
2447
2448

2465
2466
2467
2468
2469
2470
2471

2472
2473
2474
2475
2476
2477
2478
2479








-
+








} -cleanup {
    catch {image delete gif1}
} -result {comment ABCD}

test imgPhoto-23.19 {write: empty metadata parameter overwrites image metadata} -setup {
    image create photo gif1 -data $::gifstart$::gifdata$::gifend\
	    -metadata {comment bar}
    set path [file join [configure -tmpdir] test.gif]
    set path [file join [tcltest::configure -tmpdir] test.gif]
} -body {
    gif1 write $path -format gif -metadata {}
    image delete gif1
    image create photo gif1 -file $path
    dict size [gif1 cget -metadata]
} -cleanup {
    catch {image delete gif1}
︙
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608






2609

2610
2611
2612
2613
2614
2615
2616

2630
2631
2632
2633
2634
2635
2636



2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651








-
-
-
+
+
+
+
+
+

+








} -body {
    image create photo gif1 -data $data -format "gif -index 1"
    gif1 cget -metadata
} -cleanup {
    catch {image delete gif1}
} -result {{update region} {0 0 16 16} {delay time} 4096 {disposal method} {do not dispose} {user interaction} 1}

unset -nocomplain gifstart gifdata gifend


#
# COMMON TEST SETUP
#
# For tests imgPhoto-24.*
#
unset -nocomplain gifstart gifdata gifend
set earthPhotoFile [file join [file dirname [info script]] earth.gif]

test imgPhoto-24.1 {Read GIF file with -from option - Bug [1576528]} -body {
    set earthPhotoFile [file join [file dirname [info script]] earth.gif]
    image create photo gif1
    gif1 read $earthPhotoFile -from 152 62 185 97
    list [lindex [lindex [gif1 data] 0] 0] [image width gif1] [image height gif1]
} -cleanup {
    catch {image delete gif1}
︙
2651
2652
2653
2654
2655
2656
2657
2658
2659







2660

2661
2662
2663
2664
2665
2666
2667

2686
2687
2688
2689
2690
2691
2692


2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708








-
-
+
+
+
+
+
+
+

+








    set earthPhotoFile [file join [file dirname [info script]] earth.gif]
    image create photo gif1
    catch {gif1 read $earthPhotoFile -from 152 62 2000 1000} msg
    list $msg [image width gif1] [image height gif1]
} -cleanup {
    catch {image delete gif1}
} -result {{coordinates for -from option extend outside source image} 0 0}
unset earthPhotoFile


#
# COMMON TEST SETUP
#
# For tests imgPhoto-25.*
#
unset earthPhotoFile
set ousterPhotoFile [file join [file dirname [info script]] ouster.png]

test imgPhoto-25.1 {Read PNG file with -from option - Bug [1576528]} -body {
    image create photo png1
    png1 read $ousterPhotoFile -from 102 62 135 97
    list [lindex [lindex [png1 data] 0] 0] [image width png1] [image height png1]
} -cleanup {
    catch {image delete png1}
} -result {{#c97962} 33 35}
︙
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707

2708
2709

2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722

2738
2739
2740
2741
2742
2743
2744

2745
2746

2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758

2759
2760
2761
2762








-


-
+


+








-





test imgPhoto-25.6 {Read PNG file with -from option, read large region from small file} -body {
    image create photo png1
    catch {png1 read $ousterPhotoFile -from 102 62 2000 1000} msg
    list $msg [image width png1] [image height png1]
} -cleanup {
    catch {image delete png1}
} -result {{coordinates for -from option extend outside source image} 0 0}
unset ousterPhotoFile

#
# CLEANUP
# TESTFILE CLEANUP
#

unset ousterPhotoFile
catch {rename foreachPixel {}}
catch {rename checkImgTrans {}}
catch {rename checkImgTransLoop {}}
imageFinish
removeFile README-imgPhoto

testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/imgSVGnano.test. 
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

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


-
+
-




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+







+
+
+
+








# This file is a Tcl script to test out the code in tkImgSVGnano.c, which reads
# and write SVG-format image files for photo widgets. The files is organized
# and write SVG-format image files for photo widgets.
# in the standard fashion for Tcl tests.
#
# Copyright © 2018 Rene Zaumseil
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

namespace eval svgnano {

    #
    # COMMON TEST SETUP
    #

    variable data

    set data(plus) {\
	    <svg xmlns="http://www.w3.org/2000/svg" width="100" height="100">
		<path fill="none" stroke="#000000" d="M0 0 h16 v16 h-16 z"/>
		<path fill="none" stroke="#000000" d="M8 4 v 8 M4 8 h 8"/>
︙
36
37
38
39
40
41
42



43
44
45
46
47
48
49

59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75








+
+
+









    tcltest::makeFile $data(plus) plus.svg
    set data(plusFilePath) [file join [tcltest::configure -tmpdir] plus.svg]

    tcltest::makeFile $data(bad) bad.svg
    set data(badFilePath) [file join [tcltest::configure -tmpdir] bad.svg]

#
# TESTS
#

test imgSVGnano-1.1 {reading simple image} -setup {
    catch {rename foo ""}
} -body {
    image create photo foo -data $data(plus)
    list [image width foo] [image height foo]
} -cleanup {
︙
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








+
+
+






-
+






-






			"-//W3C//DTD SVG 1.0//EN\" \
			"http://www.w3.org/TR/2001/REC-SVG-20010904/DTD/svg10.dtd">\
			<sERRORvBADFILEg xmlns="http://www.w3.org/2000/svg">\
			<circle cx="6.5cm" cy="2cm" r="100" transform="skewX(1 1)"/>\
			</g></svg>}
} -returnCodes error -result {couldn't recognize image data}

    #
    # COMMON TEST CLEANUP
    #
    tcltest::removeFile plus.svg
    tcltest::removeFile bad.svg

};# end of namespace svgnano

#
# CLEANUP
# TESTFILE CLEANUP
#

namespace delete svgnano
imageFinish
testutils forget image
cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Changes to tests/listbox.test. 
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

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
-
-
+
-

-
-
+
-
-
-
+
+
+
+
+
+




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+














-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+



-





-



+

+
+
+
+
+








# This file is a Tcl script to test out the "listbox" command
# of Tk.  It is organized in the standard fashion for Tcl tests.
# of Tk.
#
# Copyright © 1993-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
namespace import -force tcltest::test

}
set fixed {Courier -12}

proc record {name args} {
    global log
# Ensure a pristine initial window state
    lappend log [format {%s %.6g %.6g} $name {*}$args]
}

resetWindows

#
# LOCAL UTILITY PROCS
#

proc getsize w {
    regexp {(^[^+-]*)} [wm geometry $w] foo x
    return $x
}

# mkPartial --
#
# Creates a second listbox for checking things related
# to partially visible lines.
#
proc mkPartial {{w .partial}} {
    destroy $w
    toplevel $w
    wm geometry $w +0+0
    listbox $w.l -width 30 -height 5
    pack $w.l -expand 1 -fill both
    $w.l insert end one two three four five six seven eight nine ten \
	    eleven twelve thirteen fourteen fifteen
    update
    scan [wm geometry $w] "%dx%d" width height
    wm geometry $w ${width}x[expr $height-3]
    update
}

proc record {name args} {
    global log
    lappend log [format {%s %.6g %.6g} $name {*}$args]
}

proc resetGridInfo {} {
    # Some window managers, such as mwm, don't reset gridding information
    # unless the window is withdrawn and re-mapped.  If this procedure
    # isn't invoked, the window manager will stay in gridded mode, which
    # can cause all sorts of problems.  The "wm positionfrom" command is
    # needed so that the window manager doesn't ask the user to
    # manually position the window when it is re-mapped.

    wm withdraw .
    wm positionfrom . user
    wm deiconify .
}

# Procedure that creates a second listbox for checking things related
# to partially visible lines.

#
# COMMON TEST SETUP
#
proc mkPartial {{w .partial}} {
    destroy $w
    toplevel $w
    wm geometry $w +0+0
    listbox $w.l -width 30 -height 5
    pack $w.l -expand 1 -fill both
    $w.l insert end one two three four five six seven eight nine ten \
	    eleven twelve thirteen fourteen fifteen
    update
    scan [wm geometry $w] "%dx%d" width height
    wm geometry $w ${width}x[expr $height-3]
    update
}

set fixed {Courier -12}

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Listbox.borderWidth 2
option add *Listbox.selectBorderWidth 1
option add *Listbox.highlightThickness 2
option add *Listbox.font {Helvetica -12 bold}

# Listbox used in 3.* configuration options tests
listbox .l
pack .l
update

resetGridInfo

#
# TESTS
#

test listbox-1.1 {configuration options} -body {
    .l configure -activestyle under
    list [lindex [.l configure -activestyle] 4] [.l cget -activestyle]
} -cleanup {
    .l configure -activestyle [lindex [.l configure -activestyle] 3]
} -result {underline underline}
test listbox-1.2 {configuration options} -body {
︙
345
346
347
348
349
350
351
352
353





354
355
356
357
358
359

360
361
362
363
364
365
366

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








-
-
+
+
+
+
+






+








    destroy .l
} -body {
    listbox .l
} -cleanup {
    destroy .l
} -result {.l}


# Listbox used in 3.1 -3.115 tests
#
# COMMON TEST SETUP
#
# For tests listbox-3.1 - 3.115
#
destroy .l
listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
pack .l
.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
	el15 el16 el17
update

test listbox-3.1 {ListboxWidgetCmd procedure} -body {
    .l
} -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"}
test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} -body {
    .l activate
} -returnCodes error -result {wrong # args: should be ".l activate index"}
test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} -body {
︙
1122
1123
1124
1125
1126
1127
1128



1129


1130
1131
1132
1133
1134
1135

1136
1137
1138
1139
1140
1141
1142

1160
1161
1162
1163
1164
1165
1166
1167
1168
1169

1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185








+
+
+
-
+
+






+








    .l insert 0 a b c d e f g h i j k l m n o p q r s t
    mkPartial
    format {%.6g %.6g} {*}[.partial.l yview]
} -cleanup {
    destroy .l
} -result {0 0.266667}

#
# COMMON TEST SETUP
#
# Listbox used in 3.127 -3.137 tests
# For tests listbox-3.127 - 3.137
#
destroy .l
listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2
pack .l
.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \
	el15 el16 el17
update

test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body {
    .l yview foo
} -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or an index}
test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} -body {
    .l yview foo a b
} -returnCodes error -result {unknown option "foo": must be moveto or scroll}
test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} -setup {
︙
1226
1227
1228
1229
1230
1231
1232




1233

1234
1235
1236
1237
1238
1239
1240

1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288








+
+
+
+

+








    set x [getsize .]
    .l configure -setgrid 0
    update
    list $x [getsize .]
} -cleanup {
    deleteWindows
} -result {25x15 185x263}

#
# COMMON TEST CLEANUP
#
resetGridInfo

test listbox-4.2 {ConfigureListbox procedure} -setup {
    deleteWindows
    destroy .l
    listbox .l -setgrid 1 -width 25 -height 15
    pack .l
    update
} -body {
︙
1349
1350
1351
1352
1353
1354
1355



1356

1357
1358
1359
1360
1361
1362
1363

1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415








+
+
+

+








    update
    lappend result [getsize .]
} -cleanup {
    deleteWindows
    wm geom . {}
} -result {30x20 26x15 26x15}

#
# COMMON TEST CLEANUP
#
resetGridInfo

test listbox-4.8 {ConfigureListbox procedure} -setup {
    destroy .l2
} -body {
    listbox .l2 -width 15 -height 20 -xscrollcommand "record x" \
	    -yscrollcommand "record y"
    pack .l2
    update
︙
1549
1550
1551
1552
1553
1554
1555
1556
1557




1558
1559
1560
1561

1562
1563
1564
1565
1566
1567
1568

1601
1602
1603
1604
1605
1606
1607


1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623








-
-
+
+
+
+




+









    pack [listbox .l -font {{open look glyph}}]
    update
} -cleanup {
    destroy .l
} -result {}


# Listbox used in 6.*, 7.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-6.* and listbox-7.*
destroy .l
listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y"
pack .l
update

test listbox-6.1 {InsertEls procedure} -body {
    .l delete 0 end
    .l insert end a b c d
    .l insert 5 x y z
    .l insert 2 A
    .l insert 0 q r s
    .l get 0 end
︙
1868
1869
1870
1871
1872
1873
1874




1875

1876
1877
1878
1879
1880
1881
1882

1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942








+
+
+
+

+








    update
    set x [getsize .]
    destroy .l
    list $x [getsize .] [winfo exists .l] [info command .l]
} -cleanup {
    destroy .l
} -result {20x10 150x178 0 {}}

#
# COMMON TEST CLEANUP
#
resetGridInfo

test listbox-8.2 {ListboxEventProc procedure} -constraints {
	fonts
} -setup {
    destroy .l
} -body {
    listbox .l -height 5 -width 10
    .l insert 0 a b c "A string that is very very long" d e f g h i j k
︙
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942

1986
1987
1988
1989
1990
1991
1992



1993
1994
1995
1996
1997
1998
1999








-
-
-








    rename .top.l {}
    update
    lappend x [getsize .top]
} -cleanup {
    destroy .top
} -result {20x10 150x178}


# Listbox used in 10.* tests
destroy .l
test listbox-10.1 {GetListboxIndex procedure} -setup {
    destroy .l
} -body {
    pack [listbox .l]
    .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11
    .l activate 3
    update
︙
2224
2225
2226
2227
2228
2229
2230
2231
2232





2233
2234
2235
2236
2237

2238
2239
2240
2241
2242
2243
2244

2281
2282
2283
2284
2285
2286
2287


2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305








-
-
+
+
+
+
+





+








    mkPartial
    .partial.l yview 13
    .partial.l index @0,0
} -cleanup {
    destroy .l
} -result 11


# Listbox used in 12.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-12.*
#
destroy .l
listbox .l -font $fixed -xscrollcommand "record x" -width 10
.l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789
pack .l
update

test listbox-12.1 {ChangeListboxOffset procedure} -constraints {
	fonts
} -body {
    set log {}
    .l xview 99
    update
    list [format {%.6g %.6g} {*}[.l xview]] $log
︙
2259
2260
2261
2262
2263
2264
2265
2266
2267





2268
2269
2270
2271
2272
2273
2274
2275

2276
2277
2278
2279
2280
2281
2282

2320
2321
2322
2323
2324
2325
2326


2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347








-
-
+
+
+
+
+








+








    update
    set log {}
    .l xview 10
    update
    list [format {%.6g %.6g} {*}[.l xview]] $log
} -result {{0.1 0.2} {}}


# Listbox used in 13.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-13.*
#
destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
.l insert 0 a bb c d e f g h i j k l m n o p q r s
.l insert 0 0123456789a123456789b123456789c123456789d123456789
update
set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]]
set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]]

test listbox-13.1 {ListboxScanTo procedure} -constraints {
	fonts
} -body {
    .l yview 0
    .l xview 0
    .l scan mark 10 20
    .l scan dragto [expr 10-$width] [expr 20-$height]
︙
2311
2312
2313
2314
2315
2316
2317
2318






2319
2320
2321
2322
2323
2324

2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342





2343
2344
2345
2346

2347
2348
2349
2350
2351
2352
2353

2376
2377
2378
2379
2380
2381
2382

2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411


2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428








-
+
+
+
+
+
+






+
















-
-
+
+
+
+
+




+








} -result {{0.8 1} {0.75 1} {0.6 0.8} {0.25 0.5}}


test listbox-14.1 {NearestListboxElement procedure, partial last line} -body {
    mkPartial
    .partial.l nearest [winfo height .partial.l]
} -result 4
# Listbox used in 14.* tests

#
# COMMON TEST SETUP
#
# For tests listbox-14.*
#
destroy .l
listbox .l -font $fixed -width 20 -height 10
.l insert 0 a b c d e f g h i j k l m n o p q r s t
.l yview 4
pack .l
update

test listbox-14.2 {NearestListboxElement procedure} -constraints {
	fonts
} -body {
    .l index @50,0
} -result 4
test listbox-14.3 {NearestListboxElement procedure} -constraints {
	fonts
} -body {
    list [.l index @50,35] [.l index @50,36]
} -result {5 6}
test listbox-14.4 {NearestListboxElement procedure} -constraints {
	fonts
} -body {
    .l index @50,200
} -result 13


# Listbox used in 15.* 16.* and 17.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-15.* 16.* and 17.*
#
destroy .l
listbox .l -font $fixed -width 20 -height 10
pack .l
update

test listbox-15.1 {ListboxSelect procedure} -body {
    .l delete 0 end
    .l insert 0 a b c d e f g h i j k l m n o p
    .l select set 2 4
    .l select set 7 12
    .l select clear 4 7
    .l curselection
︙
2480
2481
2482
2483
2484
2485
2486
2487
2488





2489
2490
2491
2492

2493
2494
2495
2496
2497
2498
2499

2555
2556
2557
2558
2559
2560
2561


2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578








-
-
+
+
+
+
+




+








    .e select from 0
    .e select to 5
    .l curselection
} -cleanup {
    destroy .e
} -result {0 1 2 3 4}


# Listbox used in 18.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-18.*
#
destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
update

test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body {
    .l configure -yscrollcommand "record y"
    set log {}
    .l insert 0 a b c
    update
    .l insert end d e f g h
    update
︙
2521
2522
2523
2524
2525
2526
2527
2528
2529





2530
2531
2532
2533

2534
2535
2536
2537
2538
2539
2540

2600
2601
2602
2603
2604
2605
2606


2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623








-
-
+
+
+
+
+




+








} -cleanup {
    rename bgerror {}
} -result {{{invalid command name "gorp"}} {invalid command name "gorp"
    while executing
"gorp 0.0 1.0"
    (vertical scrolling command executed by listbox)}}


# Listbox used in 19.* tests
#
# COMMON TEST SETUP
#
# For tests listbox-19.*
#
destroy .l
listbox .l -font $fixed -width 10 -height 5
pack .l
update

test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints {
	fonts
} -body {
    .l configure -xscrollcommand "record x"
    set log {}
    .l insert 0 abc
    update
︙
2870
2871
2872
2873
2874
2875
2876



2877


2878
2879
2880

2881
2882
2883
2884
2885
2886
2887

2953
2954
2955
2956
2957
2958
2959
2960
2961
2962

2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975








+
+
+
-
+
+



+








    list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \
	    [.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \
	    [.l itemcget 6 -bg]
} -cleanup {
    destroy .l
} -result {red orange yellow green blue white violet}

#
# COMMON TEST SETUP
#
# Listbox used in 23.6 -23.17 tests
# For tests listbox-23.6 - 23.17
#
destroy .l
listbox .l
.l insert end a b c d

test listbox-23.6 {configuration options} -body {
    .l itemconfigure 0 -background #ff0000
    list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background]
} -cleanup {
    .l configure -background #ffffff
} -result {{#ff0000} #ff0000}
test listbox-23.7 {configuration options} -body {
︙
3207
3208
3209
3210
3211
3212
3213
3214

3215
3216
3217
3218
3219
3220
3221
3222

3295
3296
3297
3298
3299
3300
3301

3302
3303
3304
3305
3306
3307
3308
3309









-
+







-

    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}

#
# CLEANUP
# TESTFILE CLEANUP
#

resetGridInfo
deleteWindows
option clear
rename getsize {}
cleanupTests
return
Changes to tests/main.tcl. 
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

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



+
+
-
-
-
+
+
+
+
+
+




+
+
+
+
+



-
-
+
+
-
-
-
-
-
-
-
+
+
+


-
-
-
-
-
-
+
-
-
-
+
+
-
-
+

-
-
-
+
-
-
-
-
+
-
-
+
-




-
-
-
+
-
-
+
+
+




-
-
-
-
-
-
-


# main.tcl --
#
# This file holds initialization code that is common to each testfile. In mode
# "-singleproc 0" it is loaded into each interpreter by invoking the command
# This file is loaded by each test file when invoking "tcltest::loadTestedCommands".
# It performs an initial Tk setup for the root window, and loads, in turn,
# definitions of global utility procs and test constraints.
# "tcltest::loadTestedCommands". In mode "-singleproc 1" it is sourced once into
# the current interpreter by all.tcl, before evaluating any test file.
#
# It performs an initial Tk setup for the root window, imports commands from
# the tcltest namespace, and loads definitions of global utility procs and
# test constraints.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

# Error out if this file is loaded repeatedly into the same interpreter
if {[namespace exists ::tk::test]} {
    return -code error "repeated loading of file \"main.tcl\""
}

#
# SETUP FOR APPLICATION AND ROOT WINDOW
#
if {[namespace exists tk::test]} {
    # reset windows
encoding system utf-8
if {[tcltest::configure -singleproc] == 0} {
    deleteWindows
    wm geometry . {}
    raise .
    return
}

package require tk
    # Support test suite invocation by tclsh (as is the case with "-singleproc 1")
    package require tk
}
tk appname tktest
wm title . tktest
# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.

if {![winfo ismapped .]} {
    wm geometry . +0+0
wm geometry . +0+0
    update
}


#
#
# LOAD AND CONFIGURE TEST HARNESS
# IMPORT TCLTEST COMMANDS
#
package require tcltest 2.2
eval tcltest::configure $argv
namespace import -force tcltest::test
namespace import -force tcltest::cleanupTests tcltest::interpreter \
namespace import -force tcltest::makeFile
namespace import -force tcltest::removeFile
namespace import -force tcltest::makeDirectory
namespace import -force tcltest::removeDirectory
	tcltest::makeDirectory tcltest::makeFile tcltest::removeDirectory \
namespace import -force tcltest::interpreter
namespace import -force tcltest::testsDirectory
	tcltest::removeFile tcltest::test tcltest::testsDirectory
namespace import -force tcltest::cleanupTests

#
# SOURCE DEFINITIONS OF GLOBAL UTILITY PROCS AND CONSTRAINTS
#
# Note: tcltest uses [uplevel] to evaluate this script. Therefore, [info script]
#       cannot be used to determine the main Tk test directory, and we use
#       [tcltest::configure -loadfile] instead.
set mainTestDir [tcltest::configure -testdir]
#
set mainTestDir [file dirname [tcltest::configure -loadfile]]
if {[file tail $mainTestDir] eq "ttk"} {
    set mainTestDir [file dirname $mainTestDir]
}
source [file join $mainTestDir testutils.tcl]
source [file join $mainTestDir constraints.tcl]
unset mainTestDir

#
# RESET WINDOWS
#
deleteWindows
wm geometry . {}
raise .

# EOF
Changes to tests/main.test. 
1
2
3
4
5
6
7
8
9
10


















11

12
13
14









15
16
17
18
19
20
21

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



-
-
-
-




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file contains tests for the tkMain.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test main-1.1 {StdinProc} -constraints stdio -setup {
    set script [makeFile {close stdin; exit} script]
} -body {
    exec [interpreter] <$script
} -cleanup {
    removeFile script
︙
108
109
110
111
112
113
114



115

116
117

128
129
130
131
132
133
134
135
136
137

138
139









+
+
+
-
+

-

    # Repeat of 3.2 to catch cleanup, eg Bug 1927135
    $maininterp eval { set argc 1 ; set argv -help }
    load {} Tk $maininterp
} -cleanup {
    interp delete $maininterp
} -returnCodes error -match glob -result {Command-specific options:*}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return
Changes to tests/menu.test. 
1

2
3
4
5
6
7


















8

9
10
11





12
13
14
15
16
17



18
19
20
21
22
23
24


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

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+






+
+
+








# This file is a Tcl script to test menus in Tk.  It is
# This file is a Tcl script to test menus in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1995-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TESTS
#

test menu-1.1 {Tk_MenuCmd procedure} -body {
    menu
} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"}
test menu-1.2 {Tk_MenuCmd procedure} -body {
    menu bogus
} -returnCodes error -result {bad window path name "bogus"}
︙
145
146
147
148
149
150
151



152


153
154

155
156
157
158
159
160
161

167
168
169
170
171
172
173
174
175
176

177
178
179
180
181
182
183
184
185
186
187
188








+
+
+
-
+
+


+








    toplevel .t4 -menu .m1
    wm geometry .t4 +0+0
    list [menu .m1]
} -cleanup {
    deleteWindows
} -result {.m1}

#
# COMMON TEST SETUP
#
# Used for 2.1 - 2.30 tests
# For tests 2.1 - 2.30
#
destroy .m1
menu .m1

test menu-2.1 {configuration options -activebackground #012345} -body {
    .m1 configure -activebackground #012345
    .m1 cget -activebackground
} -result {#012345}
test menu-2.2 {configuration options -activebackground non-existent} -body {
    .m1 configure -activebackground non-existent
} -returnCodes error -result {unknown color name "non-existent"}
︙
276
277
278
279
280
281
282
283






284
285
286
287
288
289
290

303
304
305
306
307
308
309

310
311
312
313
314
315
316
317
318
319
320
321
322








-
+
+
+
+
+
+








    .m1 configure -tearoff 1
    .m1 cget -tearoff
} -result 1
test menu-2.30 {configuration options -tearoffcommand {any old string}} -body {
    .m1 configure -tearoffcommand {any old string}
    .m1 cget -tearoffcommand
} -result {any old string}
destroy .m1

#
# COMMON TEST SETUP
#
# For tests 2.31 - 2.228
#

# We need to test all of the options with all of the different types of
# menu entries. The following code sets up .m1 with 6 items. It then
# runs through the 2.31 - 2.228 tests below
# index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton,
# 5 radiobutton
deleteWindows
︙
1189
1190
1191
1192
1193
1194
1195



1196
1197
1198
1199
1200
1201
1202
1203
1204
1205

1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232

1233
1234
1235
1236
1237
1238
1239








+
+
+


-








    .m1 entryconfigure 4 -underline 3p
} -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""}

test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body {
    .m1 entryconfigure 5 -underline 3p
} -returnCodes error -result {bad index "3p": must be integer?[+-]integer?, end?[+-]integer?, or ""}

#
# COMMON TEST CLEANUP
#
deleteWindows
image delete image1


test menu-3.1 {MenuWidgetCmd procedure} -setup {
    destroy .m1
} -body {
    menu .m1
    .m1
} -cleanup {
︙
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382

2402
2403
2404
2405
2406
2407
2408

2409
2410
2411
2412
2413
2414
2415








-








} -body {
    menu .m1
    .m1 add command -label "one"
    .m1 clone .m2 tearoff
    list [.m2 delete 1] [destroy .m1]
} -result {{} {}}


# test menu-9 - Can only change when fonts change on system, which cannot
# be done from tcl.
test menu-9.1 {ConfigureMenu} -setup {
    destroy .m1
} -body {
    menu .m1
    list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand]
︙
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716

2734
2735
2736
2737
2738
2739
2740


2741
2742
2743
2744
2745
2746
2747








-
-








    .m1 add checkbutton -image image1 -selectimage image2
    .m1 entryconfigure 1 -selectimage image3
} -cleanup {
    deleteWindows
    imageCleanup
} -result {}

unset earthPhotoFile


test menu-12.1 {ConfigureMenuCloneEntries} -setup {
    deleteWindows
} -body {
    menu .m1
    .m1 clone .m2
    .m2 configure -tearoff 0
︙
4283
4284
4285
4286
4287
4288
4289
4290

4291
4292

4293
4294
4295
4296
4297
4298
4299
4300
4301

4314
4315
4316
4317
4318
4319
4320

4321
4322
4323
4324
4325
4326
4327
4328

4329
4330
4331
4332








-
+


+




-





    .m add command -label 3
    .m index last
} -cleanup {
    destroy .m
} -result {2}

#
# CLEANUP
# TESTFILE CLEANUP
#

unset earthPhotoFile
imageFinish
deleteWindows
testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/menuDraw.test. 
1

2
3
4
5
6
7


















8

9
10
11





12
13
14
15
16




17
18
19
20
21
22
23


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

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+








# This file is a Tcl script to test drawing of menus in Tk.  It is
# This file is a Tcl script to test drawing of menus in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# TESTS
#

test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup {
    deleteWindows
} -body {
    menu .m1
} -cleanup {
    deleteWindows
︙
707
708
709
710
711
712
713
714

715
716
717
718
719
720
721
722
723
724
725

730
731
732
733
734
735
736

737
738
739
740
741
742
743

744
745
746
747








-
+






-





    set tearoff [tk::TearOffMenu .m1 40 40]
    $tearoff postcascade 0
} -cleanup {
    deleteWindows
} -result {}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
deleteWindows
testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/menubut.test. 
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


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

-
+
-






+
+
-
-
-
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+











-



+
+
+
+
+








# This file is a Tcl script to test menubuttons in Tk.  It is
# This file is a Tcl script to test menubuttons in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# XXX This test file is woefully incomplete right now.  If any part
# XXX of a procedure has tests then the whole procedure has tests,
# XXX but many procedures have no tests.
# This test file is woefully incomplete right now.  If any part
# of a procedure has tests then the whole procedure has tests,
# but many procedures have no tests.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Menubutton.borderWidth 2
option add *Menubutton.highlightThickness 2
option add *Menubutton.font {Helvetica -12 bold}
option add *Button.borderWidth 2
option add *Button.highlightThickness 2
option add *Button.font {Helvetica -12 bold}


menubutton .mb -text "Test"
pack .mb
update

#
# TESTS
#

test menubutton-1.1 {configuration options} -body {
    .mb configure -activebackground #012345
    .mb cget -activebackground
} -cleanup {
    .mb configure -activebackground [lindex [.mb configure -activebackground] 3]
} -result {#012345}
test menubutton-1.2 {configuration options} -body {
︙
314
315
316
317
318
319
320
321



322
323
324
325

326
327
328
329
330
331
332

343
344
345
346
347
348
349

350
351
352
353
354
355
356
357
358
359
360
361
362
363
364








-
+
+
+




+








} -cleanup {
    .mb configure -wraplength [lindex [.mb configure -wraplength] 3]
} -result 100
test menubutton-1.59 {configuration options} -body {
    .mb configure -wraplength 6x
} -returnCodes error -result {expected screen distance but got "6x"}


#
# COMMON TEST SETUP
#
deleteWindows
menubutton .mb -text "Test"
pack .mb
update

test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body {
    menubutton
} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"}
test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body {
    menubutton foo
} -returnCodes error -result {bad window path name "foo"}
test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body {
︙
342
343
344
345
346
347
348
349



350
351
352

353
354
355
356
357
358
359

374
375
376
377
378
379
380

381
382
383
384
385
386
387
388
389
390
391
392
393
394








-
+
+
+



+








test menubutton-2.5 {Tk_ButtonCmd procedure} -setup {
    destroy .mb
} -body {
    catch {menubutton .mb -gorp foo}
    winfo exists .mb
} -result 0


#
# COMMON TEST SETUP
#
deleteWindows
menubutton .mb -text "Test Menu"
pack .mb

test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body {
    .mb
} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"}
test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body {
    .mb c
} -returnCodes error -result {ambiguous option "c": must be cget or configure}
test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body {
︙
382
383
384
385
386
387
388




389
390
391
392


393
394
395
396
397
398
399

417
418
419
420
421
422
423
424
425
426
427
428
429


430
431
432
433
434
435
436
437
438








+
+
+
+


-
-
+
+








    .mb configure -fg #123456
    .mb configure -bg #654321
    lindex [.mb configure -fg] 4
} -result {#123456}
test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body {
    .mb foobar
} -returnCodes error -result {bad option "foobar": must be cget or configure}

#
# COMMON TEST CLEANUP
#
deleteWindows

# XXX Need to add tests for several procedures here.   The tests for   XXX
# XXX ConfigureMenuButton aren't complete either.                      XXX
# Need to add tests for several procedures here.   The tests for   XXX
# ConfigureMenuButton aren't complete either.                      XXX

test menubutton-4.1 {ConfigureMenuButton procedure} -setup {
    deleteWindows
} -body {
    button .mb1 -text "Menubutton 1"
    .mb1 configure -width 1i
} -cleanup {
︙
513
514
515
516
517
518
519
520
521
522

523
524
525
526
527
528
529

552
553
554
555
556
557
558



559
560
561
562
563
564
565
566








-
-
-
+








    menubutton .mb -text "Test"
    catch {.mb configure -direction badValue}
    list [.mb cget -direction] [destroy .mb]
} -cleanup {
    deleteWindows
} -result {below {}}



# XXX Need to add tests for several procedures here. XXX
# Need to add tests for several procedures here. XXX

test menubutton-5.1 {MenuButtonEventProc procedure} -setup {
    deleteWindows
    set x {}
} -body {
    menubutton .mb1 -bg #543210
    rename .mb1 .mb2
︙
542
543
544
545
546
547
548



549
550
551
552
553

554
555
556
557
558
559
560

579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601








+
+
+





+








    menubutton .mb1
    rename .mb1 {}
    list [info command .mb*] [winfo children .]
} -cleanup {
    deleteWindows
} -result {{} {}}

#
# COMMON TEST SETUP
#
if {[tk windowingsystem] eq "aqua"} {
    set extraWidth 36
} else {
    set extraWidth 0
}

test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints {
    testImageType
} -setup {
    deleteWindows
    image create test image1
} -body {
    menubutton .mb -image image1 -bd 4 -highlightthickness 0
︙
780
781
782
783
784
785
786
787

788
789
790
791
792
793
794
795
796
797
798
799
800

821
822
823
824
825
826
827

828
829
830
831
832
833
834
835
836

837
838
839
840








-
+








-





    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
option clear
imageFinish

testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/message.test. 
1
2

3
4
5
6
7
8


















9

10
11
12





13



14
15
16
17
18
19
20

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+








# This file is a Tcl script to test out the "message" command
# of Tk.  It is organized in the standard fashion for Tcl tests.
# of Tk.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-2000 Ajuba Solutions.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::loadTestedCommands
eval tcltest::configure $argv
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test message-1.1 {configuration option: "anchor"} -setup {
    message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold}
    pack .m
    update
} -body {
    .m configure -anchor w
︙
503
504
505
506
507
508
509
510




511
512

526
527
528
529
530
531
532
533
534
535
536
537
538










+
+
+
+

-

    }}}
    pack .b
    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}

#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/msgbox.test. 
1
2
3
4
5
6
7


















8

9
10
11





12
13
14




















15
16
17
18
19
20
21

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


-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out Tk's "tk_messageBox" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog

#
# LOCAL UTILITY PROCS
#

proc ChooseMsg {parent btn} {
    if {! $::dialogIsNative} {
	after 100 SendButtonPress $parent $btn mouse
    }
}

proc ChooseMsgByKey {parent btn} {
    if {! $::dialogIsNative} {
	after 100 SendButtonPress $parent $btn key
    }
}

#
# TESTS
#

test msgbox-1.1.1 {tk_messageBox command} -constraints notAqua -body {
    tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}
test msgbox-1.1.2 {tk_messageBox command} -constraints aqua -body {
    tk_messageBox -foo
} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, -type, or -command}
︙
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

111
112
113
114
115
116
117













118
119
120
121
122
123
124








-
-
-
-
-
-
-
-
-
-
-
-
-








    tk_messageBox -icon foo
} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning}

test msgbox-1.19 {tk_messageBox command} -body {
    tk_messageBox -parent foo.bar
} -returnCodes error -result {bad window path name "foo.bar"}


proc ChooseMsg {parent btn} {
    if {! $::dialogIsNative} {
	after 100 SendButtonPress $parent $btn mouse
    }
}

proc ChooseMsgByKey {parent btn} {
    if {! $::dialogIsNative} {
	after 100 SendButtonPress $parent $btn key
    }
}

#
# Try out all combinations of (type) x (default button) and
# (type) x (icon).
#
test msgbox-2.1 {tk_messageBox command} -constraints {
    nonUnixUserInteraction
} -body {
︙
410
411
412
413
414
415
416
417

418
419
420
421
422

436
437
438
439
440
441
442

443
444
445
446
447









-
+




-

    tk_messageBox -title Hi -message "Please press ok" \
	    -type ok -default ok
} -cleanup {
    wm deiconify .
} -result {ok}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget dialog
cleanupTests
return
Changes to tests/obj.test. 
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

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



-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+













-
-
+
+
+
+

-

# This file is a Tcl script to test new object types in Tk.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test obj-1.1 {TkGetPixelsFromObj} -body {
} -result {}

test obj-2.1 {FreePixelInternalRep} -body {
} -result {}

test obj-3.1 {DupPixelInternalRep} -body {
} -result {}

test obj-4.1 {SetPixelFromAny} -body {
} -result {}


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/option.test. 
1
2

3
4
5
6
7
8


















9

10
11
12
13









14




15
16
17
18
19
20
21

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+

+
+
+
+








# This file is a Tcl script to test out the option-handling facilities
# of Tk.  It is organized in the standard fashion for Tcl tests.
# of Tk.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#
testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}]

#
# COMMON TEST SETUP
#

deleteWindows
set appName [winfo name .]

# First, test basic retrievals, being sure to trigger all the various
# types of NodeElements (EXACT_LEAF_NAME, WILDCARD_NODE_CLASS, and
# everything in-between).
︙
34
35
36
37
38
39
40




41
42
43
44
45
46
47

61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78








+
+
+
+








option add *Class1.x yellow
option add $appName.op1.x green
option add *Class2.Color1 orange
option add $appName.op2.op5.Color2 purple
option add $appName.Class1.Class3.y brown
option add $appName*op6*Color2 black
option add $appName*Class1.op1.Color2 grey

#
# TESTS
#

test option-1.1 {basic option retrieval} -body {
    option get . x Color1
} -result blue
test option-1.2 {basic option retrieval} -body {
    option get . y Color1
} -result red
︙
174
175
176
177
178
179
180



181
182
183
184
185
186

187
188
189
190
191
192
193

205
206
207
208
209
210
211
212
213
214
215
216
217
218

219
220
221
222
223
224
225
226
227








+
+
+




-

+








test option-7.5 {basic option retrieval} -body {
    option get .op2.op5 y Color2
} -result purple
test option-7.6 {basic option retrieval} -body {
    option get .op2.op5 z Color2
} -result purple

#
# COMMON TEST SETUP
#

# Now try similar tests to above, except jump around non-hierarchically
# between windows to make sure that the option stacks are pushed and
# popped correctly.

option get . foo Foo

test option-8.1 {stack pushing/popping} -body {
    option get .op2.op5 x Color1
} -result orange
test option-8.2 {stack pushing/popping} -body {
    option get .op2.op5 y Color1
} -result orange
test option-8.3 {stack pushing/popping} -body {
︙
279
280
281
282
283
284
285
286
287




288

289
290
291
292
293
294
295

313
314
315
316
317
318
319


320
321
322
323
324
325
326
327
328
329
330
331
332








-
-
+
+
+
+

+








test option-12.5 {stack pushing/popping} -body {
    option get .op1 y Color2
} -result {}
test option-12.6 {stack pushing/popping} -body {
    option get .op1 z Color2
} -result {}

# Test the major priority levels (widgetDefault, etc.)

#
# COMMON TEST SETUP
#
# Test the major priority levels (widgetDefault, etc.)
# Configurations for tests 13.*
#
option clear
option add $appName.op1.a 100 100
option add $appName.op1.A interactive interactive
option add $appName.op1.b userDefault userDefault
option add $appName.op1.B startupFile startupFile
option add $appName.op1.c widgetDefault widgetDefault
option add $appName.op1.C 0 0
︙
305
306
307
308
309
310
311




312

313
314
315




316

317
318
319
320
321
322
323

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








+
+
+
+

+



+
+
+
+

+








} -result userDefault
test option-13.4 {priority levels} -body {
    option get .op1 c B
} -result startupFile
test option-13.5 {priority levels} -body {
    option get .op1 c C
} -result widgetDefault

#
# COMMON TEST SETUP
#
option add $appName.op1.B file2 widget

test option-13.6 {priority levels} -body {
    option get .op1 c B
} -result startupFile

#
# COMMON TEST SETUP
#
option add $appName.op1.B file2 startupFile

test option-13.7 {priority levels} -body {
    option get .op1 c B
} -result file2


# Test various error conditions
︙
354
355
356
357
358
359
360
361



362

363
364
365
366
367
368
369

401
402
403
404
405
406
407

408
409
410
411
412
413
414
415
416
417
418
419








-
+
+
+

+








test option-14.11 {error conditions} -body {
    option get 3 4 5 6
} -returnCodes error -result {wrong # args: should be "option get window name class"}
test option-14.12 {error conditions} -body {
    option get .gorp.gorp a A
} -returnCodes error -result {bad window path name ".gorp.gorp"}


#
# COMMON TEST SETUP
#
set option1 [file join [testsDirectory] option.file1]

test option-15.1 {database files} -body {
    list [catch {option read non-existent} msg] [string tolower $msg]
} -result {1 {couldn't open "non-existent": no such file or directory}}
test option-15.2 {database files} -body {
    option read $option1
    option get . x1 color
} -result blue
︙
395
396
397
398
399
400
401


402
403
404





405
406
407
408
409
410
411
412
413
414
415
416
417

418

419
420
421

422
423
424

425
426
427
428

429
430
431

432
433

434

435
436
437
438


439
440
441

442
443



445
446
447
448
449
450
451
452
453



454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472

473
474
475

476



477
478
479
480

481
482
483

484
485
486
487

488
489



490
491



492
493

494
495








+
+
-
-
-
+
+
+
+
+













+
-
+


-
+
-
-
-
+



-
+


-
+


+
-
+

-
-
-
+
+
-
-
-
+

-
+
+

    catch {option read $option1 userDefault}
    option get . x3 color
} -result burgundy
test option-15.10 {database files} -body {
    set option2 [file join [testsDirectory] option.file2]
    option read $option2
} -returnCodes error -result {missing colon on line 2}

test option-15.11 {database files} -setup {
set option3 [file join [testsDirectory] option.file3]
option read $option3
test option-15.11 {database files} {option get . {x 4} color} brówn
    set option3 [file join [testsDirectory] option.file3]
    option read $option3
} -body {
    option get . {x 4} color
} -result brówn

test option-16.1 {ReadOptionFile} -body {
    set option4 [makeFile {} option.file4]
    set file [open $option4 w]
    fconfigure $file -translation crlf
    puts $file "*x7: true\n*x8: false"
    close $file
    option read $option4 userDefault
    list [option get . x7 color] [option get . x8 color]
} -cleanup {
    removeFile $option4
} -result {true false}

test option-16.2 {ticket 766ef52f3} -setup {
set opt162val {label {
    set expected [split {label {
  foo bar
}
}
} \n]
set opt162list [split $opt162val \n]

test option-16.2 {ticket 766ef52f3} -body {
} -body {
    set option5 [makeFile {} option.file5]
    set file [open $option5 w]
    fconfigure $file -translation crlf
    puts $file "*notok: $opt162list"
    puts $file "*notok: $expected"
    close $file
    option read $option5 userDefault
    option get . notok notok
    expr {[option get . notok notok] eq $expected}
} -cleanup {
    removeFile $option5
    unset expected
} -result $opt162list
} -result 1

deleteWindows

# cleanup
#
# TESTFILE CLEANUP
cleanupTests
return

#


deleteWindows
cleanupTests
Changes to tests/pack.test. 
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


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

-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+

















+
+
+
+








# This file is a Tcl script to test out the "pack" command of Tk.  It is
# This file is a Tcl script to test out the "pack" command of Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

# Create some test windows.

destroy .pack
toplevel .pack
wm geom .pack 300x200+0+0
wm minsize .pack 1 1
update idletasks
foreach i {a b c d} {
    frame .pack.$i
    label .pack.$i.label -text $i -relief raised
    place .pack.$i.label -relwidth 1.0 -relheight 1.0
}
.pack.a config -width 20 -height 40
.pack.b config -width 50 -height 30
.pack.c config -width 80 -height 80
.pack.d config -width 40 -height 30

#
# TESTS
#

test pack-1.1 {-side option} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
} -body {
    pack .pack.a -side top
    pack .pack.b -expand yes -fill both
    update
︙
720
721
722
723
724
725
726



727

728
729
730
731
732
733
734

747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765








+
+
+

+








	-ipady 6 -expand 1 -side top
    update
    list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3]
} -cleanup {
    destroy .pack2
} -result {38x42+181+45 38x42+181+178 38x42+181+312}

#
# COMMON TEST SETUP
#
wm geometry .pack {}

test pack-7.1 {requesting size for parent} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
} -body {
    pack .pack.a .pack.b .pack.c .pack.d -side left -padx 5 -pady 10
    update
    list [winfo reqwidth .pack] [winfo reqheight .pack]
} -result {230 100}
︙
777
778
779
780
781
782
783




784
785
786
787
788
789
790
791
792
793
794
795
796
797

798
799
800
801
802


803
804
805



806
807
808
809


810
811
812



813
814
815
816


817
818
819



820
821
822
823
824





825
826
827
828

829




830
831
832
833


834
835
836



837
838
839
840




841
842

843
844
845
846
847


848
849
850



851
852
853
854




855
856
857

858
859
860
861
862




863
864
865
866
867
868
869

808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840



841
842
843
844
845
846
847
848
849



850
851
852
853
854
855
856
857
858



859
860
861
862
863
864
865

866
867
868
869
870
871
872
873
874
875

876
877
878
879
880
881
882
883
884
885



886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
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
937








+
+
+
+














+





+
+
-
-
-
+
+
+




+
+
-
-
-
+
+
+




+
+
-
-
-
+
+
+




-
+
+
+
+
+




+
-
+
+
+
+




+
+
-
-
-
+
+
+




+
+
+
+


+





+
+
-
-
-
+
+
+




+
+
+
+



+





+
+
+
+








} -body {
    pack .pack.a -side right
    pack .pack.c -side bottom
    pack .pack.d -side top
    update
    list [winfo reqwidth .pack] [winfo reqheight .pack]
} -result {100 110}

#
# COMMON TEST SETUP
#

# For the tests below, create a couple of "pad" windows to shrink
# the available space for the remaining windows.  The tests have to
# be done this way rather than shrinking the whole window, because
# some window managers like mwm won't let a top-level window get
# very small.

pack forget .pack.a .pack.b .pack.c .pack.d
frame .pack.right -width 200 -height 10 -bd 2 -relief raised
frame .pack.bottom -width 10 -height 150 -bd 2 -relief raised
pack .pack.right -side right
pack .pack.bottom -side bottom
pack .pack.a .pack.b .pack.c -side top
update

test pack-8.1 {insufficient space} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1}

test pack-8.2 {insufficient space} -setup {
wm geom .pack 270x250
update
test pack-8.2 {insufficient space} -body {
    wm geom .pack 270x250
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1}

test pack-8.3 {insufficient space} -setup {
wm geom .pack 240x220
update
test pack-8.3 {insufficient space} -body {
    wm geom .pack 240x220
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0}

test pack-8.4 {insufficient space} -setup {
wm geom .pack 350x350
update
test pack-8.4 {insufficient space} -body {
    wm geom .pack 350x350
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1}
wm geom .pack {}

#
# COMMON TEST SETUP
#

pack .pack.a -side left
pack .pack.b -side right
pack .pack.c -side left
update

test pack-8.5 {insufficient space} -body {
test pack-8.5 {insufficient space} -setup {
    wm geom .pack {}
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}

test pack-8.6 {insufficient space} -setup {
wm geom .pack 320x180
update
test pack-8.6 {insufficient space} -body {
    wm geom .pack 320x180
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1}

#
# COMMON TEST SETUP
#
wm geom .pack 250x180
update

test pack-8.7 {insufficient space} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0}

test pack-8.8 {insufficient space} -setup {
pack forget .pack.b
update
test pack-8.8 {insufficient space} -body {
    pack forget .pack.b
    update
} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1}

#
# COMMON TEST SETUP
#
pack .pack.b -side right -after .pack.a
wm geom .pack {}
update

test pack-8.9 {insufficient space} -body {
    list [winfo geometry .pack.a] [winfo ismapped .pack.a] \
	[winfo geometry .pack.b] [winfo ismapped .pack.b] \
	[winfo geometry .pack.c] [winfo ismapped .pack.c]
} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1}

#
# COMMON TEST SETUP
#
pack forget .pack.right .pack.bottom

test pack-9.1 {window ordering} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
} -body {
    pack .pack.a .pack.b .pack.c .pack.d -side top
    pack .pack.a -after .pack.b
︙
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195

1249
1250
1251
1252
1253
1254
1255

1256
1257
1258
1259
1260
1261
1262








-








    pack .pack.a -fill z
} -returnCodes error -result {bad fill style "z": must be none, x, y, or both}
test pack-12.14 {command options and errors} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
} -body {
    pack .pack.a -in z
} -returnCodes error -result {bad window path name "z"}
set pad [winfo pixels .pack 1c]
test pack-12.15 {command options and errors} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
} -body {
    pack .pack.a -padx abc
} -returnCodes error -result {bad pad value "abc": must be positive screen distance}
test pack-12.16 {command options and errors} -setup {
    pack forget .pack.a .pack.b .pack.c .pack.d
︙
1747
1748
1749
1750
1751
1752
1753



1754

1755
1756
1757
1758
1759
1760

1814
1815
1816
1817
1818
1819
1820
1821
1822
1823

1824
1825

1826
1827
1828
1829








+
+
+
-
+

-





    update
    info exists A
} -cleanup {
    bind . <<NoManagedChild>> {}
    destroy .1
} -result 0

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/packgrid.test. 
1
2
3
4
5
6
7


















8

9
10
11









12
13
14
15
16
17
18

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



-




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out interaction between Tk's "pack" and
# "grid" commands.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 2008 Peter Spjuth
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::*
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test packgrid-1.1 {pack and grid in same container window} -setup {
    grid propagate . true
    pack propagate . true
    label .p -text PACK
    label .g -text GRID
} -body {
︙
271
272
273
274
275
276
277
278




279
280

294
295
296
297
298
299
300
301
302
303
304
305
306










+
+
+
+

-

    set res [winfo manager .b]
    # shall not crash
    grid .b
    set res
} -cleanup {
    destroy .b
} -result {}

#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/panedwindow.test. 
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


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

-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+







+
+
+
+
+








# This file is a Tcl script to test entry widgets in Tk.  It is
# This file is a Tcl script to test paned window widgets in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

deleteWindows
# Panedwindow for tests 1.*
panedwindow .p
# Buttons for tests 1.33 - 1.52
.p add [button .b]
.p add [button .c]

#
# TESTS
#

test panedwindow-1.1 {configuration options: -background (good)} -body {
    .p configure -background #ff0000
    list [lindex [.p configure -background] 4] [.p cget -background]
} -cleanup {
    .p configure -background [lindex [.p configure -background] 3]
} -result {{#ff0000} #ff0000}
test panedwindow-1.2 {configuration options: -background (bad)} -body {
︙
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

313
314
315
316
317
318
319

320
321
322
323
324
325
326








-








	[.p panecget .b -width]
} -cleanup {
    .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3]
} -result {10 10}
test panedwindow-1.58 {configuration options: -width (bad)} -body {
    .p paneconfigure .b -width badValue
} -returnCodes error -result {expected screen distance or "" but got "badValue"}
deleteWindows


test panedwindow-2.1 {panedwindow widget command} -setup {
    deleteWindows
} -body {
    panedwindow .p
    .p foo
︙
5539
5540
5541
5542
5543
5544
5545
5546
5547


5548
5549
5550

5551


5566
5567
5568
5569
5570
5571
5572


5573
5574



5575
5576
5577








-
-
+
+
-
-
-
+

+

    .t.f.p proxy forget
    update
    # If we got here, we didn't crash and that's good
} -cleanup {
    deleteWindows
} -result {}


# cleanup
#
# TESTFILE CLEANUP
cleanupTests
return

#

cleanupTests
Changes to tests/pkgconfig.test. 
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





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

-
-
-
-
+
-
-









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# -*- tcl -*-
# Commands covered:  pkgconfig
#
# This file contains a collection of tests for one or more of the Tk
# This file is a Tcl script to test the command "pkgconfig".
# built-in commands.  Sourcing this file into Tk runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1991-1993 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2017 Stuart Cassoff <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test pkgconfig-1.1 {query keys} -constraints {nonwin} -body {
    lsort [::tk::pkgconfig list]
} -match glob -result [list \
    *bindir,install bindir,runtime *demodir,install \
    demodir,runtime*docdir,install docdir,runtime fontsystem \
    includedir,install includedir,runtime \
︙
58
59
60
61
62
63
64



65

66
67

77
78
79
80
81
82
83
84
85
86

87
88









+
+
+
-
+

-

    set msg
} {key not known}
test pkgconfig-2.5 {error: query with to many arguments} {
    catch {::tk::pkgconfig get foo bar} msg
    set msg
} {wrong # args: should be "::tk::pkgconfig subcommand ?arg?"}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return
Changes to tests/place.test. 
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


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

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+



-
-
-
-
+
+
+
+
+
+






+
+
+
+








# This file is a Tcl script to test out the "place" command.  It is
# This file is a Tcl script to test out the "place" command.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# This test file is woefully incomplete.  At present, only a
# few of the features are tested.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]

# XXX - This test file is woefully incomplete.  At present, only a
# few of the features are tested.

# Widgets used in tests 1.* - 8.*
#
# COMMON TEST SETUP
#
# For tests 1.* - 8.*
#

toplevel .t -width 300 -height 200 -bd 0
wm geom .t +0+0
frame .t.f -width 154 -height 84 -bd 2 -relief raised
place .t.f -x 48 -y 38
frame .t.f2 -width 30 -height 60 -bd 2 -relief raised
update

#
# TESTS
#

test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup {
    place forget .t.f2
} -body {
    place .t.f2 -x 0
    place info .t.f2
} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside}
︙
298
299
300
301
302
303
304
305
306





307
308
309
310
311
312
313

332
333
334
335
336
337
338


339
340
341
342
343
344
345
346
347
348
349
350








-
-
+
+
+
+
+








    place .t.f2 -x 40 -y 30 -relx 0 -rely 0 -anchor nw
    update
    lappend result [winfo x .t.f2] [winfo y .t.f2] [winfo ismapped .t.f2]
    wm deiconify .t
    update
    lappend result [winfo ismapped .t.f2]
} -result {1 0 42 32 0 1}
destroy .t


#
# COMMON TEST CLEANUP
#
destroy .t

test place-9.1 {PlaceObjCmd} -body {
    place
} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
test place-9.2 {PlaceObjCmd} -body {
    place foo
} -returnCodes error -result {wrong # args: should be "place option|pathName args"}
︙
519
520
521
522
523
524
525
526
527


528
529
530

531
532


556
557
558
559
560
561
562


563
564



565
566

567








-
-
+
+
-
-
-
+

-
+

    }
} -cleanup {
    destroy .f
    rename getbytes {}
    rename stress {}
} -result {0 0 0}


# cleanup
#
# TESTFILE CLEANUP
cleanupTests
return

#


cleanupTests
Changes to tests/raise.test. 
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

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



-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
-
-
+
-
-

-
-
-
-
-
+
+
-
-
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+













+
+
-
-
+
+









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+



+
+
+








# This file is a Tcl script to test out Tk's "raise" and
# "lower" commands, plus associated code to manage window
# stacking order.  It is organized in the standard fashion
# stacking order.
# for Tcl tests.
#
# Copyright © 1993-1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
namespace import -force tcltest::test

}
# Procedure to create a bunch of overlapping windows, which should
# make it easy to detect differences in order.

wm geometry . +400+400
proc raise_setup {} {
    destroy {*}[winfo children .raise]
    update idletasks
    foreach i {a b c d e} {
# Ensure a pristine initial window state
resetWindows
	    label .raise.$i -text $i -relief raised -bd 2
    }

    place .raise.a -x 20 -y 60 -width 60 -height 80
    place .raise.b -x 60 -y 60 -width 60 -height 80
    place .raise.c -x 100 -y 60 -width 60 -height 80
    place .raise.d -x 40 -y 20 -width 100 -height 60
    place .raise.e -x 40 -y 120 -width 100 -height 60
}

# Procedure to return information about which windows are on top
#
# LOCAL UTILITY PROCS
#

# raise_getOrder --
#
# Return information about which windows are on top of which other windows.
# of which other windows.

#
proc raise_getOrder {} {
    set x [winfo rootx .raise]
    set y [winfo rooty .raise]
    list [winfo name [winfo containing [expr $x+50] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+90] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+130] [expr $y+70]]] \
	    [winfo name [winfo containing [expr $x+70] [expr $y+100]]] \
	    [winfo name [winfo containing [expr $x+110] [expr $y+100]]] \
	    [winfo name [winfo containing [expr $x+50] [expr $y+130]]] \
	    [winfo name [winfo containing [expr $x+90] [expr $y+130]]] \
	    [winfo name [winfo containing [expr $x+130] [expr $y+130]]]
}

# raise_makeToplevels --
#
# Procedure to set up a collection of top-level windows

# Set up a collection of top-level windows
#
proc raise_makeToplevels {} {
    deleteWindows
    foreach i {.raise1 .raise2 .raise3} {
	toplevel $i
	wm geom $i 150x100+0+0
	update
    }
}

# raise_setup --
#
# Create a bunch of overlapping windows, which should make it easy to detect
# differences in order.
#
proc raise_setup {} {
    destroy {*}[winfo children .raise]
    update idletasks
    foreach i {a b c d e} {
	    label .raise.$i -text $i -relief raised -bd 2
    }
    place .raise.a -x 20 -y 60 -width 60 -height 80
    place .raise.b -x 60 -y 60 -width 60 -height 80
    place .raise.c -x 100 -y 60 -width 60 -height 80
    place .raise.d -x 40 -y 20 -width 100 -height 60
    place .raise.e -x 40 -y 120 -width 100 -height 60
}

#
# COMMON TEST SETUP
#

wm geometry . +400+400
toplevel .raise
wm geom .raise 250x200+0+0

#
# TESTS
#

test raise-1.1 {preserve creation order} -body {
    raise_setup
    tkwait visibility .raise.e
    raise_getOrder
} -result {d d d b c e e e}
test raise-1.2 {preserve creation order} -constraints testmakeexist -body {
︙
308
309
310
311
312
313
314
315
316
317





318
319
320

343
344
345
346
347
348
349



350
351
352
353
354
355










-
-
-
+
+
+
+
+

-
-

test raise-7.7 {errors in raise/lower commands} -body {
    lower badName3
} -returnCodes error -result {bad window path name "badName3"}
test raise-7.8 {errors in raise/lower commands} -body {
    lower . badName4
} -returnCodes error -result {bad window path name "badName4"}

deleteWindows

# cleanup
#
# TESTFILE CLEANUP
#

deleteWindows
cleanupTests
return
Changes to tests/safe.test. 
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


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

-
+
-






-
+
-
-
-
-
-
-
-
-
+
+
+
+
+

-
-
-
-
-
-
-
+
+
+
+
+
+
+


-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the Safe Tk facility. It is organized in
# This file is a Tcl script to test the Safe Tk facility.
# the standard fashion for Tk tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
# NOTE
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test

## NOTE: Any time tests fail here with an error like:

# Can't find a usable tk.tcl in the following directories:
#     {$p(:26:)}
#
# Any time tests fail here with an error like:
#
#     Can't find a usable tk.tcl in the following directories:
# 	{$p(:26:)}
#
# $p(:26:)/tk.tcl: script error
# script error
#     invoked from within
# "source {$p(:26:)/tk.tcl}"
#     ("uplevel" body line 1)
#     invoked from within
# "uplevel #0 [list source $file]"
#     $p(:26:)/tk.tcl: script error
#     script error
# 	invoked from within
#     "source {$p(:26:)/tk.tcl}"
# 	("uplevel" body line 1)
# 	invoked from within
#     "uplevel #0 [list source $file]"
#
#
# This probably means that tk wasn't installed properly.

## it indicates that something went wrong sourcing tk.tcl.
## Ensure that any changes that occurred to tk.tcl will work or are properly
## prevented in a safe interpreter.  -- hobbs
#     This probably means that tk wasn't installed properly.
#
# it indicates that something went wrong sourcing tk.tcl.
# Ensure that any changes that occurred to tk.tcl will work or are properly
# prevented in a safe interpreter.  -- hobbs

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

# The set of hidden commands is platform dependent:

set hidden_cmds [list bell cd clipboard encoding exec exit \
	fconfigure glob grab load menu open pwd selection \
	socket source toplevel unload wm]
lappend hidden_cmds file tcl:encoding:dirs tcl:encoding:system
︙
60
61
62
63
64
65
66
67





68
69
70
71
72
73
74

85
86
87
88
89
90
91

92
93
94
95
96
97
98
99
100
101
102
103








-
+
+
+
+
+








if {[llength [info commands send]]} {
    lappend hidden_cmds send
}

set saveAutoPath $::auto_path
set auto_path [list [info library] $::tk_library]
set hidden_cmds [lsort $hidden_cmds]


#
# TESTS
#

test safe-1.1 {Safe Tk loading into an interpreter} -setup {
    catch {safe::interpDelete a}
} -body {
    safe::loadTk [safe::interpCreate a]
    safe::interpDelete a
    set x {}
    return $x
︙
242
243
244
245
246
247
248
249
250





251
252
253
254
255
256
257
258
259

271
272
273
274
275
276
277


278
279
280
281
282
283
284
285

286
287
288
289
290








-
-
+
+
+
+
+



-







test safe-7.1 {canvas printing} -body {
    set i [safe::loadTk [safe::interpCreate]]
    interp eval $i {canvas .c; .c postscript}
} -cleanup {
    safe::interpDelete $i
} -returnCodes ok -match glob -result *

# cleanup

#
# TESTFILE CLEANUP
#

set ::auto_path $saveAutoPath
unset hidden_cmds
cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End:
Changes to tests/safePrimarySelection.test. 
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



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

-
-
+
+






-
-
-
-
-
+
-
-
-
+
-
-
-



-
+










-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test entry widgets in Tk.  It is
# organized in the standard fashion for Tcl tests.
# This file is a Tcl script to test that a Safe Base interpreter cannot write
# to the PRIMARY selection.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

# NOTES
# Import utility procs for specific functional areas
testutils import child

#
# ------------------------------------------------------------------------------
# Tests that a Safe Base interpreter cannot write to the PRIMARY selection.
# ------------------------------------------------------------------------------
# - Tests 3.*, 6.* test that the fix for ticket de156e9efe implemented in branch
#   bug-de156e9efe has been applied and still works.  They test that a Safe Base
#   child interpreter cannot write to the PRIMARY selection.
# - The other tests verify that the parent interpreter and an child interpreter
# - The other tests verify that the parent interpreter and a child interpreter
#   CAN write to the PRIMARY selection, and therefore that the test scripts
#   themselves are valid.
# - A text, entry, ttk::entry, listbox, spinbox or ttk::spinbox widget can have
#   option -exportselection 1, meaning (in an unsafe interpreter) that a
#   selection made in one of these widgets is automatically written to the
#   PRIMARY selection.
# - A safe interpreter must not write to the PRIMARY selection.
# - The spinbox, ttk::spinbox are variants of entry, ttk::entry respectively.
# - The command "childTkInterp" is not needed for Safe Base children because
#   safe::loadTk does something similar and works correctly.
# ------------------------------------------------------------------------------

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# COMMON TEST SETUP
#

namespace eval ::_test_tmp {}

set ::_test_tmp::script {
    package require tk
    namespace eval ::_test_tmp {}
︙
179
180
181
182
183
184
185




186
187
188
189
190
191
192

201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218








+
+
+
+








	    # selects 3
	}
    }
}

# Do this once for the parent interpreter.
eval $::_test_tmp::script

#
# TESTS
#

test safePrimarySelection-1.1 {parent interpreter, text, no existing selection} -setup {
    catch {interp delete child2}
    destroy {*}[winfo children .]
    ::_test_tmp::clearPrimarySelection
} -body {
    ::_test_tmp::tryText
︙
1181
1182
1183
1184
1185
1186
1187
1188

1189
1190
1191
1192
1193
1194

1207
1208
1209
1210
1211
1212
1213

1214
1215
1216
1217
1218
1219









-
+





-

    interp delete $int2
    destroy {*}[winfo children .]
    unset int2 res0 res1 res2 res3
    ::_test_tmp::clearPrimarySelection
} -result {OLD_VALUE----OLD_VALUE}

#
# CLEANUP
# TESTFILE CLEANUP
#

namespace delete ::_test_tmp
testutils forget child
cleanupTests
return
Changes to tests/scale.test. 
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

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+








+
+
+
-
+
+



+
+
+
+








# This file is a Tcl script to test out the "scale" command
# of Tk.  It is organized in the standard fashion for Tcl tests.
# of Tk.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Scale.borderWidth 2
option add *Scale.highlightThickness 2
option add *Scale.font {Helvetica -12 bold}

#
# COMMON TEST SETUP
#
# Widget used in 1.* tests
# For tests 1.*
#
scale .s -from 100 -to 300
pack .s
update

#
# TESTS
#

test scale-1.1 {configuration options} -body {
    .s configure -activebackground #ff0000
    .s cget -activebackground
} -cleanup {
    .s configure -activebackground [lindex [.s configure -activebackground] 3]
} -result {#ff0000}
︙
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

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








-
-
+
+
+
+
+



















-
-
+
+
+
+
+




+








    .s cget -width
} -cleanup {
    .s configure -width [lindex [.s configure -width] 3]
} -result 32
test scale-1.70 {configuration options} -body {
	.s configure -width badValue
} -returnCodes error -result {expected screen distance but got "badValue"}
destroy .s


#
# COMMON TEST CLEANUP
#
destroy .s

test scale-2.1 {Tk_ScaleCmd procedure} -body {
    scale
} -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"}
test scale-2.2 {Tk_ScaleCmd procedure} -body {
    scale foo
} -returnCodes error -result {bad window path name "foo"}
test scale-2.3 {Tk_ScaleCmd procedure} -body {
    catch {scale foo}
    winfo children .
} -result {}
test scale-2.4 {Tk_ScaleCmd procedure} -body {
    scale .s -gorp dumb
} -returnCodes error -result {unknown option "-gorp"}
test scale-2.5 {Tk_ScaleCmd procedure} -body {
    catch {scale .s -gorp dumb}
    winfo children .
} -result {}


# Widget used in 3.* tests
#
# COMMON TEST SETUP
#
# For tests 3.*
#
destroy .s
scale .s -from 100 -to 200
pack .s
update idletasks

test scale-3.1 {ScaleWidgetCmd procedure} -body {
    .s
} -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"}
test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body {
    .s cget
} -returnCodes error -result {wrong # args: should be ".s cget option"}
test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body {
︙
419
420
421
422
423
424
425






426

427
428
429
430
431
432
433

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475








+
+
+
+
+
+

+








} -result 133
test scale-3.18 {ScaleWidgetCmd procedure, get option} -body {
    .s configure -orient vertical -resolution 0.5
    update
    .s set 150
    .s get 37 34
} -result {119.5}

#
# COMMON TEST SETUP
#
# For tests from scale-3.19
#
.s configure -resolution 1

test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body {
    .s identify
} -returnCodes error -result {wrong # args: should be ".s identify x y"}
test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body {
    .s identify 1 2 3
} -returnCodes error -result {wrong # args: should be ".s identify x y"}
test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body {
︙
472
473
474
475
476
477
478




479
480
481
482
483
484
485

514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531








+
+
+
+








} -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set}
test scale-3.30 {ScaleWidgetCmd procedure} -body {
    .s c
} -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set}
test scale-3.31 {ScaleWidgetCmd procedure} -body {
    .s co
} -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set}

#
# COMMON TEST CLEANUP
#
destroy .s

test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup {
    destroy .s
} -body {
    proc kill args {
	    destroy .s
︙
575
576
577
578
579
580
581
582
583






584
585
586

587
588
589
590
591
592
593

621
622
623
624
625
626
627


628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644








-
-
+
+
+
+
+
+



+








    deleteWindows
} -body {
    scale .s -from 0 -to 100 -state bogus
} -cleanup {
    deleteWindows
} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal}


# Widget used in 6.* tests
#
# COMMON TEST SETUP
#
# For tests scale-6.*
#

destroy .s
scale .s -orient horizontal -length 200
pack .s

test scale-6.1 {ComputeFormat procedure} -body {
    .s configure -from 10 -to 100 -resolution 10
    .s set 49.3
    .s get
} -result 50
test scale-6.2 {ComputeFormat procedure} -body {
    .s configure -from 100 -to 1000 -resolution 100
︙
689
690
691
692
693
694
695
696
697





698
699
700
701
702
703
704

740
741
742
743
744
745
746


747
748
749
750
751
752
753
754
755
756
757
758








-
-
+
+
+
+
+








    .s get
} -result {1001.235}
test scale-6.21 {ComputeFormat procedure} -body {
    .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 200
    .s set 1001.23456789
    .s get
} -result {1001.235}
destroy .s


#
# COMMON TEST CLEANUP
#
destroy .s

test scale-7.1 {ComputeScaleGeometry procedure} -constraints {
    nonPortable fonts
} -setup {
    deleteWindows
} -body {
    scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i
︙
918
919
920
921
922
923
924
925
926






927
928

929
930
931
932
933
934
935

972
973
974
975
976
977
978


979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994








-
-
+
+
+
+
+
+


+








    update
    list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \
	[.s identify 166 28]
} -cleanup {
    deleteWindows
} -result {trough1 slider slider trough2}


#widget used in 9.* tests
#
# COMMON TEST SETUP
#
# For tests scale-9.*
#

destroy .s
pack [scale .s]

test scale-9.1 {PixelToValue procedure} -body {
    .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
    update
    .s get 46 0
} -result 0
test scale-9.2 {PixelToValue procedure} -body {
    .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2
︙
968
969
970
971
972
973
974
975
976





977
978
979
980
981
982
983

1027
1028
1029
1030
1031
1032
1033


1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045








-
-
+
+
+
+
+








} -result 100
test scale-9.9 {PixelToValue procedure} -body {
    .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
	-orient horizontal
    update
    .s get 76 152
} -result 65
destroy .s


#
# COMMON TEST CLEANUP
#
destroy .s

test scale-10.1 {ValueToPixel procedure} -constraints {
    fonts
} -setup {
    deleteWindows
} -body {
    scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \
︙
1046
1047
1048
1049
1050
1051
1052
1053
1054





1055
1056
1057

1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074






1075

1076
1077
1078
1079
1080
1081
1082

1108
1109
1110
1111
1112
1113
1114


1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155








-
-
+
+
+
+
+



+

















+
+
+
+
+
+

+








    scale .s1
    rename .s1 {}
    list [info command .s*] [winfo children .]
} -cleanup {
    deleteWindows
} -result {{} {}}


# Widget used in 13.* tests
#
# COMMON TEST SETUP
#
# For tests scale-13.*
#
destroy .s
pack [scale .s]
update

test scale-13.1 {SetScaleValue procedure} -body {
    .s configure -from 0 -to 100 -command {set x} -variable y
    update
    set x xyzzy
    .s set 44
    set result [list $x $y]
    update
    lappend result $x $y
} -result {xyzzy 44 44 44}
test scale-13.2 {SetScaleValue procedure} -body {
    .s set -3
    .s get
} -result 0
test scale-13.3 {SetScaleValue procedure} -body {
    .s set 105
    .s get
} -result 100

#
# COMMON TEST SETUP
#
# For tests scale-13.4 -
#
.s configure -from 100 -to 0

test scale-13.4 {SetScaleValue procedure} -body {
    .s set -3
    .s get
} -result 0
test scale-13.5 {SetScaleValue procedure} -body {
    .s set 105
    .s get
︙
1095
1096
1097
1098
1099
1100
1101
1102
1103





1104
1105
1106

1107
1108
1109
1110
1111
1112
1113

1168
1169
1170
1171
1172
1173
1174


1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190








-
-
+
+
+
+
+



+








    set traceInfo empty
    set x untouched
    .s set 50
    update
    list $x $traceInfo
} -result {untouched empty}


# Widget used in 14.* tests
#
# COMMON TEST SETUP
#
# For tests from scale-14.1
#
destroy .s
pack [scale .s]
update

test scale-14.1 {RoundValueToResolution procedure} -body {
    .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \
	-orient horizontal -resolution 4.0
    update
    .s get 84 152
} -result 72
test scale-14.2 {RoundValueToResolution procedure} -body {
︙
1177
1178
1179
1180
1181
1182
1183




1184
1185
1186
1187
1188
1189
1190

1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271








+
+
+
+








} -result {164.25}
test scale-14.12 {RoundValueToResolution procedure} -body {
    .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \
	-orient horizontal -resolution 0 -digits 5
    update
    .s get 86 152
} -result {168.75}

#
# COMMON TEST CLEANUP
#
destroy .s

test scale-14.13 {RoundValueToResolution procedure, round-off errors} -setup {
    # see [220665ffff], and duplicates [220265ffff] and [779559ffff]
    set x NotSet
    pack [scale .s -orient horizontal -resolution .1 -from -180 -to 180 -command "set x"]
    update
︙
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622





1623
1624

1694
1695
1696
1697
1698
1699
1700



1701
1702
1703
1704
1705
1706









-
-
-
+
+
+
+
+

-

    pack .b
    bind .b <Configure> {unset -nocomplain var}
    update
    destroy .b
    unset new
} {}

option clear

# cleanup
#
# TESTFILE CLEANUP
#

option clear
cleanupTests
return
Changes to tests/scrollbar.test. 
1
2
3
4
5
6
7
8
9
























10

11
12









13
14
15
16
17
18
19

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










+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out scrollbar widgets and
# the "scrollbar" command of Tk.  It is organized in the standard
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Note: this test file is woefully incomplete.  Right now there are
# only bits and pieces of tests.  Please make this file more complete
# as you fix bugs and add features.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc getTroughSize {w} {
    if {[testConstraint testmetrics]} {
	# Only Windows has [testmetrics]
	if [string match v* [$w cget -orient]] {
	    return [expr {[winfo height $w] - 2*[testmetrics cyvscroll $w]}]
	} else {
︙
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

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








-
-
+
+
+
+
-
+











+
+
+
+
+








			- ([$w cget -highlightthickness] \
			  +[$w cget -bd])*2}]
	    }
	}
    }
}

# XXX Note: this test file is woefully incomplete.  Right now there are
# only bits and pieces of tests.  Please make this file more complete
#
# COMMON TEST SETUP
#
# For tests scrollbar-1.*
# as you fix bugs and add features.
#

foreach {width height} [wm minsize .] {
    set height [expr {($height < 200) ? 200 : $height}]
    set width [expr {($width < 1) ? 1 : $width}]
}

frame .f -height $height -width $width
pack .f -side left
scrollbar .s
pack .s -side right -fill y
update

#
# TESTS
#

set i 1
foreach test {
    {-activebackground #ff0000 #ff0000 non-existent
	    {unknown color name "non-existent"}}
    {-activerelief sunken sunken non-existent
	    {bad relief "non-existent": must be flat, groove, raised, ridge, solid, or sunken}}
    {-background #ff0000 #ff0000 non-existent
︙
101
102
103
104
105
106
107



108

109
110
111
112
113
114
115

139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157








+
+
+

+








	    -body [list .s configure $name $badValue] \
	    -returnCodes error -result $badResult
	incr i
    }
    .s configure $name [lindex [.s configure $name] 3]
}

#
# COMMON TEST CLEANUP
#
destroy .s

test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body {
    scrollbar
} -result {wrong # args: should be "scrollbar pathName ?-option value ...?"}
test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body {
    scrollbar gorp
} -returnCodes error -result {bad window path name "gorp"}
test scrollbar-2.3 {Tk_ScrollbarCmd procedure} -setup {
︙
127
128
129
130
131
132
133




134
135
136

137
138
139
140
141
142
143

169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190








+
+
+
+



+








    catch {destroy .s}
} -body {
    scrollbar .s
} -cleanup {
    destroy .s
} -result .s


#
# COMMON TEST SETUP
#
scrollbar .s -orient vertical -highlightthickness 2 -bd 2
pack .s -side right -fill y
update

test scrollbar-3.1 {ScrollbarWidgetCmd procedure} {
    list [catch {.s} msg] $msg
} {1 {wrong # args: should be ".s option ?arg ...?"}}
test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} {
    list [catch {.s cget} msg] $msg
} {1 {wrong # args: should be ".s cget option"}}
test scrollbar-3.3 {ScrollbarWidgetCmd procedure, "cget" option} {
︙
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

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








+
+
+
+

+


















+
+
+
+

+








} {}
test scrollbar-3.9 {ScrollbarWidgetCmd procedure, "activate" option} {
    list [catch {.s activate trough1} msg] $msg
} {0 {}}
test scrollbar-3.10 {ScrollbarWidgetCmd procedure, "cget" option} {
    list [catch {.s cget -orient} msg] $msg
} {0 vertical}

#
# COMMON TEST SETUP
#
scrollbar .s2

test scrollbar-3.11 {ScrollbarWidgetCmd procedure, "cget" option} {
    expr {[.s2 cget -bd] == [lindex [.s2 configure -bd] 3]}
} 1
test scrollbar-3.12 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
    # empty test; duplicated scrollbar-3.11
} {}
test scrollbar-3.12.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
    # empty test; duplicated scrollbar-3.11
} {}
test scrollbar-3.13 {ScrollbarWidgetCmd procedure, "cget" option} {
    expr {[.s2 cget -highlightthickness] == [lindex [.s2 configure -highlightthickness] 3]}
} 1
test scrollbar-3.14 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
    # empty test; duplicated scrollbar-3.13
} {}
test scrollbar-3.14.1 {ScrollbarWidgetCmd procedure, "cget" option} emptyTest {
    # empty test; duplicated scrollbar-3.13
} {}

#
# COMMON TEST CLEANUP
#
destroy .s2

test scrollbar-3.15 {ScrollbarWidgetCmd procedure, "configure" option} {
    llength [.s configure]
} 20
test scrollbar-3.16 {ScrollbarWidgetCmd procedure, "configure" option} {
    list [catch {.s configure -bad} msg] $msg
} {1 {unknown option "-bad"}}
test scrollbar-3.17 {ScrollbarWidgetCmd procedure, "configure" option} {
︙
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

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








+
+
+
+










+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
-
+

+
-
+
+
+
+

+








       /([getTroughSize .s] - 1)}]]
test scrollbar-3.39 {ScrollbarWidgetCmd procedure, "fraction" option} {testmetrics win} {
    expr {
    [format {%.6g} [.s fraction 4 [expr {200 - [testmetrics cyvscroll .s] - 2}]]]
	== [format %g [expr {(200.0 - [testmetrics cyvscroll .s]*2 - 2)
			   / ($height - 1 - [testmetrics cyvscroll .s]*2)}]]}
} 1

#
# COMMON TEST SETUP
#

toplevel .t -width 250 -height 100
wm geom .t +0+0
scrollbar .t.s -orient horizontal -borderwidth 2
place .t.s -width 201
update

test scrollbar-3.41 {ScrollbarWidgetCmd procedure, "fraction" option} {
    format {%.6g} [.t.s fraction 100 0]
} {0.5}

test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} -setup {
if {[testConstraint testmetrics]} {
    # Only Windows has [testmetrics]
    place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}]
} else {
    if {[tk windowingsystem] eq "x11"} {
	place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}]
    } else {
	# macOS aqua
	place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}]
    }
}
update
    if {[testConstraint testmetrics]} {
	# Only Windows has [testmetrics]
	place configure .t.s -width [expr {2*[testmetrics cxhscroll .t.s]+1}]
    } else {
	if {[tk windowingsystem] eq "x11"} {
	    place configure .t.s -width [expr {[winfo height .t.s] - 2*([.t.s cget -highlightthickness] + [.t.s cget -bd] + 1)}]
	} else {
	    # macOS aqua
	    place configure .t.s -width [expr {2*([.t.s cget -highlightthickness] + [.t.s cget -bd])}]
	}
    }
    update
test scrollbar-3.42 {ScrollbarWidgetCmd procedure, "fraction" option} {
} -body {
    format {%.6g} [.t.s fraction 100 0]
} -result 0
} 0

#
# COMMON TEST CLEANUP
#
destroy .t

test scrollbar-3.43 {ScrollbarWidgetCmd procedure, "get" option} {
    list [catch {.s get a} msg] $msg
} {1 {wrong # args: should be ".s get"}}
test scrollbar-3.45 {ScrollbarWidgetCmd procedure, "get" option} {
    .s set 0.6 0.8
    set result {}
    foreach element [.s get] {
︙
417
418
419
420
421
422
423




424
425
426
427
428
429
430

485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502








+
+
+
+









test scrollbar-5.1 {ScrollbarCmdDeletedProc procedure} {
    catch {destroy .s1}
    scrollbar .s1
    rename .s1 {}
    list [info command .s?] [winfo exists .s1]
} {{} 0}

#
# COMMON TEST SETUP
#

catch {destroy .s}
scrollbar .s -orient vertical -relief sunken -bd 2 -highlightthickness 2
pack .s -side left -fill y
.s set .2 .4
update
︙
553
554
555
556
557
558
559




560
561
562
563
564
565
566

625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642








+
+
+
+








} {trough2}
test scrollbar-6.37 {ScrollbarPosition procedure} win {
    .s identify 0 100
} {trough2}
test scrollbar-6.38 {ScrollbarPosition procedure} win {
    .s identify [expr {[winfo width .s] - 1}] 100
} {trough2}

#
# COMMON TEST SETUP
#

catch {destroy .t}
toplevel .t -width 250 -height 150
wm geometry .t +0+0
scrollbar .t.s -orient horizontal -relief sunken -bd 2 -highlightthickness 2
place .t.s -width 200
.t.s set .2 .4
︙
601
602
603
604
605
606
607




608
609
610
611

612
613
614
615
616
617
618

677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699








+
+
+
+




+








    .s configure -orient horizontal
    update
    set result [.s cget -orient]
    .s configure -orient vertical
    update
    lappend result [.s cget -orient]
} {horizontal vertical}

#
# COMMON TEST SETUP
#

catch {destroy .t}
toplevel .t
wm geometry .t +0+0

test scrollbar-8.1 {TkScrollbarEventProc: recursive deletion} notAqua {
    # constrained by notAqua because this test clicks on an arrow of the
    # scrollbar - but macOS has no such arrows in modern scrollbars
    proc doit {args} { destroy .t.f }
    proc bgerror {args} {}
    destroy .t.f
    frame .t.f
︙
648
649
650
651
652
653
654
655



656
657
658
659
660
661
662
663
664

665
666
667
668
669
670
671

729
730
731
732
733
734
735

736
737
738
739
740
741
742
743
744
745
746

747
748
749
750
751
752
753
754








-
+
+
+








-
+








    event generate .t.f <ButtonRelease> -button 1
    update
    lappend result [winfo exists .t.f.s] [winfo exists .t.f]
    rename bgerror {}
    set result
} {1 0 1}

set l [interp hidden]
#
# COMMON TEST CLEANUP
#
deleteWindows

test scrollbar-9.1 {scrollbar widget vs hidden commands} {
    catch {destroy .s}
    scrollbar .s
    interp hide {} .s
    destroy .s
    list [winfo children .] [interp hidden]
} [list {} $l]
} [list {} [interp hidden]]

test scrollbar-10.1 {<MouseWheel> event on scrollbar} -setup {
    destroy .t .s
} -body {
    pack [text .t -yscrollcommand {.s set}] -side left
    for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"}
    pack [scrollbar .s -command {.t yview}] -fill y -expand 1 -side left
︙
742
743
744
745
746
747
748




749
750
751
752
753
754
755

825
826
827
828
829
830
831
832
833
834
835
836
837
838


839









+
+
+
+



-
-

-

    focus -force .top.s
    update
    event generate .top.s <Button-2> -x 2 -y [expr {[winfo height .top.s] / 2}]
    update  ; # shall not trigger error  invalid command name ".top.s"
} -cleanup {
    destroy .top.s .top
} -result {}

#
# TESTFILE CLEANUP
#

catch {destroy .s}
catch {destroy .t}

# cleanup
cleanupTests
return
Changes to tests/select.test. 
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

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


-
+
-





+

-
+

-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+







+
+
+
+














-
+
+
+








# This file is a Tcl script to test out Tk's selection management code,
# especially the "selection" command. It is organized in the standard fashion
# especially the "selection" command.
# for Tcl tests.
#
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Note: Multiple display selection handling will only be tested if the
# Multiple display selection handling will only be tested if the
# environment variable TK_ALT_DISPLAY is set to an alternate display.
#

package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child select

#
# LOCAL TEST CONSTRAINTS
#

testConstraint cliboardManagerPresent 0
if {![catch {selection get -selection CLIPBOARD_MANAGER -type TARGETS}]} {
    if {"SAVE_TARGETS" in [selection get -selection CLIPBOARD_MANAGER -type TARGETS]} {
	testConstraint cliboardManagerPresent 1
    }
}

#
# COMMON TEST SETUP
#

# Eliminate any existing selection on the screen.  This is needed in case
# there is a selection in some other application, in order to prevent races
# from causing false errors in the tests below.
selection clear .
after 1500

# set up a very large buffer to test INCR retrievals
set longValue ""
foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# Now we start the main body of the test code
#
# TESTS
#

test select-1.1 {Tk_CreateSelHandler procedure} -setup {
    selectionSetup
} -body {
    lsort [selection get TARGETS]
} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}
test select-1.2 {Tk_CreateSelHandler procedure} -setup {
︙
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








+

+













+

+








    set result {}
    lappend result [childTkProcess eval { selection own . }]
    lappend result [childTkProcess eval {selection own}]
    update
    childTkProcess exit
    lappend result $lostSel
} -result {{} . lost1}

# check reentrancy on selection replacement

test select-3.8 {Tk_OwnSelection procedure} -setup {
    selectionSetup
} -body {
    selection own -selection CLIPBOARD -command { destroy .f1 } .f1
    selection own -selection CLIPBOARD .
} -result {}
test select-3.9 {Tk_OwnSelection procedure} -setup {
    selectionSetup .f2
    selectionSetup .f1
} -body {
    selection own -selection CLIPBOARD -command { destroy .f2 } .f1
    selection own -selection CLIPBOARD .f2
} -result {}

# multiple display tests

test select-3.10 {Tk_OwnSelection procedure} -constraints {
    altDisplay
} -body {
    selectionSetup .f1
    selectionSetup .f2 $env(TK_ALT_DISPLAY)
    list [selection own -displayof .f1] [selection own -displayof .f2]
} -result {.f1 .f2}
︙
337
338
339
340
341
342
343

344

345
346
347
348
349
350
351

370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386








+

+








    update
    set result {}
    lappend result [childTkProcess eval {selection clear; update}]
    update
    childTkProcess exit
    lappend result [selection own]
} -result {{} {}}

# multiple display tests

test select-4.5 {Tk_ClearSelection procedure} -constraints {
    altDisplay
} -setup {
    global lostSel lostSel2
    selectionSetup .f1
    selectionSetup .f2 $env(TK_ALT_DISPLAY)
} -body {
︙
468
469
470
471
472
473
474

475

476
477
478
479
480
481
482

503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519








+

+








    set selInfo ""
    selection own .f1
    set result ""
    lappend result [childTkProcess eval {selection get TEST} 1]
    childTkProcess exit
    lappend result $selInfo
} -result {{selection owner didn't respond} {}}

# multiple display tests

test select-5.11 {Tk_GetSelection procedure} -constraints {
    altDisplay
} -setup {
    selectionSetup .f1
    selectionSetup .f2 $env(TK_ALT_DISPLAY)
} -body {
    selection handle -selection PRIMARY .f1 {handler TEST} TEST
︙
625
626
627
628
629
630
631

632

633
634
635
636
637
638
639

662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678








+

+








    set result [selection own -selection CLIPBOARD]
    selection clear -selection CLIPBOARD
    lappend result [selection own -selection CLIPBOARD]
} -result {.f1 {}}
test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body {
    selection clear foo bar
} -result {wrong # args: should be "selection clear ?-option value ...?"}

# selection get

test select-6.13 {Tk_SelectionCmd procedure} -body {
    selection get -selection
} -returnCodes error -result {value for "-selection" missing}
test select-6.14 {Tk_SelectionCmd procedure} -setup {
    selectionSetup
} -body {
    selection handle .f1 {handler TEST}
︙
678
679
680
681
682
683
684

685
686

687
688
689
690
691
692
693

717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734








+


+








} -body {
    selection handle -type TEST .f1 {handler TEST}
    selection handle -type STRING .f1 {handler STRING}
    set selValue "Test value"
    set selInfo ""
    list [selection get TEST] $selInfo
} -result {{Test value} {TEST 0 4000}}

# selection handle
# most of the handle section has been covered earlier

test select-6.22 {Tk_SelectionCmd procedure} -body {
    selection handle -selection
} -returnCodes error -result {value for "-selection" missing}
test select-6.23 {Tk_SelectionCmd procedure} -setup {
    selectionSetup
} -body {
    set selValue "Test value"
︙
709
710
711
712
713
714
715

716

717
718
719
720
721
722
723

750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766








+

+








test select-6.28 {Tk_SelectionCmd procedure} -returnCodes error -body {
    selection handle . foo bar baz blat
} -result {wrong # args: should be "selection handle ?-option value ...? window command"}
test select-6.29 {Tk_SelectionCmd procedure} -body {
    catch { destroy .f2 }
    selection handle .f2 dummy
} -returnCodes error -result {bad window path name ".f2"}

# selection own

test select-6.30 {Tk_SelectionCmd procedure} -body {
    selection own -selection
} -returnCodes error -result {value for "-selection" missing}
test select-6.31 {Tk_SelectionCmd procedure} -setup {
    selectionSetup
} -body {
    selection own .
︙
862
863
864
865
866
867
868

869
870
871
872
873
874
875

905
906
907
908
909
910
911
912
913
914
915
916
917
918
919








+








    childTkProcess exit
} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}}

##############################################################################
# note, we are not testing MULTIPLE style selections

# most control paths have been exercised above

test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints {
    x11
} -setup {
    selectionSetup
} -body {
    proc Ready {fd} {
	variable x
︙
914
915
916
917
918
919
920

921

922
923
924
925
926
927
928

958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974








+

+








    childTkProcess create
} -body {
    selection handle .f1 ERROR errHandler
    childTkProcess eval {selection get ERROR}
} -cleanup {
    childTkProcess exit
} -result {PRIMARY selection doesn't exist or form "ERROR" not defined}

# testing timers

# This one hangs in Exceed
test select-10.4 {ConvertSelection procedure} -constraints {
    x11 failsOnUbuntu
} -setup {
    selectionSetup
    childTkProcess create
} -body {
︙
1071
1072
1073
1074
1075
1076
1077
1078

1079
1080
1081
1082
1083
1084
1085
1086
1087

1117
1118
1119
1120
1121
1122
1123

1124
1125
1126
1127
1128

1129
1130
1131
1132








-
+




-





    selection get -selection CLIPBOARD_MANAGER -type SAVE_TARGETS
    clipboard get
} -cleanup {
    rename get_clip {}
} -result {abcd}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget child select
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/send.test. 
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

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


-
+
-









+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+



+
+
+
+

+
+
+
+










+
+
+
+



















+
+
+
+



+








# This file is a Tcl script to test out the "send" command and the
# other procedures in the file tkSend.c.  It is organized in the
# other procedures in the file tkSend.c.
# standard fashion for Tcl tests.
#
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2001 ActiveState Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# LOCAL TEST CONSTRAINTS
#

testConstraint xhost [llength [auto_execok xhost]]

#
# COMMON TEST SETUP
#

set name [tk appname]
set commId ""
catch {
    set registry [testsend prop root InterpRegistry]
    set commId [lindex [testsend prop root InterpRegistry] 0]
}
tk appname tktest
catch {send t_s_1 destroy .}
catch {send t_s_2 destroy .}

#
# TESTS
#

test send-1.1 {RegOpen procedure, bogus property} {secureserver testsend} {
    testsend bogus
    set result [winfo interps]
    tk appname tktest
    list $result [winfo interps]
} {{} tktest}
test send-1.2 {RegOpen procedure, bogus property} {secureserver testsend} {
    testsend prop root InterpRegistry {}
    set result [winfo interps]
    tk appname tktest
    list $result [winfo interps]
} {{} tktest}
test send-1.3 {RegOpen procedure, bogus property} {secureserver testsend} {
    testsend prop root InterpRegistry abcdefg
    tk appname tktest
    set x [testsend prop root InterpRegistry]
    string range $x [string first " " $x] end
} " tktest\nabcdefg\n"

#
# COMMON TEST SETUP
#

frame .f -width 1 -height 1
set id [string range [winfo id .f] 2 end]

test send-2.1 {RegFindName procedure} {secureserver testsend} {
    testsend prop root InterpRegistry {}
    list [catch {send foo bar} msg] $msg
} {1 {no application named "foo"}}
test send-2.2 {RegFindName procedure} {secureserver testsend} {
    testsend prop root InterpRegistry " abc\n def\nghi\n\n$id foo\n"
    tk appname foo
︙
130
131
132
133
134
135
136






137
138
139
140
141
142
143

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186








+
+
+
+
+
+








    list [catch {send Bogus set a 44} msg] $msg
} {1 {target application died or uses a Tk version before 4.0}}
test send-5.4 {ValidateName procedure} {secureserver testsend} {
    tk appname test
    testsend prop root InterpRegistry "$commId Bogus\n$commId test\n"
    winfo interps
} {test}

#
# COMMON TEST SETUP
#
# For tests send-6.*
#

if {[testConstraint nonPortable] && [testConstraint xhost]} {
    winfo interps
    tk appname tktest
    update
    childTkProcess create
    set x [split [exec xhost] \n]
︙
156
157
158
159
160
161
162




163
164
165
166
167
168
169

199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216








+
+
+
+








    list [catch {childTkProcess eval [list send [tk appname] set a 33]} msg] $a $msg
} {0 22 {X server insecure (must use xauth-style authorization); command ignored}}
test send-6.3 {ServerSecure procedure} {nonPortable secureserver xhost} {
    set a abc
    exec xhost - [exec hostname]
    list [childTkProcess eval [list send [tk appname] set a new]] $a
} {new new}

#
# COMMON TEST CLEANUP
#
childTkProcess exit

test send-7.1 {Tk_SetAppName procedure} {secureserver testsend} {
    testsend prop root InterpRegistry ""
    tk appname newName
    list [tk appname oldName] [testsend prop root InterpRegistry]
} "oldName {$commId oldName\n}"
︙
204
205
206
207
208
209
210

211
212
213
214
215
216
217

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265








+








    set a altDisplay
    tk appname xyzgorp
    list \[send xyzgorp set a\] \[send -displayof .t xyzgorp set a\]
    "]
    childTkProcess exit
    set result
} {altDisplay homeDisplay}

# Since macOS has no registry of interpreters, 8.3 and 8.10 will fail.
test send-8.3 {Tk_SendCmd procedure, options} {secureserver notAqua} {
    list [catch {send -- -async foo bar baz} msg] $msg
} {1 {no application named "-async"}}
test send-8.4 {Tk_SendCmd procedure, options} {secureserver} {
    list [catch {send -gorp foo bar baz} msg] $msg
} {1 {bad option "-gorp": must be -async, -displayof, or --}}
︙
239
240
241
242
243
244
245




246
247
248
249
250
251
252

287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304








+
+
+
+








    while executing
"open bad_file"
    invoked from within
"send [tk appname] open bad_file"} {posix enoent {no such file or directory}}}
test send-8.10 {Tk_SendCmd procedure, no such interpreter} {secureserver notAqua} {
    list [catch {send bogus_name bogus_command} msg] $msg
} {1 {no application named "bogus_name"}}

#
# COMMON TEST SETUP
#

catch {
    childTkInterp t_s_1 -class Test
    t_s_1 eval wm withdraw .
}

test send-8.11 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
︙
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

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








-
+


-
-
-
-
+
+
+


















+
+
+








    list $a [send t_s_1 {set a}]
} {us them}
test send-8.13 {Tk_SendCmd procedure, local execution, different interp} {secureserver testsend} {
    set a us
    send t_s_1 {set a them}
    list $a [send t_s_1 {set a}]
} {us them}
test send-8.14 {Tk_SendCmd procedure, local interp killed by send} {secureserver testsend} {
test send-8.14 {Tk_SendCmd procedure, local interp killed by send} -constraints {secureserver testsend} -body {
    childTkInterp t_s_2 -class Test
    list [catch {send t_s_2 {destroy .; concat result}} msg] $msg
} {0 result}

catch {interp delete t_s_2}

} -cleanup {
    catch {interp delete t_s_2}
} -result {0 result}
test send-8.15 {Tk_SendCmd procedure, local interp, error info} {secureserver testsend failsOnUbuntu} {
    catch {error foo}
    list [catch {send t_s_1 {if 1 {open bogus_file_name}}} msg] $msg $errorInfo $errorCode
} {1 {couldn't open "bogus_file_name": no such file or directory} {couldn't open "bogus_file_name": no such file or directory
    while executing
"open bogus_file_name"
    invoked from within
"if 1 {open bogus_file_name}"
    invoked from within
"send t_s_1 {if 1 {open bogus_file_name}}"} {POSIX ENOENT {no such file or directory}}}
test send-8.16 {Tk_SendCmd procedure, bogusCommWindow} {secureserver testsend failsOnUbuntu failsOnXQuartz} {
    testsend prop root InterpRegistry "10234 bogus\n"
    set result [list [catch {send bogus bogus command} msg] $msg]
    winfo interps
    tk appname tktest
    set result
} {1 {no application named "bogus"}}

#
# COMMON TEST CLEANUP
#
catch {interp delete t_s_1}

test send-8.17 {Tk_SendCmd procedure, deferring events} {secureserver nonPortable} {
    # Non-portable because some window managers ignore "raise"
    # requests so can't guarantee that new app's window won't
    # obscure .f, thereby masking the Expose event.
︙
331
332
333
334
335
336
337




338
339
340
341
342
343
344

385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402








+
+
+
+








    after 0 {set x yes}
    lappend result [send $app {concat x y z}]
    lappend result $x
    update
    childTkProcess exit
    lappend result $x
} {{x y z} no yes}

#
# COMMON TEST SETUP
#

tk appname tktest
catch {destroy .f}
frame .f
set id [string range [winfo id .f] 2 end]

test send-9.1 {Tk_GetInterpNames procedure} {secureserver testsend} {
︙
353
354
355
356
357
358
359



360
361
362
363
364
365
366

411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427








+
+
+








    list [winfo interps] [testsend prop root InterpRegistry]
} "tktest {$commId tktest\n}"
test send-9.3 {Tk_GetInterpNames procedure} {secureserver testsend} {
    testsend prop root InterpRegistry {}
    list [winfo interps] [testsend prop root InterpRegistry]
} {{} {}}

#
# COMMON TEST SETUP
#
catch {testsend prop root InterpRegistry "$commId tktest\n$id dummy\n"}

test send-10.1 {SendEventProc procedure, bogus comm property} {secureserver testsend} {
    testsend prop comm Comm {abc def}
    testsend prop comm Comm {}
    update
} {}
︙
503
504
505
506
507
508
509



510
511


512
513
514
515




516
517
518



519





520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538



539

540
541


542

543
544
545
546
547
548

549
550
551
552
553
554
555

564
565
566
567
568
569
570
571
572
573
574
575
576
577




578
579
580
581

582
583
584
585
586

587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613

614
615
616
617
618

619
620
621
622
623
624

625
626
627
628
629
630
631
632








+
+
+


+
+
-
-
-
-
+
+
+
+
-


+
+
+
-
+
+
+
+
+



















+
+
+
-
+


+
+
-
+





-
+








    send dummy foo
} -returnCodes 1 -match regexp -result {^(target application died|no application named "dummy")$}
test send-11.2 {AppendPropCarefully and AppendErrorProc procedures} {secureserver testsend} {
    testsend prop comm Comm "c\n-r0x123 44\n-n tktest\n-s concat a b c\n"
    update
} {}

#
# COMMON TEST SETUP
#
winfo interps
tk appname tktest

test send-12.1 {TimeoutProc procedure} -constraints {secureserver testsend} -setup {
catch {destroy .f}
frame .f
set id [string range [winfo id .f] 2 end]

    catch {destroy .f}
    frame .f
    set id [string range [winfo id .f] 2 end]
} -body {
test send-12.1 {TimeoutProc procedure} {secureserver testsend} {
    testsend prop root InterpRegistry "$id dummy\n"
    list [catch {send dummy foo} msg] $msg
} -cleanup {
    unset id
    destroy .f
} {1 {target application died or uses a Tk version before 4.0}}
} -result {1 {target application died or uses a Tk version before 4.0}}

#
# COMMON TEST CLEANUP
#

catch {testsend prop root InterpRegistry ""}

#macOS does not send to other processes
test send-12.2 {TimeoutProc procedure} {secureserver notAqua} {
    winfo interps
    tk appname tktest
    update
    childTkProcess create
    set app [childTkProcess eval {
	after 10 {after 10 {after 5000; exit}}
	tk appname
    }]
    after 200
    set result [list [catch {send $app foo} msg] $msg]
    childTkProcess exit
    set result
} {1 {target application died}}

#
# COMMON TEST SETUP
#
#macOS does not send to other processes

winfo interps
tk appname tktest

#macOS does not send to other processes
test send-13.1 {DeleteProc procedure} {secureserver notAqua} {
test send-13.1 {DeleteProc procedure} -constraints {secureserver notAqua} -body {
    childTkProcess create
    set app [childTkProcess eval {rename send {}; tk appname}]
    set result [list [catch {send $app foo} msg] $msg [winfo interps]]
    childTkProcess exit
    set result
} {1 {no application named "tktest #2"} tktest}
} -result {1 {no application named "tktest[0-9]+"} tktest} -match regexp
test send-13.2 {DeleteProc procedure} {secureserver notAqua} {
    winfo interps
    tk appname tktest
    rename send {}
    set result {}
    lappend result [winfo interps] [info commands send]
    tk appname foo
︙
570
571
572
573
574
575
576




577
578
579
580
581

582
583
584
585
586
587
588
589
590
591
592
593
594
595
596

597
598
599
600
601
602
603
604
605
606
607

647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677

678
679
680
681
682
683
684
685
686
687
688









+
+
+
+





+














-
+










-

    update
    set y parent
    set result [send -displayof .t xyzgorp1 {list $x [send -displayof .t xyzgorp2 set y]}]
    destroy .t
    childTkProcess exit
    set result
} {child parent}

#
# COMMON TEST SETUP
#

catch {
    testsend prop root InterpRegister $registry
    tk appname tktest
}

test send-15.1 {UpdateCommWindow procedure} {secureserver testsend} {
    set x [list [testsend prop comm TK_APPLICATION]]
    childTkInterp t_s_1 -class Test
    send t_s_1 wm withdraw .
    childTkInterp t_s_2 -class Test
    send t_s_2 wm withdraw .
    lappend x [testsend prop comm TK_APPLICATION]
    interp delete t_s_1
    lappend x [testsend prop comm TK_APPLICATION]
    interp delete t_s_2
    lappend x [testsend prop comm TK_APPLICATION]
} {tktest {t_s_2 t_s_1 tktest} {t_s_2 tktest} tktest}

#
# CLEANUP
# TESTFILE CLEANUP
#

catch {
    tk appname $name
    testsend prop root InterpRegistry $registry
    testdeleteapps
}

testutils forget child
cleanupTests
return
Changes to tests/spinbox.test. 
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


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

-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+






+
+
+








# This file is a Tcl script to test spinbox widgets in Tk.  It is
# This file is a Tcl script to test spinbox widgets in Tk.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Collected comments about lacks from the test
# - Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
#   and SpinboxTextVarProc.
# - No tests for DisplaySpinbox.
# - Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
# - No tests for EventuallyRedraw

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry scroll

#
# COMMON TEST SETUP
#

foreach i {1 2 3} {
    set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V]
}
set cy [font metrics {Courier -12} -linespace]

#
# TESTS
#

test spinbox-1.1 {configuration option: "activebackground"} -setup {
    spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \
	    -relief sunken
    pack .e
    update
} -body {
︙
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048



1049
1050
1051
1052
1053
1054
1055

1074
1075
1076
1077
1078
1079
1080



1081
1082
1083
1084
1085
1086
1087
1088
1089
1090








-
-
-
+
+
+








    update
} -body {
   .e bbox 0
} -cleanup {
    destroy .e
} -result [list 5 5 0 $cy]

# Oryginaly the result was count using measurements
# and metrics. It was changed to less verbose solution - the result is the one
# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
# Originally the result was counted using measurements and metrics. It was
# changed to less verbose solution - the result is the one that passes fonts
# constraint (this concerns tests 3.6, 3.7, 3.8, 3.10)
test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints {
	fonts
} -setup {
    spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2
    pack .e
    update
} -body {
︙
3119
3120
3121
3122
3123
3124
3125
3126

3127
3128
3129
3130
3131
3132
3133

3154
3155
3156
3157
3158
3159
3160

3161
3162
3163
3164
3165
3166
3167
3168








-
+








    .e xview 4
    update
    .e index 49
} -cleanup {
    destroy .e
} -result 21

# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
# Still need to write tests for SpinboxScanTo and SpinboxSelectTo.

test spinbox-14.1 {SpinboxFetchSelection procedure} -body {
    spinbox .e
    .e insert end "This is a test string"
    .e select from 1
    .e select to 18
    selection get
︙
3255
3256
3257
3258
3259
3260
3261

3262
3263
3264
3265
3266
3267
3268

3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304








+








##
# The validation tests build each one upon the previous, so cascading
# failures aren't good
#
# 19.* test cases in previous version highly depended on the previous
# test cases. This was replaced by inserting recently set configurations
# that matters for the test case

test spinbox-19.1 {spinbox widget validation} -setup {
    unset -nocomplain textVar validationData
} -body {
    spinbox .e -validate all \
	-validatecommand $validateCmd1 \
	-invalidcommand bell \
	-textvariable textVar \
︙
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898

3899
3900

3901
3902
3903
3904
3905
3906
3907
3908
3909
3910

3921
3922
3923
3924
3925
3926
3927







3928


3929
3930
3931

3932
3933
3934
3935
3936
3937









-
-
-
-
-
-
-
+
-
-
+


-






-

    event generate .s <<NextWord>>  ; # shall move insert to index 9
    .s delete 0 insert
    lappend res [.s get]
} -cleanup {
    destroy .s
} -result {{A sample } text}

# Collected comments about lacks from the test
# XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc,
# and SpinboxTextVarProc.
# No tests for DisplaySpinbox.
# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo.
# No tests for EventuallyRedraw

#
#
# CLEANUP
# TESTFILE CLEANUP
#

# option clear
foreach i {1 2 3} {
    unset validateCmd$i
}
unset i
testutils forget entry scroll
cleanupTests
return
Changes to tests/systray.test. 
1
2
3
4
5
6
7


















8

9
10
11
12






13
14




15
16
17
18
19
20
21

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


-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+








# This file is a Tcl script to test systray and sysnotify features in Tk.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 2020 Kevin Walzer/WordTech Communications LLC.
# Copyright © 2020 Francois Vogel.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# TESTS
#

test systray-1 {systray icon creation, all options} -setup {
    image create photo _book -data R0lGODlhDwAPAKIAAP//////AP8AAMDAwICAgAAAAAAAAAAAACwAAAAADwAPAAADSQhA2u5ksPeKABKSCaya29d4WKgERFF0l1IMQCAKatvBJ0OTdzzXI1xMB3TBZAvATtB6NSLKleXi3OBoLqrVgc0yv+DVSEUuFxIAOw==
} -body {
    tk systray create -image _book -text "Systray sample" \
	    -button1 {puts "button 1 click"} -button3 {puts "button 3 click"}
} -cleanup {
︙
220
221
222
223
224
225
226
227

228
229
230
231

243
244
245
246
247
248
249

250
251
252
253
254








-
+





} -setup {
    catch {tk systray destroy}
} -body {
    tk sysnotify {Alert} {This is an alert}
} -result {}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget child
cleanupTests
Changes to tests/testutils.GUIDE.
︙
163
164
165
166
167
168
169
170
171


172
173
174
175
176
177
178

163
164
165
166
167
168
169


170
171
172
173
174
175
176
177
178








-
-
+
+








	variable tasteVerdict
    }

Note that the namespace variables "doneNess" and "seasonings" are initialized
with a value, while the namespace variable "tasteVerdict" is not. Both variants
of declaring/defining a namespace variable are supported.

B3. Tricky aspects of repeated initialization
---------------------------------------------
B3. Tricky aspects of repeated initialization (in mode "-singleproc 1")
-----------------------------------------------------------------------
While the entire Tk test suite is running, many test files are loaded, each of
which may import and subsequently forget utility domains. When tracking a single
utility domain across test files that come and go, associated namespace variables
may be imported, initialized and cleaned up repeatedly. This repetitive cycle
presents tricky aspects for the re-initialization of those namespace variables
that were declared using the "variable" command without supplying a value. This
is caused by the fact that, once established, the upvar link for imported
︙
Changes to tests/testutils.tcl.
︙
136
137
138
139
140
141
142












143
144
145
146
147
148
149

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








+
+
+
+
+
+
+
+
+
+
+
+









	set num [incr _pause(count)]
	set _pause($num) 1

	after $ms [list unset [namespace current]::_pause($num)]
	vwait [namespace current]::_pause($num)
    }

    # resetWindows --
    #
    #	Restores a proper initial window setup for a test file, cleaning up from
    #	the state brought about by a previous testfile.
    #
    proc resetWindows {} {
	deleteWindows
	wm geometry . {}
	raise .
	update
    }

    # On macOS windows are not allowed to overlap the menubar at the top of the
    # screen or the dock.  So tests which move a window and then check whether it
    # got moved to the requested location should use a y coordinate larger than the
    # height of the menubar (normally 23 pixels) and an x coordinate larger than the
    # width of the dock, if it happens to be on the left.
    # The C-level command "testmenubarheight" deals with this issue but it may
︙
365
366
367
368
369
370
371

372
373
374
375
376








377
378

379
380
381
382
383
384
385

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








+





+
+
+
+
+
+
+
+

-
+








    #	Create a new Tk application in a child process, and enable it to
    #	evaluate scripts on our behalf.
    #
    #	Suggestion: replace with child interp or thread ?
    #
    proc childTkProcess {subcmd args} {
	variable fd
	variable interpCount
	switch -- $subcmd {
	    create {
		if {[info exists fd] && [string length $fd]} {
		    childTkProcess exit
		}
		# Beware of bug #280189e35d. We prevent that bug by not relying
		# on the automatic detection of duplicate interp names, as
		# advertised by the manual page for "tk appname". Instead, we
		# pass a unique appname to the executable that is being invoked
		# below.
		if {! [info exists interpCount]} {
		    set interpCount 1
		}
		set fd [open "|[list [::tcltest::interpreter] \
			-geometry +0+0 -name tktest] $args" r+]
			-geometry +0+0 -name tktest[incr interpCount]] $args" r+]
		puts $fd "puts foo; flush stdout"
		flush $fd
		if {[gets $fd data] < 0} {
		    error "unexpected EOF from \"[::tcltest::interpreter]\""
		}
		if {$data ne "foo"} {
		    error "unexpected output from\
︙
Changes to tests/testutils.test. 
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

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









-
-
-
-
-
+

-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+


+
+
+
+








# Tests for the "testutils" command, defined in testutils.tcl
#
# © 2025 Erik Leunissen
#
# 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.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

# Notes:
# NOTE
#
# - All tests have been constrained with test constraint "testutils". This
#   constraint isn't set anywhere, and therefore false by default. Therefore,
#   the tests in this file are skipped in a regular invocation of the Tk test
#   suite. In order to run these test, you need to use the tcltest option
#   "-constraints testutils" in the invocation, possibly combined with the
#   option "-file testutils.test" to exclude other test files, or with
#   "-limitconstraints true" to exclude other tests.
#
# - At this place in the test file, the file "testutils.tcl" has already been
#   sourced (through tcltest::loadTestedCommands above), and the utility procs
# All tests in this testfile have been constrained with test constraint "testutils".
# This constraint isn't set anywhere, and therefore false by default. Therefore,
# the tests in this file are skipped in a regular invocation of the Tk test suite.
# In order to run these test, you need to use the tcltest option
# "-constraints testutils" in the invocation, possibly combined with the option
# "-file testutils.test" to exclude other test files, or with
# "-limitconstraints true" to exclude other tests.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
#   from domain "generic" are already available. Therefore we can make use of
#   proc "assert" here.
#
}

# Ensure a pristine initial window state
resetWindows

assert {"testutils" in [info procs testutils]}

#
# TESTS
#

#
# Section 1: invalid invocations
#
test testutils-1.1 {invalid subcommand} -constraints testutils -body {
    testutils foo
} -result {invalid subCmd "foo". Usage: testutils export|import|forget ?domain domain ...?} -returnCodes error
︙
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

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








-
+

+
+
















-
+













-
+








} -result {testutils domain "foo" doesn't exist} -returnCodes error

test testutils-1.6 {invalid domain for subCmd forget} -constraints testutils -body {
    testutils forget foo
} -result {testutils domain "foo" doesn't exist} -returnCodes error

#
# Create a domain namespace for testing export, import, forget
# COMMON TEST SETUP
#

# Create a domain namespace for testing export, import, forget
assert {"::tk::test::foo" ni [namespace children ::tk::test]}
assert {"::tk::test::zez" ni [namespace children ::tk::test]}
catch {rename init {}}
catch {rename kuk {}}
unset -nocomplain bar pip
namespace eval ::tk::test::foo {
    proc init {} {
	variable bar 123
	variable pip
    }
    proc kuk {} {}
    testutils export
}
set initVars [info vars]; lappend initVars initVars

#
# 2. Domain failures for forget and import
# Section 2. Domain failures for forget and import
#
test testutils-2.1 {forget not-imported domain} -constraints testutils -body {
    testutils forget foo
} -result {testutils domain "foo" was not imported} -returnCodes error

test testutils-2.2 {duplicate import} -constraints testutils -body {
    testutils import foo
    testutils import foo
} -result {testutils domain "foo" was already imported} -returnCodes error -cleanup {
    testutils forget foo
}

#
# 3. Import procs
# Section 3. Import procs
#
test testutils-3.1 {utility proc is imported and init proc is not} -constraints testutils -body {
    testutils import foo
    expr {([info procs kuk] eq "kuk") && ([info procs init] eq "")}
} -result 1 -cleanup {
    testutils forget foo
}
︙
112
113
114
115
116
117
118
119

120
121
122
123
124
125
126

133
134
135
136
137
138
139

140
141
142
143
144
145
146
147








-
+








	testutils import foo
    }
} -result "import from testutils domain \"foo\" failed: can't import command \"kuk\": already exists" -returnCodes error -cleanup {
    namespace delete ::zez
}

#
# 4. Import variables
# Section 4. Import variables
#
test testutils-4.1 {associated variables are imported} -constraints testutils -body {
    testutils import foo
    set varNames [info vars]
    foreach name $initVars {
	set varNames [lremove $varNames [lsearch $varNames $name]]
    }
︙
223
224
225
226
227
228
229
230

231
232
233
234
235
236
237

244
245
246
247
248
249
250

251
252
253
254
255
256
257
258








-
+








#
# COMMON TEST CLEANUP
#
testutils forget timing


#
# CLEANUP
# TESTFILE CLEANUP
#

namespace delete ::tk::test::foo
unset -nocomplain bar initVars pip
cleanupTests

# EOF
Changes to tests/text.test. 
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

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+









+
+
+
+








# This file is a Tcl script to test the code in the file tkText.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1992-1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

# The statements below reset the main window;  it's needed if the window
# manager is mwm to make mwm forget about a previous minimum size setting.
wm geometry . {}
wm withdraw .
wm minsize . 1 1
wm positionfrom . user
wm deiconify .

#
# TESTS
#

test text-1.1 {configuration option: "autoseparators"} -setup {
    text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold}
    pack .t
    update
} -body {
    .t configure -autoseparators yes
    .t cget -autoseparators
︙
1171
1172
1173
1174
1175
1176
1177

1178
1179
1180
1181
1182
1183
1184

1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212








+








bOy GIrl .#@? x_yz
!@#$%
Line 7"
    .t co 1.0 z 1.2
} -cleanup {
    destroy .t
} -returnCodes error -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, pendingsync, replace, scan, search, see, sync, tag, window, xview, or yview}

# "configure" option is already covered above

test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup {
    text .t
} -body {
    .t debug 0 1
} -cleanup {
︙
3478
3479
3480
3481
3482
3483
3484





3485
3486
3487
3488




3489
3490
3491
3492
3493

3494
3495
3496
3497
3498

3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523

3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517




3518
3519
3520
3521
3522
3523
3524
3525

3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545





3546
3547
3548
3549
3550
3551
3552








+
+
+
+
+
-
-
-
-
+
+
+
+




-
+





+













-
-
-
-
-








    pack .top.t
    update
    set geom [wm geometry .top]
    set x [string range $geom 0 [string first + $geom]]
} -cleanup {
    destroy .top
} -result {150x140+}

#
# COMMON TEST SETUP
#

# This test was failing Windows because the title bar on .t was a certain
# minimum size and it was interfering with the size requested by the -setgrid.
# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink
# to the appropriate size.
# Tests text-14.19 and text-14.20 were failing Windows because the title bar on
# .t was a certain minimum size and it was interfering with the size requested
# by the -setgrid. The "overrideredirect" gets rid of the titlebar so the
# toplevel can shrink to the appropriate size.
# On macOS, however, there is no way to make the window overlap the
# menubar.  Starting with macOS 15 (Sequoia) it became impossible for
# the y coordinate of the top of a window to be less than 10 plus the
# menubar height (as reported by [[NSApp mainMenu] menuBarHeight]).

#
if {[tk windowingsystem] eq "aqua"} {
    set minY [expr [testmenubarheight] + 11]
} else {
    set minY 0
}

test text-14.19 {ConfigureText procedure} -setup {
    toplevel .top
    text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
} -body {
    .top.t configure -width 20 -height 10 -setgrid 1
    wm overrideredirect .top 1
    pack .top.t
    wm geometry .top +0+$minY
    update
    wm geometry .top
} -cleanup {
    destroy .top
} -result "20x10+0+$minY"
# This test was failing on Windows because the title bar on .t was a certain
# minimum size and it was interfering with the size requested by the -setgrid.
# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink
# to the appropriate size.
# On macOS we again use minY as a workaround.
test text-14.20 {ConfigureText procedure} -setup {
    toplevel .top
    text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2
} -body {
    .top.t configure -width 20 -height 10 -setgrid 1
    wm overrideredirect .top 1
    pack .top.t
︙
7819
7820
7821
7822
7823
7824
7825
7826
7827




7828
7829
7830
7831
7832
7833

7848
7849
7850
7851
7852
7853
7854


7855
7856
7857
7858
7859

7860
7861
7862
7863








-
-
+
+
+
+

-





    event generate .t <Button-1> -x 50 -y 50
    event generate .t <B1-Motion> -x 50 -y -50
    .t index sel.first
} -cleanup {
    destroy .t
} -result {1.0}


# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/textBTree.test. 
1
2
3

4
5
6
7
8
9
10


















11

12
13
14









15
16
17
18
19
20
21

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



-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out the B-tree facilities of
# Tk's text widget (the contents of the file "tkTextBTree.c".  There are
# several file with additional tests for other features of text widgets.
# several files with additional tests for other features of text widgets.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1992-1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc setup {} {
    .t delete 1.0 100000.0
    .t tag delete x y
    .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info"
    .t tag add x 1.1
    .t tag add x 1.5 1.13
︙
55
56
57
58
59
60
61



62


63
64
65




66
67
68
69
70
71
72

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








+
+
+
-
+
+



+
+
+
+








    for {set i 0} {$i < 2000} {incr i} {
	append x "Line $i abcd efgh ijkl\n"
    }
    .t insert insert $x
    .t debug 1
}

#
# COMMON TEST SETUP
#
# Widget used in tests 1.* - 13.*
# For tests 1.* - 13.*
#
destroy .t
text .t
.t debug on

#
# TESTS
#

test btree-1.1 {basic insertions} -body {
    .t delete 1.0 100000.0
    .t insert 1.0 "Line 1\nLine 2\nLine 3"
    .t get 1.0 1000000.0
} -result "Line 1\nLine 2\nLine 3\n"
test btree-1.2 {basic insertions} -body {
︙
897
898
899
900
901
902
903
904
905





906
907
908
909
910
911
912

928
929
930
931
932
933
934


935
936
937
938
939
940
941
942
943
944
945
946








-
-
+
+
+
+
+








    }
} -body {
    setup
    .t insert 1.2 $bigText2
    .t tag add x 190.3 191.2
    .t tag next x 3.5
} -result {190.3 191.2}
destroy .t


#
# COMMON TEST CLEANUP
#
destroy .t

test btree-14.1 {check tag presence} -setup {
    destroy .t
    text .t
    set bigText2 {}
    for {set i 0} {$i < 200} {incr i} {
	append bigText2 "Line $i\n"
︙
1301
1302
1303
1304
1305
1306
1307
1308

1309
1310
1311
1312
1313

1335
1336
1337
1338
1339
1340
1341

1342
1343
1344
1345
1346









-
+




-

    .t tag add x 500.0 520.0
    list [.t tag prev x end] [.t tag prev x 433.0]
} -cleanup {
    destroy .t
} -result {{500.0 520.0} {200.0 220.0}}

#
# CLEANUP
# TESTFILE CLEANUP
#

rename setup {}
cleanupTests
return
Changes to tests/textDisp.test. 
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

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+




-
-
-
-
-
-
-
-
+
-
-
-
-
+
+
+
+
+


+
+


-
+











+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the code in the file tkTextDisp.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import scroll text

# The delay procedure needs to wait long enough for the asynchronous updates
# performed by the text widget to run.
proc delay {} {
    update
    after 100
    update
}

#
# The procedure below is used to generate errors during scrolling commands.

proc scrollError args {
    error "scrolling error"
# LOCAL UTILITY PROCS
#

proc bizarre_scroll args {
    .t2.t delete 5.0 end
}

# lequal --
#
# Return 1 if the two given lists are the same, otherwise return the two lists.
# This is used to compare a test actual result with a test expected result.

#
proc lequal {res expected} {
    if {[llength $res] != [llength $expected]} {
	return [list "Lengths differ"  result: $res - expected: $expected]
    }
    for {set i 0} {$i < [llength $res]} {incr i} {
	if {[lindex $res $i] ne [lindex $expected $i]} {
	    return [list result: $res - expected: $expected]
	}
    }
    return 1
}

# delay --
#
# Wait long enough for the asynchronous updates performed by the text widget to run.
#
proc delay {} {
    update
    after 100
    update
}

# scrollError --
#
# Generate errors during scrolling commands
#
proc scrollError args {
    error "scrolling error"
}

# xcharr --
#
# Return x-coordinate in widget $w of the first pixel of $n-th char
# counted from the right, right justified
#
proc xcharr {n {w .t}} {
    return [expr {[winfo width $w] - [bo $w] - [xw $n]}]
}

# xe --
#
# Return x-pixels of empty space in widget $w on a line containing $n chars
#
proc xe {n {w .t}} {
    return [expr {[winfo width $w] - (2 * [bo $w]) - [xw $n]}]
}

#
# COMMON TEST SETUP
#

# Create entries in the option database to be sure that geometry options
# like border width have selected values.
option add *Text.borderWidth 2         ; # tests work with [1-3]
option add *Text.highlightThickness 2  ; # tests work with [0-5]
option add *Text.padX 1  ; # same padding in x and y, see proc bo; tests work with [0-4]
option add *Text.padY 1  ; # same padding in x and y, see proc bo; tests work with [0-4]
︙
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

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








-
-
-
-
-
-
-
-
-



















+
+
+
+








text .t -font $fixedFont -width 20 -height 10 -yscrollcommand setScrollInfo
pack .t -expand 1 -fill both
.t tag configure big -font $bigFont
.t debug on

wm geometry . {}

# x-coordinate in widget $w of the first pixel of $n-th char counted from the right, right justified
proc xcharr {n {w .t}} {
    return [expr {[winfo width $w] - [bo $w] - [xw $n]}]
}
# x-pixels of empty space in widget $w on a line containing $n chars
proc xe {n {w .t}} {
    return [expr {[winfo width $w] - (2 * [bo $w]) - [xw $n]}]
}

# The statements below reset the main window;  it's needed if the window
# manager is mwm to make mwm forget about a previous minimum size setting.

wm withdraw .
wm minsize . 1 1
wm positionfrom . user
wm deiconify .
update

# Some window managers (like olwm under SunOS 4.1.3) misbehave in a way
# that tends to march windows off the top and left of the screen.  If
# this happens, some tests will fail because parts of the window will
# not need to be displayed (because they're off-screen).  To keep this
# from happening, move the window if it's getting near the left or top
# edges of the screen.

if {([winfo rooty .] < 50) || ([winfo rootx .] < 50)} {
    wm geom . +50+50
}

#
# TESTS
#

test textDisp-0.1 {double tag elide transition} {
    # Example from tkchat crash.  For some reason can only
    # get this test case to crash when first.
    catch {destroy .top}
    pack [text .top]
︙
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

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








+
+
+
+

+
















+
+
+
+








    .t tag configure z -tabs {}
    lappend x [lindex [.t bbox 1.2] 0]
    .t tag configure z -tabs 30
    .t tag raise x
    update idletasks
    lappend x [lindex [.t bbox 1.2] 0]
} [list [expr {[bo]+70}] [expr {[bo]+50}] [expr {[bo]+50}]]

#
# COMMON TEST CLEANUP
#
.t tag delete x y z

test textDisp-1.2 {GetStyle procedure, wrapmode} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "abcd\nefg hijkl mnop qrstuv wxyz"
    .t tag configure x -wrap word
    .t tag configure y -wrap none
    .t tag raise y
    update
    set result [list [.t bbox 2.20]]
    .t tag add x 2.0 2.1
    lappend result [.t bbox 2.20]
    .t tag add y 1.end 2.2
    lappend result [.t bbox 2.20]
} [list [list [xchar 0] [yline 3] $fixedWidth $fixedHeight] \
	[list [xchar 5] [yline 3] $fixedWidth $fixedHeight] \
	    {}]

#
# COMMON TEST CLEANUP
#
.t tag delete x y

test textDisp-2.1 {LayoutDLine, basics} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "This is some sample text for testing."
    list [.t bbox 1.19] [.t bbox 1.20]
︙
310
311
312
313
314
315
316




317
318
319

320
321
322
323
324
325
326

368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389








+
+
+
+



+








    .t insert 1.0 "This isxxx some sample text for testing."
    .t tag add foo 1.4 1.6
    .t mark set insert 1.8
    list [.t bbox 1.2] [.t bbox 1.5] [.t bbox 1.11]
} [list [list [xchar 2] [yline 1] $fixedWidth $fixedHeight] \
	[list [xchar 5] [yline 1] $fixedWidth $fixedHeight] \
	    [list [xchar 11] [yline 1] $fixedWidth $fixedHeight]]

#
# COMMON TEST CLEANUP
#
foreach m [.t mark names] {
    catch {.t mark unset $m}
}

test textDisp-2.8 {LayoutDLine, extra chunk at end of dline} -setup {
    scan [wm geom .] %dx%d width height
} -body {
    wm geom . [expr {$width+1}]x$height
    update
    .t configure -wrap char
    .t delete 1.0 end
︙
443
444
445
446
447
448
449





450
451

452
453
454
455
456
457
458

506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527








+
+
+
+
+


+








    .t tag configure y -justify right
    .t tag add x 2.0
    .t tag add y 3.0
    .t xview scroll 5 units
    list [.t bbox 2.0] [.t bbox 3.0]
} [list [list [expr {[bo]+[xe 4]/2-[xw 5]}] [yline 2] $fixedWidth $fixedHeight] \
	[list [expr {[xcharr 10]-[xw 5]}] [yline 3] $fixedWidth $fixedHeight]]

#
# COMMON TEST CLEANUP
#

.t tag delete x
.t tag delete y

test textDisp-2.19 {LayoutDLine, margins} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Lots of long words, enough to force word wrap\nThen\nmore lines"
    # margins in pixels depend on the font width for more flexibility
    set lm1 [expr {3*$fixedWidth}]
    set lm2 [expr {2*$lm1}]
︙
485
486
487
488
489
490
491





492
493

494
495
496
497
498
499
500

554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575








+
+
+
+
+


+








    .t insert 1.0 "Sample text"
    .t tag configure x -lmargin1 80 -lmargin2 80 -rmargin 100
    .t tag add x 1.0 end
    list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2]
} [list [list [expr {[bo]+80}] [yline 1] [expr {[xe 0]-80}] $fixedHeight] \
	[list [expr {[bo]+80}] [yline 2] [expr {[xe 0]-80}] $fixedHeight] \
	[list [expr {[bo]+80}] [yline 3] [expr {[xe 0]-80}] $fixedHeight]]

#
# COMMON TEST CLEANUP
#

.t tag delete x
.t tag delete y

test textDisp-2.22 {LayoutDLine, spacing options} {
    .t configure -wrap word
    .t delete 1.0 end
    .t tag delete x y
    .t insert end "Short line\nLine 2 is long enough "
    .t insert end "to wrap around a couple of times"
    .t insert end "\nLine 3\nLine 4"
︙
513
514
515
516
517
518
519





520

521
522
523
524
525
526
527

588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608








+
+
+
+
+

+








    set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}]
    set i [.t dlineinfo 2.end]
    set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}]
    set i [.t dlineinfo 3.0]
    set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}]
    list $b1 $b2 $b3 $b4
} [list 2 7 10 15]

#
# COMMON TEST SETUP
#

.t configure -spacing1 0 -spacing2 0 -spacing3 0

test textDisp-2.23 {LayoutDLine, spacing options} {
    .t configure -wrap word
    .t delete 1.0 end
    .t tag delete x y
    .t insert end "Short line\nLine 2 is long enough "
    .t insert end "to wrap around a couple of times"
    .t insert end "\nLine 3\nLine 4"
︙
545
546
547
548
549
550
551





552

553
554
555
556
557
558
559

626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646








+
+
+
+
+

+








    set b2 [expr {[lindex $i 1] + [lindex $i 4] - $b2}]
    set i [.t dlineinfo 2.end]
    set b3 [expr {[lindex $i 1] + [lindex $i 4] - $b3}]
    set i [.t dlineinfo 3.0]
    set b4 [expr {[lindex $i 1] + [lindex $i 4] - $b4}]
    list $b1 $b2 $b3 $b4
} [list 1 5 13 16]

#
# COMMON TEST SETUP
#

.t configure -spacing1 0 -spacing2 0 -spacing3 0

test textDisp-2.24 {LayoutDLine, tabs, saving from first chunk} {
    .t delete 1.0 end
    .t tag delete x y
    .t tag configure x -tabs 70
    .t tag configure y -tabs 80
    .t insert 1.0 "ab\tcde"
    .t tag add x 1.0 end
︙
622
623
624
625
626
627
628





629
630
631
632
633
634
635

709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727








+
+
+
+
+








    .t tag add big 1.5 1.10
    .t tag add big 2.11 2.14
    list [.t bbox 1.1] [.t bbox 1.6] [.t dlineinfo 1.0] [.t dlineinfo 3.0]
} [list [list [xchar 1] [expr {[yline 1]+$ascentDiff}] $fixedWidth $fixedHeight] \
	[list [expr {[xchar 5]+[font measure $bigFont s]}] [yline 1] [font measure $bigFont a] $bigHeight] \
	[list [bo] [yline 1] [expr {[xw 5]+[font measure $bigFont sampl]+[xw 2]}] $bigHeight $bigAscent] \
	[list [bo] [expr {[bo]+2*$bigHeight+2*$fixedHeight}] [xw 5] $fixedHeight $fixedAscent]]

#
# COMMON TEST SETUP
#

.t configure -wrap char

test textDisp-4.1 {UpdateDisplayInfo, basic} {
    .t delete 1.0 end
    .t insert end "Line 1\nLine 2\nLine 3\n"
    update
    .t delete 2.0 2.end
︙
667
668
669
670
671
672
673




674

675
676
677
678
679
680
681

759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778








+
+
+
+

+








    .t delete 2.2
    update
    list [.t bbox 2.0] [.t bbox x] [.t bbox 3.0] $tk_textRelayout
} [list [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \
	[list [xchar 0] [yline 3] $fixedWidth $fixedHeight] \
	[list [xchar 0] [yline 4] $fixedWidth $fixedHeight] \
	{2.0 2.20}]

#
# COMMON TEST CLEANUP
#
.t mark unset x

test textDisp-4.4 {UpdateDisplayInfo, wrap-mode "none"} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
    update
    list [.t bbox 2.0] [.t bbox 2.25] [.t bbox 3.0] $tk_textRelayout
} [list [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \
︙
693
694
695
696
697
698
699





700
701
702

703
704
705
706
707
708
709

790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812








+
+
+
+
+



+








    .t insert end "Line 1\nLine 2 is so long that it wraps around\nLine 3"
    update
    list [.t bbox 2.0] [.t bbox 2.1] [.t bbox 3.0] $tk_textRelayout
} [list [list [xchar 0] [yline 2] 1 $fixedHeight] \
	{} \
	[list [xchar 0] [yline 3] 1 $fixedHeight] \
	{1.0 2.0 3.0}]

#
# COMMON TEST SETUP
#

if {[tk windowingsystem] eq "win32"} {
    wm overrideredirect . 0
}

test textDisp-4.6 {UpdateDisplayInfo, tiny window} {
    # This test was failing on Windows because the title bar on .
    # was a certain minimum size and it was interfering with the size
    # requested.  The "overrideredirect" gets rid of the titlebar so
    # the toplevel can shrink to the appropriate size.  On Unix, setting
    # the overrideredirect on "." confuses the window manager and
    # causes subsequent tests to fail.
︙
721
722
723
724
725
726
727





728
729
730
731

732
733
734
735
736
737
738

824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847








+
+
+
+
+




+








    update
    set x [list [.t bbox 1.0] [.t bbox 2.0] $tk_textRelayout]
    wm overrideredirect . 0
    update
    set expected [list [list [xchar 0] [yline 1] 1 1] {} 1.0]
    lequal $x $expected
} {1}

#
# COMMON TEST SETUP
#

catch {destroy .f2}
.t configure -borderwidth 0 -wrap char
wm geom . {}
update

test textDisp-4.7 {UpdateDisplayInfo, filling in extra vertical space} {
    # This test was failing on Windows because the title bar on .
    # was a certain minimum size and it was interfering with the size
    # requested.  The "overrideredirect" gets rid of the titlebar so
    # the toplevel can shrink to the appropriate size.  On Unix, setting
    # the overrideredirect on "." confuses the window manager and
    # causes subsequent tests to fail.
︙
796
797
798
799
800
801
802





803
804
805
806
807
808
809

810
811
812
813
814
815
816

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








+
+
+
+
+







+








    update
    .t yview moveto 0
    update
    .t yview moveto 1
    update
    winfo ismapped .b
} 0

#
# COMMON TEST SETUP
#

.t configure -wrap word
.t delete 1.0 end
.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5\nLine 6\nLine 7\n"
.t insert end "Line 8\nLine 9\nLine 10\nLine 11\nLine 12\nLine 13\n"
.t insert end "Line 14\nLine 15\nLine 16"
.t tag delete x
.t tag configure x -relief raised -borderwidth 2 -background white

test textDisp-4.13 {UpdateDisplayInfo, special handling for top/bottom lines} {
    .t tag add x 1.0 end
    .t yview 1.0
    update
    .t yview scroll 3 units
    update
    list $tk_textRelayout $tk_textRedraw
︙
919
920
921
922
923
924
925
926

927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942


943

944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960




961

962
963
964
965
966
967
968

1034
1035
1036
1037
1038
1039
1040

1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059

1060
1061
1062
1063

1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089








-
+
















+
+
-
+



-













+
+
+
+

+








    .t xview scroll 25 units
    update
    .t configure -wrap char
    list [.t bbox 2.0] [.t bbox 2.16]
} [list [list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \
	[list [xchar 16] [yline 2] $fixedWidth $fixedHeight]]

test textDisp-5.1 {DisplayDLine, handling of spacing} {
test textDisp-5.1 {DisplayDLine, handling of spacing} -body {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz"
    .t tag configure spacing -spacing1 8 -spacing3 2
    .t tag add spacing 1.0 end
    frame .t.f1 -width 10 -height 4 -bg black
    frame .t.f2 -width 10 -height 4 -bg black
    frame .t.f3 -width 10 -height 4 -bg black
    frame .t.f4 -width 10 -height 4 -bg black
    .t window create 1.3 -window .t.f1 -align top
    .t window create 1.7 -window .t.f2 -align center
    .t window create 2.1 -window .t.f3 -align bottom
    .t window create 2.10 -window .t.f4 -align baseline
    update
    list [winfo geometry .t.f1] [winfo geometry .t.f2] \
	    [winfo geometry .t.f3] [winfo geometry .t.f4]
} -cleanup {
    .t tag delete spacing
} [list 10x4+[xchar 3]+[expr {[yline 1]+8}] \
} -result [list 10x4+[xchar 3]+[expr {[yline 1]+8}] \
	10x4+[expr {[xchar 6]+10}]+[expr {[yline 1]+8+($fixedHeight-4)/2}] \
	10x4+[xchar 1]+[expr {[yline 2]+8+2+8+($fixedHeight-4)}] \
	10x4+[expr {[xchar 9]+10}]+[expr {[yline 2]+8+2+8+($fixedAscent-4)}]]
.t tag delete spacing

# Although the following test produces a useful result, its main
# effect is to produce a core dump if Tk doesn't handle display
# relayout that occurs during redisplay.
test textDisp-5.2 {DisplayDLine, line resizes during display} {
    .t delete 1.0 end
    frame .t.f -width 20 -height 20 -bd 2 -relief raised
    bind .t.f <Configure> {.t.f configure -width 30 -height 30}
    .t window create insert -window .t.f
    update
    list [winfo width .t.f] [winfo height .t.f]
} [list 30 30]

#
# COMMON TEST SETUP
#

.t configure -wrap char

test textDisp-6.1 {scrolling in DisplayText, scroll up} {
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    update
︙
1038
1039
1040
1041
1042
1043
1044





1045

1046
1047
1048
1049
1050
1051
1052

1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179








+
+
+
+
+

+








    }
    update
    .t delete 1.6 1.end
    destroy .f2
    update
    list $tk_textRelayout $tk_textRedraw
} {{1.0 9.0 10.0} {1.0 4.0 5.0 6.0 7.0 8.0 9.0 10.0}}

#
# COMMON TEST SETUP
#

.t configure -bd 0

test textDisp-6.7 {DisplayText, vertical scrollbar updates} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    .t count -update -ypixels 1.0 end
    update
    set scrollInfo
︙
1060
1061
1062
1063
1064
1065
1066





1067

1068
1069
1070
1071
1072
1073
1074

1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207








+
+
+
+
+

+








    foreach i {2 3 4 5 6 7 8 9 10 11 12 13} {
	.t insert end "\nLine $i"
    }
    update
    .t count -update -ypixels 1.0 end ; update
    set scrollInfo
} [list 0.0 [expr {10.0/13}]]

#
# COMMON TEST SETUP
#

.t configure -yscrollcommand {} -xscrollcommand setScrollInfo

test textDisp-6.9 {DisplayText, horizontal scrollbar updates} {
    .t configure -wrap none
    .t delete 1.0 end
    update
    set scrollInfo unchanged
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
︙
1100
1101
1102
1103
1104
1105
1106



1107
1108
1109
1110
1111
1112
1113

1114
1115
1116
1117
1118
1119
1120

1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257








+
+
+







+








    update
    set tk_textEmbWinDisplay {}
    .t delete 2.0 3.0
    update
    list $tk_textEmbWinDisplay
} {{4.0 6.0}}

#
# COMMON TEST SETUP
#

.t configure -bd 2 -relief raised -wrap char
.t delete 1.0 end
.t insert 1.0 "Line 1 is so long that it wraps around, a couple of times"
foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
    .t insert end "\nLine $i"
}

test textDisp-7.1 {TkTextRedrawRegion} {aquaKnownBug} {
# constrained by aquaKnownBug until ticket [aad0231f07] is fixed
    frame .f2 -bg #ff0000
    place .f2 -in .t -relx 0.2 -relwidth 0.6 -rely 0.22 -relheight 0.55
    update
    destroy .f2
    update
︙
1186
1187
1188
1189
1190
1191
1192





1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206





1207

1208
1209
1210
1211
1212
1213
1214

1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362








+
+
+
+
+














+
+
+
+
+

+








    place .f2 -in .t -relx 0.0 -relwidth 0.4 -rely 0.35 -relheight 0.4 \
	    -anchor nw -bordermode ignore
    update
    destroy .f2
    update
    list $tk_textRelayout $tk_textRedraw
} {{} {borders 4.0 5.0 6.0 7.0 eof}}

#
# COMMON TEST SETUP
#

.t configure -bd 0

test textDisp-8.1 {TkTextChanged: redisplay whole lines} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Line 1\nLine 2 is so long that it wraps around, two times"
    foreach i {3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    update
    .t delete 2.36 2.38
    update
    list $tk_textRelayout $tk_textRedraw [.t bbox 2.32]
} [list {2.0 2.18 2.38} {2.0 2.18 2.38} [list [xchar 14] [yline 3] $fixedWidth $fixedHeight]]

#
# COMMON TEST SETUP
#

.t configure -wrap char

test textDisp-8.2 {TkTextChanged, redisplay whole lines} {
    .t delete 1.0 end
    .t insert 1.0 "Line 1 is so long that it wraps around, two times"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
    update
︙
1546
1547
1548
1549
1550
1551
1552





1553
1554

1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568






1569
1570
1571
1572
1573
1574

1575
1576
1577
1578
1579
1580
1581

1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720


1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740








+
+
+
+
+


+












-
-
+
+
+
+
+
+






+








    .t delete 1.0 end
    .t insert 1.0 "Line 1\nLine 2 is long enough to wrap\nLine 3 is also long enough to wrap\nLine 4"
    update
    .t configure -bg black
    update
    list $tk_textRelayout $tk_textRedraw
} {{1.0 2.0 2.20 3.0 3.20 4.0} {borders 1.0 2.0 2.20 3.0 3.20 4.0 eof}}

#
# COMMON TEST SETUP
#

.t configure -bg [lindex [.t configure -bg] 3]
catch {destroy .top}

test textDisp-10.2 {TkTextRelayoutWindow} {
    toplevel .top -width 300 -height 200
    wm geometry .top +0+0
    text .top.t -font $fixedFont -width 20 -height 10 -relief raised -bd 2
    place .top.t -x 0 -y 0 -width 20 -height 20
    .top.t insert end "First line"
    .top.t see insert
    tkwait visibility .top.t
    place .top.t -width 150 -height 100
    update
    .top.t index @0,0
} {1.0}
catch {destroy .top}


#
# COMMON TEST SETUP
#

catch {destroy .top}
.t delete 1.0 end
.t insert end "Line 1"
for {set i 2} {$i <= 200} {incr i} {
    .t insert end "\nLine $i"
}
update

test textDisp-11.1 {TkTextSetYView} {
    .t yview 30.0
    update
    .t index @0,0
} {30.0}
test textDisp-11.2 {TkTextSetYView} {
    .t yview 30.0
︙
1659
1660
1661
1662
1663
1664
1665




1666

1667
1668
1669
1670
1671
1672
1673

1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837








+
+
+
+

+








    .t yview 1.0
    update
    set tk_textRedraw {}
    .t see 10.30
    update
    list [.t index @0,0] $tk_textRedraw
} {2.0 10.20}

#
# COMMON TEST CLEANUP
#
.t delete 10.0 11.0

test textDisp-11.13 {TkTestSetYView, partially visible last line} {
    catch {destroy .top}
    toplevel .top
    wm geometry .top +0+0
    text .top.t -width 20 -height 5
    pack .top.t
    .top.t insert end "Line 1"
︙
1683
1684
1685
1686
1687
1688
1689





1690
1691
1692
1693
1694
1695
1696
1697
1698
1699

1700
1701
1702
1703
1704
1705
1706

1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876








+
+
+
+
+










+








    set tk_textRedraw {}
    .top.t see 5.0
    update
    # Note, with smooth scrolling, the results of this test
    # have changed, and the old '2.0 {5.0 6.0}' is quite wrong.
    list [.top.t index @0,0] $tk_textRedraw
} {1.0 5.0}

#
# COMMON TEST SETUP
#

catch {destroy .top}
toplevel .top
wm geometry .top +0+0
text .top.t -width 30 -height 3
pack .top.t
.top.t insert end "Line 1"
for {set i 2} {$i <= 20} {incr i} {
    .top.t insert end "\nLine $i"
}
update

test textDisp-11.14 {TkTextSetYView, only a few lines visible} {
    .top.t yview 5.0
    update
    .top.t see 10.0
    .top.t index @0,0
} {8.0}
test textDisp-11.15 {TkTextSetYView, only a few lines visible} {
︙
1803
1804
1805
1806
1807
1808
1809




1810
1811
1812
1813

1814
1815
1816
1817
1818
1819
1820

1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995








+
+
+
+




+








    update
    .top.p yview moveto 0
    update
    set res [.top.p get @0,0 "@0,0 lineend"]
    destroy .top.p
    set res
} {Line 5}

#
# COMMON TEST SETUP
#

.t configure -wrap word
.t delete 50.0 51.0
.t insert 50.0 "This is a long line, one that will wrap around twice.\n"

test textDisp-12.1 {MeasureUp} {
    .t yview 100.0
    update
    .t yview -pickplace 52.0
    update
    .t index @0,0
} {49.0}
︙
1828
1829
1830
1831
1832
1833
1834





1835

1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849




1850
1851
1852
1853
1854
1855
1856
1857

1858
1859
1860
1861
1862
1863
1864

2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050








+
+
+
+
+

+














+
+
+
+








+








test textDisp-12.3 {MeasureUp} {
    .t yview 100.0
    update
    .t yview -pickplace 50.10
    update
    .t index @0,0
} {45.0}

#
# COMMON TEST SETUP
#

.t configure -wrap none

test textDisp-12.4 {MeasureUp} {
    .t yview 100.0
    update
    .t yview -pickplace 53.0
    update
    .t index @0,0
} {48.0}
test textDisp-12.5 {MeasureUp} {
    .t yview 100.0
    update
    .t yview -pickplace 50.10
    update
    .t index @0,0
} {45.0}

#
# COMMON TEST SETUP
#

.t configure -wrap none
.t delete 1.0 end
for {set i 1} {$i < 99} {incr i} {
    .t insert end "Line $i\n"
}
.t insert end "Line 100"
.t insert 30.end { is quite long, so that it flows way off the end of the window and we can use it to test out the horizontal positioning features of the "see" command.}

test textDisp-13.1 {TkTextSeeCmd procedure} {
    list [catch {.t see} msg] $msg
} {1 {wrong # args: should be ".t see index"}}
test textDisp-13.2 {TkTextSeeCmd procedure} {
    list [catch {.t see a b} msg] $msg
} {1 {wrong # args: should be ".t see index"}}
test textDisp-13.3 {TkTextSeeCmd procedure} {
︙
1985
1986
1987
1988
1989
1990
1991
1992
1993






1994

1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005




2006
2007
2008
2009
2010
2011
2012
2013




2014
2015
2016
2017
2018
2019
2020

2171
2172
2173
2174
2175
2176
2177


2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194


2195
2196
2197
2198
2199
2200
2201
2202
2203
2204


2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215








-
-
+
+
+
+
+
+

+









-
-
+
+
+
+






-
-
+
+
+
+








    .top2.t2 see "1.0 lineend"
    update
    set new [.top2.t2 index @0,0]
    set res [.top2.t2 compare $ref == $new]
    destroy .top2
    set res
} 0
wm geom . {}


#
# COMMON TEST SETUP
#

wm geom . {}
.t configure -wrap none

test textDisp-14.1 {TkTextXviewCmd procedure} {
    .t delete 1.0 end
    update
    .t insert end xxxxxxxxx\n
    .t insert end "xxxxx xxxxxxxxxxx xxxx xxxxxxxxxxxxxxxxxxxx xxxxxxxxxxxx\n"
    .t insert end "xxxx xxxxxxxxx xxxxxxxxxxxxx"
    .t xview moveto .5
    .t xview
} [list 0.5 [expr {6./7.}]]
.t configure -wrap char
test textDisp-14.2 {TkTextXviewCmd procedure} {

test textDisp-14.2 {TkTextXviewCmd procedure} -setup {
    .t configure -wrap char
} -body {
    .t delete 1.0 end
    update
    .t insert end xxxxxxxxx\n
    .t insert end "xxxxx\n"
    .t insert end "xxxx"
    .t xview
} {0.0 1.0}
.t configure -wrap none
} -cleanup {
    .t configure -wrap none
} -result {0.0 1.0}

test textDisp-14.3 {TkTextXviewCmd procedure} {
    .t delete 1.0 end
    update
    .t insert end xxxxxxxxx\n
    .t insert end "xxxxx\n"
    .t insert end "xxxx"
    .t xview
︙
2091
2092
2093
2094
2095
2096
2097




2098
2099
2100
2101
2102
2103
2104
2105
2106

2107
2108
2109
2110
2111
2112
2113

2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313








+
+
+
+









+








} {2.21 2.20 2.99 2.84}
test textDisp-14.15 {TkTextXviewCmd procedure} {
    list [catch {.t xview scroll 14 globs} msg] $msg
} {1 {bad argument "globs": must be pages, pixels, or units}}
test textDisp-14.16 {TkTextXviewCmd procedure} {
    list [catch {.t xview flounder} msg] $msg
} {1 {bad option "flounder": must be moveto or scroll}}

#
# COMMON TEST SETUP
#

.t configure -wrap char
.t delete 1.0 end
for {set i 1} {$i < 99} {incr i} {
    .t insert end "Line $i\n"
}
.t insert end "Line 100"
.t delete 50.0 51.0
.t insert 50.0 "This is a long line, one that will wrap around twice.\n"

test textDisp-15.1 {ScrollByLines procedure, scrolling backwards} {
    .t yview 45.0
    update
    .t yview scroll -3 units
    .t index @0,0
} {42.0}
test textDisp-15.2 {ScrollByLines procedure, scrolling backwards} {
︙
2174
2175
2176
2177
2178
2179
2180




2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198

2199
2200
2201
2202
2203
2204
2205

2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410








+
+
+
+


















+








    .tf.f.t yview scroll 1 unit
    # Check that it has scrolled
    set newind [.tf.f.t index @0,[winfo height .tf.f.t]]
    set res [.tf.f.t compare $newind > $refind]
    destroy .tf
    set res
} 1

#
# COMMON TEST SETUP
#

.t configure -wrap char
.t delete 1.0 end
.t insert insert "Line 1"
for {set i 2} {$i <= 200} {incr i} {
    .t insert end "\nLine $i"
}
.t tag add big 100.0 105.0
.t insert 151.end { has a lot of extra text, so that it wraps around on the screen several times over.}
.t insert 153.end { also has largely enough extra text to wrap.}
update
set totpix [.t count -update -ypixels 1.0 end]
# check that the wrapping lines wrap exactly 6 times in total (4 times for line 151, and twice for line 153),
# this is an assumption of the upcoming tests
if {double(($totpix-5*$heightDiff)/$fixedHeight) != 206.0} {
    puts "---> Warning: the font actually used by the tests, which is \"[font actual [.t cget -font]]\",\
is too different from the requested \"[.t cget -font]\". Some of the upcoming tests will probably fail."
}

test textDisp-16.1 {TkTextYviewCmd procedure} {
    .t yview 21.0
    set x [.t yview]
    .t yview 1.0
    list [expr {int([lindex $x 0]*100)}] [expr {int([lindex $x 1]*100)}]
} {9 14}
test textDisp-16.2 {TkTextYviewCmd procedure} {
︙
2533
2534
2535
2536
2537
2538
2539




2540
2541
2542
2543
2544
2545
2546

2547
2548
2549
2550
2551
2552
2553

2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763








+
+
+
+







+








    }
    .t tag configure hidden -elide true ; # 5 hidden lines
    update
    .t see [expr {5 + [winfo height .t] / $fixedHeight + 1}].0
    update
    .t index @0,0
} {2.0}

#
# COMMON TEST SETUP
#

.t delete 1.0 end
foreach i {a b c d e f g h i j k l m n o p q r s t u v w x y z} {
    .t insert end "\nLine $i 11111 $i 22222 $i 33333 $i 44444 $i 55555"
    .t insert end " $i 66666 $i 77777 $i 88888 $i"
}
.t configure -wrap none

test textDisp-17.1 {TkTextScanCmd procedure} {
    list [catch {.t scan a b} msg] $msg
} {1 {wrong # args: should be ".t scan mark x y" or ".t scan dragto x y ?gain?"}}
test textDisp-17.2 {TkTextScanCmd procedure} {
    list [catch {.t scan a b c d} msg] $msg
} {1 {expected integer but got "b"}}
test textDisp-17.3 {TkTextScanCmd procedure} {
︙
2622
2623
2624
2625
2626
2627
2628





2629

2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643





2644
2645
2646
2647
2648
2649
2650

2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871








+
+
+
+
+

+














+
+
+
+
+








    update
    set expected [.t index @[expr {[winfo width .t]-[bo]-40}],[expr {[winfo height .t]-[bo]-50}]]
    set expected [.t index "$expected - [.t cget -height] lines - [.t cget -width] chars"]
    .t scan dragto 14 5
    update
    lequal [.t index @0,0] $expected
} {1}

#
# COMMON TEST SETUP
#

.t configure -wrap word

test textDisp-17.10 {TkTextScanCmd procedure, word wrapping} {
    .t yview 10.0
    update
    set origin [.t index @0,0]
    set expected [.t index "$origin - [expr {int(ceil(50.0/$fixedHeight))}] display lines"]
    .t scan mark -10 60
    .t scan dragto -5 65
    update
    set x [.t index @0,0]
    lappend expected [.t index "$origin - [expr {int(ceil((50.0+70.0)/$fixedHeight))}] display lines"]
    .t scan dragto 0 72
    update
    lequal [list $x [.t index @0,0]] $expected
} {1}

#
# COMMON TEST SETUP
#

.t configure -xscrollcommand setScrollInfo -yscrollcommand {}

test textDisp-18.1 {GetXView procedure} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end xxxxxxxxx\n
    .t insert end xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n
︙
2736
2737
2738
2739
2740
2741
2742





2743
2744
2745
2746

2747
2748
2749
2750
2751
2752
2753

2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970

2971
2972
2973
2974
2975
2976
2977
2978
2979








+
+
+
+
+


-

+








} {{scrolling error} {scrolling error
    while executing
"error "scrolling error""
    (procedure "scrollError" line 2)
    invoked from within
"scrollError 0.0 1.0"
    (horizontal scrolling command executed by text)}}

#
# COMMON TEST SETUP
#

catch {rename bgerror {}}
catch {rename bogus {}}

.t configure -xscrollcommand {} -yscrollcommand setScrollInfo

test textDisp-19.1 {GetYView procedure} {
    .t configure -wrap char
    .t delete 1.0 end
    update
    set scrollInfo
} {0.0 1.0}
test textDisp-19.2 {GetYView procedure} {
︙
2918
2919
2920
2921
2922
2923
2924





2925

2926
2927
2928
2929
2930
2931
2932

3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164








+
+
+
+
+

+








} 4
test textDisp-19.11.11 {TextWidgetCmd procedure, "count -displaylines"} {
    .t count -displaylines 16.0 "16.0 +2displaylines"
} 2
test textDisp-19.11.12 {TextWidgetCmd procedure, "count -displaylines"} {
    .t count -displaylines "16.0 +1displayline" "16.0 +2displaylines -1c"
} 0

#
# COMMON TEST SETUP
#

.t tag configure elide -elide 1

test textDisp-19.11.13 {TextWidgetCmd procedure, "count -displaylines"} {
    .t tag remove elide 1.0 end
    .t tag add elide "16.0 +1displaylines" "16.0 +1displaylines +6c"
    .t count -displaylines 16.0 "16.0 +4displaylines"
} 4
test textDisp-19.11.14 {TextWidgetCmd procedure, "count -displaylines"} {
    .t tag remove elide 1.0 end
︙
2997
2998
2999
3000
3001
3002
3003




3004

3005
3006
3007
3008
3009
3010
3011
3012
3013
3014

3015
3016
3017
3018
3019
3020
3021

3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250

3251
3252
3253
3254
3255
3256
3257
3258








+
+
+
+

+









-
+








    .t tag add elide "12.3" "16.0 +1displaylines"
    list [.t index "11.5 +1d lines"] [.t index "11.5 +2d lines"] \
      [.t index "12.0 +1d lines"] \
      [.t index "12.0 +2d lines"] [.t index "11.0 +2d lines"] \
      [.t index "13.0 +2d lines"] [.t index "13.0 +3d lines"] \
      [.t index "13.0 +4d lines"]
} {16.23 16.44 16.39 16.57 16.39 16.60 16.77 16.79}

#
# COMMON TEST CLEANUP
#
.t tag remove elide 1.0 end

test textDisp-19.11.24 {TextWidgetCmd procedure, "index +/-displaylines"} {
    list [.t index "11.5 + -1 display lines"] \
      [.t index "11.5 + +1 disp lines"] \
      [.t index "11.5 - -1 disp lines"] \
      [.t index "11.5 - +1 disp lines"] \
      [.t index "11.5 -1 disp lines"] \
      [.t index "11.5 +1 disp lines"] \
      [.t index "11.5 +0 disp lines"]
} {10.5 12.5 12.5 10.5 10.5 12.5 11.5}
.t tag remove elide 1.0 end

test textDisp-19.12 {GetYView procedure, partially visible last line} {
    catch {destroy .top}
    toplevel .top
    wm geometry .top +0+0
    text .top.t -width 40 -height 5 -font $fixedFont
    pack .top.t -expand yes -fill both
    .top.t insert end "Line 1\nLine 2\nLine 3\nLine 4\nLine 5"
︙
3036
3037
3038
3039
3040
3041
3042




3043

3044
3045
3046
3047
3048
3049
3050

3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292








+
+
+
+

+








    # Need to wait for asychronous calculations to complete.
    update
    scan [wm geom .top] %dx%d twidth theight
    wm geom .top ${twidth}x[expr {$theight - 3}]
    update
    .top.t yview
} [list 0.0 [expr {(5.0 * $fixedHeight - 3.0)/ (5.0 * $fixedHeight)}]]

#
# COMMON TEST CLEANUP
#
catch {destroy .top}

test textDisp-19.14 {GetYView procedure} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Line 1"
    foreach i {2 3 4 5 6 7 8 9 10 11 12 13 14 15} {
	.t insert end "\nLine $i"
    }
︙
3178
3179
3180
3181
3182
3183
3184





3185
3186
3187
3188
3189
3190
3191
3192

3193
3194
3195
3196
3197
3198
3199

3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447








+
+
+
+
+








+








    }
    .t tag add hidden 5.27 11.0
    .t tag configure hidden -elide true
    .t yview 5.0
    update
    set res [list [.t count -ypixels 5.0 11.0] [.t count -ypixels 5.0 11.20]]
} [list [expr {1 * $fixedHeight}] [expr {2 * $fixedHeight}]]

#
# COMMON TEST SETUP
#

.t delete 1.0 end
.t insert end "Line 1"
for {set i 2} {$i <= 200} {incr i} {
    .t insert end "\nLine $i"
}
.t configure -wrap word
.t delete 50.0 51.0
.t insert 50.0 "This is a long line, one that will wrap around twice.\n"

test textDisp-20.1 {FindDLine} {
    .t yview 48.0
    list [.t dlineinfo 46.0] [.t dlineinfo 47.0] [.t dlineinfo 49.0] \
	    [.t dlineinfo 58.0]
} [list {} {} [list [bo] [yline 2] [xw 7] $fixedHeight $fixedAscent] {}]
test textDisp-20.2 {FindDLine} {
    .t yview 100.0
︙
3216
3217
3218
3219
3220
3221
3222
3223
3224




3225
3226
3227


3228

3229
3230
3231
3232
3233
3234
3235
3236
3237
3238





3239

3240
3241
3242
3243
3244
3245
3246

3464
3465
3466
3467
3468
3469
3470


3471
3472
3473
3474
3475
3476
3477
3478
3479

3480
3481
3482
3483

3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503








-
-
+
+
+
+



+
+
-
+



-






+
+
+
+
+

+








test textDisp-20.4 {FindDLine} {
    .t yview 100.0
    .t yview 42.0
    list [.t dlineinfo 50.0] [.t dlineinfo 50.24] [.t dlineinfo 50.40]
} [list [list [bo] [yline 9] [xw 20] $fixedHeight $fixedAscent] \
	[list [bo] [yline 10] [xw 19] $fixedHeight $fixedAscent] \
	{}]
.t config -wrap none
test textDisp-20.5 {FindDLine} {

test textDisp-20.5 {FindDLine} -setup {
    .t config -wrap none
} -body {
    .t yview 100.0
    .t yview 48.0
    list [.t dlineinfo 50.0] [.t dlineinfo 50.20] [.t dlineinfo 50.40]
} -cleanup {
    .t config -wrap word
} [list [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \
} -result [list [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \
	[list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \
	[list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent]]

.t config -wrap word
test textDisp-21.1 {TkTextPixelIndex} {
    .t yview 48.0
    set off [expr {[bo]+3}]
    list [.t index @-10,-10] [.t index @$off,$off] [.t index @[expr {[xchar 2]+2}],$off] \
	    [.t index @[expr {[xchar 14]+1}],$off] [.t index @[xchar 5],[yline 5]]
} {48.0 48.0 48.2 48.7 50.45}

#
# COMMON TEST SETUP
#

.t insert end \n

test textDisp-21.2 {TkTextPixelIndex} {
    .t yview 195.0
    set off [expr {[xchar 1]+1}]
    list [.t index @$off,[expr {[yline 6]+2}]] \
	 [.t index @$off,[expr {[yline 7]+2}]] \
	 [.t index @$off,[expr {[yline 8]+2}]] \
	 [.t index @$off,1002]
︙
3275
3276
3277
3278
3279
3280
3281




3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292

3293
3294
3295
3296
3297
3298
3299

3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561








+
+
+
+











+








.tt.u mark set insert 3.10
tkwait visibility .tt.u
set res [.tt.u count -displaylines 3.10 2.173]
destroy .tt
unset message
set res
} -1

#
# COMMON TEST SETUP
#

.t delete 1.0 end
.t insert end "Line 1"
for {set i 2} {$i <= 200} {incr i} {
    .t insert end "\nLine $i"
}
.t configure -wrap word
.t delete 50.0 51.0
.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
update
.t tag add x 50.1

test textDisp-22.1 {TkTextCharBbox} {
    .t config -wrap word
    .t yview 48.0
    list [.t bbox 47.2] [.t bbox 48.0] [.t bbox 50.5] [.t bbox 50.40] \
	    [.t bbox 58.0]
} [list {} \
	[list [xchar 0] [yline 1] $fixedWidth $fixedHeight] \
︙
3350
3351
3352
3353
3354
3355
3356





3357
3358

3359
3360
3361
3362
3363
3364
3365
3366




3367

3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382

3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398


3399

3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412

3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654

3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673

3674
3675
3676
3677
3678
3679

3680
3681
3682
3683
3684
3685
3686








+
+
+
+
+


+








+
+
+
+

+














-
+
















+
+
-
+





-








    wm geom . ${width}x[expr {$height+3}]
    update
    set expected [list [list [xchar 1] [yline 10] $fixedWidth $fixedHeight] \
		       {} \
		       [list [xchar 2] [yline 11] [font measure $bigFont "n"] [expr {($height+3)-$oriHeight}]]]
    lequal [list [.t bbox 19.1] [.t bbox 20.1] [.t bbox 20.2]] $expected
} {1}

#
# COMMON TEST SETUP
#

wm geom . {}
update

test textDisp-22.7 {TkTextCharBbox, different character sizes} haveBigFontTwiceLargerThanTextFont {
    .t config -wrap char
    .t yview 10.0
    .t tag add big 12.2 12.5
    update
    list [.t bbox 12.1] [.t bbox 12.2]
} [list [list [xchar 1] [expr {[yline 3]+$ascentDiff}] $fixedWidth $fixedHeight] \
	[list [xchar 2] [yline 3] [font measure $bigFont "n"] $bigHeight]]

#
# COMMON TEST CLEANUP
#
.t tag remove big 1.0 end

test textDisp-22.8 {TkTextCharBbox, horizontal scrolling} {
    .t configure -wrap none
    .t delete 1.0 end
    .t insert end "12345\n"
    .t insert end "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    .t xview scroll 4 units
    list [.t bbox 1.3] [.t bbox 1.4] [.t bbox 2.3] [.t bbox 2.4] \
	    [.t bbox 2.23] [.t bbox 2.24]
} [list {} \
	[list [xchar 0] [yline 1] $fixedWidth $fixedHeight] \
	{} \
	[list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \
	[list [xchar 19] [yline 2] $fixedWidth $fixedHeight] \
	{}]
test textDisp-22.9 {TkTextCharBbox, handling of spacing} {
test textDisp-22.9 {TkTextCharBbox, handling of spacing} -body {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "abcdefghijkl\nmnopqrstuvwzyz"
    .t tag configure spacing -spacing1 8 -spacing3 2
    .t tag add spacing 1.0 end
    frame .t.f1 -width 10 -height 4 -bg black
    frame .t.f2 -width 10 -height 4 -bg black
    frame .t.f3 -width 10 -height 4 -bg black
    frame .t.f4 -width 10 -height 4 -bg black
    .t window create 1.3 -window .t.f1 -align top
    .t window create 1.7 -window .t.f2 -align center
    .t window create 2.1 -window .t.f3 -align bottom
    .t window create 2.10 -window .t.f4 -align baseline
    update
    list [.t bbox .t.f1] [.t bbox .t.f2] [.t bbox .t.f3] [.t bbox .t.f4] \
	    [.t bbox 1.1] [.t bbox 2.9]
} -cleanup {
    .t tag delete spacing
} [list [list [xchar 3] [expr {[yline 1]+8}] 10 4] \
} -result [list [list [xchar 3] [expr {[yline 1]+8}] 10 4] \
	[list [expr {[xchar 3]+10+[xw 3]}] [expr {[yline 1]+8+($fixedHeight-4)/2}] 10 4] \
	[list [xchar 1] [expr {[yline 2]+8+2+8+($fixedHeight-4)}] 10 4] \
	[list [expr {[xchar 1]+10+[xw 8]}] [expr {[yline 2]+8+2+8+($fixedAscent-4)}] 10 4] \
	[list [xchar 1] [expr {[yline 1]+8}] $fixedWidth $fixedHeight] \
	[list [expr {[xchar 1]+10+[xw 7]}] [expr {[yline 2]+8+2+8}] $fixedWidth $fixedHeight]]
.t tag delete spacing
test textDisp-22.10 {TkTextCharBbox, handling of elided lines} {
    .t configure -wrap char
    .t delete 1.0 end
    for {set i 1} {$i < 10} {incr i} {
	.t insert end "Line $i - Line [format %c [expr {64+$i}]]\n"
    }
    .t tag add hidden 2.8 2.13
︙
3435
3436
3437
3438
3439
3440
3441




3442
3443
3444
3445
3446
3447
3448
3449
3450
3451

3452
3453
3454
3455
3456
3457
3458
3459
3460

3461

3462



3463
3464
3465
3466
3467
3468



3469
3470
3471
3472
3473
3474
3475

3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742

3743
3744
3745
3746
3747
3748
3749


3750
3751
3752
3753
3754
3755
3756
3757
3758
3759








+
+
+
+










+









+

+
-
+
+
+




-
-
+
+
+








    .t tag add hidden 1.30 2.5
    .t tag configure hidden -elide true
    update
    list \
	[expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.4]  0]}] \
	[expr {[lindex [.t bbox 1.30] 0] - [lindex [.t bbox 2.5]  0]}]
} [list 0 0]

#
# COMMON TEST SETUP
#

.t delete 1.0 end
.t insert end "Line 1"
for {set i 2} {$i <= 200} {incr i} {
    .t insert end "\nLine $i"
}
.t configure -wrap word
.t delete 50.0 51.0
.t insert 50.0 "This is a long line, one that will wrap around twice.\n"
update

test textDisp-23.1 {TkTextDLineInfo} {
    .t config -wrap word
    .t yview 48.0
    list [.t dlineinfo 47.3] [.t dlineinfo 48.0] [.t dlineinfo 50.40] \
	    [.t dlineinfo 56.0]
} [list {} \
	[list [bo] [yline 1] [xw 7] $fixedHeight $fixedAscent] \
	[list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent] \
	{}]

.t config -bd 4

test textDisp-23.2 {TkTextDLineInfo} {
test textDisp-23.2 {TkTextDLineInfo} -setup {
    .t config -bd 4
} -body {
    .t config -wrap word
    update
    .t yview 48.0
    .t dlineinfo 50.40
} [list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent]
.t config -bd 0
} -cleanup {
    .t config -bd 0
} -result [list [bo] [yline 5] [xw 13] $fixedHeight $fixedAscent]
test textDisp-23.3 {TkTextDLineInfo} {
    .t config -wrap none
    update
    .t yview 48.0
    list [.t dlineinfo 50.40] [.t dlineinfo 57.3]
} [list [list [bo] [yline 3] [xw 53] $fixedHeight $fixedAscent] \
	[list [bo] [yline 10] [xw 7] $fixedHeight $fixedAscent]]
︙
3493
3494
3495
3496
3497
3498
3499





3500
3501

3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513





3514

3515

3516
3517
3518
3519
3520
3521
3522
3523
3524
3525


3526

3527
3528
3529
3530
3531
3532
3533
3534
3535
3536

3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810

3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823

3824
3825
3826

3827
3828
3829
3830
3831
3832
3833








+
+
+
+
+


+












+
+
+
+
+

+
-
+










+
+
-
+


-








    .t yview 10.0
    wm geom . ${width}x[expr {$height+1}]
    update
    set expected [list [list [bo] [yline 10] [xw 7] $fixedHeight $fixedAscent] \
		       [list [bo] [yline 11] [xw 7] [expr {($height+1)-$oriHeight}] $fixedAscent]]
    lequal [list [.t dlineinfo 19.0] [.t dlineinfo 20.0]] $expected
} {1}

#
# COMMON TEST SETUP
#

wm geom . {}
update

test textDisp-23.6 {TkTextDLineInfo, horizontal scrolling} {
    .t config -wrap none
    .t delete 1.0 end
    .t insert end "First line\n"
    .t insert end "Second line is a very long one that doesn't all fit.\n"
    .t insert end "Third"
    .t xview scroll 6 units
    update
    list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0]
} [list [list [expr {[xw -6]+[bo]}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \
	[list [expr {[xw -6]+[bo]}] [yline 2] [xw 52] $fixedHeight $fixedAscent] \
	[list [expr {[xw -6]+[bo]}] [yline 3] [xw 5] $fixedHeight $fixedAscent]]

#
# COMMON TEST SETUP
#

.t xview moveto 0

test textDisp-23.7 {TkTextDLineInfo, centering} {
test textDisp-23.7 {TkTextDLineInfo, centering} -body {
    .t config -wrap word
    .t delete 1.0 end
    .t insert end "First line\n"
    .t insert end "Second line is a very long one that doesn't all fit.\n"
    .t insert end "Third"
    .t tag configure x -justify center
    .t tag configure y -justify right
    .t tag add x 1.0
    .t tag add y 3.0
    list [.t dlineinfo 1.0] [.t dlineinfo 2.0] [.t dlineinfo 3.0]
} -cleanup {
    .t tag delete x y
} [list [list [expr {[bo]+[xe 10]/2}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \
} -result [list [list [expr {[bo]+[xe 10]/2}] [yline 1] [xw 10] $fixedHeight $fixedAscent] \
	[list [bo] [yline 2] [xw 17] $fixedHeight $fixedAscent] \
	[list [xcharr 5] [yline 5] [xw 5] $fixedHeight $fixedAscent]]
.t tag delete x y

test textDisp-24.1 {TkTextCharLayoutProc} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "abcdefghijklmnopqrstuvwxyz"
    list [.t bbox 1.19] [.t bbox 1.20]
} [list [list [xchar 19] [yline 1] $fixedWidth $fixedHeight] \
︙
3666
3667
3668
3669
3670
3671
3672





3673
3674

3675
3676
3677
3678
3679
3680
3681

3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984








+
+
+
+
+


+








    set result [list [.t bbox 1.21] [.t bbox 2.0]]
    .t mark set insert 1.21
    lappend result [.t bbox 1.21] [.t bbox 2.0]
} [list [list [expr {[xchar 20]+2}] [yline 1] 0 $fixedHeight] \
	[list [xchar 0] [yline 2] $fixedWidth $fixedHeight] \
	[list [expr {[xchar 20]+2}] [yline 1] 0 $fixedHeight] \
	[list [xchar 0] [yline 2] $fixedWidth $fixedHeight]]

#
# COMMON TEST SETUP
#

wm geom . {}
update

test textDisp-24.12 {TkTextCharLayoutProc, tab causes wrap} {
    .t configure -wrap char
    .t delete 1.0 end
    .t insert 1.0 "abcdefghi"
    .t mark set insert 1.4
    .t insert insert \t\t\t
    set expected [list [list [expr {[xchar 0]+2*8*$fixedWidth}] [yline 1] [expr {[winfo width .t]-([xchar 0]+2*8*$fixedWidth)-[bo]}] $fixedHeight] \
︙
3727
3728
3729
3730
3731
3732
3733





3734
3735
3736

3737
3738
3739
3740
3741
3742
3743

4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052








+
+
+
+
+



+








    set wi [expr {[winfo width .f]+[bo]}]
    wm geom . ${wi}x$height
    update
    list [.t bbox 1.0] [.t bbox 1.1] [.t bbox 1.2]
} [list [list [xchar 0] [yline 1] 1 $fixedHeight] \
	[list [xchar 0] [yline 2] 1 $fixedHeight] \
	[list [xchar 0] [yline 3] 1 $fixedHeight]]

#
# COMMON TEST SETUP
#

if {[tk windowingsystem] eq "win32"} {
    wm overrideredirect . 0
}

test textDisp-24.17 {TkTextCharLayoutProc, -wrap word} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "This is a line that wraps around"
    wm geom . {}
    update
    list [.t bbox 1.19] [.t bbox 1.20]
︙
3779
3780
3781
3782
3783
3784
3785





3786
3787

3788
3789
3790
3791
3792
3793
3794

4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109








+
+
+
+
+


+








    set result
} [list [list [xchar 1] [yline 2] $fixedWidth $fixedHeight] \
	[list [bo] [yline 2] [xw 6] $fixedHeight $fixedAscent] \
	[list [xchar 1] [yline 2] $fixedWidth $fixedHeight] \
	[list [bo] [yline 2] [xw 6] [expr {$fixedHeight+6}] [expr {$fixedAscent+6}]] \
	[list [xchar 1] [expr {[yline 2]+2}] $fixedWidth $fixedHeight] \
	[list [bo] [yline 2] [xw 6] [expr {$fixedHeight+2}] $fixedAscent]]

#
# COMMON TEST SETUP
#

.t configure -width 30
update

test textDisp-24.21 {TkTextCharLayoutProc, word breaks} {
    .t configure -wrap word
    .t delete 1.0 end
    .t insert 1.0 "Sample text xxxxxxx yyyyy zzzzzzz qqqqq rrrr ssss tt u vvvvv"
    frame .t.f -width 30 -height 20 -bg black
    .t window create 1.36 -window .t.f
    .t bbox 1.26
︙
3808
3809
3810
3811
3812
3813
3814





3815
3816
3817

3818
3819
3820
3821
3822
3823
3824

4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145








+
+
+
+
+



+








    frame .t.f -width 50 -height 20 -bg black
    .t insert 1.0 "Sample text xxxxxxx yyyyyyy "
    .t insert end "zzzzzzz qqqqq rrrr ssss tt"
    .t window create end -window .t.f
    .t insert end "u vvvvv"
    .t bbox .t.f
} [list [xchar 0] [yline 3] 50 20]

#
# COMMON TEST SETUP
#

catch {destroy .t.f}
.t configure -width 20
update

# Next test is currently constrained to not run on mac (aqua) because on
# aqua it fails due to wrong implementation of tabs with right justification
# (the text is not rendered at all). This is a bug.
test textDisp-24.24 {TkTextCharLayoutProc, justification and tabs} notAqua {
    .t delete 1.0 end
    .t tag configure x -justify center
    .t insert 1.0 aa\tbb\tcc\tdd\t
︙
3835
3836
3837
3838
3839
3840
3841




3842
3843
3844
3845

3846
3847
3848
3849
3850
3851
3852




3853
3854
3855
3856

3857
3858
3859
3860
3861
3862
3863

4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194








+
+
+
+




+







+
+
+
+




+








    set expected [list [list [expr {[bo .tt]+40-$fixedWidth}] [yline 1 .tt] $fixedWidth $fixedHeight] \
		       [list [expr {[bo .tt]+40-$fixedWidth}] [yline 2 .tt] $fixedWidth $fixedHeight] \
		       [list [expr {[bo .tt]+40-$fixedWidth}] [yline 3 .tt] $fixedWidth $fixedHeight]]
    lequal [list [.tt bbox 1.1] [.tt bbox 2.2] [.tt bbox 3.3]] $expected
} -cleanup {
    destroy .tt
} -result {1}

#
# COMMON TEST SETUP
#

.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 \
    -tabs 100
update

test textDisp-25.1 {CharBboxProc procedure, check tab width} {
    .t delete 1.0 end
    .t insert 1.0 abc\td\tfgh
    list [.t bbox 1.3] [.t bbox 1.5] [.t bbox 1.6]
} [list [list [xchar 3] [yline 1] [expr {100-3*$fixedWidth}] $fixedHeight] \
	[list [expr {[bo]+100+$fixedWidth}] [yline 1] [expr {200-(100+$fixedWidth)}] $fixedHeight] \
	[list [expr {[bo]+200}] [yline 1] $fixedWidth $fixedHeight]]

#
# COMMON TEST SETUP
#

.t configure -width 40 -bd 0 -relief flat -highlightthickness 0 -padx 0 -pady 0 \
	-tabs {}
update

test textDisp-26.1 {AdjustForTab procedure, no tabs} {
    .t delete 1.0 end
    .t insert 1.0 a\tbcdefghij\tc\td
    list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.12] 0] \
	    [lindex [.t bbox 1.14] 0]
} [list [expr {[bo]+8*$fixedWidth}] \
	[expr {[bo]+2*8*$fixedWidth+2*$fixedWidth}] \
︙
4031
4032
4033
4034
4035
4036
4037




4038
4039
4040
4041

4042
4043
4044
4045
4046
4047
4048

4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384








+
+
+
+




+








    .t tag configure moop -tabs [expr {8*$fixedWidth}]
    .t insert end "Watch the \tX and the \t\t\tY\n" moop
    set res [list [lindex [.t bbox 2.11] 0] [lindex [.t bbox 2.24] 0] \
      [lindex [.t bbox 3.11] 0] [lindex [.t bbox 3.24] 0]]
    .t configure -tabstyle tabular
    set res
} [list [xchar 16] [xchar 8] [xchar 16] [xchar 8]]

#
# COMMON TEST SETUP
#

.t configure -width 20 -bd 2 -highlightthickness 2 -relief sunken -tabs {} \
	-wrap char
update

test textDisp-27.1 {SizeOfTab procedure, old-style tabs} {
    .t delete 1.0 end
    .t insert 1.0 a\tbcdefghij\tc\td
    list [.t bbox 1.2] [.t bbox 1.10] [.t bbox 1.12]
} [list [list [xchar 8] [yline 1] $fixedWidth $fixedHeight] \
	[list [xchar [expr {8+8}]] [yline 1] $fixedWidth $fixedHeight] \
	[list [xchar [expr {8+8+1+1}]] [yline 1] $fixedWidth $fixedHeight]]
︙
4171
4172
4173
4174
4175
4176
4177




4178
4179
4180

4181
4182
4183
4184
4185
4186
4187

4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528








+
+
+
+



+








    set res [.t bbox 1.20]
    # Now, Tk's interpolated tabs should be the same as
    # non-interpolated.
    .t configure -tabs $precisetab
    update
    expr {[lindex $res 0] - [lindex [.t bbox 1.20] 0]}
} 0

#
# COMMON TEST SETUP
#

.t configure -wrap char -tabs {} -width 20
update

test textDisp-27.8 {SizeOfTab procedure, right alignment} {
    .t delete 1.0 end
    .t insert 1.0 a\t\txyzzyabc
    .t tag delete x
    .t tag configure x -tabs "[expr {14.3*$fixedWidth}] left [expr {[.t cget -width]*$fixedWidth}] right"
    .t tag add x 1.0 end
    list [.t bbox 1.6] [.t bbox 1.7]
︙
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227

4552
4553
4554
4555
4556
4557
4558



4559
4560
4561
4562
4563
4564
4565








-
-
-








    .t tag delete x
    .t tag configure x -tabs "[expr {17.14*$fixedWidth}]"
    .t tag add x 1.0 end
    list [.t bbox 1.5] [.t bbox 1.6]
} [list [list [expr {round([bo]+17.14*$fixedWidth+$fixedWidth)}] [yline 1] [expr {[winfo width .t]-round([bo]+17.14*$fixedWidth+$fixedWidth)-[bo]}] $fixedHeight] \
	[list [bo] [yline 2] $fixedWidth $fixedHeight]]

proc bizarre_scroll args {
    .t2.t delete 5.0 end
}
test textDisp-28.1 {"yview" option with bizarre scroll command} -setup {
    catch {destroy .t2}
} -body {
    toplevel .t2
    text .t2.t -width 40 -height 4
    .t2.t insert end "1\n2\n3\n4\n5\n6\n7\n8\n"
    pack .t2.t
︙
4448
4449
4450
4451
4452
4453
4454
4455
4456






4457
4458
4459
4460
4461
4462
4463

4786
4787
4788
4789
4790
4791
4792


4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805








-
-
+
+
+
+
+
+








    .t2.t tag configure elided -elide 1 -background red
    .t2.t tag add elided 1.2 2.2
    update
    .t2.t count -update -displaylines 1.0 end
} -cleanup {
    destroy .t2
} -result {2}
catch {destroy .t2}


#
# COMMON TEST SETUP
#

catch {destroy .t2}
.t configure -height 1
update

test textDisp-31.1 {line embedded window height update} {
    set res {}
    .t delete 1.0 end
    .t insert end "abcd\nefgh\nijkl\nmnop\nqrst\nuvwx\nyx"
︙
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813

5141
5142
5143
5144
5145
5146
5147

5148
5149
5150
5151
5152
5153
5154








-








	set result "window should be scrolled to the top"
    } else {
	set result "ok"
    }
    set idx [.tt index "1.0 + 1 displaylines"]
    set result
} {ok}
destroy .tt
test textDisp-33.5 {bold or italic fonts} win {
    destroy .tt
    pack [text .tt -wrap char -font {{MS Sans Serif} 15}]
    font create no -family [lindex [.tt cget -font] 0] -size 24
    font create bi -family [lindex [.tt cget -font] 0] -size 24
    font configure bi -weight bold -slant italic
    .tt tag configure bi -font bi
︙
4822
4823
4824
4825
4826
4827
4828




4829
4830
4831
4832
4833
4834
4835

5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180








+
+
+
+








    unset bb
    if {($b - $a) * 1.5 < ($c - $b)} {
	set result "italic font has much too much space"
    } else {
	set result "italic font measurement ok"
    }
} {italic font measurement ok}

#
# COMMON TEST CLEANUP
#
destroy .tt

test textDisp-34.1 {Line heights recalculation problem: bug 2677890} -setup {
    pack [text .t1] -expand 1 -fill both
    set txt ""
    for {set i 1} {$i < 100} {incr i} {
	append txt "Line $i\n"
︙
4891
4892
4893
4894
4895
4896
4897
4898

4899
4900
4901
4902
4903
4904
4905

5236
5237
5238
5239
5240
5241
5242

5243
5244
5245
5246
5247
5248
5249









-
+






-

   # wish now panics: "CalculateDisplayLineHeight called with bad indexPtr"
   .t1 yview scroll -1 pixels
} -cleanup {
    destroy .t1
} -result {}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget scroll text
deleteWindows
option clear
cleanupTests
return
Changes to tests/textImage.test. 
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

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



-
-
-
-



+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+






+
+
+
+








# textImage.test -- test images embedded in text widgets
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import image

imageInit

#
# COMMON TEST SETUP
#

# One time setup.  Create a font to insure the tests are font metric invariant.
destroy .t
font create test_font -family courier -size 14
text .t -font test_font
destroy .t

#
# TESTS
#

test textImage-1.1 {basic argument checking} -setup {
    destroy .t
} -body {
    text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0
    pack .t
    .t image
︙
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
477
478
479
480
481

486
487
488
489
490
491
492

493
494
495
496
497
498
499
500

501
502
503
504








-
+







-





    update
    destroy .t .tt
} -cleanup {
    image delete small large
} -result {}

#
# CLEANUP
# TESTFILE CLEANUP
#

destroy .t
font delete test_font
imageFinish
testutils forget image
cleanupTests
return

# Local variables:
# mode: tcl
# End:
Changes to tests/textIndex.test. 
1
2
3
4
5
6
7
8


















9

10
11
12







13




























14
15
16
17
18
19
20

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the code in the file tkTextIndex.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import text

#
# LOCAL UTILITY PROCS
#

proc getword index {
    .t get [.t index "$index wordstart"] [.t index "$index wordend"]
}

proc text_test_word {startend chars start} {
    destroy .t
    text .t
    .t insert end $chars
    if {[regexp {end} $start]} {
	set start [.t index "${start}chars -2c"]
    } else {
	set start [.t index "1.0 + ${start}chars"]
    }
    if {[.t compare $start >= "end-1c"]} {
	set start "end-2c"
    }
    set res [.t index "$start $startend"]
    .t count 1.0 $res
}

#
# COMMON TEST SETUP
#

catch {destroy .t}
text .t -font {Courier -12} -width 20 -height 10
pack .t -expand 1 -fill both
update
.t debug on
wm geometry . {}
︙
33
34
35
36
37
38
39




40
41
42
43
44
45
46

82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99








+
+
+
+








Line 4
b乏y GIrl .#@? x_yz
!@#$%
Line 7"

image create photo textimage -width 10 -height 10
textimage put red -to 0 0 9 9

#
# TESTS
#

test textIndex-1.1 {TkTextMakeByteIndex} {testtext} {
    # (lineIndex < 0)
    testtext .t byteindex -1 3
} {1.0 0}
test textIndex-1.2 {TkTextMakeByteIndex} {testtext} {
    # (lineIndex < 0), because lineIndex == strtol(argv[2]) - 1
︙
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

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








+
+
+
+














+


















+
+
+
+








    # (charIndex < segPtr->size)

    .t image create 5.0 -image textimage
    set x [.t index 5.0]
    .t delete 5.0
    set x
} 5.0

#
# COMMON TEST SETUP
#

.t mark set foo 3.2
.t tag add x 2.8 2.11
.t tag add x 6.0 6.2
set weirdTag "funny . +- 22.1\n\t{"
.t tag add $weirdTag 2.1  2.6
set weirdMark "asdf \n{-+ 66.2\t"
.t mark set $weirdMark 4.0
.t tag config y -relief raised
set weirdImage "foo-1"
.t image create 2.1 -image [image create photo $weirdImage]
set weirdEmbWin ".t.bar-1"
entry $weirdEmbWin
.t window create 3.1 -window $weirdEmbWin

test textIndex-3.1 {TkTextGetIndex, weird mark names} {
    list [catch {.t index $weirdMark} msg] $msg
} {0 4.0}
test textIndex-3.2 {TkTextGetIndex, weird mark names} knownBug {
    list [catch {.t index "$weirdMark -1char"} msg] $msg
} {0 4.0}
test textIndex-3.3 {TkTextGetIndex, weird embedded window names} {
    list [catch {.t index $weirdEmbWin} msg] $msg
} {0 3.1}
test textIndex-3.4 {TkTextGetIndex, weird embedded window names} knownBug {
    list [catch {.t index "$weirdEmbWin -1char"} msg] $msg
} {0 3.0}
test textIndex-3.5 {TkTextGetIndex, weird image names} {
    list [catch {.t index $weirdImage} msg] $msg
} {0 2.1}
test textIndex-3.6 {TkTextGetIndex, weird image names} knownBug {
    list [catch {.t index "$weirdImage -1char"} msg] $msg
} {0 2.0}

#
# COMMON TEST CLEANUP
#
.t delete 3.1  ; # remove the weirdEmbWin
.t delete 2.1  ; # remove the weirdImage

test textIndex-4.1 {TkTextGetIndex, tags} {
    list [catch {.t index x.first} msg] $msg
} {0 2.8}
test textIndex-4.2 {TkTextGetIndex, tags} {
︙
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626

672
673
674
675
676
677
678



679
680
681
682
683
684
685








-
-
-








test textIndex-14.16 {TkTextIndexBackChars: UTF} {
    .t get {5.3 - 2 chars}
} 乏
test textIndex-14.17 {TkTextIndexBackChars: UTF} {
    .t get {5.3 - 3 chars}
} b

proc getword index {
    .t get [.t index "$index wordstart"] [.t index "$index wordend"]
}
test textIndex-15.1 {StartEnd} {
    list [catch {.t index {2.3 lineend}} msg] $msg
} {0 2.13}
test textIndex-15.2 {StartEnd} {
    list [catch {.t index {2.3 linee}} msg] $msg
} {0 2.13}
test textIndex-15.3 {StartEnd} {
︙
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663

708
709
710
711
712
713
714

715
716
717
718
719
720
721








-








} x_yz
test textIndex-15.11 {StartEnd} {
    getword 6.2
} #
test textIndex-15.12 {StartEnd} {
    getword 3.4
} 12345
.t tag add x 2.8 2.11
test textIndex-15.13 {StartEnd} {
    list [catch {.t index {2.2 worde}} msg] $msg
} {0 2.13}
test textIndex-15.14 {StartEnd} {
    list [catch {.t index {2.12 words}} msg] $msg
} {0 2.0}
test textIndex-15.15 {StartEnd} {
︙
709
710
711
712
713
714
715




716
717
718
719
720
721
722

767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784








+
+
+
+








    .t2 mark set $pos 3.0
    lappend res [.t2 index $pos]
    .t2 mark set $pos 1.0
    lappend res [.t2 index $pos]
    catch {destroy .t2}
    set res
} {3.4 3.0 1.0}

#
# COMMON TEST SETUP
#

frame .f -width 100 -height 20
pack .f -side left

set varFont {Times -14}
set bigFont {Helvetica -24}
destroy .t
︙
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869

902
903
904
905
906
907
908
















909
910
911
912
913
914
915








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








    }
    .t tag configure Elided -elide 1
    .t tag add Elided 6.0 951.0
    update
    set res [.t index "951.0 + 1 displaylines"]
} {952.0}

proc text_test_word {startend chars start} {
    destroy .t
    text .t
    .t insert end $chars
    if {[regexp {end} $start]} {
	set start [.t index "${start}chars -2c"]
    } else {
	set start [.t index "1.0 + ${start}chars"]
    }
    if {[.t compare $start >= "end-1c"]} {
	set start "end-2c"
    }
    set res [.t index "$start $startend"]
    .t count 1.0 $res
}

# Following tests copied from tests from string wordstart/end in Tcl

test textIndex-21.4 {text index wordend} {
    text_test_word wordend abc. -1
} 3
test textIndex-21.5 {text index wordend} {
    text_test_word wordend abc. 100
︙
1017
1018
1019
1020
1021
1022
1023



1024

1025
1026
1027
1028
1029

1063
1064
1065
1066
1067
1068
1069
1070
1071
1072

1073
1074
1075
1076
1077









+
+
+
-
+




-

    catch {.p2 index mytag.first} msg
    lappend res [.t2 index mytag.first] $msg
    destroy .t2 .p2
    set res
} {1.0 {bad text index "mymark"} 1.0 {bad text index "redsquare"} 1.2\
   {bad text index ".f"} 1.3 {text doesn't contain any characters tagged with "mytag"}}

#
# TESTFILE CLEANUP
#
# cleanup

rename textimage {}
catch {destroy .t}
testutils forget text
cleanupTests
return
Changes to tests/textMark.test. 
1
2
3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17
18
19

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the code in the file tkTextMark.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

destroy .t
text .t -width 20 -height 10
pack .t -expand 1 -fill both
update
.t debug on
wm geometry . {}
︙
32
33
34
35
36
37
38




39
40
41
42
43
44
45

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72








+
+
+
+








# manager is mwm to make mwm forget about a previous minimum size setting.

wm withdraw .
wm minsize . 1 1
wm positionfrom . user
wm deiconify .

#
# TESTS
#

test textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body {
    .t mark
} -result {wrong # args: should be ".t mark option ?arg ...?"}
test textMark-1.2 {TkTextMarkCmd - bogus option} -returnCodes error -body {
    .t mark gorp
} -match glob -result {bad mark option "gorp": must be *}
test textMark-1.3 {TkTextMarkCmd - "gravity" option} -returnCodes error -body {
︙
301
302
303
304
305
306
307




308
309
310
311
312
313
314
315
316
317

328
329
330
331
332
333
334
335
336
337
338
339
340


341

342
343
344
345








+
+
+
+


-
-

-





test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a peer} -setup {
    .t mark unset {*}[.t mark names]
} -body {
    .t mark set mymark 1.0
    lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]]
} -result {current insert mymark}

#
# TESTFILE CLEANUP
#

destroy .pt
destroy .t

# cleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# End:
Changes to tests/textTag.test. 
1
2
3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17
18
19

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test the code in the file tkTextTag.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

#
# Don't use the variable name "fixedFont" since that variable is already defined
# in utility namespace ::tk::test::text for importing in the namespace in which
# test files are executing.
#
set fixedFont2 {Courier 12}
︙
46
47
48
49
50
51
52




53
54
55
56
57
58
59

69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86








+
+
+
+








.t insert 1.0 "Line 1
abcdefghijklm
12345
Line 4
bOy GIrl .#@? x_yz
!@#$%
Line 7"

#
# TESTS
#

test textTag-1.1 {tag configuration options} -body {
    .t tag configure x -background #012345
    .t tag cget x -background
} -cleanup {
    .t tag configure x -background [lindex [.t tag configure x -background] 3]
} -result {#012345}
︙
611
612
613
614
615
616
617




618

619
620
621
622
623
624
625

638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657








+
+
+
+

+








} -returnCodes error -result {expected screen distance or "" but got "140.1.1"}
test textTag-5.16a {TkTextTagCmd - "configure" option} -body {
    .t tag delete x
    .t tag configure x -rmargincolor rainbow
} -cleanup {
    .t tag delete x
} -returnCodes error -result {unknown color name "rainbow"}

#
# COMMON TEST CLEANUP
#
.t tag delete x

test textTag-5.17 {TkTextTagCmd - "configure" option} -body {
    .t tag delete x
    .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6
    list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \
	[.t tag configure x -spacing3]
} -cleanup {
    .t tag delete x
︙
1171
1172
1173
1174
1175
1176
1177




1178

1179
1180
1181
1182
1183
1184
1185

1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222








+
+
+
+

+








    foreach i {a b c d} {
	.t tag add $i 2.0 2.2
    }
    .t tag names 2.1
} -cleanup {
    .t tag delete a b c d
} -result {a b c d}

#
# COMMON TEST CLEANUP
#
.t tag delete a b c d

test textTag-14.2 {SortTags} -setup {
    .t tag delete a b c d
} -body {
    foreach i {a b c d} {
	.t tag configure $i -background black
    }
    foreach i {d c b a} {
︙
1208
1209
1210
1211
1212
1213
1214




1215
1216
1217
1218
1219
1220
1221

1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262








+
+
+
+








    for {set i 29} {$i >= 0} {incr i -1} {
	.t tag add x$i 2.0 2.2
    }
    .t tag names 2.1
} -cleanup {
    .t tag delete {*}[.t tag names]
} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29}

#
# COMMON TEST SETUP
#

set c [.t bbox 2.1]
set x1 [expr {[lindex $c 0] + [lindex $c 2]/2}]
set y1 [expr {[lindex $c 1] + [lindex $c 3]/2}]
set c [.t bbox 3.2]
set x2 [expr {[lindex $c 0] + [lindex $c 2]/2}]
set y2 [expr {[lindex $c 1] + [lindex $c 3]/2}]
︙
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552





1553
1554

1584
1585
1586
1587
1588
1589
1590



1591
1592
1593
1594
1595
1596









-
-
-
+
+
+
+
+

-

    event gen .t <Motion> -warp 1 -x 10 -y 10 ; update
    event gen .t <Motion> -warp 1 -x 25 -y 25 ; update
    set res
} -cleanup {
    destroy .t
} -result {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}}

destroy .t

# cleanup
#
# TESTFILE CLEANUP
#

destroy .t
cleanupTests
return
Changes to tests/textWind.test. 
1
2
3
4
5
6
7
8


















9

10
11
12
13






14
15




16
17
18
19
20
21
22

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


-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+








# This file is a Tcl script to test the code in the file tkTextWind.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import text

#
# COMMON TEST SETUP
#

deleteWindows

# On Windows at least, the tests do work with {Courier -10}, {Courier -12} or {Courier -14} as fixedFont.
# Warn the user if the actual font is too different from what was requested.
if {[font metrics [font actual $fixedFont] -fixed] != 1} {
    puts "---> Warning: the font actually used by the tests, which is \"[font actual $fixedFont]\",\
︙
58
59
60
61
62
63
64
65



66
67
68
69
70
71
72

81
82
83
84
85
86
87

88
89
90
91
92
93
94
95
96
97








-
+
+
+








wm deiconify .

# This update is needed on MacOS to make sure that the window is mapped
# when the tests begin.

update

# ----------------------------------------------------------------------
#
# TESTS
#

test textWind-1.1 {basic tests of options} -setup {
    .t delete 1.0 end
} -body {
    .t insert end "This is the first line"
    .t insert end "\nAnd this is a second line, which wraps around"
    frame .f -width 3 -height 3 -bg $color
︙
142
143
144
145
146
147
148




149
150
151

152
153
154
155
156
157
158

167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188








+
+
+
+



+








    frame .f -width 5 -height 5 -bg $color
    .t window create 2.2 -window .f -stretch 1
    update
    list [winfo geom .f] [.t window configure .f -stretch]
} -result [list \
    5x$fixedHeight+[xchar 2]+[yline 2] \
    {-stretch {} {} 0 1}]

#
# COMMON TEST SETUP
#

.t delete 1.0 end
.t insert end "This is the first line"

test textWind-2.1 {TkTextWindowCmd procedure} -body {
    .t window
} -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"}
test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} -body {
    .t window cget
} -returnCodes error -result {wrong # args: should be ".t window cget index option"}
test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} -body {
︙
300
301
302
303
304
305
306




307

308
309
310
311
312
313
314

330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349








+
+
+
+

+








    list [winfo exists .f] [.t index 1.end] [catch {.t index .f}]
} -result {1 1.0 1}
test textWind-2.22 {TkTextWindowCmd procedure} -setup {
    .t delete 1.0 end
} -body {
    .t window c
} -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names}

#
# COMMON TEST CLEANUP
#
destroy .f

test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup {
    .t delete 1.0 end
} -body {
    .t window names foo
} -returnCodes error -result {wrong # args: should be ".t window names"}
test textWind-2.24 {TkTextWindowCmd procedure, "names" option} -setup {
    .t delete 1.0 end
︙
464
465
466
467
468
469
470




471
472
473
474
475
476
477

499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516








+
+
+
+








    .t insert 1.0 "Some sample text"
    button .t.b -text "Hello!"
    .t window create 1.4 -window .t.b
    .t window create 1.6 -window .t.b
    update
    .t index .t.b
} -result {1.6}

#
# COMMON TEST SETUP
#

.t delete 1.0 end
frame .f -width 10 -height 20 -bg $color
.t window create 1.0 -window .f

test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} -body {
    .t window configure 1.0 -align baseline
︙
1641
1642
1643
1644
1645
1646
1647
1648

1649
1650
1651
1652
1653
1654

1680
1681
1682
1683
1684
1685
1686

1687
1688
1689
1690
1691
1692









-
+





-

    tkwait variable x
} -cleanup {
    destroy .t .f
} -result {}


#
# CLEANUP
# TESTFILE CLEANUP
#

option clear
testutils forget text
cleanupTests
return
Changes to tests/tk.test. 
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



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

-
-
+
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+

+
+
+
+

+
+
+
+







+
+
+
+



+













+
+
+
+

+
+
+
+



+








# This file is a Tcl script to test the tk command.
# It is organized in the standard fashion for Tcl tests.
# This file is a Tcl script to test the "tk" command, except those for
# "tk busy", which are in the test file busy.test.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 2002 ActiveState Corporation.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#

testConstraint testprintf [llength [info command testprintf]]

#
# TESTS
#

test tk-1.1 {tk command: general} -body {
    tk
} -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"}
test tk-1.2 {tk command: general} -body {
    tk xyz
} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, print, scaling, sysnotify, systray, useinputmethods, or windowingsystem}

#
# COMMON TEST SETUP
#

# Value stored to restore default settings after 2.* tests
set appname [tk appname]

test tk-2.1 {tk command: appname} -body {
    tk appname xyz abc
} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"}
test tk-2.2 {tk command: appname} -body {
    tk appname foobazgarply
} -result {foobazgarply}
test tk-2.3 {tk command: appname} -constraints unix -body {
    tk appname bazfoogarply
    expr {[lsearch -exact [winfo interps] [tk appname]] >= 0}
} -result 1
test tk-2.4 {tk command: appname} -body {
    tk appname [tk appname]
} -result [tk appname]

#
# COMMON TEST CLEANUP
#
tk appname $appname

#
# COMMON TEST SETUP
#

# Value stored to restore default settings after 3.* tests
set scaling [tk scaling]

test tk-3.1 {tk command: scaling} -body {
    tk scaling -displayof
} -returnCodes error -result {value for "-displayof" missing}
test tk-3.2 {tk command: scaling: get current} -body {
    tk scaling 1
    format %.2g [tk scaling]
}  -result 1
︙
77
78
79
80
81
82
83




84




85
86
87

88
89
90
91
92
93
94

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








+
+
+
+

+
+
+
+



+








	- [winfo screenmmwidth .]}
} -result 0
test tk-3.11 {tk command: scaling: heightmm} -body {
    tk scaling 1.25
    expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \
	- [winfo screenmmheight .]}
} -result 0

#
# COMMON TEST CLEANUP
#
tk scaling $scaling

#
# COMMON TEST SETUP
#

# Value stored to restore default settings after 4.* tests
set useim [tk useinputmethods]

test tk-4.1 {tk command: useinputmethods} -body {
    tk useinputmethods -displayof
} -returnCodes error -result {value for "-displayof" missing}
test tk-4.2 {tk command: useinputmethods: get current} -body {
    tk useinputmethods no
} -cleanup {
    tk useinputmethods $useim
︙
179
180
181
182
183
184
185
186
187
188




189
190

230
231
232
233
234
235
236



237
238
239
240
241









-
-
-
+
+
+
+

-

    ::safe::interpDelete foo
} -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter}

test tk-8.1 {Test for ticket [1cc44617e2], see if TCL_LL_MODIFIER works as expected on all platforms} -constraints testprintf -body {
    testprintf -21474836480
} -result {-21474836480 18446744052234715136}

# tests of [tk busy] in busy.test

# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return
Changes to tests/ttk/all.tcl. 
1
2
3
4

5
6
7
8
9
10
11



12
13



















14


15
16
17
18
19
20
21
























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




-
+







+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
+

-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

# all.tcl --
#
# This file contains a top-level script to run all of the ttk
# tests.  Execute it by invoking "source all.tcl" when running tktest
# tests. Execute it by invoking "source all.tcl" when running tktest
# in this directory.
#
# Copyright © 2007 the Tk developers.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# REQUIREMENTS
#
package require tk ;# This is the Tk test suite; fail early if no Tk!
package require tcltest 2.2

#
# TCLTEST CONFIGURATION
#

# Set defaults for the Tk test suite
tcltest::configure -singleproc 1

# Handle command line parameters
if {[expr {[llength $argv] & 1}]} {
    return -code error "the number of command line parameters must be even (name - value pairs)"
}
set fixedOptions [list -testdir -loadfile]
foreach {key value} $argv {
    if {$key in $fixedOptions} {
	return -code error "option \"$key\" is not user-configurable for the Tk test suite"
    }
}
unset fixedOptions
tcltest::configure {*}$argv

# Set tcltest options that are not user-configurable for the Tk test suite
tcltest::configure -testdir [file normalize [file dirname [info script]]]
tcltest::configure -loadfile \
    [file join [file dirname [tcltest::testsDirectory]] main.tcl]
tcltest::configure -singleproc 1
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
encoding system utf-8
if {[tcltest::runAllTests] && $ErrorOnFailures} {exit 1}
if {[tcltest::configure -singleproc]} {
    #
    # All test files are evaluated in the current interpreter. We need to load
    # the file main.tcl only once.
    #
    source [file join [file dirname [tcltest::testsDirectory]] main.tcl]
} else {
    #
    # Each test file is evaluated in a separate process/interpreter. Each testfile
    # needs to load the file main.tcl into its interpreter.
    #
    tcltest::configure -loadfile \
	[file join [file dirname [tcltest::testsDirectory]] main.tcl]
}

#
# RUN ALL TESTS
#

# Note: the environment variable ERROR_ON_FAILURES is set by Github CI
if {[tcltest::runAllTests] && [info exists env(ERROR_ON_FAILURES)]} {
    exit 1
}
Changes to tests/ttk/checkbutton.test. 
1
2
3
4



5
6
















7
8









9
10
11
12
13
14
15

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





+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::checkbutton widget tests.
#

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test checkbutton-1.1 "Checkbutton check" -body {
    pack [ttk::checkbutton .cb -text "TCheckbutton" -variable cb]
}
test checkbutton-1.2 "Checkbutton invoke" -body {
    .cb invoke
    list [set ::cb] [.cb instate selected]
︙
80
81
82
83
84
85
86
87




88

104
105
106
107
108
109
110
111
112
113
114
115
116









+
+
+
+


test checkbutton-2.2 "style command" -body {
    ttk::style configure customStyle.TCheckbutton
    ttk::checkbutton .w -style customStyle.TCheckbutton
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TCheckbutton customStyle.TCheckbutton TCheckbutton}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests
Changes to tests/ttk/combobox.test. 
1
2
3
4



5
6
















7
8









9
10
11
12
13
14
15

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





+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::combobox widget tests
#

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test combobox-1.0 "Combobox tests -- setup" -body {
    ttk::combobox .cb
} -result .cb

test combobox-1.1 "Bad -values list" -body {
    .cb configure -values "bad \{list"
︙
113
114
115
116
117
118
119
120




121

137
138
139
140
141
142
143
144
145
146
147
148
149









+
+
+
+


test combobox-4.2 "style command" -body {
    ttk::style configure customStyle.TCombobox
    ttk::combobox .w -style customStyle.TCombobox
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TCombobox customStyle.TCombobox TCombobox}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests
Changes to tests/ttk/entry.test. 
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

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


-
+


+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+


+
+
+
+












+
+
+








#
# Tile package: entry widget tests
# ttk::entry widget tests
#

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry scroll

#
# LOCAL UTILITY PROCS
#

# Some of the tests raise background errors;
# override default bgerror to catch them.
#
variable bgerror ""
proc bgerror {error} {
    variable bgerror $error
    variable bgerrorInfo $::errorInfo
    variable bgerrorCode $::errorCode
}

#
# TESTS
#

test entry-1.1 "Create entry widget" -body {
    ttk::entry .e
} -result .e

test entry-1.2 "Insert" -body {
    .e insert end abcde
    .e get
︙
397
398
399
400
401
402
403
404

405
406
407
408

424
425
426
427
428
429
430

431
432
433
434
435








-
+





    ttk::entry .w -style customStyle.TEntry
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TEntry customStyle.TEntry TEntry}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget entry scroll
tcltest::cleanupTests
Changes to tests/ttk/image.test. 



1
2




















3
4









5
6
7
8
9
10
11

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# Tests for images in various ttk widgets
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test image-1.1 "Bad image element" -body {
    ttk::style element create BadImage image badimage
} -returnCodes error -result {image "badimage" does not exist}

test image-1.2 "Duplicate element" -setup {
    image create photo test.element -width 10 -height 10




︙


44
45
46
47
48
49
50



51

72
73
74
75
76
77
78
79
80
81
82








+
+
+


    image delete test.image
    update
} -cleanup {
    destroy .ttk_image22
} -result {}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/labelframe.test.








1
2




















3
4









5
6
7
8
9
10
11

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::labelframe widget tests
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test labelframe-1.0 "Setup" -body {
    pack [ttk::labelframe .lf] -expand true -fill both
}

test labelframe-2.1 "Can't use indirect descendant as labelwidget" -body {
    ttk::frame .lf.t




︙


137
138
139
140
141
142
143
144




145

165
166
167
168
169
170
171
172
173
174
175
176
177









+
+
+
+


test labelframe-7.2 "style command" -body {
    ttk::style configure customStyle.TLabelframe
    ttk::labelframe .w -style customStyle.TLabelframe
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TLabelframe customStyle.TLabelframe TLabelframe}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/layout.test.








1
2




















3
4









5
6
7
8
9
10
11

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# Tests for the "ttk::style layout" command
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test layout-1.1 "Size computations for mixed-orientation layouts" -body {
    ttk::style theme use default

    set block [image create photo -width 10 -height 10]
    ttk::style element create block image $block
    ttk::style layout Blocks {




︙


21
22
23
24
25
26
27
28




29

49
50
51
52
53
54
55
56
57
58
59
60
61









+
+
+
+


    list [winfo reqwidth .b] [winfo reqheight .b]

} -cleanup { destroy .b } -result [list 24 24]

test layout-2 "Empty -children not allowed" -body {
    ttk::style layout Test.Tentry {Entry.field -children {}}
} -returnCodes error -result {Invalid -children value}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/notebook.test.








1
2




















3
4















5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+












-








#
# ttk::notebook widget tests
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc inoperative {args} {}

#
# TESTS
#

test notebook-1.0 "Setup" -body {
    ttk::notebook .nb
} -result .nb

#
# Error handling tests:
#
test notebook-1.1 "Cannot add ancestor" -body {
    .nb add .
} -returnCodes error -result "*" -match glob

proc inoperative {args} {}

inoperative test notebook-1.2 "Cannot add siblings" -body {
    # This is legal now
    .nb add [frame .sibling]
} -returnCodes error -result "*" -match glob

test notebook-1.3 "Cannot add toplevel" -body {




︙


338
339
340
341
342
343
344
345

346
347




348
349
350
351
352
353
354

371
372
373
374
375
376
377

378
379
380
381
382
383
384
385
386
387
388
389
390
391








-
+


+
+
+
+








    lappend result [$nb index current] [$nb tab $nb.f2 -state]
    $nb add $nb.f2
    update idletasks
    lappend result [$nb index current] [$nb tab $nb.f2 -state]
} -result [list 1 normal 2 hidden 2 normal]

#
# Insert:
# COMMON TEST CLEANUP
#
unset nb

#
# Insert:
#
test notebook-7.0 "insert - setup" -body {
    pack [ttk::notebook .nb]
    for {set i 0} {$i < 5} {incr i} {
	.nb add [ttk::frame .nb.f$i] -text "$i"
    }
    .nb select .nb.f1
    list [.nb index current] [.nb tabs]




︙


572
573
574
575
576
577
578
579




580

609
610
611
612
613
614
615
616
617
618
619
620
621









+
+
+
+


	.n add .n.[string tolower $tabs] -text $tabs
    }
   .n insert 2 0  ; # allowed: TabA moves to last tab position
   .n insert 3 0  ; # not allowed: position 3 is after last tab
} -cleanup {
    destroy .n
} -result {Managed window index "3" out of bounds} -returnCodes error

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/panedwindow.test.








1
2




















3
4
5

























6













7
8
9
10
11
12
13

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
+








#
# ttk::panedwindow widget tests
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# checkorder --
#	Ensure that Y coordinates windows in $winlist are strictly increasing.
#
proc checkorder {winlist} {
    set pos -1
    set positions [list]
    foreach win $winlist {
	lappend positions [set nextpos [winfo y $win]]
	if {$nextpos <= $pos} {
	    error "window $win out of order ($positions)"
	}
	set pos $nextpos
    }
}

proc propagate-geometry {} { update idletasks }

proc sashpositions {pw} {
    set positions [list]
    set npanes [llength [winfo children $pw]]
    for {set i 0} {$i < $npanes - 1} {incr i} {
	lappend positions [$pw sashpos $i]
    }
    return $positions
}

#
# TESTS
#

# Basic sanity checks:
#
test panedwindow-1.0 "Setup" -body {
    ttk::panedwindow .pw
} -result .pw





︙


118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

174
175
176
177
178
179
180



181
182
183
184
185
186
187








-
-
-








    set rw4 [winfo reqwidth .pw]

    expr {$rw4 > $rw3}
} -result 1

test panedwindow-2.end "Cleanup" -body { destroy .pw }

#
# ...
#
test panedwindow-3.0 "configure pane" -body {
    ttk::panedwindow .pw
    .pw add [listbox .pw.lb1]
    .pw add [listbox .pw.lb2]
    .pw pane 1 -weight 2
    .pw pane 1 -weight
} -result 2




︙


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

214
215
216
217
218
219
220















221
222
223
224
225
226
227








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








    update
}

test panedwindow-4.2 "forget forgotten" -body {
    .pw forget .pw.l1
} -returnCodes error -result ".pw.l1 is not managed by .pw"

# checkorder $winlist --
#	Ensure that Y coordinates windows in $winlist are strictly increasing.
#
proc checkorder {winlist} {
    set pos -1
    set positions [list]
    foreach win $winlist {
	lappend positions [set nextpos [winfo y $win]]
	if {$nextpos <= $pos} {
	    error "window $win out of order ($positions)"
	}
	set pos $nextpos
    }
}

test panedwindow-4.3 "insert command" -body {
    .pw insert end .pw.l1
    .pw insert end .pw.l3
    .pw insert 1 .pw.l2
    .pw insert end .pw.l4

    update;




︙


211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232

249
250
251
252
253
254
255








256
257
258
259
260
261
262








-
-
-
-
-
-
-
-








    set result
} -result [list 1 1 0 0] -cleanup {
    destroy .pw
}

### sashpos tests.
#
proc sashpositions {pw} {
    set positions [list]
    set npanes [llength [winfo children $pw]]
    for {set i 0} {$i < $npanes - 1} {incr i} {
	lappend positions [$pw sashpos $i]
    }
    return $positions
}

test paned-sashpos-setup "Setup for sash position test" -body {
    ttk::style theme use default
    ttk::style configure Sash -sashthickness 5

    ttk::panedwindow .pw
    .pw add [frame .pw.f1 -width 20 -height 20]




︙


318
319
320
321
322
323
324
325




326

348
349
350
351
352
353
354
355
356
357
358
359
360









+
+
+
+


test panedwindow-6.2 "style command" -body {
    ttk::style configure customStyle.TPanedwindow
    ttk::panedwindow .w -style customStyle.TPanedwindow
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TPanedwindow customStyle.TPanedwindow TPanedwindow}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/progressbar.test.








1
2




















3
4
5









6
7
8
9
10
11
12

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::progressbar widget tests
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test progressbar-1.1 "Setup" -body {
    ttk::progressbar .pb
} -result .pb

test progressbar-1.2 "Linked variable" -body {
    set PB 50




︙


155
156
157
158
159
160
161
162




163

182
183
184
185
186
187
188
189
190
191
192
193
194









+
+
+
+


test progressbar-4.2 "style command" -body {
    ttk::style configure customStyle.Vertical.TProgressbar
    ttk::progressbar .w -orient vertical -style customStyle.Vertical.TProgressbar
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.Vertical.TProgressbar Vertical.customStyle.Vertical.TProgressbar TProgressbar}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/radiobutton.test.





1
2
3
4



5
6
















7
8









9
10
11
12
13
14
15

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





+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::radiobutton widget tests.
#

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test radiobutton-1.1 "Radiobutton check" -body {
    pack \
	[ttk::radiobutton .rb1 -text "One" -variable choice -value 1] \
	[ttk::radiobutton .rb2 -text "Two" -variable choice -value 2] \
	[ttk::radiobutton .rb3 -text "Three" -variable choice -value 3] \
	;




︙


55
56
57
58
59
60
61
62




63

79
80
81
82
83
84
85
86
87
88
89
90
91









+
+
+
+


test radiobutton-2.2 "style command" -body {
    ttk::style configure customStyle.TRadiobutton
    ttk::radiobutton .w -style customStyle.TRadiobutton
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TRadiobutton customStyle.TRadiobutton TRadiobutton}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/scale.test.








1
2




















3
4









5
6
7
8
9
10
11

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

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::scale widget tests
#
package require tk
package require tcltest 2.2

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test scale-1.0 "Self-destruction" -body {
    trace add variable v write { destroy .s ;# }
    ttk::scale .s -variable v
    pack .s ; update
    .s set 1 ; update
} -returnCodes error -match glob -result "*"




︙


44
45
46
47
48
49
50




51
52
53

72
73
74
75
76
77
78
79
80
81
82
83
84
85








+
+
+
+




test scale-3.2 "style command" -body {
    ttk::style configure customStyle.Vertical.TScale
    ttk::scale .w -orient vertical -style customStyle.Vertical.TScale
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.Vertical.TScale Vertical.customStyle.Vertical.TScale TScale}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests







Changes to tests/ttk/scrollbar.test.





1
2
3




4
5


6
7
8
9
10
11
12





























13
14
15
16
17
18
19




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

-
-
-
+
+
+
+
-
-
+
+







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








package require tk
package require tcltest 2.2
namespace import -force tcltest::*
#
# ttk::scrollbar widget tests
#

loadTestedCommands

# NOTE
#
# Before 2019 the code in library/ttk/scrollbar.tcl would replace the
# constructor of ttk::scrollbar with the constructor of tk::scrollbar
# unless the -class or -style options were specified..
# Now there is an implementation of ttk::scrollbar for macOS.  The
# tests are left in place, though, except that scrollbar-swapout-1
# test was changed to expect the class to be TScrollbar instead of
# Scrollbar.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test scrollbar-swapout-1 "Don't use core scrollbars on OSX..." \
 -constraints {
     aqua
} -body {
    ttk::scrollbar .sb -command "yadda"
    list [winfo class .sb] [.sb cget -command]




︙


128
129
130
131
132
133
134
135
136






158
159
160
161
162
163
164


165
166
167
168
169








-
-
+
+
+
+
+

    ttk::style configure customStyle.Horizontal.TScrollbar
    ttk::scrollbar .w -orient horizontal -style customStyle.Horizontal.TScrollbar
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.Horizontal.TScrollbar Horizontal.customStyle.Horizontal.TScrollbar TScrollbar}

tcltest::cleanupTests

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/spinbox.test.





1
2
3
4



5
6
















7
8









9
10
11
12
13
14
15

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





+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+








#
# ttk::spinbox widget tests
#

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test spinbox-1.0 "Spinbox tests -- setup" -body {
    ttk::spinbox .sb
} -cleanup { destroy .sb } -result .sb

test spinbox-1.1 "Bad -values list" -setup {
    ttk::spinbox .sb




︙


392
393
394
395
396
397
398




399
400
401
402
403
404

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432








+
+
+
+







test spinbox-5.2 "style command" -body {
    ttk::style configure customStyle.TSpinbox
    ttk::spinbox .w -style customStyle.TSpinbox
    list [.w cget -style] [.w style] [winfo class .w]
} -cleanup {
    destroy .w
} -result {customStyle.TSpinbox customStyle.TSpinbox TSpinbox}

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests

# Local variables:
# mode: tcl
# End:






Changes to tests/ttk/treetags.test.





1
2
3























4
5
6
7
8











9
10
11
12
13
14
15




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

-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+









package require tk
package require tcltest 2.2
#
# Tests for tags in the ttk::treeview widget
#

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

### treeview tag invariants:
#
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# Treeview tag invariants:

proc itemConstraints {tv item} {
    # $tag in [$tv item $item -tags] <==> [$tv tag has $tag $item]
    foreach tag [$tv item $item -tags] {
	assert {$item in [$tv tag has $tag]}
    }
    foreach child [$tv children $item] {




︙


24
25
26
27
28
29
30
31
32




33
34
35
36
37
38
39

50
51
52
53
54
55
56


57
58
59
60
61
62
63
64
65
66
67








-
-
+
+
+
+








	foreach item [$tv tag has $tag] {
	    assert {$tag in [$tv item $item -tags]}
	}
    }

    itemConstraints $tv {}
}
#
###

#
# TESTS
#

test treetags-1.0 "Setup" -body {
    set tv [ttk::treeview .tv -columns "A B C"]
    .tv insert {} end -id item1 -text "Item 1"
    pack .tv
} -cleanup {
    treeConstraints $tv




︙


262
263
264
265
266
267
268

269
270


271
272



273

290
291
292
293
294
295
296
297


298
299


300
301
302
303








+
-
-
+
+
-
-
+
+
+


    $tv focus item1
    event generate $tv <<Remove>>
    set result
} -cleanup {
    treeConstraints $tv
} -result [list rm1 item1 <<Remove>> rm2 item1 <<Remove>> rm3 item1 <<Remove>>]

test treetags-end "Cleanup" -body { destroy $tv }
#


#
test treetags-end "Cleanup" -body { destroy $tv }

# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/ttk/treeview.test.





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

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


+
+
+
+
+
-
-
+
+

+

+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

















+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+















+















+
+
+
+








#
# ttk::treeview widget tests
#

# NOTES
#
# [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
# what it currently does)
# * [7Jun2005] TO CHECK: [$tv see {}] -- shouldn't work (at least, shouldn't do
#   what it currently does)
#
# * NEED: tests for focus item, selection

#
# TESTFILE INITIALIZATION
#
package require tk
package require tcltest 2.2

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import scroll

#
# LOCAL UTILITY PROCS
#

# get list of column IDs from list of display column ids.
#
proc columnids {tv dcols} {
    set result [list]
    foreach dcol $dcols {
	if {[catch {
	    lappend result [$tv column $dcol -id]
	}]} {
	    lappend result ERROR
	}
    }
    return $result
}

# consistencyCheck --
#	Traverse the tree to make sure the item data structures
#	are properly linked.
#
#	Since [$tv children] follows ->next links and [$tv index]
#	follows ->prev links, this should cover all invariants.
#
proc consistencyCheck {tv {item {}}} {
    set i 0
    foreach child [$tv children $item] {
	assert {[$tv parent $child] eq $item}
	assert {[$tv index $child] == $i}
	incr i
	consistencyCheck $tv $child
    }
}

proc identify* {tv comps args} {
    foreach {x y} $args {
	foreach comp $comps {
	    lappend result [$tv identify $comp $x $y]
	}
    }
    return $result
}

proc nostretch {tv} {
    foreach col [$tv cget -columns] {
	$tv column $col -stretch 0
    }
    $tv column #0 -stretch 0
    update idletasks ; # redisplay $tv
}

proc tvSetup {} {
    destroy .tv
    ttk::treeview .tv -columns {a b c}
    pack .tv -expand true -fill both
    .tv column #0 -width 50
    .tv column a -width 50
    .tv column b -width 50
    .tv column c -width 50
    # Make sure everything is created and updated
    tkwait visibility .tv
    update
    after 10
    update
}

proc tvSetupWithItems {} {
    tvSetup
    .tv insert {} end -id nn -text "nn"
    .tv insert nn end -id nn.n1 -text "nn.1"
    .tv insert nn end -id nn.n2 -text "nn.3"
    .tv insert nn end -id nn.n3 -text "nn.3"
    for {set t 2} {$t < 100} {incr t} {
	.tv insert {} end -id nn$t -text "nn$t"
	if {$t % 3 == 0} {
	    .tv insert nn$t end -id nn$t.n1 -text "nn$t.n1"
	    .tv insert nn$t end -id nn$t.n2 -text "nn$t.n2"
	    .tv insert nn$t end -id nn$t.n3 -text "nn$t.n3"
	}
    }
}

#
# TESTS
#

test treeview-1.1 "columns" -body {
    tvSetup
    .tv configure -columns {a b c}
}

test treeview-1.2 "Bad columns" -body {




︙


234
235
236
237
238
239
240




241
242
243
244
245
246
247

300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317








+
+
+
+








# Bug # ?????
test treeview-3.13 "Re-reattach" -body {
    set before [.tv detached newnode]
    .tv move newnode {} end
    consistencyCheck .tv
    list [.tv children {}] $before [.tv detached newnode]
} -result {{newfirstone firstnode anotherone onemore lastnode newlastone newnode} 0 0}

#
# COMMON TEST SETUP
#

catch {
    .tv insert newfirstone end -id x1
    .tv insert newfirstone end -id x2
    .tv insert newfirstone end -id x3
}





︙


917
918
919
920
921
922
923
924
925


926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968





969
970
971
972
973
974
975

987
988
989
990
991
992
993


994
995
996






















997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028








-
-
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-




















+
+
+
+
+








    .tv cellselection set {myItem2 a}  ; # <<TreeviewSelect>> triggers
    update
    set res
} -cleanup {
    bind .tv <<TreeviewSelect>> {}
} -result {2 3 4 5}


### identify tests:
#
# identify tests
#
proc identify* {tv comps args} {
    foreach {x y} $args {
	foreach comp $comps {
	    lappend result [$tv identify $comp $x $y]
	}
    }
    return $result
}

# get list of column IDs from list of display column ids.
#
proc columnids {tv dcols} {
    set result [list]
    foreach dcol $dcols {
	if {[catch {
	    lappend result [$tv column $dcol -id]
	}]} {
	    lappend result ERROR
	}
    }
    return $result
}

test treeview-identify-setup "identify series - setup" -body {
    destroy .tv
    ttk::setTheme default
    ttk::style configure Treeview -rowheight 10m
    ttk::style configure Treeview.Heading -font {Arial 10}
    ttk::treeview .tv -columns [list A B C]
    .tv insert {} end -id branch -text branch -open true
    .tv insert branch end -id item1 -text item1 -height 2
    .tv insert branch end -id item2 -text item2
    .tv insert branch end -id item3 -text item3
    .tv insert {} end -id item4 -text item4

    .tv column #0 -width 200	;# 0-200
    .tv column A -width 200	;# 200-400
    .tv column B -width 200	;# 400-600
    .tv column C -width 200	;# 600-800 (plus slop for margins)

    wm geometry . {} ; pack .tv ; update
}

#
# COMMON TEST SETUP
#

# treeview-identify-setup sets heading row font to Arial with size 10 points,
# so the heading line center y-coordinate is (in pixels):
set yHLC [expr {([font metrics {Arial 10} -linespace] + 2) / 2.0}]
# which makes the following in millimeters:
set yHLC [expr {$yHLC / [winfo screenwidth .] * [winfo screenmmwidth .]}]

test treeview-identify-1 "identify heading" -body {




︙


1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029

1030
1031
1032
1033
1034
1035
1036




1037
1038
1039
1040
1041
1042
1043

1065
1066
1067
1068
1069
1070
1071

1072
1073
1074
1075
1076
1077
1078
1079
1080

1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099








-









-
+







+
+
+
+








test treeview-identify-7 "vertical scan - headings, no tree" -body {
    .tv configure -displaycolumns #all -show {headings}
    update idletasks
    identify* .tv {region item cell} 100 ${yHLC}m  100 [expr {$yHLC+5}]m  100 [expr {$yHLC+15}]m  300 [expr {$yHLC+35}]m  100 [expr {$yHLC+45}]m
} -result [list heading {} {} cell branch {branch #1} cell item1 {item1 #1} cell item2 {item2 #2} cell item3 {item3 #1}]

# Disclosure element name is "Treeitem.indicator"
set disclosure "*.indicator"
test treeview-identify-8 "identify element" -body {
    .tv configure -show {tree}
    .tv insert branch  0 -id branch2 -open true
    .tv insert branch2 0 -id branch3 -open true
    .tv insert branch3 0 -id leaf3
    ttk::style configure Treeview -indent 8m
    update idletasks
    identify* .tv {item element} 4m 5m  12m 15m  20m 25m
} -match glob -result [list \
	branch $disclosure branch2 $disclosure branch3 $disclosure]
	branch "*.indicator" branch2 "*.indicator" branch3 "*.indicator"]

test treeview-identify-8.1 "identify element" -body {
    .tv configure -show {tree headings}
    update
    identify* .tv element 1 1  40 ${yHLC}m  10m [expr {$yHLC+6}]m
    # Heading elements are currently not reported
} -result [list {} {} text]

#
# COMMON TEST SETUP
#

ttk::style configure Treeview -rowheight 20

# See #2381555
test treeview-identify-9 "identify works when horizontally scrolled" -setup {
    .tv configure -show {tree headings}
    foreach column {#0 A B C} {




︙


1223
1224
1225
1226
1227
1228
1229



1230


1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241

1279
1280
1281
1282
1283
1284
1285
1286
1287
1288

1289
1290
1291
1292
1293

1294
1295
1296
1297
1298
1299
1300








+
+
+
-
+
+



-








    update
    set after [lindex [.tv bbox nn a] 3]
    set diff [expr {$after - $baseline}]
} -cleanup {
    ttk::style configure Cell -padding {}
} -result [expr {8-5 + 9-5}]

#
# COMMON TEST CLEANUP
#
### NEED: tests for focus item, selection

destroy .tv

### Misc. tests:

destroy .tv
test treeview-1541739 "Root node properly initialized (#1541739)" -setup {
    ttk::treeview .tv
    .tv insert {} end -id a
    .tv see a
} -cleanup {
    destroy .tv
}




︙


1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319

1357
1358
1359
1360
1361
1362
1363








1364
1365
1366
1367
1368
1369
1370








-
-
-
-
-
-
-
-








    set res [.tv column #0 -width]
    .tv drag #0 400
    lappend res [expr {[.tv column #0 -width] > $res}]
} -cleanup {
    destroy .tv
} -result {200 1}

proc nostretch {tv} {
    foreach col [$tv cget -columns] {
	$tv column $col -stretch 0
    }
    $tv column #0 -stretch 0
    update idletasks ; # redisplay $tv
}

test treeview-ce470f20fd-2 "changing -stretch resizes columns" -setup {
    pack [ttk::treeview .tv -columns {bar colA colB colC foo}]
    foreach col [.tv cget -columns] {
	.tv heading $col -text $col
    }
    nostretch .tv
    .tv column colA -width 50 ; .tv column colB -width 50 ; # slack created




︙


1497
1498
1499
1500
1501
1502
1503
1504

1505
1506
1507
1508

1548
1549
1550
1551
1552
1553
1554

1555
1556
1557
1558
1559








-
+





    .tv tag configure mytag -padding {2 4 6 8}
    .tv tag configure mytag -padding
} -cleanup {
    destroy .tv
} -result {2 4 6 8}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget scroll
tcltest::cleanupTests






Changes to tests/ttk/ttk.test.





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




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

-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+









-
-
+
+
-
-
-
-
+
+
+



-
-
-
+









package require tk
package require tcltest 2.2
#
# Diverse tests for ttk
#

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands

proc skip args {}
proc ok {} { return }
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc bgerror {error} {
    variable bgerror $error
    variable bgerrorInfo $::errorInfo
    variable bgerrorCode $::errorCode
}

# Tests using this will fail if the top-level window contains the cursor
proc checkstate {w} {
    foreach statespec {
	{!active !disabled}
	{!active disabled}
	{active !disabled}
	{active disabled}
	active
	disabled
    } {
	lappend result [$w instate $statespec]
    }
    set result
}

proc selfdestruct {w args} {
    destroy $w
}

proc wrong#args {args} {
    return "wrong # args: should be \"$args\""
}

proc wrong#varargs {varpart args} {
    set usage $args
    append usage " ?$varpart ...?"
    return "wrong # args: should be \"$usage\""
}

#
# COMMON TEST SETUP
#

variable widgetClasses {
    button checkbutton radiobutton menubutton label entry
    frame labelframe scrollbar
    notebook progressbar combobox separator
    panedwindow treeview sizegrip
    scale
}

proc bgerror {error} {
    variable bgerror $error
#
# TESTS
    variable bgerrorInfo $::errorInfo
    variable bgerrorCode $::errorCode
}

#

#
# Self-destruct tests.
# Do these early, so any memory corruption has a longer time to cause a crash.
#
proc selfdestruct {w args} {
    destroy $w
}

test ttk-6.1 "Self-destructing checkbutton" -body {
    pack [ttk::checkbutton .sd -text "Self-destruction" -variable ::sd]
    trace add variable sd write [list selfdestruct .sd]
    update
    .sd invoke
} -returnCodes error
test ttk-6.2 "Checkbutton self-destructed" -body {




︙


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

210
211
212
213
214
215
216
















217
218
219
220
221
222
223








-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-








    .t configure -style "nosuchstyle"
} -returnCodes error -result {Layout nosuchstyle not found}

test ttk-1.4 "Original style preserved" -body {
    .t cget -style
} -result ""

# Tests using this will fail if the top-level window contains the cursor

proc checkstate {w} {
    foreach statespec {
	{!active !disabled}
	{!active disabled}
	{active !disabled}
	{active disabled}
	active
	disabled
    } {
	lappend result [$w instate $statespec]
    }
    set result
}

test ttk-2.0 "Check state" -body {
    checkstate .t
} -result [list 1 0 0 0 0 0]

test ttk-2.1 "Change state" -body {
    .t state active
} -result !active




︙


281
282
283
284
285
286
287
288

289
290
291
292
293
294
295

325
326
327
328
329
330
331

332
333
334
335
336
337
338
339








-
+








# don't really test anything useful at the moment.)
#

test ttk-4.0 "Setup" -body {
    catch { destroy .t }
    pack [ttk::label .t -text "Button 1"]
    testConstraint fontOption [expr {![catch { set prevFont [.t cget -font] }]}]
    ok
    return -code ok
}

test ttk-4.1 "Change font" -constraints fontOption -body {
    .t configure -font "Helvetica 18 bold"
}
test ttk-4.2 "Check font" -constraints fontOption -body {
    .t cget -font




︙


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

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
417
418
419
420
421

422
423
424
425
426

427
428
429
430
431
432

433
434
435
436
437
438
439








+
+
+
+
+
+















-
-
-
-
-
-
-
-
-
-
-
-





-

-







-
+




-









-
+




-






-
+




-






-








    ttk::style theme settings alt {
	ttk::style configure TButton -font TkDefaultFont
    }
    ttk::style theme use default
    destroy .tb1
}

#
# COMMON TEST SETUP
#
# For tests ttk-8.*
#

#
# -compound tests:
#
variable iconData \
{R0lGODlhIAAgAKIAANnZ2YQAAP8AAISEhP///////////////yH5BAEAAAAALAAAAAAgACAA
AAP/CLoMGLqKoMvtGIqiqxEYCLrcioGiyxwIusyBgaLLLRiBoMsQKLrcjYGgu4Giy+2CAkFX
A0WX2wXFIOgGii7trkCEohsDCACBoktEKLpKhISiGwAIECiqSKooukiqKKoxgACBooukKiIo
SKooujGDECi6iqQqsopEV2MQAkV3kXQZRXdjEAJFl5F0FUWXY3ACRZcFSRdFlyVwJlB0WZB0
UXRZAmcCRZeRdBVFl2NwAkV3kXQZRXdjcAJFV5FURVaR6GoMDgSKLpKqiKAgqaLoxgwOBIoq
kiqKLpIqimrM4ECg6BIRiq4SIaHoxgyCBoou7a5AhKIbMzgAAIGiy+2CTWJmBhAAAkWX2wXF
zCDoBooud2PMDIKuRqDocgtGzMwg6O4Eii5z4Kgi6DIMhqLoagQGjiqCLvPgYOgqji6CLrfi
6DIj6HI7jq4i6DIkADs=}

variable compoundStrings {text image center top bottom left right none}

if {0} {
    proc now {} { set ::now [clock clicks -milliseconds] }
    proc tick {} { puts -nonewline stderr "+" ; flush stderr }
    proc tock {} {
	set then $::now; set ::now [clock clicks -milliseconds]
	puts stderr " [expr {$::now - $then}] ms"
    }
} else {
    proc now {} {} ; proc tick {} {} ; proc tock {} {}
}

now ; tick
test ttk-8.0 "Setup for 8.X" -body {
    ttk::button .ctb
    image create photo icon -data $::iconData;
    pack .ctb
}
tock

now
test ttk-8.1 "Test -compound options" -body {
    # Exhaustively test each combination.
    # Main goal is to make sure no code paths crash.
    foreach image {icon ""} {
	foreach text {"Hi!" ""} {
	    foreach compound $::compoundStrings {
		.ctb configure -image $image -text $text -compound $compound
		update; tick
		update
	    }
	}
    }
}
tock

test ttk-8.2 "Test -compound options with regular button" -body {
    button .rtb
    pack .rtb

    foreach image {"" icon} {
	foreach text {"Hi!" ""} {
	    foreach compound [lrange $::compoundStrings 2 end] {
		.rtb configure -image $image -text $text -compound $compound
		update; tick
		update
	    }
	}
    }
}
tock

test ttk-8.3 "Rerun test 8.1" -body {
    foreach image {icon ""} {
	foreach text {"Hi!" ""} {
	    foreach compound $::compoundStrings {
		.ctb configure -image $image -text $text -compound $compound
		update; tick
		update
	    }
	}
    }
}
tock

test ttk-8.4 "ImageChanged" -body {
    ttk::button .b -image icon
    icon blank
} -cleanup { destroy .b }

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

test ttk-9.1 "Traces on nonexistant namespaces" -body {
    ttk::checkbutton .tcb -variable foo::bar
} -returnCodes error -result {can't trace "foo::bar": parent namespace doesn't exist}

test ttk-9.2 "Traces on nonexistant namespaces II" -body {
    ttk::checkbutton .tcb -variable X




︙


636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657

668
669
670
671
672
673
674








675
676
677
678
679
680
681








-
-
-
-
-
-
-
-








    destroy .lf
} -result {}

## Test ensemble processing:
#
# (See also: SF#2021443)
#
proc wrong#args {args} {
    return "wrong # args: should be \"$args\""
}
proc wrong#varargs {varpart args} {
    set usage $args
    append usage " ?$varpart ...?"
    return "wrong # args: should be \"$usage\""
}

test ttk-ensemble-0 "style element create: insufficient args" -body {
     ttk::style
} -returnCodes error -result \
    [wrong#varargs arg ttk::style option]

test ttk-ensemble-1 "style element create: insufficient args" -body {




︙


683
684
685
686
687
688
689
690
691
692



693
694
695



707
708
709
710
711
712
713



714
715
716

717

718
719








-
-
-
+
+
+
-

-
+
+

test ttk-16.2 {ttk::style theme styles - theme exists} -body {
    # simply check this produces a list with some style names,
    # without checking exact content (not needed, and may vary
    # depending on platform, versions, improvements...)
    expr {[llength [ttk::style theme styles alt]] > 0}
} -result 1


destroy {*}[winfo children .]

#
# TESTFILE CLEANUP
#
tcltest::cleanupTests

#*EOF*
destroy {*}[winfo children .]
tcltest::cleanupTests






Changes to tests/ttk/validate.test.





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








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

-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+
+
+
+
+
+
+
+
+
+




-
-
-
+
+
+








##
## Entry widget validation tests
## Derived from core test suite entry-19.1 through entry-19.20
##

package require tk
package require tcltest 2.2
#
# Entry widget validation tests
# Derived from core test suite entry-19.1 through entry-19.20
#

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
eval tcltest::configure $argv
namespace import -force tcltest::*
loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import entry

#
# LOCAL TEST CONSTRAINTS
#

testConstraint ttkEntry 1
testConstraint coreEntry [expr {![testConstraint ttkEntry]}]
testConstraint NA 0

#
# COMMON TEST SETUP
#

foreach i {1 2 3 4} {
    set validateCmd$i [list validateCommand$i %W %d %i %P %s %S %v %V]
}

testConstraint ttkEntry 1
testConstraint coreEntry [expr {![testConstraint ttkEntry]}]

#
# TESTS
#

test validate-0.0 "Setup" -constraints ttkEntry -body {
    rename entry {}
    interp alias {} entry {} ttk::entry
    return;
}





︙


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

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









+
+
+
+

+

















+
+
+
+
+

















+
+
+
+
+








    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} focus focusout}

#
# COMMON TEST SETUP
#

.e configure -validate all

test validate-1.10 {entry widget validation - vmode all} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .e
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} all focusin}

test validate-1.11 {entry widget validation} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} all focusout}

#
# COMMON TEST SETUP
#

.e configure -validate focusin

test validate-1.12 {entry widget validation} -body {
    set validationData {}
    set timer [after 300 validationData lappend timeout]
    focus -force .e
    vwait validationData
    after cancel $timer
    set validationData
} -result {.e -1 -1 abcd abcd {} focusin focusin}

test validate-1.13 {entry widget validation} -body {
    set validationData {}
    focus -force .
    update
    set validationData
} -result {}

#
# COMMON TEST SETUP
#

.e configure -validate focuso

test validate-1.14 {entry widget validation} -body {
    set validationData {}
    focus -force .e
    update
    set validationData




︙


193
194
195
196
197
198
199




200
201
202
203
204
205
206

240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257








+
+
+
+








    .e configure -validate none -validatecommand $validateCmd4
    set textVar testdata
    .e configure -validate all
    .e validate
    list [.e get] $textVar $validationData
} -result {dovaldata dovaldata {.e -1 -1 testdata testdata {} all forced}}
# DIFFERENCE: core entry disables validation, ttk entry does not.

#
# COMMON TEST CLEANUP
#

destroy .e
catch {unset textVar}

# See bug #1236979

test validate-2.2 "configure in -validatecommand" -body {




︙


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

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








-

















-
+









    return [list [.e get] [.e state]]
} -result [list 1234XY {}]

test validate-3.4 "revalidate" -body {
    return [list [.e validate] [.e get] [.e state]]
} -result [list 0 1234XY {invalid}]

testConstraint NA 0
# the next two tests (used to) exercise validation lockout protection --
# if the widget is currently invalid, all edits are allowed.
# This behavior is currently disabled.
#
test validate-3.5 "all edits allowed while invalid" -constraints NA -body {
    .e delete 4
    return [list [.e get] [.e state]]
} -result [list 1234Y {invalid}]

test validate-3.6 "...until the value becomes valid" -constraints NA -body {
    .e delete 4
    return [list [.e get] [.e state]]
} -result [list 1234 {}]

test validate-3.last "Cleanup" -body { destroy .e }

#
# CLEANUP
# TESTFILE CLEANUP
#

foreach i {1 2 3 4} {
    unset validateCmd$i
}
unset i
testutils forget entry
tcltest::cleanupTests






Changes to tests/ttk/vsapi.test.









1

2

3
4
5

















6
7









8
9
10




11
12
13
14
15
16
17

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

+
+
+
+
-
+

+
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+



+
+
+
+








#
# Tests exercising Microsoft Visual Styles elements, defined through
# the command "ttk::style element create XXX vsapi"
#
# -*- tcl -*-

#
# TESTFILE INITIALIZATION

package require tk
package require tcltest 2.2
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import -force tcltest::*
loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#

testConstraint xpnative \
    [expr {"xpnative" in [ttk::style theme names]}]

#
# TESTS
#

test vsapi-1.1 "WINDOW WP_SMALLCLOSEBUTTON" -constraints {xpnative} -body {
    ttk::style element create smallclose vsapi \
	WINDOW 19 {disabled 4 pressed 3 active 2 {} 1}
    ttk::style layout CloseButton {CloseButton.smallclose -sticky news}
    ttk::button .b -style CloseButton
    pack .b -expand true -fill both




︙


40
41
42
43
44
45
46
47




48

70
71
72
73
74
75
76
77
78
79
80
81
82









+
+
+
+


    ttk::style layout Explorer.CloseButton {
	Explorer.CloseButton.headerclose -sticky news
    }
    ttk::button .b -style Explorer.CloseButton
    pack .b -expand true -fill both
    list [winfo reqwidth .b] [winfo reqheight .b]
} -cleanup { destroy .b } -result [list 16 16]

#
# TESTFILE CLEANUP
#

tcltest::cleanupTests






Changes to tests/unixButton.test.





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

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



-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+





+
+
+
+








# This file is a Tcl script to test the Unix specific behavior of
# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the
# widgets defined in tkUnixButton.c).  It is organized in the standard
# widgets defined in tkUnixButton.c).
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import -force tcltest::test
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import button image

imageInit

#
# COMMON TEST SETUP
#

# Create entries in the option database to be sure that geometry options
# like border width have predictable values.

option add *Label.borderWidth 2
option add *Label.highlightThickness 0
option add *Label.font {Helvetica -12 bold}




︙


39
40
41
42
43
44
45





46
47
48
49
50
51
52

62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80








+
+
+
+
+








    set bigIndicator 20
    set defaultBorder 10
} else {
    set smallIndicator 27
    set bigIndicator 40
    set defaultBorder 20
}

#
# TESTS
#

test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
    unix testImageType
} -setup {
    deleteWindows
    imageCleanup
} -body {
    image create test image1




︙


254
255
256
257
258
259
260
261

262
263
264
265
266
267
268
269
270
271

282
283
284
285
286
287
288

289
290
291
292
293
294

295
296
297
298








-
+





-





    after 400
    set on
} -cleanup {
    deleteWindows
} -result 1

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
testutils forget button image
cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/unixEmbed.test.





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

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


-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+



+
+
+
+



+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkUnixEmbed.c.  It is organized in the standard fashion for Tcl
# tkUnixEmbed.c.
# tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors child

#
# COMMON TEST SETUP
#

childTkProcess create
childTkProcess eval {wm withdraw .}

#
# TESTS
#

test unixEmbed-1.1 {Tk_UseWindow procedure, bad window identifier} -constraints {
    unix
} -setup {
    deleteWindows
} -body {
    toplevel .t -use xyz




︙


1098
1099
1100
1101
1102
1103
1104




1105
1106
1107
1108
1109
1110
1111

1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142








+
+
+
+








	set x [list [focus]]
	update
	lappend x [focus]
    }] [focus]
} -cleanup {
    deleteWindows
} -result {{{} .} .f1}

#
# COMMON TEST CLEANUP
#
catch {interp delete child}

test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints {
    unix testembed
} -setup {
    deleteWindows
} -body {




︙


1249
1250
1251
1252
1253
1254
1255
1256

1257
1258
1259
1260
1261
1262
1263

1280
1281
1282
1283
1284
1285
1286

1287
1288
1289
1290
1291
1292
1293









-
+






-

    update
    set result
} -cleanup {
    deleteWindows
} -result {.main.b {pushed .main.b} .embed.b {pushed .embed.b}}

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
childTkProcess exit
testutils forget child colors
cleanupTests
return






Changes to tests/unixFont.test.





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

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


-












+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+


+
+
+
+








+








# This file is a Tcl script to test out the procedures in tkUnixFont.c.
# It is organized in the standard fashion for Tcl tests.
#
# Many of these tests are visually oriented and cannot be checked
# programmatically (such as "does an underlined font appear to be
# underlined?"); these tests attempt to exercise the code in question,
# but there are no results that can be checked.  Some tests depend on the
# fonts having or not having certain properties, which may not be valid
# at all sites.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import geometry

#
# LOCAL TEST CONSTRAINTS
#

if {[tk windowingsystem] eq "x11"} {
    if {[testConstraint withXft]} {
	set fontsystemcmd [auto_execok fc-list]
    } else {
	set fontsystemcmd [auto_execok xlsfonts]
    }
}

foreach {constraint font} {
    hasArial      arial
    hasCourierNew "courier new"
    hasTimesNew   "times new roman"
} {
    testConstraint $constraint 0
    if {([tk windowingsystem] eq "x11") && [llength $fontsystemcmd]} {




︙


48
49
50
51
52
53
54




55
56
57
58
59
60
61

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90








+
+
+
+








		# so we can't rely on fallbacks for fonts to need to
		# fall back on anything.
		testConstraint $constraint 0
	    }
	}
    }
}

#
# COMMON TEST SETUP
#

catch {destroy .b}
toplevel .b
wm geom .b +0+0
update idletasks

# Fonts must be fixed width and have chars missing below char 32, so that




︙


70
71
72
73
74
75
76




77
78
79
80
81
82
83

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116








+
+
+
+








pack .b.c
update

set cx [font measure TkFixedFont 0]

set ax [winfo reqwidth .b.l]
set ay [winfo reqheight .b.l]

#
# TESTS
#

test unixfont-1.1 {TkpGetNativeFont procedure: not native} {x11} {
    list [catch {font measure {} xyz} msg] $msg
} {1 {font "" does not exist}}
test unixfont-1.2 {TkpGetNativeFont procedure: native} {x11 haveFixedFamilyFont} {
    font measure fixed 0
} 6




︙


151
152
153
154
155
156
157





158

159
160
161
162
163
164
165

184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204








+
+
+
+
+

+








} {}
test unixfont-5.3 {Tk_MeasureChars procedure: loop over chars} x11 {
    .b.l config -text "0"
    .b.l config -text "\377"
    .b.l config -text "0\3770\377"
    .b.l config -text "000000000000000"
} {}

#
# COMMON TEST SETUP
#

.b.l config -wrap [expr $ax*10]

test unixfont-5.4 {Tk_MeasureChars procedure: reached right edge} x11 {
    .b.l config -text "0000000000000"
    getsize .b.l
} "[expr $ax*10] [expr $ay*2]"
test unixfont-5.5 {Tk_MeasureChars procedure: ran out of chars} x11 {
    .b.l config -text "000000"
    getsize .b.l




︙


325
326
327
328
329
330
331
332

333
334
335
336
337

364
365
366
367
368
369
370

371
372
373
374
375









-
+




-

    lappend x [.b.c index $t @[expr $ax*2],0]
    lappend x [.b.c index $t @[expr $ax*3],0]
    lappend x [.b.c index $t @[expr $ax*4],0]
    lappend x [.b.c index $t @[expr $ax*5],0]
} {0 1 1 1 1 2}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget geometry
cleanupTests
return






Changes to tests/unixMenu.test.





1

2
3
4
5
6
7
8
9


















10

11
12
13
14









15
16
17
18
19
20
21


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

-
+
-







+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test menus in Tk.  It is
# This file is a Tcl script to test menus in Tk. This
# organized in the standard fashion for Tcl tests. This
# file tests the Macintosh-specific features of the menu
# system.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup {
    destroy .m1
} -body {
    list [menu .m1] [destroy .m1]
} -returnCodes ok -result {.m1 {}}
test unixMenu-1.2 {TkpNewMenu - help menu} -constraints unix -setup {




︙


1263
1264
1265
1266
1267
1268
1269
1270
1271
1272




1273
1274
1275

1285
1286
1287
1288
1289
1290
1291



1292
1293
1294
1295
1296
1297









-
-
-
+
+
+
+


-

    .m1 add checkbutton -label one -hidemargin 1
    list [update idletasks] [destroy .m1]
} -result {{} {}}


test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {}



# cleanup
#
# TESTFILE CLEANUP
#

deleteWindows
cleanupTests
return






Changes to tests/unixSelect.test.





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

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



-
-
-
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+














-
+
+
+








# This file contains tests for the tkUnixSelect.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child select

#
# COMMON TEST SETUP
#

# Eliminate any existing selection on the screen.  This is needed in case
# there is a selection in some other application, in order to prevent races
# from causing false errors in the tests below.
selection clear .
after 1500

# set up a very large buffer to test INCR retrievals
set longValue ""
foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} {
    set j $i.1$i.2$i.3$i.4$i.5$i.6$i.7$i.8$i.9$i.10$i.11$i.12$i.13$i.14
    append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j
}

# ----------------------------------------------------------------------
#
# TESTS
#

test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints {
    x11
} -setup {
    destroy .e
    childTkProcess create
} -body {




︙


186
187
188
189
190
191
192

193
194
195
196
197
198
199

208
209
210
211
212
213
214
215
216
217
218
219
220
221
222








+








	.e insert 0 [string repeat x 3999]ü[string repeat x 4000]
	.e selection range 0 end
    }
    selection get
} -cleanup {
    childTkProcess exit
} -result [string repeat x 3999]ü[string repeat x 4000]

# Now some tests to make sure that the right thing is done when
# transferring UTF8 selections, to prevent [Bug 614650] and its ilk
# from rearing its ugly head again.

test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints {
    x11
} -setup {




︙


354
355
356
357
358
359
360
361

362
363
364
365
366

377
378
379
380
381
382
383

384
385
386
387
388









-
+




-

    selection own .l
    selection get -type UTF8_STRING
} -cleanup {
    destroy .l
} -result {This is the selection value}

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget child select
cleanupTests
return






Changes to tests/unixWm.test.





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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+








+
+
+
+









-












+
+
+
+












+
+
+
+





-
-









+
+








# This file is a Tcl script to test out Tk's interactions with
# the window manager, including the "wm" command.  It is organized
# the window manager, including the "wm" command.
# in the standard fashion for Tcl tests.
#
# Copyright © 1992-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

# Procedure to set up a collection of top-level windows

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# makeToplevels --
#
#	Set up a collection of top-level windows
#
proc makeToplevels {} {
    deleteWindows
    foreach i {.raise1 .raise2 .raise3} {
	toplevel $i
	wm geom $i 150x100+0+0
	update
    }
}

#
# COMMON TEST SETUP
#

# On macOS windows are not allowed to overlap the menubar at the top of the
# screen or the dock.  So tests which move a window and then check whether it
# got moved to the requested location should use a y coordinate larger than the
# height of the menubar (normally 23 pixels) and an x coordinate larger than
# the width of the dock, if it happens to be on the left.  Starting with
# macOS 15 (Sequoia) it became impossible for the y coordinate of the top
# of a window to be less than 10 plus the menubar height (as reported by
# [[NSApp mainMenu] menuBarHeight]).

if {[tk windowingsystem] eq "aqua"} {
    set mb [expr [testmenubarheight] + 11]
    set X  100
    set Y0 $mb
    set Y2 [expr $mb + 2]
    set Y5 [expr $mb + 5]
} else {
    set X  20
    set Y0 0
    set Y2 2
    set Y5 5
}

#
# TESTS
#

set i 1
foreach geom "+$X+80 +80+$Y0 +$X+$Y0" {
    destroy .t
    test unixWm-1.$i {initial window position} unix {
	toplevel .t -width 200 -height 150
	wm geom .t $geom
	update
	wm geom .t
    } 200x150$geom
    incr i
}

#
# COMMON TEST SETUP
#

# The tests below are tricky because window managers don't all move
# windows correctly.  Try one motion and compute the window manager's
# error, then factor this error into the actual tests.  In other words,
# this just makes sure that things are consistent between moves.

set i 1
destroy .t
toplevel .t -width 100 -height 150
wm geom .t +200+200
update
wm geom .t +150+150
update
scan [wm geom .t] %dx%d+%d+%d width height x y
set xerr [expr 150-$x]
set yerr [expr 150-$y]

set i 1
foreach geom "+20+80 +80+$Y0 +0+$Y0 -0-0 +0-0 -0+$Y0 -10-5 -10+$Y5 +10-5" {
    test unixWm-2.$i {moving window while mapped} unix {
	wm geom .t $geom
	update
	scan [wm geom .t] %dx%d%1s%d%1s%d width height xsign x ysign y
	format "%s%d%s%d" $xsign [eval expr $x$xsign$xerr] $ysign \
		[eval expr $y$ysign$yerr]




︙


177
178
179
180
181
182
183




184
185
186
187
188
189

190
191
192
193
194
195
196

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








+
+
+
+






+








    toplevel .t -width 200 -height 100
    wm geometry .t +100+100
    update
    wm withdraw .t
    wm iconify .t
    list [winfo ismapped .t] [wm state .t]
} {0 iconic}

#
# COMMON TEST SETUP
#

destroy .t
toplevel .t -width 200 -height 100
wm geom .t +100+$Y0
wm minsize .t 1 1
update

test unixWm-6.1 {size changes} unix {
    .t config -width 180 -height 150
    update
    wm geom .t
} 180x150+100+$Y0
test unixWm-6.2 {size changes} unix {
    wm geom .t 250x60




︙


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

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








+
+
+
+









+



+
+
-
-
+
+
-
+

-
-
-
+
+
+
+
+

-
-
-
+
+
+
+








    wm title .t 2
    wm iconify .t
    update idletasks
    wm withdraw .t
    wm deiconify .t
    list [winfo ismapped .t] [wm state .t]
} {1 normal}

#
# COMMON TEST SETUP
#

destroy .m
toplevel .m
wm overrideredirect .m 1
foreach i {{Test label} Another {Yet another} {Last label}} j {1 2 3} {
    label .m.$j -text $i
}
wm geometry .m +[expr 100 - [winfo vrootx .]]+[expr 200 - [winfo vrooty .]]
update

test unixWm-7.1 {override_redirect and Tk_MoveTopLevelWindow} unix {
    list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
} {1 normal 100 200}

test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} -constraints unix -setup {
wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]]
update
    wm geometry .m +[expr 150 - [winfo vrootx .]]+[expr 210 - [winfo vrooty .]]
    update
test unixWm-7.2 {override_redirect and Tk_MoveTopLevelWindow} unix {
} -body {
    list [winfo ismapped .m] [wm state .m] [winfo x .m] [winfo y .m]
} {1 normal 150 210}
wm withdraw .m
test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} unix {
} -result {1 normal 150 210}

test unixWm-7.3 {override_redirect and Tk_MoveTopLevelWindow} -constraints unix -setup {
    wm withdraw .m
} -body {
    list [winfo ismapped .m]
} 0
destroy .m
destroy .t
} -cleanup {
    destroy .m
    destroy .t
} -result 0

test unixWm-8.1 {icon windows} unix {
    destroy .t
    destroy .icon
    toplevel .t -width 100 -height 30
    wm geometry .t +0+0
    toplevel .icon -width 50 -height 50 -bg red




︙


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

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








-
+










-
-
+
+
+








} {1 {bad window path name ".gorp"}}
test unixWm-8.6 {icon windows} unix {
    destroy .t
    toplevel .t -width 100 -height 30
    frame .t.icon -width 50 -height 50 -bg red
    list [catch {wm iconwindow .t .t.icon} msg] $msg
} {1 {can't use .t.icon as icon window: not at top level}}
test unixWm-8.7 {icon windows} unix {
test unixWm-8.7 {icon windows} -constraints unix -body {
    destroy .t
    destroy .icon
    toplevel .t -width 100 -height 30
    wm geom .t +0+0
    toplevel .icon -width 50 -height 50 -bg red
    toplevel .icon2 -width 50 -height 50 -bg green
    wm iconwindow .t .icon
    set result "[wm iconwindow .t] [wm state .icon] [wm state .icon2]"
    wm iconwindow .t .icon2
    lappend result [wm iconwindow .t] [wm state .icon] [wm state .icon2]
} {.icon icon normal .icon2 withdrawn icon}
destroy .icon2
} -cleanup {
    destroy .icon2
} -result {.icon icon normal .icon2 withdrawn icon}
test unixWm-8.8 {icon windows} unix {
    destroy .t
    destroy .icon
    toplevel .icon -width 50 -height 50 -bg red
    wm geom .icon +0+0
    update
    set result [winfo ismapped .icon]




︙


457
458
459
460
461
462
463




464
465
466
467
468
469
470
471
472
473
474

510
511
512
513
514
515
516
517
518
519
520
521
522
523

524
525
526
527
528
529
530








+
+
+
+



-








    list [catch {wm iconify bogus} msg] $msg
} {1 {bad window path name "bogus"}}
test unixWm-11.4 {Tk_WmCmd procedure, miscellaneous errors} unix {
    destroy .b
    button .b -text hello
    list [catch {wm geometry .b} msg] $msg
} {1 {window ".b" isn't a top-level window}}

#
# COMMON TEST SETUP
#

destroy .t
destroy .icon

toplevel .t -width 100 -height 50
wm geom .t +0+0
update

test unixWm-12.1 {Tk_WmCmd procedure, "aspect" option} unix {
    list [catch {wm aspect .t 12} msg] $msg
} {1 {wrong # args: should be "wm aspect window ?minNumer minDenom maxNumer maxDenom?"}}




︙


579
580
581
582
583
584
585




586
587
588
589
590
591
592

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652








+
+
+
+








    destroy .t2
    toplevel .t2 -width 200 -height 200 -colormap new
    wm geom .t2 +0+0
    set x [wm colormapwindows .t2]
    wm colormapwindows .t2 {}
    list $x [wm colormapwindows .t2]
} {{} {}}

#
# COMMON TEST CLEANUP
#
destroy .t2

test unixWm-15.1 {Tk_WmCmd procedure, "command" option} unix {
    list [catch {wm command .t 12 13} msg] $msg
} {1 {wrong # args: should be "wm command window ?value?"}}
test unixWm-15.2 {Tk_WmCmd procedure, "command" option} unix {
    list [catch {wm command .t 12 13} msg] $msg




︙


739
740
741
742
743
744
745




746
747
748
749
750
751
752

799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816








+
+
+
+








} {1 {widthInc can't be <= 0}}
test unixWm-20.10 {Tk_WmCmd procedure, "grid" option} unix {
    list [catch {wm grid .t 10 11 12 bogus} msg] $msg
} {1 {expected integer but got "bogus"}}
test unixWm-20.11 {Tk_WmCmd procedure, "grid" option} unix {
    list [catch {wm grid .t 10 11 12 -1} msg] $msg
} {1 {heightInc can't be <= 0}}

#
# COMMON TEST SETUP
#

destroy .t
destroy .icon
toplevel .t -width 100 -height 50
wm geom .t +0+0
update





︙


986
987
988
989
990
991
992




993
994
995
996
997
998
999

1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067








+
+
+
+








    set result {}
    lappend result [wm state .icon] [winfo viewable .icon]
    wm iconwindow .t .icon
    lappend result [wm state .icon] [winfo viewable .icon]
    destroy .icon
    set result
} {normal 1 icon 0}

#
# COMMON TEST SETUP
#

destroy .t
destroy .icon
toplevel .t -width 100 -height 50
wm geom .t +0+0
update





︙


1064
1065
1066
1067
1068
1069
1070




1071
1072
1073
1074
1075
1076
1077

1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149








+
+
+
+








    wm geom .t 200x200
    wm resizable .t 0 0
    wm minsize .t 300 300
    update
    set hints [testprop [testwrapper .t] WM_NORMAL_HINTS]
    format {%d %d} [lindex $hints 5] [lindex $hints 6]
} {300 300}

#
# COMMON TEST SETUP
#

destroy .t .icon
toplevel .t -width 100 -height 50
wm geom .t +0+0
update

test unixWm-30.1 {Tk_WmCmd procedure, "overrideredirect" option} unix {




︙


1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222

1223
1224
1225
1226
1227
1228
1229

1280
1281
1282
1283
1284
1285
1286





1287
1288

1289
1290
1291
1292
1293
1294
1295
1296








-
-
-
-
-


-
+








    set bit [format 0x%x [expr 0xa & [lindex [testprop [testwrapper .t] \
	    WM_NORMAL_HINTS] 0]]]
    lappend result [wm sizefrom .t] $bit
} {{} program 0x8 user 0x2}
test unixWm-34.3 {Tk_WmCmd procedure, "sizefrom" option} unix {
    list [catch {wm sizefrom .t none} msg]  $msg
} {1 {bad argument "none": must be program or user}}
if {[tk windowingsystem] eq "aqua"} {
    set result_35_1 {1 {bad argument "1": must be iconic, normal, withdrawn, or zoomed}}
} else {
    set result_35_1 {1 {bad argument "1": must be iconic, normal, or withdrawn}}
}
test unixWm-35.1 {Tk_WmCmd procedure, "state" option} {unix notAqua} {
    list [catch {wm state .t 1} msg]  $msg
} $result_35_1
} {1 {bad argument "1": must be iconic, normal, or withdrawn}}
test unixWm-35.2 {Tk_WmCmd procedure, "state" option} unix {
    list [catch {wm state .t iconic 1} msg]  $msg
} {1 {wrong # args: should be "wm state window ?state?"}}
test unixWm-35.3 {Tk_WmCmd procedure, "state" option} unix {
    set result {}
    destroy .t2
    toplevel .t2 -width 120 -height 300




︙


1332
1333
1334
1335
1336
1337
1338



1339
1340
1341
1342
1343
1344
1345

1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415








+
+
+








    lappend result [wm state .t] [winfo ismapped .t]
} {withdrawn 0 normal 1}

test unixWm-39.1 {Tk_WmCmd procedure, miscellaneous} unix {
    list [catch {wm unknown .t} msg] $msg
} {1 {bad option "unknown": must be aspect, attributes, client, colormapwindows, command, deiconify, focusmodel, forget, frame, geometry, grid, group, iconbadge, iconbitmap, iconify, iconmask, iconname, iconphoto, iconposition, iconwindow, manage, maxsize, minsize, overrideredirect, positionfrom, protocol, resizable, sizefrom, stackorder, state, title, transient, or withdraw}}

#
# COMMON TEST CLEANUP
#
destroy .t .icon

test unixWm-40.1 {Tk_SetGrid procedure, set grid dimensions before turning on grid} {unix nonPortable} {
    destroy .t
    toplevel .t
    wm geometry .t 30x10+0+0
    listbox .t.l -height 20 -width 20 -setgrid 1




︙


1524
1525
1526
1527
1528
1529
1530


1531
1532


1533

1534
1535
1536
1537
1538
1539
1540
1541
1542
1543

















1544

1545
1546
1547
1548
1549
1550
1551
1552
1553




1554

1555
1556
1557
1558
1559
1560
1561
1562



1563
1564
1565
1566
1567
1568
1569

1594
1595
1596
1597
1598
1599
1600
1601
1602


1603
1604

1605
1606
1607
1608
1609
1610
1611
1612



1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629

1630
1631
1632
1633
1634
1635
1636



1637
1638
1639
1640

1641
1642
1643
1644
1645
1646
1647


1648
1649
1650
1651
1652
1653
1654
1655
1656
1657








+
+
-
-
+
+
-
+







-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+






-
-
-
+
+
+
+
-
+






-
-
+
+
+








    wm geometry .t +30+40
    wm overrideredirect .t 1
    tkwait visibility .t
    wm geometry .t 5x8
    update
    list [winfo width .t] [winfo height .t]
} {1 72}

test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} -constraints unix -setup {
destroy .t
toplevel .t -width 80 -height 60
    destroy .t
    toplevel .t -width 80 -height 60
test unixWm-44.6 {UpdateGeometryInfo procedure, negative height} unix {
} -body {
    wm grid .t 18 7 10 12
    wm geometry .t +30+40
    wm overrideredirect .t 1
    tkwait visibility .t
    wm geometry .t 20x1
    update
    list [winfo width .t] [winfo height .t]
} {100 1}
destroy .t
toplevel .t -width 80 -height 60
} -result {100 1}

#
# COMMON TEST SETUP
#
if {! [testConstraint unix]} {
    # Although the tests in this test file are constrained by "unix", the test
    # commands themselves are being evaluated regardless any test constraint.
    # Therefore, the expected results defined for tests 44.7 and 44.8 are also
    # evaluated regardless any test constraint. This means that a dummy window
    # .t must be defined, otherwise a testfile error occurs.
    frame .t
}

test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} -constraints unix -setup {
    destroy .t
    toplevel .t -width 80 -height 60
test unixWm-44.7 {UpdateGeometryInfo procedure, computing position} {unix} {
} -body {
    wm overrideredirect .t 1
    tkwait visibility .t
    update
    wm geometry .t +5-10
    update
    list [winfo x .t] [winfo y .t]
} [list 5 [expr [winfo screenheight .t] - 70]]
destroy .t
toplevel .t -width 80 -height 60
} -result [list 5 [expr [winfo screenheight .t] - 70]]
test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} -constraints unix -setup {
    destroy .t
    toplevel .t -width 80 -height 60
test unixWm-44.8 {UpdateGeometryInfo procedure, computing position} {unix} {
} -body {
    wm overrideredirect .t 1
    tkwait visibility .t
    update
    wm geometry .t -30+$Y2
    update
    list [winfo x .t] [winfo y .t]
} [list [expr [winfo screenwidth .t] - 110] $Y2]
destroy .t
} -cleanup {
    destroy .t
} -result [list [expr [winfo screenwidth .t] - 110] $Y2]

test unixWm-44.9 {UpdateGeometryInfo procedure, updating fixed dimensions} {unix testwrapper} {
    destroy .t
    toplevel .t -width 80 -height 60
    wm resizable .t 0 0
    wm geometry .t +0+0
    tkwait visibility .t




︙


1681
1682
1683
1684
1685
1686
1687




1688
1689
1690
1691
1692
1693
1694

1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786








+
+
+
+








    wm iconify .t
    lappend result done
    update
    set result
} {iconify {unmap on .t} done {configure on .t.f} {button 3 on .t} {map on .t}}

# I don't know how to test WaitTimeoutProc, WaitForMapNotify, or UpdateHints.

#
# COMMON TEST SETUP
#

destroy .t
toplevel .t -width 300 -height 200
wm geometry .t +0+0
tkwait visibility .t

test unixWm-48.1 {ParseGeometry procedure} unix {




︙


1769
1770
1771
1772
1773
1774
1775




1776
1777
1778
1779
1780

1781
1782
1783
1784
1785
1786
1787

1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884








+
+
+
+





+








    frame .t.f -width 20 -height 30 -bd 2 -relief raised
    place .t.f -x 10 -y 30
    testmenubar window .t .t.m
    update
    list [expr [winfo rootx .t.m.f] - $x] [expr [winfo rooty .t.m.f] - $y] \
	    [expr [winfo rootx .t.f] - $x] [expr [winfo rooty .t.f] - $y]
} {52 7 12 62}

#
# COMMON TEST SETUP
#

deleteWindows
# Make sure that the root window is out of the way!
wm geom . +700+700
wm withdraw .

if {[tk windowingsystem] eq "aqua"} {
    # Modern mac windows have no border.
    set result_50_1 {{} {} .t .t .t2 {} .t2 .t .t}
} else {
    # Windows are assumed to have a border (invisible in Gnome 3).
    set result_50_1 {{} {} .t {} .t2 {} .t2 {} .t}
}




︙


1979
1980
1981
1982
1983
1984
1985




1986
1987
1988
1989
1990
1991
1992

2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093








+
+
+
+








    tkwait visibility .t.f
    update idletasks
    set result [list [winfo containing 100 100]]
    place forget .t.f
    update idletasks
    lappend result [winfo containing 100 100]
} {.t.f .t}

#
# COMMON TEST CLEANUP
#
deleteWindows
wm deiconify .

# No tests for UpdateVRootGeometry, Tk_GetVRootGeometry,
# Tk_MoveToplevelWindow, UpdateWmProtocols, or TkWmProtocolEventProc.

test unixWm-51.1 {TkWmRestackToplevel procedure, basic tests} {unix nonPortable} {




︙


2033
2034
2035
2036
2037
2038
2039




2040

2041
2042
2043
2044
2045
2046
2047

2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153








+
+
+
+

+








    lower .raise3 .raise1.f1.f2
    set result [winfo containing [winfo rootx .raise1] \
	    [winfo rooty .raise1]]
    destroy .raise1
    list $result [winfo containing [winfo rootx .raise2] \
	    [winfo rooty .raise2]]
} {.raise1 .raise3}

#
# COMMON TEST CLEANUP
#
deleteWindows

test unixWm-51.6 {TkWmRestackToplevel procedure, window to be stacked isn't mapped} unix {
    wm geometry . +300+300
    destroy .t
    update idletasks
    toplevel .t -width 200 -height 200 -bg green
    tkwait visibility .t
    wm geometry .t +0+0




︙


2089
2090
2091
2092
2093
2094
2095


2096
2097
2098
2099
2100





2101

2102
2103
2104
2105
2106
2107
2108

2195
2196
2197
2198
2199
2200
2201
2202
2203





2204
2205
2206
2207
2208

2209
2210
2211
2212
2213
2214
2215
2216








+
+
-
-
-
-
-
+
+
+
+
+
-
+








    set y [expr 100-[winfo vrooty .]]
    set result [list [winfo containing $x $y]]
    raise .t
    lappend result [winfo containing $x $y]
    raise .t2
    lappend result [winfo containing $x $y]
} {.t2 .t .t2}

test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} -constraints unix -setup {
# The mac won't put an overrideredirect window above the root,
if {[tk windowingsystem] eq "aqua"} {
    wm withdraw .
    update
}
    # The mac won't put an overrideredirect window above the root,
    if {[tk windowingsystem] eq "aqua"} {
	wm withdraw .
	update
    }
test unixWm-51.9 {TkWmRestackToplevel procedure, other window overrideredirect} unix {
} -body {
    foreach w {.t .t2 .t3} {
	destroy $w
	update
	toplevel $w -width 200 -height 200 -bg green
	wm overrideredirect $w 1
	tkwait visibility $w
	wm geometry $w +0+0




︙


2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129






2130
2131
2132
2133
2134
2135
2136

2226
2227
2228
2229
2230
2231
2232





2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245








-
-
-
-
-
+
+
+
+
+
+









    set x [expr 100-[winfo vrootx .]]
    set y [expr 100-[winfo vrooty .]]
    set result [list [winfo containing $x $y]]
    lower .t2
    update
    lappend result [winfo containing $x $y]
} {.t2 .t3}
if {[tk windowingsystem] eq "aqua"} {
    wm deiconify .
    update
}
} -cleanup {
    if {[tk windowingsystem] eq "aqua"} {
	wm deiconify .
	update
    }
} -result {.t2 .t3}
test unixWm-51.10 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {
    makeToplevels
    raise .raise1
    set time [lindex [time {raise .raise1}] 0]
    expr {$time < 2000000}
} 1
test unixWm-51.11 {TkWmRestackToplevel procedure, don't move window that's already in the right place} unix {




︙


2498
2499
2500
2501
2502
2503
2504
2505
2506


2507
2508
2509
2510
2511
2512





2513
2514
2515
2516

2517
2518
2519
2520
2521
2522
2523

2607
2608
2609
2610
2611
2612
2613


2614
2615






2616
2617
2618
2619
2620
2621
2622
2623

2624
2625
2626
2627
2628
2629
2630
2631








-
-
+
+
-
-
-
-
-
-
+
+
+
+
+



-
+









#
# wm attributes tests:
#
# NOTE: since [wm attributes] is not guaranteed to have any effect,
# the only thing we can really test here is the syntax.
#
if {[tk windowingsystem] eq "aqua"} {
    set match_60_1 glob
test unixWm-60.1.1 {wm attributes - test} -constraints {unix notAqua} -body {
    destroy .t
    set result_60_1 {-alpha 1.0 -appearance auto -buttons {close miniaturize zoom} -fullscreen 0 -isdark [01] -modified 0 -notify 0 -titlepath {} -topmost 0 -transparent 0 -stylemask {titled closable miniaturizable resizable} -class nswindow -tabbingid .t -tabbingmode auto -type unsupported}
} else {
    set match_60_1 exact
    set result_60_1 {-alpha 1.0 -fullscreen 0 -topmost 0 -type {} -zoomed 0}
}
test unixWm-60.1 {wm attributes - test} -constraints unix -body {
    toplevel .t
    wm attributes .t
} -match exact -result {-alpha 1.0 -fullscreen 0 -topmost 0 -type {} -zoomed 0}

test unixWm-60.1.2 {wm attributes - test} -constraints {unix aqua} -body {
    destroy .t
    toplevel .t
    wm attributes .t
} -match $match_60_1 -result $result_60_1
} -match glob -result {-alpha 1.0 -appearance auto -buttons {close miniaturize zoom} -fullscreen 0 -isdark [01] -modified 0 -notify 0 -titlepath {} -topmost 0 -transparent 0 -stylemask {titled closable miniaturizable resizable} -class nswindow -tabbingid .t -tabbingmode auto -type unsupported}

test unixWm-60.2 {wm attributes - test} -constraints unix -body {
    destroy .t
    toplevel .t
    wm attributes .t -topmost
} -result 0





︙


2596
2597
2598
2599
2600
2601
2602



2603

2604
2605
2606

2704
2705
2706
2707
2708
2709
2710
2711
2712
2713

2714
2715
2716









+
+
+
-
+


-

} -body {
    tkwait visibility .t
    wm attributes .t -type {xyzzy dialog}
} -cleanup {
    destroy .t
} -result {}

#
# TESTFILE CLEANUP
#
# cleanup

destroy .t
cleanupTests
return






Changes to tests/util.test.





1
2

3
4
5
6
7
8


















9

10
11
12









13
14
15
16
17





18
19
20
21
22
23
24

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


-
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+





+
+
+
+
+








# This file is a Tcl script to test out the procedures in the file
# tkUtil.c.  It is organized in the standard fashion for Tcl tests.
# tkUtil.c.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
namespace import -force tcltest::test
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

listbox .l -width 20 -height 5 -relief sunken -bd 2
pack .l
.l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
update

#
# TESTS
#

test util-1.1 {Tk_GetScrollInfo procedure} -body {
    .l yview moveto a b
} -returnCodes error -result {wrong # args: should be ".l yview moveto fraction"}
test util-1.2 {Tk_GetScrollInfo procedure} -body {
    .l yview moveto xyz
} -returnCodes error -result {expected floating-point number but got "xyz"}
test util-1.3 {Tk_GetScrollInfo procedure} -body {




︙


58
59
60
61
62
63
64



65

66
67
68

87
88
89
90
91
92
93
94
95
96

97
98










+
+
+
-
+

-
-

test util-1.11 {Tk_GetScrollInfo procedure} -body {
    .l yview scroll 3 zips
} -returnCodes error -result {bad argument "zips": must be pages or units}
test util-1.12 {Tk_GetScrollInfo procedure} -body {
    .l yview dropdead 3 times
} -returnCodes error -result {unknown option "dropdead": must be moveto or scroll}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return







Changes to tests/visual.test.





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

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+

















+
+
+
+
+




-
+
+
+








# This file is a Tcl script to test the visual- and colormap-handling
# procedures in the file tkVisual.c.  It is organized in the standard
# procedures in the file tkVisual.c.
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

#
# COMMON TEST SETUP
#

update

# If more than one visual type is available for the screen, pick one
# that is *not* the default.

set default "[winfo visual .] [winfo depth .]"
set avail [winfo visualsavailable .]
set other {}
if {[llength $avail] > 1} {
    foreach visual $avail {
	if {$visual != $default} {
	    set other $visual
	    break
	}
    }
}

#
# LOCAL TEST CONSTRAINTS
#

testConstraint haveOtherVisual [expr {$other ne ""}]
testConstraint havePseudocolorVisual [string match *pseudocolor* $avail]
testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}]

# ----------------------------------------------------------------------
#
# TESTS
#

test visual-1.1 {Tk_GetVisual, copying from other window} -body {
    toplevel .t -visual .foo.bar
} -returnCodes error -result {bad window path name ".foo.bar"}
test visual-1.2 {Tk_GetVisual, copying from other window} -constraints {
    haveOtherVisual nonPortable
} -setup {




︙


516
517
518
519
520
521
522
523

524
525
526
527
528
529
530
531
532
533

546
547
548
549
550
551
552

553
554
555
556
557
558

559
560
561
562








-
+





-





    destroy .t4
    update
} -cleanup {
    deleteWindows
} -result {}

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
testutils forget colors
cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/visual_bb.test.





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



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

-
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+

+
-
+
-



+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+











-
-
+
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+








#!/usr/local/bin/wish -f
#
# This script displays provides visual tests for many of Tk's features.
# Each test displays a window with various information in it, along
# with instructions about how the window should appear.  You can look
# at the window to make sure it appears as expected.  Individual tests
# are kept in separate ".tcl" files in this directory.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
set auto_path ". $auto_path"
resetWindows
wm title . "Visual Tests for Tk"

set testNum 1

#
# LOCAL UTILITY PROCS
#
# Each menu entry invokes a visual test file

proc end {} {
    cleanupTests
    set ::EndOfVisualTests 1
}

# lpr --
#
#	Print the contents of a canvas
#
proc lpr {c args} {
    exec lpr <<[eval [list $c postscript] $args]
}

proc runTest {file} {
    global testNum

    test "2.$testNum" "testing $file" {userInteraction} {
    uplevel #0 [list source [file join [testsDirectory] $file]]
    concat ""
    } {}
    incr testNum
}

# The following procedure is invoked to print the contents of a canvas:

#
proc lpr {c args} {
    exec lpr <<[eval [list $c postscript] $args]
}

proc end {} {
    cleanupTests
# COMMON TEST SETUP
#

set auto_path ". $auto_path"
wm title . "Visual Tests for Tk"
    set ::EndOfVisualTests 1
}

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

#
# TESTS
#

# Each menu entry invokes a visual test file

test 1.1 {running visual tests} -constraints userInteraction -body {
    #-------------------------------------------------------
    # The code below create the main window, consisting of a
    # menu bar and a message explaining the basic operation
    # of the program.
    #-------------------------------------------------------




︙


104
105
106
107
108
109
110




111
112
113
114
115
116

133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149








+
+
+
+







    # Set up a class binding to allow objects to be deleted from a canvas
    # by clicking with mouse button 1:

    bind Canvas <Button-1> {%W delete [%W find closest %x %y]}

    concat ""
} -result {}

#
# TESTFILE CLEANUP
#

if {![testConstraint userInteraction]} {
    cleanupTests
} else {
    vwait EndOfVisualTests
}






Changes to tests/winButton.test.





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

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



-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+








-
+
+
+








# This file is a Tcl script to test the Windows specific behavior of
# labels, buttons, checkbuttons, and radiobuttons in Tk (i.e., all the
# widgets defined in tkWinButton.c).  It is organized in the standard
# widgets defined in tkWinButton.c).
# fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import button image

imageInit

option clear

# ----------------------------------------------------------------------
#
# TESTS
#

test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints {
    testImageType win nonPortable
} -setup {
    # nonPortable because of [3e3e25f483]: on Win7 first started with a high DPI screen
    # the smallest size (i.e. 8) is not available for "MS Sans Serif" font
    deleteWindows




︙


189
190
191
192
193
194
195
196

197
198
199
200
201
202
203
204
205
206
207
208

210
211
212
213
214
215
216

217
218
219
220
221
222
223

224
225
226
227
228








-
+






-






    button .b2 -bitmap question -default normal
    list [winfo reqwidth .b2] [winfo reqheight .b2]
} -cleanup {
    deleteWindows
} -result {23 33}

#
# CLEANUP
# TESTFILE CLEANUP
#

imageFinish
deleteWindows
testutils forget button image
cleanupTests
return

# Local variables:
# mode: tcl
# End:







Changes to tests/winClipboard.test.





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

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


-
+
-

-
-
-
-




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
-
-
-
-
+
+
+
+
+
-
-
+
+
+








# This file is a Tcl script to test out Tk's Windows specific
# clipboard code.  It is organized in the standard fashion for Tcl
# clipboard code.
# tests.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-2000 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Some of these tests may fail if another application is grabbing the clipboard
# (e.g. an X server, or a VNC viewer) #

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
namespace import -force tcltest::test

#################################################################
# Note that some of these tests may fail if another application #
}

# Ensure a pristine initial window state
resetWindows

# is grabbing the clipboard (e.g. an X server, or a VNC viewer) #
#################################################################
#
# TESTS
#

test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup {
    clipboard clear
} -body {
    selection get -selection CLIPBOARD
} -cleanup {
    clipboard clear




︙


110
111
112
113
114
115
116



117

118
119
120
121
122
123

129
130
131
132
133
134
135
136
137
138

139
140

141
142
143
144








+
+
+
-
+

-





    clipboard append "more data in string"
    update
    list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION]
} -cleanup {
    clipboard clear
} -result {{more data in string} {new data}}

#
# TESTFILE CLEANUP
#
# cleanup

cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/winDialog.test.





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


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

-

-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+









+
-
+
-
-
-
-
-
+
-















+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# -*- tcl -*-
# This file is a Tcl script to test the Windows specific behavior of
# the common dialog boxes.  It is organized in the standard
# the common dialog boxes.
# fashion for Tcl tests.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Copyright © 1998-1999 ActiveState Corporation.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import dialog
set applyFontCmd [list set testDialogFont]

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 1}
}

#
# Locale identifier LANG_ENGLISH is 0x09
# LOCAL UTILITY PROCS
testConstraint english [expr {
    [llength [info commands testwinlocale]]
    && (([testwinlocale] & 0xff) == 9)
}]

#
set initialDir [tcltest::temporaryDirectory]

proc GetText {id} {
    variable testDialog
    switch -exact -- $id {
	ok     { set id 1 }
	cancel { set id 2 }
    }
    return [testwinevent $testDialog $id WM_GETTEXT]
}

proc SetText {id text} {
    variable testDialog
    return [testwinevent $testDialog $id WM_SETTEXT $text]
}

#
# LOCAL TEST CONSTRAINTS
#
# ----------------------------------------------------------------------

# Locale identifier LANG_ENGLISH is 0x09
testConstraint english [expr {
    [llength [info commands testwinlocale]]
    && (([testwinlocale] & 0xff) == 9)
}]

#
# COMMON TEST SETUP
#

set initialDir [tcltest::temporaryDirectory]

#
# TESTS
#

test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints {
    testwinevent
} -body {
    testDialog launch {tk_chooseColor}
    testDialog onDisplay {
	Click cancel




︙


847
848
849
850
851
852
853




854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871

879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894




895
896
897

898
899
900
901
902








+
+
+
+





-
-
-
-



-






    }
    testDialog onDisplay {
	array set a [testgetwindowinfo $testDialog]
	Click cancel
    }
    set a(text)
} -result "Привет"

#
# TESTFILE CLEANUP
#

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 0}
}

#
# CLEANUP
#

unset applyFontCmd initialDir
testutils forget dialog
cleanupTests
return

# Local variables:
# mode: tcl
# End:







Changes to tests/winFont.test.





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

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




+
+
+
+
+
+




-
-
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+


+
+
+
+








# This file is a Tcl script to test out the procedures in tkWinFont.c.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# Many of these tests are visually oriented and cannot be checked
# programmatically (such as "does an underlined font appear to be
# underlined?"); these tests attempt to exercise the code in question,
# but there are no results that can be checked.
#
# Copyright © 1996-1997 Sun Microsystems, Inc.

#
# TESTFILE INITIALIZATION
#

# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

package require tcltest 2.2
if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import geometry

#
# TESTS
#

test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints {
    win
} -body {
    catch {font delete xyz}
    font measure {} xyz
} -returnCodes error -result {font "" does not exist}




︙


106
107
108
109
110
111
112




113
114
115
116
117
118
119

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149








+
+
+
+








} -result {}


test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body {
    font families
    set x {}
} -result {}

#
# COMMON TEST SETUP
#

destroy .t
toplevel .t
wm geometry .t +0+0
update idletasks
label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed
pack .t.l




︙


377
378
379
380
381
382
383
384

385
386
387
388
389
390
391
392
393

407
408
409
410
411
412
413

414
415
416
417
418

419
420
421
422








-
+




-





test winfont-7.4 {InitFont procedure: extract info from textmetric} -constraints {
    win
} -body {
    font metric systemfixed -fixed
} -result 1

#
# CLEANUP
# TESTFILE CLEANUP
#

testutils forget geometry
cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/winMenu.test.





1

2
3

4
5
6
7
8
9


















10

11
12
13









14
15
16
17
18
19
20


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

-
+
-
-
+
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test menus in Tk.  It is
# This file is a Tcl script to test menus in Tk. This # file tests the
# organized in the standard fashion for Tcl tests. This
# file tests the Macintosh-specific features of the menu
# features of the menu system that are specific for MS Windows.
# system.
#
# Copyright © 1995-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test winMenu-1.1 {GetNewID} -constraints win -setup {
    destroy .m1
} -body {
    menu .m1
} -cleanup {
    destroy .m1




︙


1370
1371
1372
1373
1374
1375
1376



1377

1378
1379
1380
1381
1382
1383
1384
1385

1392
1393
1394
1395
1396
1397
1398
1399
1400
1401

1402
1403
1404

1405
1406
1407
1408









+
+
+
-
+


-




-

} -result {{} {} {}}


test winMenu-34.1 {TkpMenuInit called at boot time} -constraints {
    emptyTest win
} -body {}

#
# TESTFILE CLEANUP
#
# cleanup

deleteWindows
cleanupTests
return

# Local variables:
# mode: tcl
# End:







Changes to tests/winMsgbox.test.





1
2
3
4


















5

6
7
8
9










10




11
12
13
14
15
16
17

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





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+

+
+
+
+








# This file is a Tcl script to test the Windows specific message box
#
# Copyright © 2007 Pat Thoyts <[email protected]>

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL TEST CONSTRAINTS
#

testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}]

#
# COMMON TEST SETUP
#

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 1}
}

proc GetWindowInfo {title button} {
    global windowInfo




︙


29
30
31
32
33
34
35
36



37
38
39
40
41
42
43

57
58
59
60
61
62
63

64
65
66
67
68
69
70
71
72
73








-
+
+
+








    }
    set a(children) $childinfo
    set a(childtext) $childtext
    set windowInfo [array get a]
    testwinevent $hwnd $button WM_COMMAND
}

# -------------------------------------------------------------------------
#
# TESTS
#

test winMsgbox-1.1 {tk_messageBox ok} -constraints {win getwindowinfo} -setup {
    wm iconify .
} -body {
    global windowInfo
    set title "winMsgbox-1.0 [pid]"
    after 100 [list GetWindowInfo $title 2]




︙


174
175
176
177
178
179
180
181
182
183
184
185
186
187
188

204
205
206
207
208
209
210

211
212
213
214
215
216
217








-








    set title "winMsgbox-1.12 [pid]"
    after 100 [list GetWindowInfo $title 2]
    tk_messageBox -icon info -type yesnocancel -title $title -message Message
} -cleanup {
    wm deiconify .
} -result {cancel}

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

test winMsgbox-2.1 {tk_messageBox message} -constraints {win getwindowinfo} -setup {
    wm iconify .
    unset -nocomplain info
} -body {
    global windowInfo
    set title "winMsgbox-2.0 [pid]"




︙


241
242
243
244
245
246
247
248
249
250
251
252
253
254
255

270
271
272
273
274
275
276

277
278
279
280
281
282
283








-








    set r [tk_messageBox -type ok -title $title]
    array set info $windowInfo
    lappend r $info(childtext)
} -cleanup {
    wm deiconify .
} -result [list ok ""]

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

test winMsgbox-3.1 {tk_messageBox detail (sourceforge bug #1692927)} -constraints {
    win getwindowinfo
} -setup {
    wm iconify .
    unset -nocomplain info
} -body {




︙


278
279
280
281
282
283
284
285



286
287
288
289
290
291
292
293
294
295
296

306
307
308
309
310
311
312

313
314
315
316
317
318
319
320

321
322
323
324
325








-
+
+
+





-






    set r [tk_messageBox -type ok -title $title -message $message -detail $detail]
    array set info $windowInfo
    lappend r $info(childtext)
} -cleanup {
    wm deiconify .
} -result [list ok "Поиск\n\nстраниц"]

# -------------------------------------------------------------------------
#
# TESTFILE CLEANUP
#

if {[testConstraint testwinevent]} {
    catch {testwinevent debug 0}
}
cleanupTests
return

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:






Changes to tests/winSend.test.





1
2

3
4
5
6
7
8
9


















10

11
12
13






14
15
16




17





18
19
20
21
22
23
24

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


-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+



+
+
+
+

+
+
+
+
+








# This file is a Tcl script to test out the "send" command and the
# other procedures in the file tkSend.c.  It is organized in the
# other procedures in the file tkSend.c.
# standard fashion for Tcl tests.
#
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1994-1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import child

#
# COMMON TEST SETUP
#

set currentInterps [winfo interps]

#
# LOCAL TEST CONSTRAINTS
#

if {
    [testConstraint win] &&
    [llength [info commands send]] &&
    [catch {exec [interpreter] &}] == 0
} then {
    # Wait until the child application has launched.
    while {[llength [winfo interps]] == [llength $currentInterps]} {}




︙


38
39
40
41
42
43
44




45
46
47
48
49
50
51

67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84








+
+
+
+








	    console hide
	    update
	}
    }]}]
} else {
    testConstraint winSend 0
}

#
# TESTS
#

# setting up dde server is done when the first interp is created and
# cannot be tested very easily.
test winSend-1.1 {Tk_SetAppName - changing name of interp} winSend {
    childTkInterp testApp
    list [testApp eval tk appname testApp2] [interp delete testApp]
} {testApp2 {}}




︙


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

398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422




423
424









+
+
+
+














-
-
-
-


-

    send $interp {set foo winSend-10.17}
    list [catch {dde request Tk $interp foo} msg] $msg
} {0 winSend-10.17}
test winSend-10.18 {Tk_DDEObjCmd - services} winSend {
    set currentService [list Tk [tk appname]]
    list [catch {dde services Tk {}} msg] [expr {[lsearch $msg $currentService] >= 0}]
} {0 1}

#
# TESTFILE CLEANUP
#

# Get rid of the other app and all of its interps

set newInterps [winfo interps]
while {[llength $newInterps] != [llength $currentInterps]} {
    foreach interp $newInterps {
	if {[lsearch -exact $currentInterps $interp] < 0} {
	    catch {send $interp exit}
	    set newInterps [winfo interps]
	    break
	}
    }
}

#
# CLEANUP
#

testutils forget child
cleanupTests
return






Changes to tests/winWm.test.





1
2

3
4
5
6
7
8
9
10
11


















12

13
14
15









16
17
18
19
20
21
22

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


-
+
-
-
-
-





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
+
+
+
+
+
+
+
+
+








# This file tests  is a Tcl script to test the procedures in the file
# tkWinWm.c.  It is organized in the standard fashion for Tcl tests.
# tkWinWm.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright © 1996 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# TESTS
#

test winWm-1.1 {TkWmMapWindow} -constraints win -setup {
    destroy .t
} -body {
    toplevel .t
    wm override .t 1
    wm geometry .t +0+0




︙


559
560
561
562
563
564
565
566
567
568





569
570
571
572
573
574
575

579
580
581
582
583
584
585



586
587
588
589
590
591

592
593
594
595









-
-
-
+
+
+
+
+

-




-

    }
    set winwm92
} -cleanup {
    destroy .t.f.x .t.f .t
    unset -nocomplain winwm92 aid id
} -result ok

destroy .t

# cleanup
#
# TESTFILE CLEANUP
#

destroy .t
cleanupTests
return

# Local variables:
# mode: tcl
# End:







Changes to tests/window.test.





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

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


-
+





+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+



-
+
-
-
+
-
+
+








# This file is a Tcl script to test the procedures in the file
# tkWindow.c.  It is organized in the standard fashion for Tcl tests.
# tkWindow.c.
#
# Copyright © 1995 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# This file is woefully incomplete.  Right now it only tests
# a few parts of a few procedures in tkWindow.c

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# COMMON TEST SETUP
#

update
# Move the mouse out of the way for window-2.1
event generate {} <Motion> -warp 1 -x 640 -y 10
# XXX This file is woefully incomplete.  Right now it only tests

# a few parts of a few procedures in tkWindow.c

#
# ----------------------------------------------------------------------
# TESTS
#

test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup {
    destroy .t
} -body {
    proc bgerror msg {
	global x errorInfo
	set x [list $msg $errorInfo]




︙


370
371
372
373
374
375
376
377
378
379




380
381
382
383
384
385

399
400
401
402
403
404
405



406
407
408
409
410

411
412
413
414








-
-
-
+
+
+
+

-





    lower .t.e2 .t.f
    update
    # If stacking order isn't handled properly, generates an X error.
} -cleanup {
    destroy .t
} -result {}



# cleanup
#
# TESTFILE CLEANUP
#

cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/winfo.test.





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


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

-
+
-






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
+
+
+
+
+
+



-
-
-
+
-
+
+








# This file is a Tcl script to test out the "winfo" command.  It is
# This file is a Tcl script to test out the "winfo" command.
# organized in the standard fashion for Tcl tests.
#
# Copyright © 1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

# NOTE
#
# This test file is woefully incomplete.  At present, only a
# few of the winfo options are tested.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

# Import utility procs for specific functional areas
testutils import colors

# XXX - This test file is woefully incomplete.  At present, only a
# few of the winfo options are tested.

#
# ----------------------------------------------------------------------
# TESTS
#

test winfo-1.1 {"winfo atom" command} -body {
    winfo atom
} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}
test winfo-1.2 {"winfo atom" command} -body {
    winfo atom a b
} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"}




︙


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

393
394
395
396
397
398
399






400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422
423








-
-
-
-
-
-
+
+














-
+








	rooty [expr {[winfo rooty .emb] == [winfo rooty .con]}]
} -cleanup {
    deleteWindows
} -result {rootx 1 rooty 1}

# Windows does not destroy the container when an embedded window is
# destroyed.  Unix and macOS do destroy it.  See ticket [67384bce7d].
if {[tk windowingsystem] eq "win32"} {
   set result_13_2 {embedded 0 container 1}
} else {
   set result_13_2 {embedded 0 container 0}
}
test winfo-13.2 {destroying embedded toplevel} -setup {
test winfo-13.2 {destroying embedded toplevel
} -setup {
    deleteWindows
} -body {
    frame .con -container 1
    pack .con -expand yes -fill both
    toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0
    button .emb.b
    pack .emb.b -expand yes -fill both
    update

    destroy .emb
    update
    list embedded [winfo exists .emb.b] container [winfo exists .con]
} -cleanup {
    deleteWindows
} -result $result_13_2
} -result [expr {[tk windowingsystem] eq "win32"?{embedded 0 container 1}:{embedded 0 container 0}}]

test winfo-13.3 {destroying container window} -setup {
    deleteWindows
} -body {
    frame .con -container 1
    pack .con -expand yes -fill both
    toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0




︙


459
460
461
462
463
464
465
466

467
468
469
470
471
472
473
474
475
476

478
479
480
481
482
483
484

485
486
487
488
489
490

491
492
493
494








-
+





-





    update idletasks
    winfo ismapped .t
} -cleanup {
    destroy .t
} -result 1

#
# CLEANUP
# TESTFILE CLEANUP
#

deleteWindows
testutils forget colors
cleanupTests
return

# Local variables:
# mode: tcl
# End:






Changes to tests/wm.test.





1
2
3



4
5
6
7
8
9



10

11
12
13
14















15
16






























17
18
19
20
21
22
23

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


-
-
+
+
+






+
+
+
-
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








# This file is a Tcl script to test out Tk's interactions with the window
# manager, including the "wm" command. It is organized in the standard fashion
# for Tcl tests.
# manager, including the "wm" command. It tests window manager interactions
# that work across platforms. Window manager tests that only work on a specific
# platform should be placed in unixWm.test or winWm.test.
#
# Copyright © 1992-1994 The Regents of the University of California.
# Copyright © 1994-1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.

#
# TESTFILE INITIALIZATION
#
# This file tests window manager interactions that work across platforms.

# Window manager tests that only work on a specific platform should be placed
# in unixWm.test or winWm.test.

package require tcltest 2.2
if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
    package require tcltest 2.2
eval tcltest::configure $argv
tcltest::loadTestedCommands
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

# [raise] and [lower] may return before the window manager has completed the
# operation. The raiseDelay procedure idles for a while to give the operation
# a chance to complete.
#
proc raiseDelay {} {
    after 250;
    update idletasks
    update
}

proc stdWindow {} {
    destroy .t
    toplevel .t -width 100 -height 50
    wm geom .t +0+0
    update
}

#
# COMMON TEST SETUP
#

image create photo icon -data {
    iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAALGPC/xhBQAAA
    CBjSFJNAAB6JgAAgIQAAPoAAACA6AAAdTAAAOpgAAA6mAAAF3CculE8AAAABmJLR0QA/w
    D/AP+gvaeTAAAACXBIWXMAArQNAAK0DQEdFIm+AAAJQElEQVRYw+WXW2xdV5nHf/ty7lc
    f2/FxYsdOnMSNC0HTpDiRKJWAQjWCEQNUSEAFfUOiQqrEC2+IxwpemDLSzNBBCCQeQEKq
    RJgBSikiuGlN22TqhsR27OPL8eWc43Pdt7X22osHHydOm4FBPM6Slr69paX9/32Xtb614




︙


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

124
125
126
127
128
129
130

131






132





133
134






135


136



137
138
139
140
141
142
143








-
+
-
-
-
-
-
-
+
-
-
-
-
-
+
+
-
-
-
-
-
-
+
-
-
+
-
-
-








}

wm deiconify .
if {![winfo ismapped .]} {
    tkwait visibility .
}

proc stdWindow {} {
deleteWindows
    destroy .t
    toplevel .t -width 100 -height 50
    wm geom .t +0+0
    update
}

stdWindow
# [raise] and [lower] may return before the window manager has completed the
# operation. The raiseDelay procedure idles for a while to give the operation
# a chance to complete.
#


#
proc raiseDelay {} {
    after 250;
    update idletasks
    update
}

# TESTS
deleteWindows

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

stdWindow

test wm-1.1 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
    wm
} -result {wrong # args: should be "wm option window ?arg ...?"}
# Next test will fail every time set of subcommands is changed
test wm-1.2 {Tk_WmObjCmd procedure, miscellaneous errors} -returnCodes error -body {
    wm foo




︙


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

217
218
219
220
221
222
223



224
225

226
227








228










229
230
231
232
233
234
235
236
237








-
-
-


-
+

-
-
-
-
-
-
-
-
+
-
-
-
-
-
-
-
-
-
-
+
+








} -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}
test wm-attributes-1.2.3 {usage} -constraints win -returnCodes error -body {
    wm attributes . -to
} -result {bad attribute "-to": must be -alpha, -disabled, -fullscreen, -toolwindow, -topmost, or -transparentcolor}
test wm-attributes-1.2.4 {usage} -constraints {unix notAqua} -returnCodes error -body {
    wm attributes . _
} -result {bad attribute "_": must be -alpha, -fullscreen, -topmost, -type, or -zoomed}
if {[tk windowingsystem] eq "aqua"} {
    set result_1_2_5 {bad attribute "_": must be -alpha, -appearance, -buttons, -fullscreen, -isdark, -modified, -notify, -titlepath, -topmost, -transparent, -stylemask, -class, -tabbingid, -tabbingmode, or -type}
} else {set result_1_2_5 {bad attribute "_": must be -alpha, -fullscreen, -modified, -notify, -titlepath, -topmost, -transparent, or -type}}
test wm-attributes-1.2.5 {usage} -constraints aqua -returnCodes error -body {
    wm attributes . _
} -result $result_1_2_5
} -result {bad attribute "_": must be -alpha, -appearance, -buttons, -fullscreen, -isdark, -modified, -notify, -titlepath, -topmost, -transparent, -stylemask, -class, -tabbingid, -tabbingmode, or -type}

### wm client ###
test wm-client-1.1 {usage} -returnCodes error -body {
    wm client
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-client-1.2 {usage} -returnCodes error -body {
    wm client . _ _
} -result {wrong # args: should be "wm client window ?name?"}

#
test wm-client-2.1 {setting and reading values} -setup {
    set result {}
} -body {
    lappend result [wm client .t]
    wm client .t Miffo
    lappend result [wm client .t]
    wm client .t {}
    lappend result [wm client .t]
} -result [list {} Miffo {}]

# COMMON TEST CLEANUP
#
deleteWindows

test wm-attributes-1.3.0 {default -fullscreen value} -constraints win -body {
    toplevel .t
    wm attributes .t -fullscreen
} -cleanup {
    deleteWindows




︙


496
497
498
499
500
501
502







503












504
505





506
507
508
509
510
511
512

504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530


531
532
533
534
535
536
537
538
539
540
541
542








+
+
+
+
+
+
+

+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+








    wm attributes .b -fullscreen 0
    pause 200
    lappend results [wm stackorder .]
} -cleanup {
    deleteWindows
} -result {{. .a .b .c} {. .a .b .c} {. .a .b .c}}

### wm client ###
test wm-client-1.1 {usage} -returnCodes error -body {
    wm client
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-client-1.2 {usage} -returnCodes error -body {
    wm client . _ _
} -result {wrong # args: should be "wm client window ?name?"}

test wm-client-2.1 {setting and reading values} -setup {
    toplevel .t
    set result {}
} -body {
    lappend result [wm client .t]
    wm client .t Miffo
    lappend result [wm client .t]
    wm client .t {}
    lappend result [wm client .t]
} -cleanup {
    destroy .t
} -result [list {} Miffo {}]
stdWindow


#
# COMMON TEST SETUP
#
stdWindow

### wm colormapwindows ###
test wm-colormapwindows-1.1 {usage} -returnCodes error -body {
    wm colormapwindows
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-colormapwindows-1.2 {usage} -returnCodes error -body {
    wm colormapwindows . _ _




︙


605
606
607
608
609
610
611



612

613
614
615
616
617
618
619

635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653








+
+
+

+








    frame .t.f -container 1
    toplevel .embed -use [winfo id .t.f]
    wm deiconify .embed
} -returnCodes error -cleanup {
    destroy .t.f .embed
} -result {can't deiconify .embed: it is an embedded window}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-deiconify-2.1 {a window that has never been mapped\
	should not be mapped by a call to deiconify} -body {
    toplevel .t
    wm deiconify .t
    winfo ismapped .t
} -cleanup {
    deleteWindows




︙


663
664
665
666
667
668
669



670
671
672
673
674
675
676

697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713








+
+
+








test wm-focusmodel-1.2 {usage} -returnCodes error -body {
    wm focusmodel . _ _
} -result {wrong # args: should be "wm focusmodel window ?active|passive?"}
test wm-focusmodel-1.3 {usage} -returnCodes error -body {
    wm focusmodel . bogus
} -result {bad argument "bogus": must be active or passive}

#
# COMMON TEST SETUP
#
stdWindow

test wm-focusmodel-2.1 {setting and reading values} -setup {
    set result {}
} -body {
    lappend result [wm focusmodel .t]
    wm focusmodel .t active




︙


888
889
890
891
892
893
894



895

896
897
898
899
900
901
902

925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943








+
+
+

+








test wm-iconify-1.1 {usage} -returnCodes error -body {
    wm iconify
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-iconify-1.2 {usage} -returnCodes error -body {
    wm iconify .t _
} -result {wrong # args: should be "wm iconify window"}

#
# COMMON TEST SETUP
#
destroy .t2

test wm-iconify-2.1 {Misc errors} -body {
    toplevel .t2
    wm overrideredirect .t2 1
    wm iconify .t2
} -returnCodes error -cleanup {
    destroy .t2
} -result {can't iconify ".t2": override-redirect flag is set}




︙


1123
1124
1125
1126
1127
1128
1129



1130

1131
1132
1133
1134
1135
1136
1137

1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182








+
+
+

+








    set s_width [winfo screenwidth .t]
    set s_height [winfo screenheight .t]
    expr {($t_width <= $s_width) && ($t_height <= $s_height)}
} -cleanup {
    destroy .t
} -result 1

#
# COMMON TEST CLEANUP
#
destroy .t

test wm-maxsize-2.1 {setting the maxsize to a value smaller\
	than the current size will resize a toplevel} -body {
    toplevel .t -width 300 -height 300
    update
    wm maxsize .t 200 150
    # UpdateGeometryInfo invoked at idle
    update




︙


1275
1276
1277
1278
1279
1280
1281



1282
1283
1284
1285
1286
1287
1288

1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336








+
+
+








    wm minsize .t 300 300
    update
    lappend result [lrange [split [wm geom .t] x+] 0 1]
} -cleanup {
    destroy .t
} -result {{250 250} {300 300}}

#
# COMMON TEST SETUP
#
stdWindow

### wm overrideredirect ###
test wm-overrideredirect-1.1 {usage} -returnCodes error -body {
    wm overrideredirect
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-overrideredirect-1.2 {usage} -returnCodes error -body {




︙


1411
1412
1413
1414
1415
1416
1417



1418
1419
1420
1421
1422
1423
1424

1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475








+
+
+








    lappend result [wm sizefrom .t]
    wm sizefrom .t program
    lappend result [wm sizefrom .t]
    wm sizefrom .t {}
    lappend result [wm sizefrom .t]
} {{} user program {}}

#
# COMMON TEST CLEANUP
#
destroy .t

### wm stackorder ###
test wm-stackorder-1.1 {usage} -returnCodes error -body {
    wm stackorder
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-stackorder-1.2 {usage} -returnCodes error -body {




︙


1473
1474
1475
1476
1477
1478
1479




1480
1481
1482
1483
1484
1485
1486

1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541








+
+
+
+








    toplevel .t
    update
    wm withdraw .t
    wm stackorder . isbelow .t
} -cleanup {
    destroy .t
} -returnCodes error -result {window ".t" isn't mapped}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-stackorder-2.1 {stacking order} -body {
    toplevel .t ; update
    raiseDelay
    wm stackorder .
} -cleanup {




︙


1552
1553
1554
1555
1556
1557
1558



1559
1560
1561
1562
1563
1564
1565

1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623








+
+
+








} -result {. .t1}
test wm-stackorder-2.7 {stacking order: no children returns self} -setup {
    deleteWindows
} -body {
    wm stackorder .
} -result {.}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-stackorder-3.1 {unmapped toplevel} -constraints {failsOnUbuntu failsOnXQuartz} -body {
    toplevel .t1 ; update
    raiseDelay
    toplevel .t2 ; update
    raiseDelay




︙


1625
1626
1627
1628
1629
1630
1631




1632
1633
1634
1635
1636
1637
1638

1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700








+
+
+
+








} -result {.t1.t2}
test wm-stackorder-3.8 {toplevel mapped in idle callback} -body {
    toplevel .t1
    wm stackorder .
} -cleanup {
    destroy .t1
} -result {.}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-stackorder-4.1 {wm stackorder isabove|isbelow} -body {
    toplevel .t ; update
    raise .t
    wm stackorder . isabove .t
} -cleanup {




︙


1658
1659
1660
1661
1662
1663
1664




1665
1666
1667
1668
1669
1670
1671

1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737








+
+
+
+








    toplevel .t ; update
    raise .
    raiseDelay
    wm stackorder .t isb .
} -cleanup {
    destroy .t
} -result 1

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-stackorder-5.1 {a menu is not a toplevel} -body {
    toplevel .t
    menu .t.m -type menubar
    .t.m add cascade -label "File"
    .t configure -menu .t.m




︙


1720
1721
1722
1723
1724
1725
1726



1727
1728
1729
1730
1731
1732
1733

1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802








+
+
+








    toplevel .embd -bg blue -use [winfo id .real]
    raiseDelay
    wm stackorder .
} -cleanup {
    deleteWindows
} -result {. .real}

#
# COMMON TEST SETUP
#
stdWindow

### wm title ###
test wm-title-1.1 {usage} -returnCodes error -body {
    wm title
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-title-1.2 {usage} -returnCodes error -body {




︙


1755
1756
1757
1758
1759
1760
1761




1762

1763
1764
1765
1766
1767
1768
1769

1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843








+
+
+
+

+








    catch {destroy .t} ; toplevel .t
    wm transient .t foo
} -result {bad window path name "foo"}
test wm-transient-1.3 {usage} -returnCodes error -body {
    catch {destroy .t} ; toplevel .t
    wm transient foo .t
} -result {bad window path name "foo"}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-transient-1.4 {usage} -returnCodes error -body {
    toplevel .top
    toplevel .subject
    wm transient .subject .top
    wm iconify .subject
} -cleanup {
    deleteWindows




︙


2101
2102
2103
2104
2105
2106
2107



2108

2109
2110
2111
2112
2113
2114
2115

2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193








+
+
+

+








test wm-state-1.1 {usage} -returnCodes error -body {
    wm state
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-state-1.2 {usage} -returnCodes error -body {
    wm state . _ _
} -result {wrong # args: should be "wm state window ?state?"}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-state-2.1 {initial state} -body {
    toplevel .t
    wm state .t
} -cleanup {
    deleteWindows
} -result {normal}
test wm-state-2.2 {state change before map} -body {




︙


2254
2255
2256
2257
2258
2259
2260



2261

2262
2263
2264
2265
2266
2267
2268

2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350








+
+
+

+








test wm-withdraw-1.1 {usage} -returnCodes error -body {
    wm withdraw
} -result {wrong # args: should be "wm option window ?arg ...?"}
test wm-withdraw-1.2 {usage} -returnCodes error -body {
    wm withdraw . _
} -result {wrong # args: should be "wm withdraw window"}

#
# COMMON TEST CLEANUP
#
deleteWindows

test wm-withdraw-2.1 {Misc errors} -body {
    toplevel .t
    toplevel .t2
    wm iconwindow .t .t2
    wm withdraw .t2
} -returnCodes error -cleanup {
    deleteWindows




︙


2483
2484
2485
2486
2487
2488
2489
2490
2491

2492
2493
2494
2495


2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506

2565
2566
2567
2568
2569
2570
2571


2572




2573
2574

2575
2576
2577
2578
2579

2580
2581
2582
2583








-
-
+
-
-
-
-
+
+
-





-





    update
    lappend res [winfo manager .f]
} -cleanup {
    destroy .l .f.b .f
    unset res
} -result {pack {} wm {}}

# FIXME:

#
# Test delivery of virtual events to the WM. We could check to see if the
# window was raised after a button click for example. This sort of testing may
# not be possible.

# TESTFILE CLEANUP
#
##############################################################################

deleteWindows
cleanupTests
catch {unset results}
catch {unset focusin}
return

# Local variables:
# mode: tcl
# End:






Changes to tests/xmfbox.test.





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







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

-
-
-
-
-
-
+
+
+
+






+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+








# xmfbox.test --
#
#	This file is a Tcl script to test the file dialog that's used
#	when the tk_strictMotif flag is set. Because the file dialog
#	runs in a modal loop, the only way to test it sufficiently is
#	to call the internal Tcl procedures in xmfbox.tcl directly.
# This file is a Tcl script to test the file dialog that's used
# when the tk_strictMotif flag is set. Because the file dialog
# runs in a modal loop, the only way to test it sufficiently is
# to call the internal Tcl procedures in xmfbox.tcl directly.
#
# Copyright © 1997 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
# All rights reserved.

#
# TESTFILE INITIALIZATION
#

if {[namespace exists ::tk::test]} {
    # All test files, including this one, are evaluated in the current interpreter
    # (-singleproc 1). The file "main.tcl" has already been sourced into this
    # interpreter by all.tcl.
} else {
    # This test file is evaluated inside its own separate process/interpreter
    # (-singleproc 0).
    #
    # Load the main script "main.tcl", which takes care of:
    # - setup for the application and the root window
    # - importing commands from the tcltest namespace
    # - loading of the testutils mechanism along with its utility procs
    # - loading of Tk specific test constraints (additionally to constraints
    #   provided by the package tcltest)
package require tcltest 2.2
    package require tcltest 2.2
namespace import ::tcltest::*
tcltest::configure {*}$argv
tcltest::loadTestedCommands

set testPWD [pwd]
catch {unset data foo}
    tcltest::loadTestedCommands
}

# Ensure a pristine initial window state
resetWindows

#
# LOCAL UTILITY PROCS
#

proc cleanup {} {
    global testPWD

    set err0 [catch {
	    cd $testPWD
    } msg0]




︙


53
54
55
56
57
58
59



60







61
62
63
64
65
66
67

72
73
74
75
76
77
78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95








+
+
+
-
+
+
+
+
+
+
+








	    error [list $msg0 $msg1 $msg2 $msg3 $msg4]
    }
    catch {unset foo}
    destroy .foo
    update
}

#
# COMMON TEST SETUP
#
# ----------------------------------------------------------------------

set testPWD [pwd]
catch {unset data foo}

#
# TESTS
#

test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints {
    unix
} -setup {
    catch {unset foo}
} -body {
    set x [tk::MotifFDialog_Create foo open {-parent .}]




︙


159
160
161
162
163
164
165



166

167
168
169
170
171
172
173

187
188
189
190
191
192
193
194
195
196

197
198
199

200
201
202
203








+
+
+
-
+


-





    $::tk::dialog::file::foo(fList) selection set $i
    tk::MotifFDialog_BrowseFList $x
    tk::MotifFDialog_ActivateFList $x
    list $::tk::dialog::file::foo(selectPath) \
	    $::tk::dialog::file::foo(selectFile) [file normalize $tk::Priv(selectFilePath)]
} -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1"

#
# TESTFILE CLEANUP
#
# cleanup

cleanup
cleanupTests
return

# Local variables:
# mode: tcl
# End:









This page was generated in about
0.174s by
Fossil 2.27 [a6d506ecc4] 2025-07-09 13:52:53