#! /usr/local/bin/scotty -inf
##
## Command to examine bones objects from within tkined.
##
## Copyright (c) 1993, 1994
##
## J. Schoenwaelder
## TU Braunschweig, Germany
## Institute for Operating Systems and Computer Networks
##
## Permission to use, copy, modify, and distribute this
## software and its documentation for any purpose and without
## fee is hereby granted, provided that this copyright
## notice appears in all copies.  The University of Braunschweig
## makes no representations about the suitability of this
## software for any purpose.  It is provided "as is" without
## express or implied warranty.
##

if {[lsearch [info commands] bones] < 0} {
    ined acknowledge "Sorry, this version of scotty has no bones support."
    exit
}

LoadDefaults bones

##
## Set up some default parameters.
##

if {[info exists default(server)]} {
    bones server $default(server)
}

if {[info exists default(directory)]} {
    bones path $default(directory)
}

##
## Two small procs to access and change a single attribute of an
## object. Here and objects is the representation of a bones object
## as a TCL list. Always use these procs to modify TCL bones objects!
##

proc Lock { args } {
    if {[catch {
	foreach class [join $args] {
	    bones lock $class
	}
    } error]} {
	error $error
    }
}

proc Unlock { args } {
    catch {
	foreach class $args {
            bones unlock $class
        }
    }
}

##
## This one should be replaced by making some more schema information
## available from the bones system.
##

proc GetShortKey { class object } {

    foreach attr [bones attributes $class] {
	set name [lindex $attr 0]
	set opts [lindex $attr 2]
	if {[lsearch $opts key] >= 0} {
	    append txt "[$object $name] "
	}
    }

    if {[info exists txt]} { 
	return $txt 
    } else { 
	return $object 
    }
}

##
## Display an attribute of the given object. Retrieve the readable short
## key if the reference class is not empty.
##

proc MakeDisplay { class object attribute {type ""} } {

    set val [$object $attribute]

    if {$type == "date"} { 
	set val [list [getdate $val] ]
    }

    if {[lsearch [bones classes] $type] >= 0} {
	set refclass $type
    } else {
	set refclass ""
    }

    if {$refclass == ""} {
	set newval $val
    } else {
	set newval ""
	foreach one [split $val ,] {
	    if {[catch {bones retrieve $refclass $one} obj]} {
		set refclass ""
		lappend newval $one
	    } else {
		lappend newval [GetShortKey $refclass $obj]
	    }
	}
    }

    write [format "  %-16s: " $attribute ]
    set idx 0
    foreach one $newval {
	set one [string trim $one]
	if {$idx > 0} {
	    write ", "
	}
	if {$idx % 5 == 4} {
	    writeln
	    write [format "  %-16s " " "]
	}
	if {$refclass == ""} {
	    write "$one"
	} else {
	    set oid [lindex [split $val ,] $idx]
	    write "$one" "DisplayInstance $refclass $oid"
	}
	incr idx
    }
    writeln
}

##
## Get a list of all objects in a given class. Make a projection
## on the attributes.
##

proc InspectClass { class } {

    if {[catch {
        bones forallobjects object $class {
            set oid [$object oid]
            set key($oid) [GetShortKey $class $object]
        }
    } error]} {
        ined acknowledge "Could not load instances of class $class:" "" $error
	return
    }

    if {![info exists key]} {
        ined acknowledge "No instances found in class $class."
	return
    }

    foreach oid [array names key] {
	lappend keylist $key($oid)
	lappend oidlist $oid
    }
    set count [llength $keylist]

    set sel [ined list "$count $class objects" [lsort $keylist] \
	       [list inspect cancel] ]

    if {[lindex $sel 0] == "cancel"} return

    set idx [lsearch $keylist [lindex $sel 1]]
    set oid [lindex $oidlist $idx]

    DisplayInstance $class $oid
}

##
## Display a single instance.
##

proc DisplayInstance { class oid } {

    if {[catch {bones lock $class} error]} {
        ined acknowledge "Can not access bones server:" "" $error
    }

    if {[catch {bones retrieve $class $oid} object]} {
	ined acknowledge "Can not retrieve object:" "" $object
    }

    set classes [bones classes]
    set opened $class
    foreach attr [bones attributes $class] {
	set type [string trimright [lindex $attr 1] "\[\]"]
	if {[lsearch -glob $classes $type] >= 0} {
	    catch {bones lock $type}
	    lappend opened $type
	}
    }

    writeln "Instance $oid of class $class:"

    if {[lsearch [info procs] $class::display] < 0} {
	foreach attr [bones attributes $class] {
	    set name [lindex $attr 0]
	    set type [string trimright [lindex $attr 1] "\[\]"]
	    MakeDisplay $class $object $name $type
	}
    } else {
	$class::display $object
    }

    writeln

    foreach one $opened {
	catch {bones unlock $one}
    }
}

##
## Get the oid for a node object. First check if the IP address
## can be found in the IPInterface class. If this fails, check
## if the name can be found in the IPInterface class. If this 
## fails, check if the name can be found in the Device class.
##

proc GetNodeOid { comp } {

    set ip [GetIpAddress $comp]
    set name [ined name $comp]
    set oid  ""

    if {! [catch {Lock IPInterface}]} {
	bones forallobjects object IPInterface {
	    if {[$object address] == $ip} {
                set oid [$object device]
                break
            }
	}
	bones forallobjects object IPInterface {
            if {[$object name] == $name} {
                set oid [$object device]
                break
            }
        }
	Unlock IPInterface
    }

    if {$oid != ""} {
	return $oid
    }

#    if {! [catch {Lock Device}]} {
#	bones forallobjects object Device {
#	    if {[$object name] == $name} {
#                set oid [$object oid]
#		break
#	    }
#	}
#    }

    return $oid
}

proc GetGroupOid { comp } {
    writeln "GetGroupOid: not yet available"
    return ""
}

proc GetNetworkOid { comp } {
    writeln "GetNetworkOid: not yet available"
    return ""
}

proc "Info" { list } {

    foreach comp $list {

	switch [ined type $comp] {
	    NODE {
		set oid [GetNodeOid $comp]
		set class Device
	    }
	    GROUP {
		set oid [GetGroupOid $comp]
		set class Netgroup
	    }
	    NETWORK {
		set oid [GetNetworkOid $comp]
		set class IPNetwork
	    }
	    default {
		return
	    }
	}

	if {$oid == ""} {
	    ined acknowledge "No OID found for [ined name $comp]."
	    return
	}

	DisplayInstance $class $oid
    }
}

##
## Run the database consistency checker and write the output in
## a log window for examination.
##

proc "Check Integrity" {list} {

    global env
    
    if {[catch {split $env(PATH) :} path]} {
        set path "/usr/bin /bin /usr/local/bin /etc /usr/etc /usr/local/etc"
    }

    set checker ""
    foreach dir $path {
	if {[file executable $dir/checker]} {
	    set checker $dir/checker
	    break
	}
    }

    if {$checker == ""} {
        ined acknowledge "Sorry, can not find checker program."
        return
    }

    set result [ined request "Select checking level:" \
		  [list [list "Level:" high radio low medium high] ] \
		  [list start cancel] ]

    if {[lindex $result 0] == "cancel"} return

    switch [lindex $result 1] {
	low {
	    set level ""
	}
	medium {
	    set level "-l"
	}
	high {
	    set level "-l -l"
	}
    }

    set f [open "| $checker -v $level"]
    while {![eof $f]} {
	gets $f line
	writeln $line
    }
}

##
## Inspect that details of a class.
##

proc ClassDefinition { class } {
    set parent [bones parent $class]
    write "$class OBJECT CLASS SUBCLASS of "
    if {[lsearch [bones classes] $parent] < 0} {
	write $parent
    } else {
	write $parent "ClassDefinition $parent"
    }
    writeln
    foreach attr [bones attributes $class] {
	set name [lindex $attr 0]
	set type [lindex $attr 1]
	set opts [lindex $attr 2]
	if {[lsearch [bones classes] [string trim $type "\[\]"]] < 0} {
	    writeln [format "    %-16s :: %-12s %s" $name $type $opts]
	} else {
	    write   [format "    %-16s :: " $name]
	    write   $type "ClassDefinition $type"
	    writeln " $opts"
	}
    }
    writeln
}

##
## Set the parameter that control bones server access.
##

proc "Set Parameter" { list } {

    set server [bones server]
    set path [bones path]

    set result [ined request "Set bones rgdbm server:" \
		 [list [list "Server Host:" $server ] \
		       [list "Server Directory:" $path ] ] \
		 [list "set values" cancel] ]

    if {[lindex $result 0] == "cancel"} return

    bones server [lindex $result 1]
    bones path   [lindex $result 2]
}

##
## Delete the Tool and exit the interpreter.
##

proc "Delete BONES" {list} {
    global menus
    foreach id $menus { ined delete $id }
    exit
}

##
## Create the menu and wait for something to happen...
##

set cmds [list "Check Integrity" "" ]

foreach class [bones classes] {
    set procname "*$class"
    proc $procname { args } [list ClassDefinition $class]
    set nm ":$procname"
    set parent [bones parent $class]
    while {[lsearch [bones classes] $parent] >= 0} {
	set nm ":$parent$nm"
	set parent [bones parent $parent]
    }
    lappend cmds "Definition$nm"
}
foreach class [bones classes] {
    set procname "+$class"
    proc $procname { args } [list InspectClass $class]
    set nm ":$procname"
    set parent [bones parent $class]
    while {[lsearch [bones classes] $parent] >= 0} {
        set nm ":$parent$nm"
        set parent [bones parent $parent]
    }
    lappend cmds "Instances$nm"
}
lappend cmds ""

set cmds [concat $cmds [list "Info" "" "Set Parameter" "" "Delete BONES"]]

set menus [eval ined create MENU BONES $cmds]
