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