initial commit
This commit is contained in:
l_samenv
406
tcl/startup/hdb.tcl
Normal file
406
tcl/startup/hdb.tcl
Normal file
@@ -0,0 +1,406 @@
|
||||
set hl_showhidden 0
|
||||
set hl_showprop 0
|
||||
|
||||
proc hl {{path "/"} {prefix ""}} {
|
||||
global hl_showhidden hl_showprop
|
||||
switch -- $path {
|
||||
-p {
|
||||
set hl_showprop 1
|
||||
clientput "show properties"
|
||||
return
|
||||
}
|
||||
-h {
|
||||
set hl_showhidden 1
|
||||
clientput "show hidden nodes"
|
||||
return
|
||||
}
|
||||
-s {
|
||||
set hl_showhidden 0
|
||||
set hl_showprop 0
|
||||
clientput "short listing"
|
||||
return
|
||||
}
|
||||
}
|
||||
if {"[string index $path end]" != "/"} {
|
||||
append path /
|
||||
set nest 0
|
||||
} else {
|
||||
set nest 1
|
||||
}
|
||||
set node [lindex [split $path /] end-1]
|
||||
if {[string equal "" $node]} {
|
||||
set node "/"
|
||||
}
|
||||
set prop [split [hlistprop $path] "\n"]
|
||||
if {! $hl_showhidden && $nest} {
|
||||
foreach p $prop {
|
||||
if {[string equal visible=false $p]} {
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
scan [hinfo $path] {%[a-z],%d,%d} type children length
|
||||
switch $type {
|
||||
text - float - int - none {
|
||||
clientput "$prefix$node ($type) [silent -9e-9 hvali $path]"
|
||||
}
|
||||
default {
|
||||
clientput "$prefix$node ($type)"
|
||||
}
|
||||
}
|
||||
if {$hl_showprop || ! $nest} {
|
||||
foreach p $prop {
|
||||
clientput "$prefix $p"
|
||||
}
|
||||
}
|
||||
if {$children > 0 && $nest} {
|
||||
set nodes [split [hlist $path]]
|
||||
foreach n $nodes {
|
||||
if {! [string equal "" $n]} {
|
||||
hl $path$n/ "$prefix "
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
publishLazy hl spy
|
||||
|
||||
proc hdbItem {path title} {
|
||||
set cmd [silent 0 hgetpropval $path sicscommand]
|
||||
scan [hinfo $path] {%[a-z],%d,%d} type children length
|
||||
if {![string equal 0 $cmd]} {
|
||||
switch $type {
|
||||
text - float - int - func {
|
||||
set label [silent 0 hgetpropval $path label]
|
||||
if {$label ne 0} {
|
||||
set title $label
|
||||
}
|
||||
set help [silent 0 hgetpropval $path help]
|
||||
if {! [string equal 0 $help]} {
|
||||
foreach line [split $help "\n"] {
|
||||
clientput "-H$line"
|
||||
}
|
||||
}
|
||||
if {[silent 0 hgetpropval $path newline]} {
|
||||
clientput "-P"
|
||||
}
|
||||
if {[silent 0 hgetpropval $path nonewline]} {
|
||||
clientput "--"
|
||||
}
|
||||
set priv [silent internal hgetpropval $path priv]
|
||||
set buttons [silent "" hgetpropval $path buttons]
|
||||
set val ""
|
||||
if {[string match "run *" $cmd]} {
|
||||
set val [silent "" hgetpropval $path target]
|
||||
set cmd2 [string range $cmd 4 end]
|
||||
set val [silent $val result $cmd2 target]
|
||||
clientput "-P"
|
||||
} elseif {$type eq "func"} {
|
||||
clientput "-T$title"
|
||||
clientput "-B $cmd"
|
||||
clientput "--"
|
||||
return
|
||||
} else {
|
||||
set cmd2 ""
|
||||
if {[catch {set val [result $cmd]} msg]} {
|
||||
if {$msg eq "ERROR: not read yet"} {
|
||||
set val ""
|
||||
} else {
|
||||
clientput "-SW"
|
||||
clientput "-L${title}:[string map {"ERROR:" ""} $msg]"
|
||||
return 1
|
||||
}
|
||||
}
|
||||
}
|
||||
set graph 1
|
||||
if {$buttons ne ""} {
|
||||
set priv internal
|
||||
clientput "-P"
|
||||
}
|
||||
switch $priv {
|
||||
user - spy {
|
||||
set val [silent $val hgetpropval $path requested]
|
||||
set val [silent $val hgetpropval $path secoprequested]
|
||||
set enum [silent "" hgetpropval $path enum]
|
||||
if {$enum eq ""} {
|
||||
# experimental
|
||||
set vlist [silent 0 hgetpropval $path vlist]
|
||||
if {$vlist ne "0"} {
|
||||
set title "$title ([lindex [split $vlist ,] $val])"
|
||||
}
|
||||
clientput "-T$title"
|
||||
clientput "-V$val"
|
||||
set wid [silent 0 hgetpropval $path width]
|
||||
if {$wid != 0} {
|
||||
clientput "-W$wid"
|
||||
}
|
||||
clientput "-I$cmd"
|
||||
} elseif {$enum eq "1"} {
|
||||
clientput "-T$title"
|
||||
clientput "-V$val"
|
||||
clientput "-C$cmd"
|
||||
} elseif {$enum eq "push"} {
|
||||
clientput "-T[silent $title hgetpropval $path buttontitle]"
|
||||
# space after B because BC,BD,BS have special meaning
|
||||
clientput "-B $cmd 1"
|
||||
} else {
|
||||
if {[silent 1 hgetpropval $path newline]} {
|
||||
clientput "-P"
|
||||
}
|
||||
if {$label ne 0} {
|
||||
clientput "-L$label"
|
||||
clientput "--"
|
||||
}
|
||||
clientput "-V[lindex $val end]"
|
||||
clientput "-R$cmd"
|
||||
set enumsplit [silent "" hgetpropval $path enumsplit]
|
||||
if {$enumsplit ne ""} {
|
||||
foreach split_val [split $enumsplit ,] {
|
||||
set enumsplit_at($split_val) 1
|
||||
}
|
||||
}
|
||||
set idx 0
|
||||
foreach item [split $enum ,] {
|
||||
lassign [split $item =] nam num
|
||||
if {$num eq ""} {
|
||||
set num $idx
|
||||
} else {
|
||||
set idx $num
|
||||
}
|
||||
incr idx
|
||||
if {[info exists enumsplit_at($num)]} {
|
||||
clientput "-P"
|
||||
} else {
|
||||
clientput "--"
|
||||
}
|
||||
clientput "-T$nam"
|
||||
if {[llength $val] <= 1} {
|
||||
clientput "-r$num"
|
||||
} else {
|
||||
clientput "-r$nam"
|
||||
}
|
||||
}
|
||||
GraphIcon $path
|
||||
set graph 0
|
||||
if {[silent 1 hgetpropval $path lineend]} {
|
||||
clientput "-P"
|
||||
}
|
||||
}
|
||||
}
|
||||
default {
|
||||
set enum [split [silent 0 hgetpropval $path enum] ","]
|
||||
set name $val
|
||||
set wid 0
|
||||
if {[llength $enum] > 1} {
|
||||
set idx 0
|
||||
foreach item $enum {
|
||||
lassign [split $item =] itm_name itm_value
|
||||
if {$itm_value eq ""} {
|
||||
set itm_value $idx
|
||||
} elseif {[string is integer $itm_value]} {
|
||||
set idx $itm_value
|
||||
}
|
||||
if {$itm_value == $val} {
|
||||
set name $itm_name
|
||||
}
|
||||
incr idx
|
||||
set wid [expr max($wid, [string length $itm_name])]
|
||||
}
|
||||
}
|
||||
set wid [silent $wid hgetpropval $path width]
|
||||
if {$wid != 0} {
|
||||
set wid [expr $wid - [string length $name]]
|
||||
if {$wid < 0} {
|
||||
set wid 0
|
||||
}
|
||||
set name "$name[string repeat { } $wid]"
|
||||
}
|
||||
|
||||
if {$buttons ne ""} {
|
||||
clientput "--"
|
||||
}
|
||||
clientput "-T$title"
|
||||
clientput "-V$name"
|
||||
clientput "-i$cmd"
|
||||
}
|
||||
}
|
||||
if {$cmd2 ne ""} {
|
||||
set title [silent "" hgetpropval $path runlabel]
|
||||
if {[catch {set val [result $cmd2]} msg]} {
|
||||
clientput "-SW"
|
||||
clientput "-L${title}:[string map {"ERROR:" ""} $msg]"
|
||||
return 1
|
||||
}
|
||||
clientput "-T$title"
|
||||
clientput "-V$val"
|
||||
clientput "-i$cmd2"
|
||||
clientput "-P"
|
||||
}
|
||||
if {$buttons ne ""} {
|
||||
# buttons syntax:
|
||||
# buttons are separated with ':'
|
||||
# on buttons is: <name>/<value>/<hidden_values>
|
||||
# hidden values are separated with ',' or '-' (for ranges)
|
||||
foreach button [split $buttons :] {
|
||||
lassign [split $button /] name bval values
|
||||
set showbutton 1
|
||||
foreach v [split $values ,] {
|
||||
lassign [split $v -] from to
|
||||
if {$to eq ""} {
|
||||
set to $from
|
||||
}
|
||||
if {$val >= $from && $val <= $to} {
|
||||
set showbutton 0
|
||||
break
|
||||
}
|
||||
}
|
||||
if {$showbutton} {
|
||||
clientput "--"
|
||||
clientput "-T$name"
|
||||
# space after B because BC,BD,BS have special meaning
|
||||
clientput "-B $cmd $bval"
|
||||
}
|
||||
}
|
||||
clientput "-P"
|
||||
}
|
||||
if {$graph} {
|
||||
GraphIcon $path
|
||||
}
|
||||
set warning [silent "" hgetpropval $path warning]
|
||||
if {[string index $warning 0] eq "/"} {
|
||||
set warning [silent "" hgetpropval $warning geterror]
|
||||
}
|
||||
if {$warning ne ""} {
|
||||
clientput "-SW"
|
||||
clientput "-L[string map {"ERROR:" ""} $warning]"
|
||||
}
|
||||
return 1
|
||||
}
|
||||
func {
|
||||
set label [silent 0 hgetpropval $path label]
|
||||
if {$label ne 0} {
|
||||
set title $label
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
proc nodeVisible {path {key visible}} {
|
||||
global shown_groups
|
||||
set vis [silent true hgetpropval $path $key]
|
||||
if {$vis eq "expert"} {
|
||||
return [info exists shown_groups(expertMode)]
|
||||
}
|
||||
return $vis
|
||||
}
|
||||
|
||||
proc hdbLayout {path} {
|
||||
global shown_groups
|
||||
|
||||
# for the parent layouts
|
||||
|
||||
set group [silent 0 hgetpropval $path group]
|
||||
# clientput "L $path G $group [nodeVisible $path groupMode]"
|
||||
if {! [string equal 0 $group] && [nodeVisible $path groupMode]} {
|
||||
lassign [split $path /] _ obj
|
||||
if {![string match *$obj* $group]} {
|
||||
set group "$group \[$obj\]"
|
||||
}
|
||||
clientput "-T$group"
|
||||
clientput "-G$path"
|
||||
if {[info exists shown_groups($path)]} {
|
||||
lassign [split $path /] nul obj sub
|
||||
if {$sub eq ""} { # bare object
|
||||
showStatus $obj
|
||||
}
|
||||
if {[nodeVisible $path]} {
|
||||
# show node inside of kids group
|
||||
hdbItem /$path $path
|
||||
}
|
||||
hdbLay $path/
|
||||
clientput "-E1"
|
||||
} else {
|
||||
clientput "-E0"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc hdbLay {path} {
|
||||
global shown_groups
|
||||
|
||||
# for the kids layouts
|
||||
|
||||
set nodes [split [hlist $path]]
|
||||
foreach n $nodes {
|
||||
if {![string equal "" $n]} {
|
||||
if {[nodeVisible $path$n]} {
|
||||
# show node outside of kids group
|
||||
hdbItem $path$n $n
|
||||
}
|
||||
set group [silent 0 hgetpropval $path$n group]
|
||||
if {! [string equal 0 $group] && [nodeVisible $path$n groupMode]} {
|
||||
clientput "-T$group"
|
||||
clientput "-G$path$n"
|
||||
if {[info exists shown_groups($path$n)]} {
|
||||
hdbLay $path$n/
|
||||
clientput "-E1"
|
||||
} else {
|
||||
clientput "-E0"
|
||||
}
|
||||
}
|
||||
if {[silent 0 hgetpropval $path$n show_more]} {
|
||||
if {![hval $path$n]} {
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc hdbGrp {path} {
|
||||
set group [silent 0 hgetpropval $path group]
|
||||
if {! [string equal 0 $group] && [nodeVisible $path groupMode]} {
|
||||
clientput "-T$group"
|
||||
clientput "-G$path"
|
||||
lassign [split $path /] nul obj sub
|
||||
if {$sub eq ""} { # bare object
|
||||
showStatus $obj
|
||||
}
|
||||
if {[nodeVisible $path]} {
|
||||
# show node inside of kids group
|
||||
hdbItem /$path $path
|
||||
}
|
||||
hdbLay $path/
|
||||
clientput "-E1"
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc hdbScan {path action args} {
|
||||
# scan the children of <path> (path must end with "/")
|
||||
# for each node
|
||||
# <action> <node> <args>
|
||||
# is executed.
|
||||
# an action must return a integer.
|
||||
# if this value is negative, hdbScan immediately returns this value
|
||||
# else the return value is the sum of the action return values
|
||||
|
||||
set nodes [split [hlist $path]]
|
||||
set retsum 0
|
||||
foreach n $nodes {
|
||||
if {![string equal "" $n]} {
|
||||
if {[llength $args] > 0} {
|
||||
set ret [$action $path$n $args]
|
||||
} else {
|
||||
set ret [$action $path$n]
|
||||
}
|
||||
if {$ret < 0} {
|
||||
return $ret
|
||||
}
|
||||
incr retsum $ret
|
||||
}
|
||||
}
|
||||
return $retsum
|
||||
}
|
||||
Reference in New Issue
Block a user