#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Tracing.tcl,v $
# $Date: 2002/01/18 12:22:24 $
# $Revision: 1.18.1.43 $
#
#
package provide Tracing 1.18
#
proc ircInput {unusedmode conn} {
    global STN zircon 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 on $conn" $net
	$net doClose $conn
	switch $conn [$net sock] { $net close }
    } {
	zIn "$conn: $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 q1Send "PONG :[string range $cmd 1 end]"
		return
	    }
	ERROR {
		switch {} [$net closing] {
		    $net error {} [string range $line 7 end] {}
		} default {
		    $net doClose $conn
		}
		return
	    }
	NOTICE {
		set prefix :[$net host]
		set b $cmd
		set cmd NOTICE
	    }
	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
    if {$ndata(sock) == {}} { return 1 }
    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} err]} { $this close $err ; return 1}
    return 0
}
#
proc net_qSend {this op args} {
    upvar #0 $this ndata
    set msg "$op [join $args]"
    zOut $msg $this
    if {[catch {puts $ndata(sock) $msg} err]} {
        $this close $err
	return 1
    }
    return 0
}
#
proc net_sendRaw {this value} {
    upvar #0 ${this}(sock) sock
    switch {} $sock {} default {
	zOut $value $this
        if {[catch {puts $sock $value} msg]} {$this close $msg ; return 1}
    }
    return 0
}
#
proc net_q1Send {this op} {
    upvar #0 $this ndata
    zOut $op $this
    if {[catch {puts $ndata(sock) $op} err]} { $this close $err ; return 1}
    return 0
}
#
proc net_connect {this host port} {
    zOut "**** Connecting to $host:$port" $this
    if {[catch {[$this sockcmd] $host $port} sk]} {
	zOut "**** Connect error - $sk" $this
	error $sk
    }
    zOut "**** Connected to $host:$port" $this
    sconf $sk {}
    return $sk
}
#
proc net_doClose {this sock} {
    switch {} $sock return
    upvar #0 $this ndata
    zOut "**** Closing connection on $sock" $this
    if {[catch {close $sock} msg]} { zOut "Error closing $sock - $msg" $this }
    switch $sock $ndata(sock) {
	$this inform "Disconnected from [$this host]"
    }
    switch {} $ndata(closing) {} default {
	catch {after cancel $ndata(closing)}
	set ndata(closing) {}
    }
}
#
proc net_closeSock {this msg} {
    upvar #0 $this ndata MkOp$this MkOp
    foreach x {monitorTest pingTest isonTest ircTests popQueue} {
	catch {after cancel "$this $x"}
    }
    catch {unset MkOp}
    set ctl [$this control]
    $ctl setQuit open "$ctl open"
    switch {} [set sock $ndata(sock)] {} default {
	set ndata(sock) {}
	set ndata(pinged) 0	
	switch {} $msg {
	    $this doClose $sock
	} default {
	    zOut "QUIT :$msg" $this
	    catch {puts $sock "QUIT :$msg"}
	    set ndata(closing) [after $ndata(quitwait) "$this doClose $sock"]
	}
    }
    if {!$ndata(integrate)} {
        retitleFrame [MainInfo] [$this info] [$this name] $this 1
    }
    retitleFrame [MainControl] $this [$this name] $this 1
    zDBGRet $this
    [$this listid] release
}
#
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 $req $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 {} [$this net]
    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 {} [set net [$this net]]
    switch {} $string return
    upvar #0 ${this}(sock) sock
    $this addHist $string
    switch {} $sock {
	$this addText {} {*** Connection is closed!!!!}
    } default {
	if {[catch {puts $sock $string} err]} {
	    $this addText {} "*** Error : $err"
	} {
	    flush $sock
	    regsub -all %n [$this mytag] [[$net myid] name] pr
	    $this addText @me "$pr $string"
	    zOut "= $string" $net
	}
    }
}
#
proc acceptChat {usr newc hst args} {
    set net [$usr net]
    upvar #0 AChat$net AChat
    [set cht [$net eval "Chat [list [$usr name]] -caller $usr"]] show
    $cht addUser $usr 0 0
    upvar #0 $newc chdata
    $cht configure -sock $newc
    set chdata(who) [$usr ref]
    set chdata(obj) $cht
    fconfigure $newc -buffering none -blocking 0 -translation auto
    fileevent $newc readable "dccChat r $newc"
    if {[catch {close $AChat($usr)} msg]} { zIn "Error : $msg" }
    if {[catch {unset AChat($usr)} msg]} { zIn "error : $msg" }
    if {[winfo exists .@dls$net]} { buildDCCList $net }
    zIn "Chat Accept : [$usr name] on $hst" [$usr net]
}
