#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Server.tcl,v $
# $Date: 2001/06/13 07:20:27 $
# $Revision: 1.18.1.35 $
#
#
package provide zircon 1.18
#
proc Server {name args} {
    switch -- $name :: {return [eval Server_[lindex $args 0] [lrange $args 1 end]]}
    switch -glob -- $name -* {
	set args [linsert $args 0 $name]
	set name [newName _srv]
    }
    set this [makeObj Server $args]
    global currentNet
    upvar #0 STO$currentNet STO $this sdata
    array set sdata "
	name	[list $name]
	net	$currentNet
    "
    $currentNet register servers $this
    switch -- $sdata(name) $sdata(host) {set sdata(name) [newName _srv]}
    set STO([string tolower $sdata(name)]) $this
    return $this
}
#
proc server_nextPort {this} {
    upvar #0 $this sdata
    set x [lsearch $sdata(port) $sdata(selport)]
    switch {} [set np [lindex $sdata(port) [incr x]]] { return {} }
    set sdata(selport) $np
    return $np
}
#
proc server_configure {this args} {
    upvar #0 $this sdata
    foreach {opt val} $args {
	switch -exact -- $opt {
	+port {
	    if {![listmember $sdata(port) $val]} {
	        lappend sdata(list) $val
		set sdata(port) [lsort -integer $sdata(port)]
	    }
	    set sdata(selport) $val
	}
	-port {
		set sdata(port) {}
		regsub -all {,} $val { } val
		foreach x $val {
		    if {[regexp {^([0-9]+)-([0-9]+)$} $x m st fn]} {
			if {$fn < $st} {
			    set a $fn
			    set fn $st
			    set st $a
			}
			for {} {$st <= $fn} {incr st} {
			    lappend sdata(port) $st
			}
		    } {
			lappend sdata(port) $x
		    }
		}
		set sdata(port) [lsort -integer $sdata(port)]
		set sdata(selport) [lindex $sdata(port) 0]
	    }
	-host { set sdata(host) [string tolower $val] }
	default { set sdata([string range $opt 1 end]) $val }
	}
    }
}
#
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 [list Server -host [$id host]]
	switch 6667 [set pl [$id port]] {} default {
	    if {[llength $pl] > 1} {
		set lst [set start [lindex $pl 0]]
		set npl $start
		foreach x [lrange $pl 1 end] {
		    switch [incr start] $x {} default {
		    	incr start -1
			switch $start $lst {
			    append npl " $x"
			} default {
			    append npl "-$start $x"
			}
			set lst [set start $x]
		    }
		}
		switch $lst $start {} default {
		    append npl "-$start"
		}
		set pl "{$npl}"
	    }
	    append ln " -port $pl"
	}
	foreach x {ip oper operpw script passwd} {
	    switch {} [set y [$id $x]] {} default {append ln " -$x [list $y]"}
	}
	foreach x {invisible wallops srvmsg undernet} {
	    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 {net host} {
    switch nil [set s [Server :: find $host $net]] {
	set s [$net eval [list Server -host $host]]
    }
    return $s
}
#
proc server_pack {this net} {
    upvar #0 new$this new ${net}STO STO
    foreach v {host port ip oper operpw script name passwd invisible wallops srvmsg} {
	set new($v) [$this $v]
    }
    set STO([string tolower [$this name]]) $this
}
#
proc server_unpack {this net} {
    upvar #0 new$this new ${net}STO STO
    foreach v {host port ip 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 $net new
}
#
proc Server_cleanup {net where} {
    foreach x [$net servers] { safeUnset ${where}$x }
}
#
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
}