if {[package vcompare [package provide Tcl] 8] < 0} {
array set Tcl7.6_fcopy [list "" ""]
unset Tcl7.6_fcopy()
;proc Tcl7.6_fcopy {i o toCopy copied} {
global Tcl7.6_fcopy
fileevent $i readable {}
# We need our [fcopy] replacement to be "binary-safe".
# In Tcl 7.*, the only command which can perform a binary-safe output
# to a channel is [unsupported0].
if {[catch {unsupported0 $i $o 1} written]} {
set Tcl7.6_fcopy($i) [list $copied $written]
} elseif {$written == 0} {
# EOF on $i --> quit.
set Tcl7.6_fcopy($i) $copied
} else {
incr toCopy -$written
incr copied $written
if {$toCopy == 0} {
# Copy reqest completed.
set Tcl7.6_fcopy($i) $copied
} else {
# Keep working
fileevent $i readable [list Tcl7.6_fcopy $i $o $toCopy $copied]
}
}
}
;proc Tcl7.6_fcopyTrace {cmd n1 n2 op} {
set val [uplevel 1 [list set ${n1}($n2)]]
uplevel 1 [list unset ${n1}($n2)]
uplevel #0 $cmd $val
}
;proc fcopy {in out args} {
# Strange quirk: if [unsupported0] has negative request for number of
# bytes to copy, it will copy until EOF
set aa(-size) -1
array set aa $args
if {[catch {incr aa(-size) 0} msg]} {
return -code error "bad -size argument: $msg"
}
if {[info exists aa(-command)]} {
global Tcl7.6_fcopy
if {![string match "" [fileevent $in readable]]} {
return -code error "can't fcopy from $in in background;\
fileevent in use:\n[fileevent $in readable]"
}
fileevent $in readable [list Tcl7.6_fcopy $in $out $aa(-size) 0]
trace variable Tcl7.6_fcopy($in) w \
[list Tcl7.6_fcopyTrace $aa(-command)]
return {}
} else {
return [uplevel [list unsupported0 $in $out $aa(-size)]]
}
}
}Please ignore my previous attempt [1]. It was wrong, wrong wrong. DGPAMG: Link broken.
