blob: 845782287482fba3ad2a4da3cbb5517877e3bd3d (
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
|
# This file is a Tcl script to test out the procedures in the file
# tkBitmap.c.
#
# Copyright © 1998 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
# All rights reserved.
#
# TESTFILE INITIALIZATION
#
package require tcltest 2.2; # needed in mode -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)
source [file join [tcltest::configure -testdir] main.tcl]
# 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
lindex $x 0
testbitmap gray25
} -cleanup {
destroy .b
} -result {{1 0}}
test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x gray25
button .b1 -bitmap $x
destroy .b1
lappend result [testbitmap gray25]
button .b2 -bitmap $x
lappend result [testbitmap gray25]
} -cleanup {
destroy .b1 .b2
} -result {{} {{1 1}}}
test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x gray25
button .b1 -bitmap $x
lappend result [testbitmap gray25]
button .b2 -bitmap $x
pack .b1 .b2 -side top
lappend result [testbitmap gray25]
} -cleanup {
destroy .b1 .b2
} -result {{{1 1}} {{2 1}}}
test bitmap-2.1 {Tk_GetBitmap procedure} -body {
button .b1 -bitmap bad_name
} -cleanup {
destroy .b1
} -returnCodes error -result {bitmap "bad_name" not defined}
test bitmap-2.2 {Tk_GetBitmap procedure} -body {
button .b1 -bitmap @xyzzy
} -cleanup {
destroy .b1
} -returnCodes error -result {error reading bitmap file "xyzzy"}
test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints {
testbitmap
} -setup {
set result {}
} -body {
set x questhead
button .b1 -bitmap $x
button .b3 -bitmap $x
button .b2 -bitmap $x
lappend result [testbitmap questhead]
destroy .b1
lappend result [testbitmap questhead]
destroy .b2
lappend result [testbitmap questhead]
destroy .b3
lappend result [testbitmap questhead]
} -cleanup {
destroy .b1 .b2 .b3 ;# destroying just in case
} -result {{{3 1}} {{2 1}} {{1 1}} {}}
test bitmap-4.1 {FreeBitmapObjProc} -constraints {
testbitmap
} -setup {
proc copy {s} {return [string index $s 0][string range $s 1 end]}
} -body {
set x [copy questhead]
button .b -bitmap $x
set y [copy questhead]
.b configure -bitmap $y
set z [copy questhead]
.b configure -bitmap $z
set result {}
lappend result [testbitmap questhead]
set x red
lappend result [testbitmap questhead]
set z 32
lappend result [testbitmap questhead]
destroy .b
lappend result [testbitmap questhead]
set y bogus
return $result
} -cleanup {
rename copy {}
destroy .b
} -result {{{1 3}} {{1 2}} {{1 1}} {}}
#
# TESTFILE CLEANUP
#
cleanupTests
|
