event.test

来自「tcl是工具命令语言」· TEST 代码 · 共 595 行 · 第 1/2 页

# This file contains a collection of tests for the procedures in the file
# tclEvent.c, which includes the "update", and "vwait" Tcl
# commands.  Sourcing this file into Tcl runs the tests and generates
# output for errors.  No output means no errors were found.
#
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: event.test,v 1.20 2002/07/10 11:56:44 dgp Exp $

package require tcltest 2
namespace import -force ::tcltest::*

testConstraint testfilehandler [llength [info commands testfilehandler]]
testConstraint testexithandler [llength [info commands testexithandler]]
testConstraint testfilewait [llength [info commands testfilewait]]

test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
    testfilehandler close
    testfilehandler create 0 readable off
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 0} {1 0} {2 0}}
test event-1.2 {Tcl_CreateFileHandler, writing} {testfilehandler nonPortable} {
    # This test is non-portable because on some systems (e.g.
    # SunOS 4.1.3) pipes seem to be writable always.
    testfilehandler close
    testfilehandler create 0 off writable
    testfilehandler clear 0
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 0]
    testfilehandler fillpartial 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler fill 0
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 1} {0 2} {0 2}}
test event-1.3 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler create 0 disabled disabled
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}

test event-2.1 {Tcl_DeleteFileHandler} {testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 off off
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-2.2 {Tcl_DeleteFileHandler, fd reused & events still pending} \
	{testfilehandler nonPortable} {
    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler fillpartial 0
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    testfilehandler create 0 readable writable
    testfilehandler oneevent
    lappend result [testfilehandler counts 0]
    testfilehandler close
    set result
} {{0 1} {0 0}}

test event-3.1 {FileHandlerCheckProc, TCL_FILE_EVENTS off } {testfilehandler} {
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    testfilehandler windowevent
    set result [testfilehandler counts 1]
    testfilehandler close
    set result
} {0 0}

test event-4.1 {FileHandlerEventProc, race between event and disabling} \
	{testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 2 disabled disabled
    testfilehandler create 1 readable writable
    testfilehandler fillpartial 1
    set result ""
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler create 1 disabled disabled
    testfilehandler oneevent
    lappend result [testfilehandler counts 1]
    testfilehandler close
    set result
} {{0 1} {1 1} {1 2} {0 0}}
test event-4.2 {FileHandlerEventProc, TCL_FILE_EVENTS off} \
	{testfilehandler nonPortable} {
    update
    testfilehandler close
    testfilehandler create 1 readable writable
    testfilehandler create 2 readable writable
    testfilehandler fillpartial 1
    testfilehandler fillpartial 2
    testfilehandler oneevent
    set result ""
    lappend result [testfilehandler counts 1] [testfilehandler counts 2]
    testfilehandler windowevent
    lappend result [testfilehandler counts 1] [testfilehandler counts 2]
    testfilehandler close
    set result
} {{0 0} {0 1} {0 0} {0 1}}
update

test event-5.1 {Tcl_BackgroundError, HandleBgErrors procedures} {
    catch {rename bgerror {}}
    proc bgerror msg {
	global errorInfo errorCode x
	lappend x [list $msg $errorInfo $errorCode]
    }
    after idle {error "a simple error"}
    after idle {open non_existent}
    after idle {set errorInfo foobar; set errorCode xyzzy}
    set x {}
    update idletasks
    rename bgerror {}
    regsub -all [file join {} non_existent] $x "non_existent" x
    set x
} {{{a simple error} {a simple error
    while executing
"error "a simple error""
    ("after" script)} NONE} {{couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory
    while executing
"open non_existent"
    ("after" script)} {POSIX ENOENT {no such file or directory}}}}
test event-5.2 {Tcl_BackgroundError, HandleBgErrors procedures} {
    catch {rename bgerror {}}
    proc bgerror msg {
	global x
	lappend x $msg
	return -code break
    }
    after idle {error "a simple error"}
    after idle {open non_existent}
    set x {}
    update idletasks
    rename bgerror {}
    set x
} {{a simple error}}

test event-6.1 {BgErrorDeleteProc procedure} {
    catch {interp delete foo}
    interp create foo
    set erroutfile [makeFile Unmodified err.out]
    foo eval [list set erroutfile $erroutfile]
    foo eval {
	proc bgerror args {
	    global errorInfo erroutfile
	    set f [open $erroutfile r+]
	    seek $f 0 end
	    puts $f "$args $errorInfo"
	    close $f
	}
	after 100 {error "first error"}
	after 100 {error "second error"}
    }
    after 100 {interp delete foo}
    after 200
    update
    set f [open $erroutfile r]
    set result [read $f]
    close $f
    removeFile $erroutfile
    set result
} {Unmodified
}

test event-7.1 {bgerror / regular} {
    set errRes {}
    proc bgerror {err} {
	global errRes;
	set errRes $err;
    }
    after 0 {error err1}
    vwait errRes;
    set errRes;
} err1

test event-7.2 {bgerror / accumulation} {
    set errRes {}
    proc bgerror {err} {
	global errRes;
	lappend errRes $err;
    }
    after 0 {error err1}
    after 0 {error err2}
    after 0 {error err3}
    update
    set errRes;
} {err1 err2 err3}

test event-7.3 {bgerror / accumulation / break} {
    set errRes {}
    proc bgerror {err} {
	global errRes;
	lappend errRes $err;
	return -code break "skip!";
    }
    after 0 {error err1}
    after 0 {error err2}
    after 0 {error err3}
    update
    set errRes;
} err1

test event-7.4 {tkerror is nothing special anymore to tcl} {
    set errRes {}
    # we don't just rename bgerror to empty because it could then
    # be autoloaded...
    proc bgerror {err} {
	global errRes;
	lappend errRes "bg:$err";
    }
    proc tkerror {err} {
	global errRes;
	lappend errRes "tk:$err";
    }
    after 0 {error err1}
    update
    rename tkerror {}
    set errRes
} bg:err1

testConstraint exec [llength [info commands exec]]

test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
    set script {
	after 1000 error hello
	after 2000 set a 0
	vwait a
    }

    list [catch {exec [interpreter] << $script} errMsg] $errMsg
} {1 {hello
    while executing
"error hello"
    ("after" script)}}


# someday : add a test checking that 
# when there is no bgerror, an error msg goes to stderr
# ideally one would use sub interp and transfer a fake stderr
# to it, unfortunatly the current interp tcl API does not allow
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.

# end of bgerror tests