1# This file is a Tcl script to test out the procedures in the file
2# tkBorder.c.  It is organized in the standard fashion for Tcl tests.
3#
4# Copyright (c) 1998 Sun Microsystems, Inc.
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# All rights reserved.
7#
8# RCS: @(#) $Id: border.test,v 1.3 2002/07/14 05:48:46 dgp Exp $
9
10package require tcltest 2.1
11namespace import -force tcltest::configure
12namespace import -force tcltest::testsDirectory
13configure -testdir [file join [pwd] [file dirname [info script]]]
14configure -loadfile [file join [testsDirectory] constraints.tcl]
15tcltest::loadTestedCommands
16
17testConstraint testborder [llength [info commands testborder]]
18
19if {[testConstraint pseudocolor8]} {
20    toplevel .t -visual {pseudocolor 8} -colormap new
21    wm geom .t +0+0
22}
23
24test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
25    set x orange
26    lindex $x 0
27    destroy .b1
28    button .b1 -bg $x -text .b1
29    lindex $x 0
30    testborder orange
31} {{1 0}}
32test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
33    set x orange
34    destroy .b1 .b2
35    button .b1 -bg $x -text First
36    destroy .b1
37    set result {}
38    lappend result [testborder orange]
39    button .b2 -bg $x -text Second
40    lappend result [testborder orange]
41} {{} {{1 1}}}
42test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
43    set x orange
44    destroy .b1 .b2
45    button .b1 -bg $x -text First
46    set result {}
47    lappend result [testborder orange]
48    button .b2 -bg $x -text Second
49    pack .b1 .b2 -side top
50    lappend result [testborder orange]
51} {{{1 1}} {{2 1}}}
52test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
53    set x purple
54    destroy .b1 .b2 .t.b
55    button .b1 -bg $x -text First
56    pack .b1 -side top
57    set result {}
58    lappend result [testborder purple]
59    button .t.b -bg $x -text Second
60    pack .t.b -side top
61    lappend result [testborder purple]
62    button .b2 -bg $x -text Third
63    pack .b2 -side top
64    lappend result [testborder purple]
65} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
66
67test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
68    set x purple
69    destroy .b1 .b2 .t.b
70    button .b1 -bg $x -text First
71    pack .b1 -side top
72    button .t.b -bg $x -text Second
73    pack .t.b -side top
74    button .b2 -bg $x -text Third
75    pack .b2 -side top
76    set result {}
77    lappend result [testborder purple]
78    destroy .b1
79    lappend result [testborder purple]
80    destroy .b2
81    lappend result [testborder purple]
82    destroy .t.b
83    lappend result [testborder purple]
84} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
85test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
86    destroy .b .t.b .t2 .t3
87    toplevel .t2 -visual {pseudocolor 8} -colormap new
88    toplevel .t3 -visual {pseudocolor 8} -colormap new
89    set x purple
90    button .b -bg $x -text .b1
91    button .t.b1 -bg $x -text .t.b1
92    button .t.b2 -bg $x -text .t.b2
93    button .t2.b1 -bg $x -text .t2.b1
94    button .t2.b2 -bg $x -text .t2.b2
95    button .t2.b3 -bg $x -text .t2.b3
96    button .t3.b1 -bg $x -text .t3.b1
97    button .t3.b2 -bg $x -text .t3.b2
98    button .t3.b3 -bg $x -text .t3.b3
99    button .t3.b4 -bg $x -text .t3.b4
100    set result {}
101    lappend result [testborder purple]
102    destroy .t2
103    lappend result [testborder purple]
104    destroy .b
105    lappend result [testborder purple]
106    destroy .t3
107    lappend result [testborder purple]
108    destroy .t
109    lappend result [testborder purple]
110} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
111
112test border-4.1 {FreeBorderObjProc} testborder {
113    destroy .b
114    set x [format purple]
115    button .b -bg $x -text .b1
116    set y [format purple]
117    .b configure -bg $y
118    set z [format purple]
119    .b configure -bg $z
120    set result {}
121    lappend result [testborder purple]
122    set x red
123    lappend result [testborder purple]
124    set z 32
125    lappend result [testborder purple]
126    destroy .b
127    lappend result [testborder purple]
128    set y bogus
129    set result
130} {{{1 3}} {{1 2}} {{1 1}} {}}
131
132catch {destroy .b}
133button .b
134test get-2.1 {Tk_GetReliefFromObj} {
135    .b configure -relief flat
136    .b cget -relief
137} {flat}
138test get-2.2 {Tk_GetReliefFromObj} {
139    .b configure -relief groove
140    .b cget -relief
141} {groove}
142test get-2.3 {Tk_GetReliefFromObj} {
143    .b configure -relief raised
144    .b cget -relief
145} {raised}
146test get-2.3 {Tk_GetReliefFromObj} {
147    .b configure -relief ridge
148    .b cget -relief
149} {ridge}
150test get-2.3 {Tk_GetReliefFromObj} {
151    .b configure -relief solid
152    .b cget -relief
153} {solid}
154test get-2.3 {Tk_GetReliefFromObj} {
155    .b configure -relief sunken
156    .b cget -relief
157} {sunken}
158test get-2.4 {Tk_GetReliefFromObj - error} {
159    list [catch {.b configure -relief upanddown} msg] $msg
160} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
161
162if {[testConstraint pseudocolor8]} {
163    destroy .t
164}
165
166# cleanup
167::tcltest::cleanupTests
168return
169
170
171
172
173
174
175
176
177
178
179
180
181
182