通讯编程

开发平台：
Visual C++

border.test：源码内容
							# This file is a Tcl script to test out the procedures in the file
# tkBorder.c.  It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: border.test,v 1.3 2002/07/14 05:48:46 dgp Exp $
package require tcltest 2.1
namespace import -force tcltest::configure
namespace import -force tcltest::testsDirectory
configure -testdir [file join [pwd] [file dirname [info script]]]
configure -loadfile [file join [testsDirectory] constraints.tcl]
tcltest::loadTestedCommands
testConstraint testborder [llength [info commands testborder]]
if {[testConstraint pseudocolor8]} {
    toplevel .t -visual {pseudocolor 8} -colormap new
    wm geom .t +0+0
}
test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder {
    set x orange
    lindex $x 0
    destroy .b1
    button .b1 -bg $x -text .b1
    lindex $x 0
    testborder orange
} {{1 0}}
test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder {
    set x orange
    destroy .b1 .b2
    button .b1 -bg $x -text First
    destroy .b1
    set result {}
    lappend result [testborder orange]
    button .b2 -bg $x -text Second
    lappend result [testborder orange]
} {{} {{1 1}}}
test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder {
    set x orange
    destroy .b1 .b2
    button .b1 -bg $x -text First
    set result {}
    lappend result [testborder orange]
    button .b2 -bg $x -text Second
    pack .b1 .b2 -side top
    lappend result [testborder orange]
} {{{1 1}} {{2 1}}}
test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} {
    set x purple
    destroy .b1 .b2 .t.b
    button .b1 -bg $x -text First
    pack .b1 -side top
    set result {}
    lappend result [testborder purple]
    button .t.b -bg $x -text Second
    pack .t.b -side top
    lappend result [testborder purple]
    button .b2 -bg $x -text Third
    pack .b2 -side top
    lappend result [testborder purple]
} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}}
test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} {
    set x purple
    destroy .b1 .b2 .t.b
    button .b1 -bg $x -text First
    pack .b1 -side top
    button .t.b -bg $x -text Second
    pack .t.b -side top
    button .b2 -bg $x -text Third
    pack .b2 -side top
    set result {}
    lappend result [testborder purple]
    destroy .b1
    lappend result [testborder purple]
    destroy .b2
    lappend result [testborder purple]
    destroy .t.b
    lappend result [testborder purple]
} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}}
test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} {
    destroy .b .t.b .t2 .t3
    toplevel .t2 -visual {pseudocolor 8} -colormap new
    toplevel .t3 -visual {pseudocolor 8} -colormap new
    set x purple
    button .b -bg $x -text .b1
    button .t.b1 -bg $x -text .t.b1
    button .t.b2 -bg $x -text .t.b2
    button .t2.b1 -bg $x -text .t2.b1
    button .t2.b2 -bg $x -text .t2.b2
    button .t2.b3 -bg $x -text .t2.b3
    button .t3.b1 -bg $x -text .t3.b1
    button .t3.b2 -bg $x -text .t3.b2
    button .t3.b3 -bg $x -text .t3.b3
    button .t3.b4 -bg $x -text .t3.b4
    set result {}
    lappend result [testborder purple]
    destroy .t2
    lappend result [testborder purple]
    destroy .b
    lappend result [testborder purple]
    destroy .t3
    lappend result [testborder purple]
    destroy .t
    lappend result [testborder purple]
} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}}
test border-4.1 {FreeBorderObjProc} testborder {
    destroy .b
    set x [format purple]
    button .b -bg $x -text .b1
    set y [format purple]
    .b configure -bg $y
    set z [format purple]
    .b configure -bg $z
    set result {}
    lappend result [testborder purple]
    set x red
    lappend result [testborder purple]
    set z 32
    lappend result [testborder purple]
    destroy .b
    lappend result [testborder purple]
    set y bogus
    set result
} {{{1 3}} {{1 2}} {{1 1}} {}}
catch {destroy .b}
button .b
test get-2.1 {Tk_GetReliefFromObj} {
    .b configure -relief flat
    .b cget -relief
} {flat}
test get-2.2 {Tk_GetReliefFromObj} {
    .b configure -relief groove
    .b cget -relief
} {groove}
test get-2.3 {Tk_GetReliefFromObj} {
    .b configure -relief raised
    .b cget -relief
} {raised}
test get-2.3 {Tk_GetReliefFromObj} {
    .b configure -relief ridge
    .b cget -relief
} {ridge}
test get-2.3 {Tk_GetReliefFromObj} {
    .b configure -relief solid
    .b cget -relief
} {solid}
test get-2.3 {Tk_GetReliefFromObj} {
    .b configure -relief sunken
    .b cget -relief
} {sunken}
test get-2.4 {Tk_GetReliefFromObj - error} {
    list [catch {.b configure -relief upanddown} msg] $msg
} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}}
if {[testConstraint pseudocolor8]} {
    destroy .t
}
# cleanup
::tcltest::cleanupTests
return

						