blob: 11e23aa2c1c1b35ee54b60ada039cc67c8f16c0d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
# 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
# Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: cursor.test,v 1.5 2002/06/13 15:31:39 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
source [file join [pwd] [file dirname [info script]] defs.tcl]
}
set ::tcltest::testConfig(testcursor) [llength [info commands testcursor]]
eval destroy [winfo children .]
wm geometry . {}
raise .
test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} {
set x watch
lindex $x 0
destroy .b1
button .b1 -cursor $x
lindex $x 0
testcursor watch
} {{1 0}}
test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} {
set x watch
destroy .b1 .b2
button .b1 -cursor $x
destroy .b1
set result {}
lappend result [testcursor watch]
button .b2 -cursor $x
lappend result [testcursor watch]
} {{} {{1 1}}}
test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} {
set x watch
destroy .b1 .b2
button .b1 -cursor $x
set result {}
lappend result [testcursor watch]
button .b2 -cursor $x
pack .b1 .b2 -side top
lappend result [testcursor watch]
} {{{1 1}} {{2 1}}}
test cursor-2.1 {Tk_GetCursor procedure} {
destroy .b1
list [catch {button .b1 -cursor bad_name} msg] $msg
} {1 {bad cursor spec "bad_name"}}
test cursor-2.2 {Tk_GetCursor procedure} {
destroy .b1
list [catch {button .b1 -cursor @xyzzy} msg] $msg
} {1 {bad cursor spec "@xyzzy"}}
# Next two tests need a helper file with a very specific name and
# controlled format.
set wincur(data_octal) {
000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001
000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000
000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000
000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036
000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360
000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370
000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016
000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377
377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300
377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007
377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003
377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340
377 377 017 360 377 377
}
set wincur(data_binary) {}
foreach wincur(num) $wincur(data_octal) {
append wincur(data_binary) [binary format c 0$wincur(num)]
}
set wincur(dir) [::tcltest::makeDirectory {dir with spaces}]
set wincur(file) [::tcltest::makeFile $wincur(data_binary) "test file.cur" $wincur(dir)]
test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
destroy .b1
button .b1 -cursor [list @$wincur(file)]
} {.b1}
test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} {pcOnly} {
destroy .b1
button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}]
} {.b1}
::tcltest::removeDirectory $wincur(dir)
unset wincur
test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} {
set x heart
destroy .b1 .b2 .b3
button .b1 -cursor $x
button .b3 -cursor $x
button .b2 -cursor $x
set result {}
lappend result [testcursor heart]
destroy .b1
lappend result [testcursor heart]
destroy .b2
lappend result [testcursor heart]
destroy .b3
lappend result [testcursor heart]
} {{{3 1}} {{2 1}} {{1 1}} {}}
test cursor-4.1 {FreeCursorObjProc} {testcursor} {
destroy .b
set x [format heart]
button .b -cursor $x
set y [format heart]
.b configure -cursor $y
set z [format heart]
.b configure -cursor $z
set result {}
lappend result [testcursor heart]
set x red
lappend result [testcursor heart]
set z 32
lappend result [testcursor heart]
destroy .b
lappend result [testcursor heart]
set y bogus
set result
} {{{1 3}} {{1 2}} {{1 1}} {}}
destroy .t
# cleanup
::tcltest::cleanupTests
return
|
