通讯编程

开发平台：
Visual C++

constraints.tcl：源码内容
							if {[namespace exists tk::test]} {
    deleteWindows
    wm geometry . {}
    raise .
    return
}
package require Tcl 8.4
package require Tk 8.4
tk appname tktest
wm title . tktest
# If the main window isn't already mapped (e.g. because the tests are
# being run automatically) , specify a precise size for it so that the
# user won't have to position it manually.
if {![winfo ismapped .]} {
    wm geometry . +0+0
    update
}
package require tcltest 2.1
namespace eval tk {
    namespace eval test {
	namespace eval bg {
	    # Manage a background process.  
	    # Replace with slave interp or thread?
	    namespace import ::tcltest::interpreter
	    namespace export setup cleanup do
	    proc cleanup {} {
		variable fd
		# catch in case the background process has closed $fd
		catch {puts $fd exit}
		catch {close $fd}
		set fd ""
	    }
	    proc setup args {
		variable fd
		if {[info exists fd] && [string length $fd]} {
		    cleanup
		}
		set fd [open "|[list [interpreter] 
			-geometry +0+0 -name tktest] $args" r+]
		puts $fd "puts foo; flush stdout"
		flush $fd
		if {[gets $fd data] < 0} {
		    error "unexpected EOF from "[interpreter]""
		}
		if {$data ne "foo"} {
		    error "unexpected output from
			    background process: "$data""
		}
		fileevent $fd readable [namespace code Ready]
	    }
	    proc Ready {} {
		variable fd
		variable Data
		variable Done
		set x [gets $fd]
		if {[eof $fd]} {
		    fileevent $fd readable {}
		    set Done 1
		} elseif {$x eq "**DONE**"} {
		    set Done 1
		} else {
		    append Data $x
		}
	    }
	    proc do {cmd {block 0}} {
		variable fd
		variable Data
		variable Done
		if {$block} {
		    fileevent $fd readable {}
		}
		puts $fd "[list catch $cmd msg]; update; puts $msg;
			puts **DONE**; flush stdout"
		flush $fd
		set Data {}
		if {$block} {
		    while {![eof $fd]} {
			set line [gets $fd]
			if {$line eq "**DONE**"} {
			    break
			}
			append Data $line
		    }
		} else {
		    set Done 0
		    vwait [namespace which -variable Done]
		}
		return $Data
	    }
	}
	proc Export {internal as external} {
	    uplevel 1 [list namespace import $internal]
	    uplevel 1 [list rename [namespace tail $internal] $external]
	    uplevel 1 [list namespace export $external]
	}
	Export bg::setup as setupbg
	Export bg::cleanup as cleanupbg
	Export bg::do as dobg
	namespace export deleteWindows
	proc deleteWindows {} {
	    eval destroy [winfo children .]
	}
	namespace export fixfocus 
	proc fixfocus {} {
            catch {destroy .focus}
            toplevel .focus
            wm geometry .focus +0+0
            entry .focus.e
            .focus.e insert 0 "fixfocus"
            pack .focus.e
            update
            focus -force .focus.e
            destroy .focus
	}
    }
}
namespace import -force tk::test::*
namespace import -force tcltest::testConstraint
testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
testConstraint userInteraction 0
testConstraint nonUnixUserInteraction [expr {[testConstraint userInteraction]
                                                || [testConstraint unix]}]
testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
testConstraint noExceed [expr {![testConstraint unix]
			|| [catch {font actual "{xyz"}]}]
testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
testConstraint testembed [llength [info commands testembed]]
testConstraint testwrapper [llength [info commands testwrapper]]
testConstraint testfont [llength [info commands testfont]]
testConstraint fonts 1
destroy .e
entry .e -width 0 -font {Helvetica -12} -bd 1
.e insert end a.bcd
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
    testConstraint fonts 0
}
destroy .e
destroy .t
text .t -width 80 -height 20 -font {Times -14} -bd 1
pack .t
.t insert end "This isna dot."
update
set x [list [.t bbox 1.3] [.t bbox 2.5]]
destroy .t
if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
    testConstraint fonts 0
}
testConstraint pseudocolor8 [expr {([catch {
                        toplevel .t -visual {pseudocolor 8} -colormap new
                        }] == 0) && ([winfo depth .t] == 8)}]
destroy .t
testConstraint haveTruecolor24 [expr {[lsearch [winfo visualsavailable .] {truecolor 24}] != -1}]
setupbg
set app [dobg {tk appname}]
testConstraint secureserver 0
if {[llength [info commands send]]} {
    testConstraint secureserver 1
    if {[catch {send $app set a 0} msg] == 1} {
        if {[string match "X server insecure *" $msg]} {
            testConstraint secureserver 0
	}
    }
}
cleanupbg
eval tcltest::configure $argv
namespace import -force tcltest::test
deleteWindows
wm geometry . {}
raise .

						