path: root/tests/ioTrans.test

# -*- tcl -*-
# Functionality covered: operation of the reflected transformation
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
#                                    <akupries@shaw.ca>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioTrans.test,v 1.3 2008/06/16 18:38:42 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2
    namespace import -force ::tcltest::*
}

# Custom constraints used in this file
testConstraint testchannel	[llength [info commands testchannel]]
testConstraint testthread	[llength [info commands testthread]]

# testchannel cut|splice  Both needed to test the reflection in threads.
# testthread  send 

#----------------------------------------------------------------------

# ### ### ### ######### ######### #########
## Testing the reflected transformation.

# Helper commands to record the arguments to handler methods.  Stored
# in a script so that the tests needing this code do not need their
# own copy but can access this variable.

set helperscript {
    if {[lsearch [namespace children] ::tcltest] == -1} {
	package require tcltest 2
	namespace import -force ::tcltest::*
    }

    proc note  {item}  {global res; lappend res $item; return}
    proc track {}      {upvar args item; note $item; return}
    proc notes {items} {foreach i $items {note $i}}

    # Use to prevent *'s in pattern to match beyond the expected end
    # of the recording.
    proc endnote {} {note |}

    # This forces the return options to be in the order that the test
    # expects!
    proc noteOpts opts {global res; lappend res [dict merge {
	-code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
    } $opts]; return}

    # Helper command, canned result for 'initialize' method.  Gets the
    # optional methods as arguments. Use return features to post the
    # result higher up.

    proc init {args} {
	lappend args initialize finalize read write
	return -code return $args
    }
    proc oninit {args} {
	upvar args hargs
	if {[lindex $hargs 0] ne "initialize"} {return}
	lappend args initialize finalize read write
	return -code return $args
    }
    proc onfinal {} {
	upvar args hargs
	if {[lindex $hargs 0] ne "finalize"} {return}
	return -code return ""
    }
    proc onread {} {
	upvar args hargs
	if {[lindex $hargs 0] ne "read"} {return}
	return -code return "@"
    }
    proc ondrain {} {
	upvar args hargs
	if {[lindex $hargs 0] ne "drain"} {return}
	return -code return "<>"
    }
    proc onclear {} {
	upvar args hargs
	if {[lindex $hargs 0] ne "clear"} {return}
	return -code return ""
    }

    proc tempchan {{mode r+}} {
	global  tempchan
	set     tempchan [open [makeFile {test data} tempchanfile] $mode]
	return $tempchan
    }

    proc tempdone {} {
	global tempchan
	catch {close $tempchan}
	removeFile tempchanfile
	return
    }

    proc tempview {} { viewFile tempchanfile }
}

# Set everything up in the main thread.
eval $helperscript

#puts <<[file channels]>>

# ### ### ### ######### ######### #########

test iortrans-1.0 {chan, wrong#args} {
    catch {chan} msg
    set msg
} {wrong # args: should be "chan subcommand ?argument ...?"}
test iortrans-1.1 {chan, unknown method} {
    catch {chan foo} msg
    set msg
} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate}

# --- --- --- --------- --------- ---------
# chan push, and method "initalize"

test iortrans-2.0 {chan push, wrong#args, not enough} {
    catch {chan push} msg
    set msg
} {wrong # args: should be "chan push channel cmdprefix"}
test iortrans-2.1 {chan push, wrong#args, too many} {
    catch {chan push a b c} msg
    set msg
} {wrong # args: should be "chan push channel cmdprefix"}
test iortrans-2.2 {chan push, invalid channel} {
    proc foo {} {}
    catch {chan push {} foo} msg
    rename foo {}
    set msg
} {can not find channel named ""}
test iortrans-2.3 {chan push, bad handler, not a list} {
    catch {chan push [tempchan] "foo \{"} msg
    tempdone
    set msg
} {unmatched open brace in list}
test iortrans-2.4 {chan push, bad handler, not a command} {
    catch {chan push [tempchan] foo} msg
    tempdone
    set msg
} {invalid command name "foo"}
test iortrans-2.5 {chan push, initialize failed, bad signature} {
    proc foo {} {}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} {wrong # args: should be "foo"}
test iortrans-2.6 {chan push, initialize failed, bad signature} {
    proc foo {} {}
    catch {chan push [tempchan] ::foo} msg
    tempdone
    rename foo {}
    set msg
} {wrong # args: should be "::foo"}
test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body {
    proc foo {args} {return "\{"}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set ::errorInfo
} -match glob -result {chan handler "foo initialize" returned non-list: *}
test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body {
    proc foo {args} {return \{\{\}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {chan handler "foo initialize" returned non-list: *}
test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body {
    proc foo {args} {}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*all required methods*}
test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return 1}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*bad method "1": must be *}
test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body {
    proc foo {args} {return {a b c}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*bad method "c": must be *}
test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body {
    # Required: initialize, and finalize.
    proc foo {args} {return {initialize}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*all required methods*}
test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body {
    proc foo {args} {return {initialize finalize BOGUS}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write}
test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body {
    proc foo {args} {return {initialize finalize}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*makes the channel inacessible}
# iortrans-2.15 event/watch methods elimimated, removed these tests.
# iortrans-2.16
test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body {
    proc foo {args} {return {initialize finalize drain write}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*supports "drain" but not "read"}
test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body {
    proc foo {args} {return {initialize finalize flush read}}
    catch {chan push [tempchan] foo} msg
    tempdone
    rename foo {}
    set msg
} -match glob -result {*supports "flush" but not "write"}
test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body {
    proc foo {args} {
	global  res
	lappend res $args
	if {[lindex $args 0] ne "initialize"} {return}
	return {initialize finalize drain flush read write}
    }
    set res {}
    lappend res [file channel rt*]
    lappend res [chan push [tempchan] foo]
    lappend res [close [lindex $res end]]
    lappend res [file channel rt*]
    tempdone
    rename foo {}
    set res
} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}}
test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body {
    proc foo {args} {
	global  res
	lappend res $args
	return {}
    }
    set res {}
    lappend res [file channel rt*]
    lappend res [catch {chan push [tempchan] foo} msg]
    lappend res $msg
    lappend res [file channel rt*]
    tempdone
    rename foo {}
    set res
} -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}}

# --- --- --- --------- --------- ---------
# method finalize (via close)

# General note: file channels rt* finds the transform channel, however
# the name reported will be that of the underlying base driver, fileXX
# here.  This actually allows us to see if the whole channel is gone,
# or only the transformation, but not the base.

test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return}
    note [set c [chan push [tempchan] foo]]
    rename foo {}
    note [file channels file*]
    note [file channels rt*]
    note [catch {close $c} msg]; note $msg
    note [file channels file*]
    note [file channels rt*]
    set res
} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
test iortrans-3.2 {chan finalize, for close} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return {}}
    note [set c [chan push [tempchan] foo]]
    close $c
    # Close deleted the channel.
    note [file channels rt*]
    # Channel destruction does not kill handler command!
    note [info command foo]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code error 5}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg
    # Channel is gone despite error.
    note [file channels rt*]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; error FOO}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg; note $::errorInfo
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
*"close $c"}}
test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return SOMETHING}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 3}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 4}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 777 BANG}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg]; note $msg
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup {
    set res {}
} -body {
    proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
    note [set c [chan push [tempchan] foo]]
    note [catch {close $c} msg opt]; note $msg; noteOpts $opt
    return $res
} -cleanup {
    rename foo {}
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}

# --- === *** ###########################
# method read (via read)

test iortrans-4.1 {chan read, transform call and return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return snarf
    }
    set c [chan push [tempchan] foo]
    note [read $c 10]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} snarf}
test iortrans-4.2 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track; note MUST_NOT_HAPPEN
    }
    set c [chan push [tempchan w] foo]
    note [catch {read $c 2} msg]; note $msg
    tempdone
    rename foo {}
    set res
} -result {1 {channel "file*" wasn't opened for reading}}
test iortrans-4.3 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code error BOOM!
    }
    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg]; note $msg
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 BOOM!}
test iortrans-4.4 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code break BOOM!
    }
    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg]; note $msg
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.5 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code continue BOOM!
    }
    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg]; note $msg
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.6 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg]; note $msg
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.7 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}


# --- === *** ###########################
# method write (via puts)

test iortrans-5.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} { oninit; onfinal; track ; return transformresult }
    set c [chan push [tempchan] foo]
    puts -nonewline $c snarf; flush $c
    close $c
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarf} transformresult}
test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body {
    set res {}
    proc foo {args} { oninit; onfinal; track ; return {} }
    set c [chan push [tempchan] foo]
    puts -nonewline $c snarfsnarfsnarf; flush $c
    close $c
    note [tempview];# This has to show the original data, as nothing was written
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} {test data}}
test iortrans-5.3 {chan write, failed write} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
    set c [chan push [tempchan] foo]
    puts -nonewline $c snarfsnarfsnarf
    note [catch {flush $c} msg] ; note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
test iortrans-5.4 {chan write, non-writable channel} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
    set c [chan push [tempchan r] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg
    close $c
    tempdone
    rename foo {}
    set res
} -result {1 {channel "file*" wasn't opened for writing}}
test iortrans-5.5 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
    set c [chan push [tempchan] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
    note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
test iortrans-5.6 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; error BOOM!}
    set c [chan push [tempchan] foo]
    notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
    note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
    set c [chan push [tempchan] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
    note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
    set c [chan push [tempchan] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
    note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
    set c [chan push [tempchan] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
    note $msg
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
    set c [chan push [tempchan] foo]
    note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
    note $msg
    noteOpts $opt
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}

# --- === *** ###########################
# method limit?, drain (via read)

test iortrans-6.1 {chan read, read limits} -match glob -body {
    set res {}
    proc foo {args} {
	oninit limit?; onfinal; track ; onread
	return 6
    }
    set c [chan push [tempchan] foo]
    note [read $c 10]
    tempdone
    rename foo {}
    set res
} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
}} {limit? rt*} @@}
test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body {
    set res {}
    proc foo {args} {
	oninit drain; onfinal; track ; onread ; ondrain
	return
    }
    set c [chan push [tempchan] foo]
    note [read  $c]
    note [close $c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} {drain rt*} @<> {}}

# --- === *** ###########################
# method clear (via puts, seek)

test iortrans-7.1 {chan write, write clears read buffers} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track ; onclear
	return transformresult
    }
    set c [chan push [tempchan] foo]
    puts -nonewline $c snarf; flush $c
    tempdone
    rename foo {}
    set res
} -result {{clear rt*} {write rt* snarf}}
test iortrans-7.2 {seek clears read buffers} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track
	return
    }
    set c [chan push [tempchan] foo]
    seek $c 2
    tempdone
    rename foo {}
    set res
} -result {{clear rt*}}
test iortrans-7.3 {clear, any result is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track
	return -code error "X"
    }
    set c [chan push [tempchan] foo]
    seek $c 2
    tempdone
    rename foo {}
    set res
} -result {{clear rt*}}

# --- === *** ###########################
# method flush (via seek, close)

test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
    set res {}
    proc foo {args} {
	oninit flush; onfinal; track
	return X
    }
    set c [chan push [tempchan] foo]
    # Flush, no writing
    seek $c 2
    # The close flushes again, this modifies the file!
    note | ; note [close $c] ; note |
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{flush rt*} | {flush rt*} {} | {teXt data}}

test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
    set res {}
    proc foo {args} {
	oninit flush; track ; onfinal
	return .flushed.
    }
    set c [chan push [tempchan] foo]
    close $c
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{flush rt*} {finalize rt*} .flushed.}


# --- === *** ###########################
# method watch - removed from TIP (rev 1.12+)

# --- === *** ###########################
# method event - removed from TIP (rev 1.12+)

# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.

test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body {

    set ida [interp create];#puts <<$ida>>
    set idb [interp create];#puts <<$idb>>

    # Magic to get the test* commands in the slaves
    load {} Tcltest $ida
    load {} Tcltest $idb

    # Set up channel and transform in interpreter
    interp eval $ida $helperscript
    set chan [interp eval $ida {
	proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return}
	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]

    # Move channel to 2nd interpreter, transform goes with it.
    interp eval $ida [list testchannel cut    $chan]
    interp eval $idb [list testchannel splice $chan]

    # Kill origin interpreter, then access channel from 2nd interpreter.
    interp delete $ida

    set     res {}
    lappend res [catch {interp eval $idb [list puts  $chan shoo]} msg] $msg
    lappend res [catch {interp eval $idb [list tell  $chan]}      msg] $msg
    lappend res [catch {interp eval $idb [list seek  $chan 1]}    msg] $msg
    lappend res [catch {interp eval $idb [list gets  $chan]}      msg] $msg
    lappend res [catch {interp eval $idb [list close $chan]}      msg] $msg
    #lappend res [interp eval $ida {set res}]
    # actions: clear|write|clear|write|clear|flush|limit?|drain|flush
    tempdone
    set res
    # The 'tell' is ok, as it passed through the transform to the base
    # channel without invoking the transform handler.
} -constraints {testchannel} \
    -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}

test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -match glob -body {

    set ida [interp create];#puts <<$ida>>
    set idb [interp create];#puts <<$idb>>

    # Magic to get the test* commands in the slaves
    load {} Tcltest $ida
    load {} Tcltest $idb

    # Set up channel in thread
    set chan [interp eval $ida $helperscript]
    set chan [interp eval $ida {
	proc foo {args} {
	    oninit clear drain flush limit? read write; onfinal; track;
	    # destroy interpreter during channel access
	    # Actually not possible for an interp to destroy itself.
	    interp delete {}
	    return}
	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]

    # Move channel to 2nd thread, transform goes with it.
    interp eval $ida [list testchannel cut    $chan]
    interp eval $idb [list testchannel splice $chan]

    # Run access from interpreter B, this will give us a synchronous
    # response.

    interp eval $idb [list set chan $chan]
    interp eval $idb [list set mid $tcltest::mainThread]
    set res [interp eval $idb {
	# wait a bit, give the main thread the time to start its event
	# loop to wait for the response from B
	after 2000
	catch { puts $chan shoo } res
	set res
    }]
    tempdone
    set res
} -constraints {testchannel impossible} \
    -result {Owner lost}

# ### ### ### ######### ######### #########
## Same tests as above, but exercising the code forwarding and
## receiving driver operations to the originator thread.

# -*- tcl -*-
# ### ### ### ######### ######### #########
## Testing the reflected channel (Thread forwarding).
#
## The id numbers refer to the original test without thread
## forwarding, and gaps due to tests not applicable to forwarding are
## left to keep this association.

# Duplicate of code in "thread.test", and "ioCmd.test". Find a better
# way of doing this without duplication. Maybe placement into a proc
# which transforms to nop after the first call, and placement of its
# defintion in a central location.

if {[testConstraint testthread]} {
    testthread errorproc ThreadError

    proc ThreadError {id info} {
	global threadError
	set threadError $info
    }
    proc ThreadNullError {id info} {
	# ignore
    }
}

# ### ### ### ######### ######### #########
## Helper command. Runs a script in a separate thread and returns the
## result. A channel is transfered into the thread as well, and a list
## of configuation variables

proc inthread {chan script args} {
    # Test thread.

    set tid [testthread create]

    # Init thread configuration.
    # - Listed variables
    # - Id of main thread
    # - A number of helper commands

    foreach v $args {
	upvar 1 $v x
	testthread send $tid [list set $v $x]
    }
    testthread send $tid [list set mid $tcltest::mainThread]
    testthread send $tid {
	proc note {item} {global notes; lappend notes $item}
	proc notes {} {global notes; return $notes}
	proc noteOpts opts {global notes; lappend notes [dict merge {
	    -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
	} $opts]}
    }
    testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*)

    # Transfer channel (cut/splice aka detach/attach)

    testchannel cut $chan
    testthread send $tid [list testchannel splice $chan]

    # Run test script, also run local event loop!
    # The local event loop waits for the result to come back.
    # It is also necessary for the execution of forwarded channel
    # operations.

    set ::tres ""
    testthread send -async $tid {
	after 500
	catch {s} res; # This runs the script, 's' was defined at (*)
	testthread send -async $mid [list set ::tres $res]
    }
    vwait ::tres
    # Remove test thread, and return the captured result.

    tcltest::threadReap
    return $::tres
}

# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

test iortrans.tf-3.2 {chan finalize, for close} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return {}}
    note [set c [chan push [tempchan] foo]]
    note [inthread $c {
	close $c
	# Close the deleted the channel.
	file channels rt*
    } c]
    # Channel destruction does not kill handler command!
    note [info command foo]
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code error 5}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	# Channel is gone despite error.
	note [file channels rt*]
	notes
    } c]
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; error FOO}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO}
test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return SOMETHING}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 3}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
    -constraints {testchannel testthread}


test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 4}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -code 777 BANG}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg]; note $msg
	notes
    } c]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -match glob -body {
    set res {}
    proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
    note [set c [chan push [tempchan] foo]]
    notes [inthread $c {
	note [catch {close $c} msg opt]; note $msg; noteOpts $opt
	notes
    } c]
    rename foo {}
    set res
} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method read

test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return snarf
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [read $c 10]
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{read rt* {test data
}} snarf}

test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track; note MUST_NOT_HAPPEN
    }
    set c [chan push [tempchan w] foo]
    notes [inthread $c {
	note [catch {[read $c 2]} msg]; note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}}
test iortrans.tf-4.3 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code error BOOM!
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {read $c 2} msg]; note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 BOOM!} \
    -constraints {testchannel testthread}
test iortrans.tf-4.4 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code break BOOM!
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {read $c 2} msg]; note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code continue BOOM!
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {read $c 2} msg]; note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {read $c 2} msg]; note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code*} \
    -constraints {testchannel testthread}

test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
    -constraints {testchannel testthread}

# --- === *** ###########################
# method write

test iortrans.tf-5.1 {chan write, regular write} -match glob -body {
    set res {}
    proc foo {args} { oninit; onfinal; track ; return transformresult }
    set c [chan push [tempchan] foo]
    inthread $c {
	puts -nonewline $c snarf; flush $c
	close $c
    } c
    note [tempview]
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult}
test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body {
    set res {}
    proc foo {args} { oninit; onfinal; track ; return {} }
    set c [chan push [tempchan] foo]
    inthread $c {
	puts -nonewline $c snarfsnarfsnarf; flush $c
	close $c
    } c
    note [tempview];# This has to show the original data, as nothing was written
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{write rt* snarfsnarfsnarf} {test data}}
test iortrans.tf-5.3 {chan write, failed write} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	puts -nonewline $c snarfsnarfsnarf
	note [catch {flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
    set c [chan push [tempchan r] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -constraints {testchannel testthread} \
    -result {1 {channel "file*" wasn't opened for writing}}
test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}
test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; error BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
    -constraints {testchannel testthread}


test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
	note $msg
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
    -constraints {testchannel testthread}
test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
	note $msg
	noteOpts $opt
	close $c
	notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
    -constraints {testchannel testthread}


# --- === *** ###########################
# method limit?, drain (via read)

test iortrans.tf-6.1 {chan read, read limits} -match glob -body {
    set res {}
    proc foo {args} {
	oninit limit?; onfinal; track ; onread
	return 6
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [read $c 10]
	close $c
	set notes
    } c]
    tempdone
    rename foo {}
    set res
} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
}} {limit? rt*} @@} -constraints {testchannel testthread}
test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body {
    set res {}
    proc foo {args} {
	oninit drain; onfinal; track ; onread ; ondrain
	return
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	note [read  $c]
	note [close $c]
    } c]
    tempdone
    rename foo {}
    set res
} -result {{read rt* {test data
}} {drain rt*} @<> {}} -constraints {testchannel testthread}

# --- === *** ###########################
# method clear (via puts, seek)

test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track ; onclear
	return transformresult
    }
    set c [chan push [tempchan] foo]
    inthread $c {
	puts -nonewline $c snarf; flush $c
	close $c
    } c
    tempdone
    rename foo {}
    set res
} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread}
test iortrans.tf-7.2 {seek clears read buffers} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track
	return
    }
    set c [chan push [tempchan] foo]
    inthread $c {
	seek $c 2
	close $c
    } c
    tempdone
    rename foo {}
    set res
} -result {{clear rt*}} -constraints {testchannel testthread}
test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body {
    set res {}
    proc foo {args} {
	oninit clear; onfinal; track
	return -code error "X"
    }
    set c [chan push [tempchan] foo]
    inthread $c {
	seek $c 2
	close $c
    } c
    tempdone
    rename foo {}
    set res
} -result {{clear rt*}} -constraints {testchannel testthread}

# --- === *** ###########################
# method flush (via seek, close)

test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -match glob -body {
    set res {}
    proc foo {args} {
	oninit flush; onfinal; track
	return X
    }
    set c [chan push [tempchan] foo]
    notes [inthread $c {
	# Flush, no writing
	seek $c 2
	# The close flushes again, this modifies the file!
	note | ; note [close $c] ; note |
	# NOTE: The flush generated by the close is recorded
	# immediately, the other note's here are defered until after
	# the thread is done. This changes the order of the result a
	# bit from the non-threaded case (The first | moves one to the
	# right). This is an artifact of the 'inthread' framework, not
	# of the transformation itself.
	notes
    } c]
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread}

test iortrans.tf-8.2 {close flushes write buffers, writes data} -match glob -body {
    set res {}
    proc foo {args} {
	oninit flush; track ; onfinal
	return .flushed.
    }
    set c [chan push [tempchan] foo]
    inthread $c {
	close $c
    } c
    note [tempview]
    tempdone
    rename foo {}
    set res
} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread}


# --- === *** ###########################
# method watch - removed from TIP (rev 1.12+)

# --- === *** ###########################
# method event - removed from TIP (rev 1.12+)

# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a thread A, move to other
# thread B, destroy the origin thread (A) before or during access from
# B. Must not crash, must return proper errors.

test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body {

    #puts <<$tcltest::mainThread>>main
    set tida [testthread create];#puts <<$tida>>
    set tidb [testthread create];#puts <<$tidb>>

    # Set up channel in thread
    testthread send $tida $helperscript
    set chan [testthread send $tida {
	proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return}
	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]

    # Move channel to 2nd thread, transform goes with it.
    testthread send $tida [list testchannel cut    $chan]
    testthread send $tidb [list testchannel splice $chan]

    # Kill origin thread, then access channel from 2nd thread.
    testthread send -async $tida {testthread exit}
    after 100

    set     res {}
    lappend res [catch {testthread send $tidb [list puts  $chan shoo]} msg] $msg
    lappend res [catch {testthread send $tidb [list tell  $chan]}      msg] $msg
    lappend res [catch {testthread send $tidb [list seek  $chan 1]}    msg] $msg
    lappend res [catch {testthread send $tidb [list gets  $chan]}      msg] $msg
    lappend res [catch {testthread send $tidb [list close $chan]}      msg] $msg
    tcltest::threadReap
    tempdone
    set res
    # The 'tell' is ok, as it passed through the transform to the base
    # channel without invoking the transform handler.

} -constraints {testchannel testthread} \
    -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}

test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body {

    #puts <<$tcltest::mainThread>>main
    set tida [testthread create];#puts <<$tida>>
    set tidb [testthread create];#puts <<$tidb>>

    # Set up channel in thread
    set chan [testthread send $tida $helperscript]
    set chan [testthread send $tida {
	proc foo {args} {
	    oninit clear drain flush limit? read write; onfinal; track;
	    # destroy thread during channel access
	    testthread exit
	    return}
	set chan [chan push [tempchan] foo]
	fconfigure $chan -buffering none
	set chan
    }]

    # Move channel to 2nd thread, transform goes with it.
    testthread send $tida [list testchannel cut    $chan]
    testthread send $tidb [list testchannel splice $chan]

    # Run access from thread B, wait for response from A (A is not
    # using event loop at this point, so the event pile up in the
    # queue.

    testthread send $tidb [list set chan $chan]
    testthread send $tidb [list set mid $tcltest::mainThread]
    testthread send -async $tidb {
	# wait a bit, give the main thread the time to start its event
	# loop to wait for the response from B
	after 2000
	catch { puts $chan shoo } res
	catch { close $chan }
	testthread send -async $mid [list set ::res $res]
    }
    vwait ::res

    tcltest::threadReap
    tempdone
    set res
} -constraints {testchannel testthread} \
    -result {Owner lost}

# ### ### ### ######### ######### #########

# ### ### ### ######### ######### #########

rename track {}
cleanupTests
return