#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Server.tcl,v $
# $Date: 1997/02/13 11:32:48 $
# $Revision: 1.18.1.16 $
#
#
package provide zircon 1.18
#
proc Server {name args} {
    switch -- $name :: {return [eval Server_[lindex $args 0] [lrange $args 1 end]]}
    set this [objName Server]
    initObj $this Server
    global currentNet
    upvar #0 STO$currentNet STO $this sdata
    switch -glob -- $name -* {
	set args [linsert $args 0 $name]
	set name [newName _srv]
    }
    set sdata(name) $name
    set sdata(host) $name
    set sdata(net) $currentNet
    $currentNet register servers $this
    proc $this {args} "eval server_call $this \$args"
    eval $this configure $args
    switch -- $sdata(name) $sdata(host) {set sdata(name) [newName _srv]}
    set STO([string tolower $sdata(name)]) $this
    return $this
}
#
proc server_configure {this args} {
    upvar #0 $this sdata
    while {![string match {} $args]} {
	set opt [lindex $args 0]
	set val [lindex $args 1]
	switch -exact -- $opt {
	-port {
		set sdata(port) {}
		foreach x $val {
		    if [regexp {^([0-9]+)-([0-9]+)$} $x m st fn] {
			for {} {$st <= $fn} {incr st} {
			    lappend sdata(port) $st
			}
		    } {
			lappend sdata(port) $x
		    }
		}
	    }
	-host { set sdata(host) [string tolower $val] }
	default {
		set sdata([string range $opt 1 end]) $val
	    }
	}
	set args [lrange $args 2 end]
    }
}
#
proc server_call {this op args} {
   upvar #0 $this sdata
   if [info exists sdata($op)] { return $sdata($op) }
   return [eval server_$op $this $args ]
}
#
proc server_delete {this} {
    uplevel #0 unset STO\${currentNet}([string tolower [$this name]]) $this
    uplevel #0 \$currentNet deregister servers $this
    rename $this {}
}
#
proc Server_select {host} {
    global zircon currentNet
    switch nil [set hst [Server :: find $host $currentNet]] {
	tellError {} {Server Host Error} "Cannot find host - $host"
    } default {
	$currentNet configure -hostid $hst
    }
}
#
proc Server_save {desc net} {
    set cm 1
    set sid 1
    foreach id [$net servers] {
	if [$id sys] continue
	set n [$id name]
	set nmap($n) $sid
	switch default $n continue
	set ln "Server -host [list [$id host]]"
	switch 6667 [$id port] {} default {append ln " -port [$id port]"}
	foreach x {oper operpw script passwd} {
	    switch {} [set y [$id $x]] {} default {append ln " -$x [list $y]"}
	}
	foreach x {invisible wallops srvmsg} {
	    if [$id $x] { append ln " -$x 1" }
	}
	if $cm { puts $desc "#\n# Servers\n#" ; set cm 0 }
	puts $desc $ln
	incr sid
    }
    switch nil [set hst [$net hostid]] {
	if {[llength [Net :: list]] > 1 &&
	  [string compare default [set nn [$net name]]]} {
	    tellError {} Warning \
		"You have no default server selected for netspace $nn!"
	}
    } default {
	if {![$hst sys] && [string compare default [$hst name]]} {
	    puts $desc "Server :: select [list [$hst host]]"
	}
    }
}
#
proc Server_make {host args} {
    set net [switch {} $args {global currentNet ; set currentNet} default {lindex $args 0}]
    switch nil [set s [Server :: find $host $net]] {set s [$net eval "Server [list -host $host]"]}
    return $s
}
#
proc server_pack {this net} {
    upvar #0 new$this new
    foreach v {host port oper operpw script name passwd invisible wallops srvmsg} {
	set new($v) [$this $v]
    }
    global ${net}STO
    set ${net}STO([string tolower [$this name]]) $this
}
#
proc server_unpack {this net} {
    upvar #0 new$this new ${net}STO STO
    foreach v {host port oper operpw passwd script invisible wallops srvmsg} {
	$this configure -$v $new($v)
    }
    unset STO([string tolower $new(name)]) new
}
#
proc Server_pack {net} {
    foreach s [$net servers] { if ![$s sys] { $s pack $net} }
}
#
proc Server_unpack {net} {
    upvar #0 ${net}STO newst
    foreach s [array names newst] { $newst($s) unpack $net}
    Server :: cleanup new
}
#
proc Server_cleanup {where} { }
#
proc Server_find {name net} {
    upvar #0 STO$net STO
    set name [string tolower $name]
    if [info exists STO($name)] { return $STO($name) }
    foreach x [array names STO] {
	switch -- [$STO($x) host] $name {return $STO($x)}
    }
    return nil
}
