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