Tcl Source Code

Artifact d02ff179d192d51d696d079c1150872a264f7402:

proc connect {socket ip port} {
    fconfigure $socket -translation binary -blocking 0
    fileevent $socket readable [list startCopy $socket]
}

proc startCopy {socket} {
    fileevent $socket readable {}

    file delete -force tempFile
    set f [open tempFile w]
    fconfigure $f -translation binary

    set input [read $socket 4]
    binary scan $input i size    

    variable fSize $size

    puts "server: copying $fSize bytes to tempFile"
    fcopy $socket $f -size $fSize -command [list doneCopy $fSize]
}

proc doneCopy {size written {msg {}}} {
    puts stderr "server: copied  $written bytes to tempFile."
    if {($size != $written) || ($size != [file size tempFile])}  {
        puts stderr "server: bytes written ?? ([file size tempFile] ?= $written ?= $size)"
    }
    if {[string length $msg]} {
        puts stderr "Copy error: $msg"
    }
    puts "server: all done"
    exit
}

set count 0
proc clientMsg {fd} {
    if {[gets $fd msg] != -1} {
	puts $msg
	incr ::count
    }
    if {$::count == 2} {
	variable fSize
	set rfSize [file size tempFile]
	puts "server: \[fcopy\] wanted $fSize, and got $rfSize"
	if {$fSize == $rfSize} {
	    puts "server: \[fcopy\] doesn't tell us we are finished, exit anyway"
	}
	exit
    }
}

proc startClient {size} {
    global client
    set client [open |[info nameofexecutable] w+]
    fconfigure $client -blocking 0 -buffering none
    fileevent $client readable [list clientMsg $client]
    puts $client [string map [list %EXP% $size] {
	set wait 10000
	fconfigure stdout -buffering line
	set data [binary format i 1]
	set exp %EXP%
	while {[incr exp -1]} {
	    append data $data
	}
	set sock [socket localhost 5000]
	fconfigure $sock -translation binary
	puts -nonewline $sock [binary format i [string length $data]]
	puts -nonewline $sock $data

	###
	### Uncomment the line below tomake the bug go away
	###
	#puts -nonewline $sock "\0"

	flush $sock
	puts "client: done sending"
	after 10000 [list puts "client: won't wait anymore ..."]
	vwait forever
    }]
}

puts "[info nameofexecutable] - [info patchlevel]"
socket -server connect 5000

set exp [lindex $argv 0]
if {[catch {incr exp 0}]} {
    set exp 13
}
startClient $exp

vwait forever