sl@0: # This file contains a collection of tests for generic/tclMain.c.
sl@0: #
sl@0: # RCS: @(#) $Id$
sl@0:
sl@0: if {[catch {package require tcltest 2.0.2}]} {
sl@0: puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
sl@0: return
sl@0: }
sl@0:
sl@0: namespace eval ::tcl::test::main {
sl@0:
sl@0: namespace import ::tcltest::test
sl@0: namespace import ::tcltest::testConstraint
sl@0: namespace import ::tcltest::interpreter
sl@0: namespace import ::tcltest::cleanupTests
sl@0: namespace import ::tcltest::makeFile
sl@0: namespace import ::tcltest::removeFile
sl@0: namespace import ::tcltest::temporaryDirectory
sl@0: namespace import ::tcltest::workingDirectory
sl@0:
sl@0: # Is [exec] defined?
sl@0: testConstraint exec [llength [info commands exec]]
sl@0:
sl@0: # Is the Tcltest package loaded?
sl@0: # - that is, the special C-coded testing commands in tclTest.c
sl@0: # - tests use testing commands introduced in Tcltest 8.4
sl@0: testConstraint Tcltest [expr {
sl@0: [llength [package provide Tcltest]]
sl@0: && [package vsatisfies [package provide Tcltest] 8.4]}]
sl@0:
sl@0: # Procedure to simulate interactive typing of commands, line by line
sl@0: proc type {chan script} {
sl@0: foreach line [split $script \n] {
sl@0: if {[catch {
sl@0: puts $chan $line
sl@0: flush $chan
sl@0: }]} {
sl@0: return
sl@0: }
sl@0: # Grrr... Behavior depends on this value.
sl@0: after 1000
sl@0: }
sl@0: }
sl@0:
sl@0: cd [temporaryDirectory]
sl@0: # Tests Tcl_Main-1.*: variable initializations
sl@0:
sl@0: test Tcl_Main-1.1 {
sl@0: Tcl_Main: startup script - normal
sl@0: } -constraints {
sl@0: stdio
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} script
sl@0: catch {set f [open "|[list [interpreter] script]" r]}
sl@0: } -body {
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile script
sl@0: } -result [list script {} 0]\n
sl@0:
sl@0: test Tcl_Main-1.2 {
sl@0: Tcl_Main: startup script - can't begin with '-'
sl@0: } -constraints {
sl@0: stdio
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} -script
sl@0: catch {set f [open "|[list [interpreter] -script]" w+]}
sl@0: } -body {
sl@0: puts $f {puts [list $argv0 $argv $tcl_interactive]; exit}
sl@0: flush $f
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile -script
sl@0: } -result [list [interpreter] -script 0]\n
sl@0:
sl@0: test Tcl_Main-1.3 {
sl@0: Tcl_Main: encoding of arguments: done by system encoding
sl@0: Note the shortcoming explained in Tcl Feature Request 491789
sl@0: } -constraints {
sl@0: stdio
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} script
sl@0: catch {set f [open "|[list [interpreter] script \u00c0]" r]}
sl@0: } -body {
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile script
sl@0: } -result [list script [list [encoding convertfrom [encoding system] \
sl@0: [encoding convertto [encoding system] \u00c0]]] 0]\n
sl@0:
sl@0: test Tcl_Main-1.4 {
sl@0: Tcl_Main: encoding of arguments: done by system encoding
sl@0: Note the shortcoming explained in Tcl Feature Request 491789
sl@0: } -constraints {
sl@0: stdio tempNotWin
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} script
sl@0: catch {set f [open "|[list [interpreter] script \u20ac]" r]}
sl@0: } -body {
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile script
sl@0: } -result [list script [list [encoding convertfrom [encoding system] \
sl@0: [encoding convertto [encoding system] \u20ac]]] 0]\n
sl@0:
sl@0: test Tcl_Main-1.5 {
sl@0: Tcl_Main: encoding of script name: system encoding loss
sl@0: Note the shortcoming explained in Tcl Feature Request 491789
sl@0: } -constraints {
sl@0: stdio
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} \u00c0
sl@0: catch {set f [open "|[list [interpreter] \u00c0]" r]}
sl@0: } -body {
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile \u00c0
sl@0: } -result [list [list [encoding convertfrom [encoding system] \
sl@0: [encoding convertto [encoding system] \u00c0]]] {} 0]\n
sl@0:
sl@0: test Tcl_Main-1.6 {
sl@0: Tcl_Main: encoding of script name: system encoding loss
sl@0: Note the shortcoming explained in Tcl Feature Request 491789
sl@0: } -constraints {
sl@0: stdio tempNotWin
sl@0: } -setup {
sl@0: makeFile {puts [list $argv0 $argv $tcl_interactive]} \u20ac
sl@0: catch {set f [open "|[list [interpreter] \u20ac]" r]}
sl@0: } -body {
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: removeFile \u20ac
sl@0: } -result [list [list [encoding convertfrom [encoding system] \
sl@0: [encoding convertto [encoding system] \u20ac]]] {} 0]\n
sl@0:
sl@0: # Tests Tcl_Main-2.*: application-initialization procedure
sl@0:
sl@0: test Tcl_Main-2.1 {
sl@0: Tcl_Main: appInitProc returns error
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {puts "In script"} script
sl@0: } -body {
sl@0: exec [interpreter] script -appinitprocerror >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "application-specific initialization failed: \nIn script\n"
sl@0:
sl@0: test Tcl_Main-2.2 {
sl@0: Tcl_Main: appInitProc returns error
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} -appinitprocerror >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "application-specific initialization failed: \nIn script\n"
sl@0:
sl@0: test Tcl_Main-2.3 {
sl@0: Tcl_Main: appInitProc deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {puts "In script"} script
sl@0: } -body {
sl@0: exec [interpreter] script -appinitprocdeleteinterp >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "application-specific initialization failed: \n"
sl@0:
sl@0: test Tcl_Main-2.4 {
sl@0: Tcl_Main: appInitProc deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} \
sl@0: -appinitprocdeleteinterp >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "application-specific initialization failed: \n"
sl@0:
sl@0: test Tcl_Main-2.5 {
sl@0: Tcl_Main: appInitProc closes stderr
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} \
sl@0: -appinitprocclosestderr >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "In script\n"
sl@0:
sl@0: # Tests Tcl_Main-3.*: startup script evaluation
sl@0:
sl@0: test Tcl_Main-3.1 {
sl@0: Tcl_Main: startup script does not exist
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: if {[file exists no-such-file]} {
sl@0: error "Can't run test Tcl_Main-3.1\
sl@0: where a file named \"no-such-file\" exists"
sl@0: }
sl@0: } -body {
sl@0: set code [catch {exec [interpreter] no-such-file >& result} result]
sl@0: set f [open result]
sl@0: list $code $result [read $f]
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -match glob -result [list 1 {child process exited abnormally} \
sl@0: {couldn't read file "no-such-file":*}]
sl@0:
sl@0: test Tcl_Main-3.2 {
sl@0: Tcl_Main: startup script raises error
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: makeFile {error ERROR} script
sl@0: } -body {
sl@0: set code [catch {exec [interpreter] script >& result} result]
sl@0: set f [open result]
sl@0: list $code $result [read $f]
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -match glob -result [list 1 {child process exited abnormally} \
sl@0: "ERROR\n while executing*"]
sl@0:
sl@0: test Tcl_Main-3.3 {
sl@0: Tcl_Main: startup script closes stderr
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: makeFile {close stderr; error ERROR} script
sl@0: } -body {
sl@0: set code [catch {exec [interpreter] script >& result} result]
sl@0: set f [open result]
sl@0: list $code $result [read $f]
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result [list 1 {child process exited abnormally} {}]
sl@0:
sl@0: test Tcl_Main-3.4 {
sl@0: Tcl_Main: startup script holds incomplete script
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: makeFile "if 1 \{" script
sl@0: } -body {
sl@0: set code [catch {exec [interpreter] script >& result} result]
sl@0: set f [open result]
sl@0: join [list $code $result [read $f]] \n
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -match glob -result [join [list 1 {child process exited abnormally}\
sl@0: "missing close-brace\n while executing*"] \n]
sl@0:
sl@0: test Tcl_Main-3.5 {
sl@0: Tcl_Main: startup script sets main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {
sl@0: rename exit _exit
sl@0: proc exit {code} {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: after 0 {
sl@0: puts event
sl@0: testexitmainloop
sl@0: }
sl@0: testexithandler create 0
sl@0: testsetmainloop
sl@0: } script
sl@0: } -body {
sl@0: exec [interpreter] script >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "event\nExit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-3.6 {
sl@0: Tcl_Main: startup script sets main loop and closes stdin
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {
sl@0: close stdin
sl@0: testsetmainloop
sl@0: rename exit _exit
sl@0: proc exit {code} {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: after 0 {
sl@0: puts event
sl@0: testexitmainloop
sl@0: }
sl@0: testexithandler create 0
sl@0: } script
sl@0: } -body {
sl@0: exec [interpreter] script >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "event\nExit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-3.7 {
sl@0: Tcl_Main: startup script deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {
sl@0: rename exit _exit
sl@0: proc exit {code} {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testexithandler create 0
sl@0: testinterpdelete {}
sl@0: } script
sl@0: } -body {
sl@0: exec [interpreter] script >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "even 0\n"
sl@0:
sl@0: test Tcl_Main-3.8 {
sl@0: Tcl_Main: startup script deletes interp and sets mainloop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: makeFile {
sl@0: testsetmainloop
sl@0: rename exit _exit
sl@0: proc exit {code} {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testexitmainloop
sl@0: testexithandler create 0
sl@0: testinterpdelete {}
sl@0: } script
sl@0: } -body {
sl@0: exec [interpreter] script >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result "Exit MainLoop\neven 0\n"
sl@0:
sl@0: test Tcl_Main-3.9 {
sl@0: Tcl_Main: startup script can set tcl_interactive without limit
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: makeFile {set tcl_interactive foo} script
sl@0: } -body {
sl@0: exec [interpreter] script >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile script
sl@0: } -result {}
sl@0:
sl@0: # Tests Tcl_Main-4.*: rc file evaluation
sl@0:
sl@0: test Tcl_Main-4.1 {
sl@0: Tcl_Main: rcFile evaluation deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: set rc [makeFile {testinterpdelete {}} rc]
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} \
sl@0: -appinitprocsetrcfile $rc >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile rc
sl@0: } -result "application-specific initialization failed: \n"
sl@0:
sl@0: test Tcl_Main-4.2 {
sl@0: Tcl_Main: rcFile evaluation closes stdin
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: set rc [makeFile {close stdin} rc]
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} \
sl@0: -appinitprocsetrcfile $rc >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile rc
sl@0: } -result "application-specific initialization failed: \n"
sl@0:
sl@0: test Tcl_Main-4.3 {
sl@0: Tcl_Main: rcFile evaluation closes stdin and sets main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: set rc [makeFile {
sl@0: close stdin
sl@0: testsetmainloop
sl@0: after 0 testexitmainloop
sl@0: testexithandler create 0
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: } rc]
sl@0: } -body {
sl@0: exec [interpreter] << {puts "In script"} \
sl@0: -appinitprocsetrcfile $rc >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile rc
sl@0: } -result "application-specific initialization failed:\
sl@0: \nExit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-4.4 {
sl@0: Tcl_Main: rcFile evaluation sets main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: set rc [makeFile {
sl@0: testsetmainloop
sl@0: after 0 testexitmainloop
sl@0: testexithandler create 0
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: } rc]
sl@0: } -body {
sl@0: exec [interpreter] << {} \
sl@0: -appinitprocsetrcfile $rc >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: removeFile rc
sl@0: } -result "application-specific initialization failed:\
sl@0: \nExit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-4.5 {
sl@0: Tcl_Main: Bug 1481986
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: set rc [makeFile {
sl@0: testsetmainloop
sl@0: after 0 {puts "Event callback"}
sl@0: } rc]
sl@0: } -body {
sl@0: set f [open "|[list [interpreter] -appinitprocsetrcfile $rc]" w+]
sl@0: after 1000
sl@0: type $f {puts {Interactive output}
sl@0: exit
sl@0: }
sl@0: read $f
sl@0: } -cleanup {
sl@0: catch {close $f}
sl@0: removeFile rc
sl@0: } -result "Event callback\nInteractive output\n"
sl@0:
sl@0: # Tests Tcl_Main-5.*: interactive operations
sl@0:
sl@0: test Tcl_Main-5.1 {
sl@0: Tcl_Main: tcl_interactive must be boolean
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {set tcl_interactive foo} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "can't set \"tcl_interactive\":\
sl@0: variable must have boolean value\n"
sl@0:
sl@0: test Tcl_Main-5.2 {
sl@0: Tcl_Main able to handle non-blocking stdin
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: catch {set f [open "|[list [interpreter]]" w+]}
sl@0: } -body {
sl@0: type $f {
sl@0: fconfigure stdin -blocking 0
sl@0: puts SUCCESS
sl@0: }
sl@0: list [catch {gets $f} line] $line
sl@0: } -cleanup {
sl@0: close $f
sl@0: } -result [list 0 SUCCESS]
sl@0:
sl@0: test Tcl_Main-5.3 {
sl@0: Tcl_Main handles stdin EOF in mid-command
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: catch {set f [open "|[list [interpreter]]" w+]}
sl@0: catch {fconfigure $f -blocking 0}
sl@0: } -body {
sl@0: type $f "fconfigure stdin -eofchar \\032
sl@0: if 1 \{\n\032"
sl@0: variable wait
sl@0: fileevent $f readable \
sl@0: [list set [namespace which -variable wait] "child exit"]
sl@0: set id [after 2000 [list set [namespace which -variable wait] timeout]]
sl@0: vwait [namespace which -variable wait]
sl@0: after cancel $id
sl@0: set wait
sl@0: } -cleanup {
sl@0: if {[string equal timeout $wait]
sl@0: && [string equal unix $::tcl_platform(platform)]} {
sl@0: exec kill [pid $f]
sl@0: }
sl@0: close $f
sl@0: } -result {child exit}
sl@0:
sl@0: test Tcl_Main-5.4 {
sl@0: Tcl_Main handles stdin EOF in mid-command
sl@0: } -constraints {
sl@0: exec
sl@0: } -setup {
sl@0: set cmd {makeFile "if 1 \{" script}
sl@0: catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
sl@0: catch {fconfigure $f -blocking 0}
sl@0: } -body {
sl@0: variable wait
sl@0: fileevent $f readable \
sl@0: [list set [namespace which -variable wait] "child exit"]
sl@0: set id [after 2000 [list set [namespace which -variable wait] timeout]]
sl@0: vwait [namespace which -variable wait]
sl@0: after cancel $id
sl@0: set wait
sl@0: } -cleanup {
sl@0: if {[string equal timeout $wait]
sl@0: && [string equal unix $::tcl_platform(platform)]} {
sl@0: exec kill [pid $f]
sl@0: }
sl@0: close $f
sl@0: removeFile script
sl@0: } -result {child exit}
sl@0:
sl@0: test Tcl_Main-5.5 {
sl@0: Tcl_Main: error raised in interactive mode
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {error foo} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "foo\n"
sl@0:
sl@0: test Tcl_Main-5.6 {
sl@0: Tcl_Main: interactive mode: errors don't stop command loop
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: error foo
sl@0: puts bar
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "foo\nbar\n"
sl@0:
sl@0: test Tcl_Main-5.7 {
sl@0: Tcl_Main: interactive mode: closed stderr
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: close stderr
sl@0: error foo
sl@0: puts bar
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "bar\n"
sl@0:
sl@0: test Tcl_Main-5.8 {
sl@0: Tcl_Main: interactive mode: close stdin
sl@0: -> main loop & [exit] & exit handlers
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testsetmainloop
sl@0: testexitmainloop
sl@0: testexithandler create 0
sl@0: close stdin
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-5.9 {
sl@0: Tcl_Main: interactive mode: delete interp
sl@0: -> main loop & exit handlers, but no [exit]
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testsetmainloop
sl@0: testexitmainloop
sl@0: testexithandler create 0
sl@0: testinterpdelete {}
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\neven 0\n"
sl@0:
sl@0: test Tcl_Main-5.10 {
sl@0: Tcl_Main: exit main loop in mid-interactive command
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -setup {
sl@0: catch {set f [open "|[list [interpreter]]" w+]}
sl@0: catch {fconfigure $f -blocking 0}
sl@0: } -body {
sl@0: type $f "testsetmainloop
sl@0: after 2000 testexitmainloop
sl@0: puts \{1 2"
sl@0: after 4000
sl@0: type $f "3 4\}"
sl@0: set code1 [catch {gets $f} line1]
sl@0: set code2 [catch {gets $f} line2]
sl@0: set code3 [catch {gets $f} line3]
sl@0: list $code1 $line1 $code2 $line2 $code3 $line3
sl@0: } -cleanup {
sl@0: close $f
sl@0: } -result [list 0 {Exit MainLoop} 0 {1 2} 0 {3 4}]
sl@0:
sl@0: test Tcl_Main-5.11 {
sl@0: Tcl_Main: EOF in interactive main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testexithandler create 0
sl@0: after 0 testexitmainloop
sl@0: testsetmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-5.12 {
sl@0: Tcl_Main: close stdin in interactive main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: testexithandler create 0
sl@0: after 100 testexitmainloop
sl@0: testsetmainloop
sl@0: close stdin
sl@0: puts "don't reach this"
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: # Tests Tcl_Main-6.*: interactive operations with prompts
sl@0:
sl@0: test Tcl_Main-6.1 {
sl@0: Tcl_Main: enable prompts with tcl_interactive
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {set tcl_interactive 1} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% "
sl@0:
sl@0: test Tcl_Main-6.2 {
sl@0: Tcl_Main: prompt deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {testinterpdelete {}}
sl@0: set tcl_interactive 1
sl@0: puts "not reached"
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n"
sl@0:
sl@0: test Tcl_Main-6.3 {
sl@0: Tcl_Main: prompt closes stdin
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {close stdin}
sl@0: set tcl_interactive 1
sl@0: puts "not reached"
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n"
sl@0:
sl@0: test Tcl_Main-6.4 {
sl@0: Tcl_Main: interactive output, closed stdout
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_interactive 1
sl@0: close stdout
sl@0: set a NO
sl@0: puts stderr YES
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% YES\n"
sl@0:
sl@0: test Tcl_Main-6.5 {
sl@0: Tcl_Main: interactive entry to main loop
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_interactive 1
sl@0: testsetmainloop
sl@0: testexitmainloop} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% % % Exit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-6.6 {
sl@0: Tcl_Main: number of prompts during stdin close exit
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_interactive 1
sl@0: close stdin} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% "
sl@0:
sl@0: test Tcl_Main-6.7 {
sl@0: [unknown]: interactive auto-completion.
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: proc foo\{ x {}
sl@0: set ::auto_noexec xxx
sl@0: set tcl_interactive 1
sl@0: foo y} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% % "
sl@0:
sl@0: # Tests Tcl_Main-7.*: exiting
sl@0:
sl@0: test Tcl_Main-7.1 {
sl@0: Tcl_Main: [exit] defined as no-op -> still have exithandlers
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: proc exit args {}
sl@0: testexithandler create 0
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "even 0\n"
sl@0:
sl@0: test Tcl_Main-7.2 {
sl@0: Tcl_Main: [exit] defined as no-op -> still have exithandlers
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: proc exit args {}
sl@0: testexithandler create 0
sl@0: after 0 testexitmainloop
sl@0: testsetmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\neven 0\n"
sl@0:
sl@0: # Tests Tcl_Main-8.*: StdinProc operations
sl@0:
sl@0: test Tcl_Main-8.1 {
sl@0: StdinProc: handles non-blocking stdin
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: fconfigure stdin -blocking 0
sl@0: testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-8.2 {
sl@0: StdinProc: handles stdin EOF
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: testexithandler create 0
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: after 100 testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\nIn exit\neven 0\n"
sl@0:
sl@0: test Tcl_Main-8.3 {
sl@0: StdinProc: handles interactive stdin EOF
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: testexithandler create 0
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: set tcl_interactive 1} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% even 0\n"
sl@0:
sl@0: test Tcl_Main-8.4 {
sl@0: StdinProc: handles stdin close
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: after 100 testexitmainloop
sl@0: after 0 puts 1
sl@0: close stdin
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\nExit MainLoop\nIn exit\n"
sl@0:
sl@0: test Tcl_Main-8.5 {
sl@0: StdinProc: handles interactive stdin close
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: set tcl_interactive 1
sl@0: rename exit _exit
sl@0: proc exit code {
sl@0: puts "In exit"
sl@0: _exit $code
sl@0: }
sl@0: after 100 testexitmainloop
sl@0: after 0 puts 1
sl@0: close stdin
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% % % after#0\n% after#1\n% 1\nExit MainLoop\nIn exit\n"
sl@0:
sl@0: test Tcl_Main-8.6 {
sl@0: StdinProc: handles event loop re-entry
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: after 100 {puts 1; set delay 1}
sl@0: vwait delay
sl@0: puts 2
sl@0: testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n2\nExit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-8.7 {
sl@0: StdinProc: handling of errors
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: error foo
sl@0: testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "foo\nExit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-8.8 {
sl@0: StdinProc: handling of errors, closed stderr
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: close stderr
sl@0: error foo
sl@0: testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "Exit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-8.9 {
sl@0: StdinProc: interactive output
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: set tcl_interactive 1
sl@0: testexitmainloop} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% % Exit MainLoop\n"
sl@0:
sl@0: test Tcl_Main-8.10 {
sl@0: StdinProc: interactive output, closed stdout
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: close stdout
sl@0: set tcl_interactive 1
sl@0: testexitmainloop
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result {}
sl@0:
sl@0: test Tcl_Main-8.11 {
sl@0: StdinProc: prompt deletes interp
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: set tcl_prompt1 {testinterpdelete {}}
sl@0: set tcl_interactive 1} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n"
sl@0:
sl@0: test Tcl_Main-8.12 {
sl@0: StdinProc: prompt closes stdin
sl@0: } -constraints {
sl@0: exec Tcltest
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: testsetmainloop
sl@0: set tcl_prompt1 {close stdin}
sl@0: after 100 testexitmainloop
sl@0: set tcl_interactive 1
sl@0: puts "not reached"
sl@0: } >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\nExit MainLoop\n"
sl@0:
sl@0: # Tests Tcl_Main-9.*: Prompt operations
sl@0:
sl@0: test Tcl_Main-9.1 {
sl@0: Prompt: custom prompt variables
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {puts -nonewline stdout "one "}
sl@0: set tcl_prompt2 {puts -nonewline stdout "two "}
sl@0: set tcl_interactive 1
sl@0: puts {This is
sl@0: a test}} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\none two This is\n\t\ta test\none "
sl@0:
sl@0: test Tcl_Main-9.2 {
sl@0: Prompt: error in custom prompt variables
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {error foo}
sl@0: set tcl_interactive 1
sl@0: set errorInfo} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\nfoo\n% foo\n while executing\n\"error foo\"\n (script\
sl@0: that generates prompt)\nfoo\n% "
sl@0:
sl@0: test Tcl_Main-9.3 {
sl@0: Prompt: error in custom prompt variables, closed stderr
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {close stderr; error foo}
sl@0: set tcl_interactive 1} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\n% "
sl@0:
sl@0: test Tcl_Main-9.4 {
sl@0: Prompt: error in custom prompt variables, closed stdout
sl@0: } -constraints {
sl@0: exec
sl@0: } -body {
sl@0: exec [interpreter] << {
sl@0: set tcl_prompt1 {close stdout; error foo}
sl@0: set tcl_interactive 1} >& result
sl@0: set f [open result]
sl@0: read $f
sl@0: } -cleanup {
sl@0: close $f
sl@0: file delete result
sl@0: } -result "1\nfoo\n"
sl@0:
sl@0: cd [workingDirectory]
sl@0:
sl@0: cleanupTests
sl@0: }
sl@0:
sl@0: namespace delete ::tcl::test::main
sl@0: return