======
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
[http://groups.google.com/groups?threadm=906n2e%24nsq%241%40bob.news.rcn.net].
It was wrong, wrong wrong.
'''DGP'''

<<categories>> Porting | Oldies