通讯编程

开发平台：
Visual C++

clrpick.test：源码内容
							# This file is a Tcl script to test out Tk's "tk_chooseColor" command.
# It is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: clrpick.test,v 1.7 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
test clrpick-1.1 {tk_chooseColor command} {
    list [catch {tk_chooseColor -foo} msg] $msg
} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
catch {tk_chooseColor -foo 1} msg
regsub -all ,      $msg "" options
regsub "-foo" $options "" options
foreach option $options {
    if {[string index $option 0] == "-"} {
	test clrpick-1.2 {tk_chooseColor command} {
	    list [catch {tk_chooseColor $option} msg] $msg
	} [list 1 "value for "$option" missing"]
    }
}
test clrpick-1.3 {tk_chooseColor command} {
    list [catch {tk_chooseColor -foo bar} msg] $msg
} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}}
test clrpick-1.4 {tk_chooseColor command} {
    list [catch {tk_chooseColor -initialcolor} msg] $msg
} {1 {value for "-initialcolor" missing}}
test clrpick-1.5 {tk_chooseColor command} {
    list [catch {tk_chooseColor -parent foo.bar} msg] $msg
} {1 {bad window path name "foo.bar"}}
test clrpick-1.6 {tk_chooseColor command} {
    list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg
} {1 {unknown color name "badbadbaadcolor"}}
test clrpick-1.7 {tk_chooseColor command} {
    list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg
} {1 {invalid color name "##badbadbaadcolor"}}
if {[info commands tk::dialog::color::] == ""} {
    set isNative 1
} else {
    set isNative 0
}
proc ToPressButton {parent btn} {
    global isNative
    if {!$isNative} {
	after 200 "SendButtonPress $parent $btn mouse"
    }
}
proc ToChooseColorByKey {parent r g b} {
    global isNative
    if {!$isNative} {
	after 200 ChooseColorByKey $parent $r $g $b
    }
}
proc PressButton {btn} {
    event generate $btn <Enter>
    event generate $btn <1> -x 5 -y 5
    event generate $btn <ButtonRelease-1> -x 5 -y 5
}
proc ChooseColorByKey {parent r g b} {
    set w .__tk__color
    upvar ::tk::dialog::color::[winfo name $w] data
    update
    $data(red,entry)   delete 0 end
    $data(green,entry) delete 0 end
    $data(blue,entry)  delete 0 end
    $data(red,entry)   insert 0 $r
    $data(green,entry) insert 0 $g
    $data(blue,entry)  insert 0 $b
    # Manually force the refresh of the color values instead
    # of counting on the timing of the event stream to change
    # the values for us.
    tk::dialog::color::HandleRGBEntry $w
    SendButtonPress $parent ok mouse
}
proc SendButtonPress {parent btn type} {
    set w .__tk__color
    upvar ::tk::dialog::color::[winfo name $w] data
    set button $data($btnBtn)
    if ![winfo ismapped $button] {
	update
    }
    if {$type == "mouse"} {
	PressButton $button
    } else {
	event generate $w <Enter>
	focus $w
	event generate $button <Enter>
	event generate $w <KeyPress> -keysym Return
    }
}
set parent .
set verylongstring longstring:
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
set verylongstring $verylongstring$verylongstring
#set verylongstring $verylongstring$verylongstring
# Interesting thing...when this is too long, the
# delay caused in processing it kills the automated testing,
# and makes a lot of the test cases fail.
#set verylongstring $verylongstring$verylongstring
#set verylongstring $verylongstring$verylongstring
#set verylongstring $verylongstring$verylongstring
#set verylongstring $verylongstring$verylongstring
# let's soak up a bunch of colors...so that
# machines with small color palettes still fail.
# some tests will be skipped if there are no more colors
set numcolors 32
testConstraint colorsLeftover 1
set i 0
canvas .c
pack .c -expand 1 -fill both
while {$i<$numcolors} {
    set color #[format "%02x%02x%02x" $i [expr $i+1] [expr $i+3]]
    .c create rectangle [expr 10+$i] [expr 10+$i] [expr 50+$i] [expr 50+$i] -fill $color -outline $color
    incr i
}
set i 0
while {$i<$numcolors} {
    set color [.c itemcget $i -fill]
    if {$color != ""} {
	foreach {r g b} [winfo rgb . $color] {}
	set r [expr $r/256]
	set g [expr $g/256]
	set b [expr $b/256]
	if {"$color" != "#[format %02x%02x%02x $r $g $b]"} {
	    testConstraint colorsLeftover 0
	}
    }
    .c delete $i
    incr i
}
destroy .c
set color #404040
test clrpick-2.1 {tk_chooseColor command} 
	{nonUnixUserInteraction colorsLeftover} {
    ToPressButton $parent ok
    tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color 
	    -parent $parent
} "$color"
set color #808040
test clrpick-2.2 {tk_chooseColor command} 
	{nonUnixUserInteraction colorsLeftover} {
    if {$tcl_platform(platform) == "macintosh"} {
	set colors "32768 32768 16384"
    } else {
	set colors "128 128 64"
    }
    ToChooseColorByKey $parent 128 128 64
    tk_chooseColor -parent $parent -title "choose $colors"
} "$color"
test clrpick-2.3 {tk_chooseColor command} 
	{nonUnixUserInteraction colorsLeftover} {
    ToPressButton $parent ok
    tk_chooseColor -parent $parent -title "Press OK"
} "$color"
test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} {
    ToPressButton $parent cancel
    tk_chooseColor -parent $parent -title "Press Cancel"
} ""
set color "#000000"
test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} {
    after 1 {set x 53}
    ToPressButton $parent ok
    tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color
} "#000000"
test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} {
    after 1 {set x 53}
    ToPressButton $parent cancel
    tk_chooseColor -parent $parent -title "Press Cancel"
} ""
test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} unixOnly {
    after 50 {set ::scr [winfo screen .__tk__color]}
    ToPressButton $parent cancel
    tk_chooseColor -parent $parent
    set ::scr
} [winfo screen $parent]
# cleanup
::tcltest::cleanupTests
return

						