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$
9
10package require tcltest 2.1
11eval tcltest::configure $argv
12tcltest::loadTestedCommands
13
14if {[testConstraint pseudocolor8]} {
15    toplevel .t -visual {pseudocolor 8} -colormap new
16    wm geom .t +0+0
17}
18
19test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
20    set x orange
21    lindex $x 0
22    destroy .b1
23    button .b1 -bg $x -text .b1
24    lindex $x 0
25    testborder orange
26} {{1 0}}
27test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
28    set x orange
29    destroy .b1 .b2
30    button .b1 -bg $x -text First
31    destroy .b1
32    set result {}
33    lappend result [testborder orange]
34    button .b2 -bg $x -text Second
35    lappend result [testborder orange]
36} {{} {{1 1}}}
37test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
38    set x orange
39    destroy .b1 .b2
40    button .b1 -bg $x -text First
41    set result {}
42    lappend result [testborder orange]
43    button .b2 -bg $x -text Second
44    pack .b1 .b2 -side top
45    lappend result [testborder orange]
46} {{{1 1}} {{2 1}}}
47test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
48    set x purple
49    destroy .b1 .b2 .t.b
50    button .b1 -bg $x -text First
51    pack .b1 -side top
52    set result {}
53    lappend result [testborder purple]
54    button .t.b -bg $x -text Second
55    pack .t.b -side top
56    lappend result [testborder purple]
57    button .b2 -bg $x -text Third
58    pack .b2 -side top
59    lappend result [testborder purple]
60} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
61
62test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
63    set x purple
64    destroy .b1 .b2 .t.b
65    button .b1 -bg $x -text First
66    pack .b1 -side top
67    button .t.b -bg $x -text Second
68    pack .t.b -side top
69    button .b2 -bg $x -text Third
70    pack .b2 -side top
71    set result {}
72    lappend result [testborder purple]
73    destroy .b1
74    lappend result [testborder purple]
75    destroy .b2
76    lappend result [testborder purple]
77    destroy .t.b
78    lappend result [testborder purple]
79} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
80test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
81    destroy .b .t.b .t2 .t3
82    toplevel .t2 -visual {pseudocolor 8} -colormap new
83    toplevel .t3 -visual {pseudocolor 8} -colormap new
84    set x purple
85    button .b -bg $x -text .b1
86    button .t.b1 -bg $x -text .t.b1
87    button .t.b2 -bg $x -text .t.b2
88    button .t2.b1 -bg $x -text .t2.b1
89    button .t2.b2 -bg $x -text .t2.b2
90    button .t2.b3 -bg $x -text .t2.b3
91    button .t3.b1 -bg $x -text .t3.b1
92    button .t3.b2 -bg $x -text .t3.b2
93    button .t3.b3 -bg $x -text .t3.b3
94    button .t3.b4 -bg $x -text .t3.b4
95    set result {}
96    lappend result [testborder purple]
97    destroy .t2
98    lappend result [testborder purple]
99    destroy .b
100    lappend result [testborder purple]
101    destroy .t3
102    lappend result [testborder purple]
103    destroy .t
104    lappend result [testborder purple]
105} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
106
107test border-4.1 {FreeBorderObjProc} testborder {
108    destroy .b
109    set x [format purple]
110    button .b -bg $x -text .b1
111    set y [format purple]
112    .b configure -bg $y
113    set z [format purple]
114    .b configure -bg $z
115    set result {}
116    lappend result [testborder purple]
117    set x red
118    lappend result [testborder purple]
119    set z 32
120    lappend result [testborder purple]
121    destroy .b
122    lappend result [testborder purple]
123    set y bogus
124    set result
125} {{{1 3}} {{1 2}} {{1 1}} {}}
126
127catch {destroy .b}
128button .b
129test border-5.1 {Tk_GetReliefFromObj} {
130    .b configure -relief flat
131    .b cget -relief
132} {flat}
133test border-5.2 {Tk_GetReliefFromObj} {
134    .b configure -relief groove
135    .b cget -relief
136} {groove}
137test border-5.3 {Tk_GetReliefFromObj} {
138    .b configure -relief raised
139    .b cget -relief
140} {raised}
141test border-5.4 {Tk_GetReliefFromObj} {
142    .b configure -relief ridge
143    .b cget -relief
144} {ridge}
145test border-5.5 {Tk_GetReliefFromObj} {
146    .b configure -relief solid
147    .b cget -relief
148} {solid}
149test border-5.6 {Tk_GetReliefFromObj} {
150    .b configure -relief sunken
151    .b cget -relief
152} {sunken}
153test border-5.7 {Tk_GetReliefFromObj - error} {
154    list [catch {.b configure -relief upanddown} msg] $msg
155} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
156
157if {[testConstraint pseudocolor8]} {
158    destroy .t
159}
160
161# cleanup
162cleanupTests
163return
164