426 lines
12 KiB
Tcl
426 lines
12 KiB
Tcl
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 cmd2 [string range $cmd 4 end]
|
|
if {[silent 0 hgetpropval $path visible] eq "readonly"} {
|
|
set val [silent "" hvali $path]
|
|
} else {
|
|
# set val [silent "" hgetpropval $path target]
|
|
set val [silent $val result $cmd2 target]
|
|
}
|
|
clientput "-P"
|
|
} elseif {$type eq "func"} {
|
|
clientput "-T$title"
|
|
clientput "-B $cmd"
|
|
clientput "--"
|
|
return
|
|
} else {
|
|
set cmd2 ""
|
|
# using {set val [result $cmd]} will have strange effects: 'xatto info' is like 'run xatto inf'!
|
|
if {[catch {set val [hval $path]} 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"
|
|
}
|
|
set fmtstr [silent "" hgetpropval $path fmtstr]
|
|
if {$fmtstr ne ""} {
|
|
set val [format $fmtstr $val]
|
|
}
|
|
if {[silent "" hgetpropval $path visible] eq "readonly"} {
|
|
set priv internal
|
|
}
|
|
switch $priv {
|
|
user - spy {
|
|
set val [silent $val hgetpropval $path requested]
|
|
set val [silent $val hgetpropval $path secoprequested]
|
|
#if {$fmtstr ne ""} {
|
|
# set val [format $fmtstr $val]
|
|
#}
|
|
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)]
|
|
} elseif {$vis eq "readonly"} {
|
|
return 1
|
|
}
|
|
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 tolower $obj] eq $group} {
|
|
set group $obj
|
|
} elseif {![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
|
|
}
|