#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/dbgsrv.tcl,v $
# $Date: 2001/07/10 15:36:13 $
# $Revision: 1.18.1.14 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide Debug 1.18
#
proc DebugServer {w} {
    global zircsrv zircon zircsin
    if {[catch {socket -server acceptIRC 6667} zircsrv]} { return 0 }
    $w configure -state disabled
    set ctl [makeToplevel .@dbgsrv "Zircon Dummy Server" "DSClose $w $ctl" {}]
    set f [frame $ctl.btn]
    button $f.stop -text Stop -command "DSClose $w $ctl" -width 8
    button $f.close -text Close -width 8 -command {
	catch {close $zircsin}
	set zircsin {}
	foreach x {btn.quit btn.cnct btn.join entry} {
	    .@dbgsrv.$x configure -state disabled
	}
    }
    grid $f.stop $f.close -sticky ew
    grid $f -sticky ew
    grid [frame $ctl.l1 -background $zircon(sepColor) -borderwidth 2] -sticky ew -pady 4
    grid [set f [frame $ctl.resp]] -sticky ew
    grid [menubutton $f.cnct -text Connect -menu $f.cnct.menu -state disabled] -sticky ew
    set m [menu $f.cnct.menu]
    $m add command -label Accept -command "DSAccept $ctl.txt"
    $m add command -label Unavailable -command "DSUnavailable $ctl.txt ztest"
    grid [button $f.quit -text Quit -command "QuitEm $ctl.txt #ztest ztest" -state disabled] -row 0 -column 1 -sticky ew
    grid [menubutton $f.join -text Join -menu $f.join.menu -state disabled] -row 0 -column 2 -sticky ew
    set m [menu $f.join.menu]
    $m add command -label Join -command "DSJoin1 $ctl.txt #ztest ztest"
    $m add command -label Join1 -command "DSJoin2 $ctl.txt #ztest ztest1"
    $m add command -label Unavailable -command "DSUnavailable $ctl.txt #ztest"
    grid [frame $ctl.l2 -background $zircon(sepColor) -borderwidth 2]\
       -sticky ew -pady 4
    set f [frame $ctl.txt]
    grid columnconfigure $f 0 -weight 1
    grid rowconfigure $f 0 -weight 1
    scrollbar $f.vs -command "$f.txt yview"
    scrollbar $f.hs -command "$f.txt xview" -orient horizontal
    text $f.txt -xscrollcommand "$f.hs set" -yscrollcommand "$f.vs set" \
      -wrap none
    $f.txt tag configure out -foreground red
    $f.txt tag configure in -foreground blue
    grid $f.txt -row 0 -column 0 -sticky nsew
    grid $f.vs -column 1 -row 0 -sticky ns
    grid $f.hs -column 0 -row 1 -sticky ew
    grid $f -sticky nsew
    emacsEntry $ctl.entry -relief sunken -state disabled
    grid $ctl.entry -sticky ew
    bind $ctl.entry <Return> "DSPut $f \[%W get\] ; %W delete 0 end"
    return 1
}
#
proc DSPut {w txt} {
    global zircsin
    if {![string match :* $txt]} { set txt ":[info hostname] $txt" }
    puts $zircsin $txt
    $w.txt insert end <$txt out "\n"
    $w.txt see end
}
#
proc DSClose {w ctl} {
    global zircsrv zircsin
    catch {close $zircsrv}
    catch {close $zircsin}
    set zircsrv {}
    destroy $ctl
    $w configure -state normal
}
#
proc acceptIRC {s x y} {
    global zircsin
    set zircsin $s
    .@dbgsrv.txt.txt insert end "*** request from $x $y" in "\n"
    .@dbgsrv.txt.txt see end
    fileevent $zircsin readable "dbgSIN $s"
    fconfigure $s -blocking 0 -translation {lf lf} -buffering line
    foreach x {btn.quit btn.cnct btn.join entry} {
	.@dbgsrv.$x configure -state normal
    }
}
#
proc dbgSIN {sock} {
    if {[eof $sock]} {
	close $sock
	.@dbgsrv.txt.txt insert end {**** Connection closed} in "\n"
    } {
	set line [gets $sock]
	.@dbgsrv.txt.txt insert end >$line in "\n"
    }
   .@dbgsrv.txt.txt see end
}
#
proc DSAccept {w} {
    set h [info hostname]
    set v 1.1
    DSPut $w {001 ztest :Welcome to the Zircon Test Harness ztest}
    DSPut $w "002 ztest :Your host is $h, running version $v"
    DSPut $w {003 ztest :This server was created sometime}
    DSPut $w "004 ztest $h $v oiwsg biklmnopstv"
    DSPut $w {251 ztest :There are 2707 users and 358 invisible on 27 servers}
    DSPut $w {252 ztest 14 :operator(s) online}
    DSPut $w {253 ztest 2 :unknown connection(s)}
    DSPut $w {254 ztest 994 :channels formed}
    DSPut $w {255 ztest :I have 1 clients and 0 servers}
    DSPut $w "375 ztest :- $h Message of the Day - "
    DSPut $w {372 ztest :- Welcome to the zircon test harness}
    DSPut $w {372 ztest :- Rules:}
    DSPut $w {376 ztest :End of /MOTD command.}
}
#
proc DSUnavailable {w nk} {
     DSPut $w "437 ztest $nk :temporarily unavailable"
}
#
proc DSJoin1 {w chn nk} {
    DSPut $w ":$nk!nlfm@catless.ncl.ac.uk JOIN :$chn"
    DSPut $w "353 $nk = $chn :@$nk "
    for {set i 0} {$i < 100} {incr i} {DSPut $w "353 $nk = $chn :user$i"}

    DSPut $w "366 $nk $chn :End of /NAMES list."
}
#
proc DSJoin2 {w chn nk} {
    DSPut $w ":$nk!nlfm@catless.ncl.ac.uk JOIN :$chn"
    DSPut $w "353 $nk = $chn :@$nk fred1 fred2 fred3"
    DSPut $w "353 $nk = $chn :@user2 user3 user4 user5 user6 user7 user8"
    DSPut $w "366 $nk $chn :End of /NAMES list."
}
#
proc QuitEm {w chn nk} {
    for {set i 0} {$i < 100} {incr i} {DSPut $w ":user$i!foo@bar QUIT $chn :a.b c.d"}
}