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