#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Tracing.tcl,v $
# $Date: 1997/02/18 16:37:45 $
# $Revision: 1.18.1.6 $
#
#
package provide Tracing 1.18
#
proc ircInput {mode conn} {
    global STN zircon fgo inexp1 inexp2 currentNet
    set net $STN($conn)
    if [catch {gets $conn} line] {
	zIn "**** Error on input ($line) eof = [eof $conn]" $net
	switch {socket is not connected} $line {
	    set line {connection request timed out}
 	}
	$net close $line
	return
    }
    if [eof $conn] {
	zIn "**** EOF from server." $net
	$net close
    } {
	zIn $line $net
	if ![regexp $inexp1 $line match prefix cmd b c d e param] {
	    if ![regexp $inexp2 $line match prefix cmd b] {
		switch {} $line {} default {
		    $net errmsg "Error on server connection - $line"
		}
		return
	    }
	    set param {}
	}
        set currentNet $net
	switch -glob $prefix {
	:* { }
	PING {
		$net qSend PONG :[string range $cmd 1 end]
		return
	    }
	ERROR {
		$net error {} [string range $line 7 end] {}
		return
	    }
	default { set prefix :[$net host] }
	}
	set pargs [safeClean [string range $b 1 end]]
	if [catch {irc$cmd $net $prefix $param $pargs} msg] {
	    zError $msg $cmd $prefix $param [string range $b 1 end]
	}
    }
}
#
proc net_send {this op args} {
    upvar #0 $this ndata
    switch {} $ndata(sock) {} default {
	set msg $op
	switch {} [set last :[lindex $args end]] {} default {
	    if ![catch {set foo [lreplace $args end end]}] {
		append msg " $foo $last"
	    }
	}
	zOut $msg $this
	if [catch {puts $ndata(sock) $msg}] { $this close }
    }
}
#
proc net_qSend {this op args} {
    upvar #0 $this ndata
    set msg "$op [join $args]"
    zOut $msg $this
    if [catch {puts $ndata(sock) $msg}] { $this close }
}
#
proc net_sendRaw {this value} {
    zOut $value $this
    upvar #0 ${this}(sock) sock
    switch {} $sock return
    if [catch {puts $sock $value} msg] {$this close $msg}
}
#
proc net_q1Send {this op} {
    upvar #0 $this ndata
    zOut $op $this
    if [catch {puts $ndata(sock) $op}] { $this close }
}
#
proc connect {host port} {
    global currentNet
    zOut "**** Connecting to $host:$port" $currentNet
    if [catch {socket $host $port} sk] {
	zOut "**** Connect error - $sk" $currentNet
	error $sk
    }
    sconf $sk
    return $sk
}
#
proc net_closeSock {this msg} {
    global ztrans
    upvar #0 $this ndata
    foreach x {monitorTest pingTest isonTest ircTests popQueue} {
	catch {after cancel "$this $x"}
    }
    set ctl [$this control]
    $ctl setQuit open "$ctl open"
    switch {} [set sock $ndata(sock)] {} default {
	set ndata(sock) {}
	set ndata(pinged) 0	
	switch {} $msg {} default {
	   zOut "QUIT :$msg" $this
	   catch {puts $sock "QUIT :$msg"}
	}
	catch {close $sock}
	$this inform "Connection to [$this host] closed"
    }
    retitleFrame .@inf [$this info] [$this name] 1
    retitleFrame .@ctl $this [$this name] 1
    zDBGRet $this
    if [winfo exists .@l$this] {
	catch {grab release .@l$this}
	catch {.@l$this configure -cursor arrow}
    }
}
#
proc net_queue {this req} {
    upvar #0 $this ndata
    if $ndata(antiflood) {
	switch {} $ndata(maxQueue) {} default {
	    if {$ndata(msgQLen) >= $ndata(maxQueue)} return
	}
	lappend ndata(msgQueue) $req
	incr ndata(msgQLen)
	switch {} $ndata(msgQTag) {
	    set ndata(msgQTag) [after $ndata(antiflood) "$this popQueue"]
	}
    } {
	zOut $msg $this
	if [catch {puts $ndata(sock) $req} msg] { $this close $msg }
    }
}
#
proc net_popQueue {this} {
    upvar #0 $this ndata
    set ndata(msgQTag) {}
    switch {} $ndata(sysQueue) {
	switch {} $ndata(msgQueue) return
	zOut [lindex $ndata(msgQueue) 0] $this
	if [catch {puts $ndata(sock) [lindex $ndata(msgQueue) 0]} msg] {
	    $this close $msg
	}
	set ndata(msgQueue) [lrange $ndata(msgQueue) 1 end]
	if [incr ndata(msgQLen) -1] {
	    set ndata(msgQTag) [after $ndata(antiflood) "$this popQueue"]
	}
    } default {
	zOut [lindex $ndata(sysQueue) 0] $this
	if [catch {puts $ndata(sock) [lindex $ndata(sysQueue) 0]} msg] {
	    $this close $msg
	}
	switch {} [set ndata(sysQueue) [lrange $ndata(sysQueue) 1 end]] { 
	    switch {} $ndata(msgQueue) return
	    set ndata(msgQTag) [after $ndata(antiflood) "$this popQueue"]
	} default {
	    set ndata(msgQTag) [after $ndata(sysQDelay) "$this popQueue"]
	}
    }
}
#
proc chat_action {this string} {
    notIdle {}
    switch {} $string return
    upvar #0 ${this}(sock) sock
    switch {} $sock {
	$this addText {} {*** Connection is closed!!!!}
    } default {
	if [catch {puts $sock "\001ACTION $string\001"} err] {
	    $this addText {} "*** Error : $err"
	} {
	    set net [$this net]
	    flush $sock
	    $this addText @me "* [$net nickname] $string"
	    zOut "= \001ACTION $string\001" [$this net]
	}
    }
}
#
proc chat_send {this string args} {
    notIdle {}
    switch {} $string return
    upvar #0 ${this}(sock) sock
    switch {} $sock {
	$this addText {} {*** Connection is closed!!!!}
    } default {
	if [catch {puts $sock $string} err] {
	    $this addText {} "*** Error : $err"
	} {
	    flush $sock
	    $this addText @me "= $string"
	    zOut "= $string" [$this net]
	}
    }
}
#
proc acceptChat {usr newc hst args} {
    set net [$usr net]
    upvar #0 AChat$net AChat
    [set cht [Chat [$usr name] -caller $usr]] show
    $cht addUser $usr 0 0
    upvar #0 $newc chdata
    $cht configure -sock $newc
    set chdata(who) $usr
    set chdata(obj) $cht
    fconfigure $newc -buffering none -blocking 0 -translation {auto lf}
    fileevent $newc readable "dccChat r $newc"
    catch {close $AChat($usr)}
    catch {unset AChat($usr)}
    $usr deref
    if [winfo exists .@dls$net] { buildDCCList $net }
    zIn "Chat Accept : [$usr name] on $hst" [$usr net]
}
