tk8.6-blt2.5 2.5.3+dfsg-1 / usr / lib / blt2.5 / tvutil.tcl

# BLT TreeView Utilities.
# Load and dump treeview to XTL form.

namespace eval ::blt::tv {
  variable pc
  set pc(colors) {LightBlue Aquamarine Khaki LightCyan Cornsilk LightYellow Lavender Azure}
}

proc ::blt::tv::_TreeLoad {w tl {id 0}} {
    upvar 1 p p
    foreach {i j} $tl {
        set tag [lindex $i 0]
        if {[llength $i]==1} {
            set lbl [expr {$j == {}?$i:$j}]
            if {$j == {}} {
                $w insert end $tag -at $id
            } else {
                $w insert end $tag -at $id -data [list $p(-datacol) $j]
            }
        } else {
            set tind [lindex $i 1]
            array unset data
            foreach {k l} [lrange $i 2 end] {
                if {$p(-trim) != {}} { set k [string trimleft $k $p(-trim)] }
                set data($k) $l
            }
            set cns [$w col names]
            foreach k [array names data] {
                if {[lsearch -exact $cns $k]<0} {
                    $w col insert end $k
                    foreach m {-relief -bd} { $w col conf $k $m [$w col cget 0 $m] }
                }
            }
            if {$tind != "+"} {
                set data($p(-datacol)) $j
            }
            set nid [$w insert end $tag -at $id -data [array get data]]
            switch -- $tind {
                + {
                    if {$p(-defer)} {
                        $w entry conf $nid -forcetree 1 -opencommand [concat [list ::blt::tv::TreeLoad $w $j] [array get p] -id $nid -nice 0]
                    } else {
                        _TreeLoad $w $j $nid
                    }
                }
                - - {} {}
                default {
                    tclLog "Tag '$tind' is not '+' or '-' in: $i $j"
                }
            }
        }
    }
}

proc ::blt::tv::TreeLoad {w tl args} { #TYPES: . Win . {opts -trim -nice -defer -id -datacol}
    # Load treeview from an XTL.
    array set p {-trim {} -nice 0 -defer 1 -id 0 -datacol Value}
    array set p $args
    if {$p(-id) && [$w entry children $p(-id)] != {}} return
    if {[lsearch -exact [$w col names] $p(-datacol)]<0} {
      $w col insert end $p(-datacol)
    }
    $w conf -allowduplicates 1
    busy hold $w
    update
    set rc [catch {_TreeLoad $w $tl $p(-id)} rv]
    busy release $w
    update
    if {$p(-nice)} {
        $w style create textbox alt -bg LightBlue
        $w conf -underline 1 -altstyle alt -bg White -selectbackground SteelBlue -nofocusselectbackground SteelBlue
        eval $w col conf [$w col names] -bd 1 -relief raised
    }
    return -code $rc $rv
}

proc ::blt::tv::_TreeDump1 {w node} {
    upvar 1 p p rc rc
    set val {}
    set i $node
    if {$p(-label)} {
       set tag [$w entry cget $i -label]
    } else {
       set tag [$w get $i]
    }
    set avals {}
    if {$p(-aval) != {}} {
       catch { set avals [$w entry set $i $p(-aval)] }
    } else {
       set avals [$w entry cget $i -data]
    }
    foreach {j k} $avals {
	if {$j == "#0"} {
	    set val $k
	} else {
	    set j $p(-prefix)$j
	    set data($j) $k
	}
    }
    if {$p(-vval) != {}} {
       catch { set val [$w entry set $i $p(-vval)] }
    }
    if {[$w entry isleaf $i]} {
	if {[array size data]} {
	    set tattr [concat [list $tag -] [array get data]]
	} elseif {[string match #* $tag]} {
	    set tattr $tag
	} else {
	    set tattr [list $tag]
	}
	lappend rc $tattr $val
    } else {
	set tattr [concat [list $tag +] [array get data]]
	lappend rc $tattr [_TreeDump $w $i]
    }
}

proc ::blt::tv::_TreeDump {w node} {
    upvar 1 p p
    set rc {}
    foreach i [$w entry children $node] {
         _TreeDump1 $w $i
    }
    return $rc
}

proc ::blt::tv::FmtTree {lst {ind "    "} {sp {}}} {
    set rc {}
    set n 0
    foreach {atag val} $lst {
        incr n
        if {[string index $rc end] != "\n"} { append rc \n }
        if {[lindex $atag 1] == "+"} {
            set src [FmtTree $val $ind "$sp$ind"]
            append rc $sp [list $atag $src] \n
        } else {
            append rc $sp [list $atag $val] \n
        }
    }
    return $rc[string range $sp 0 end-[string length $ind]]
}

proc ::blt::tv::TreeDump {w args} { #TYPES: . Win {opts -prefix -fmt -label -aval -vval -start -notop}
    # Dump a treeview to XTL.
    array set p {-prefix {} -fmt 1 -label 1 -aval {} -vval {} -start 0 -notop 0}
    array set p $args
    if {!$p(-notop)} {
        set rc [_TreeDump1 $w $p(-start)]
    } else {
        set rc [_TreeDump $w $p(-start)]
    }
    if {$p(-fmt)} { set rc [FmtTree $rc] }
    return $rc
}

proc ::blt::tv::WNew {cmd args} {
    # Use style commands if possible.
    if {[info exists ::Tk::Wins]} {
        return [eval $cmd new $args]
    }
    return [eval $cmd $args]
}


proc ::blt::tv::XTLLoad {args} { #TYPES: win {opts -altcolor -colopts -conf -data -eval -refresh -titles -win} 
    # Load a flat table.
    array set p {
        -altcolor   *
        -colopts    {}
        -conf       {}
        -data       {}
        -eval       {}
        -refresh    0
        -titles     {}
        -win        {}
    }
    variable pc
    array set p $args
    set data $p(-data)
    if {$p(-eval) != {}} {
        set data [eval $p(-eval)]
    }
    if {$data == {}} {
        error "Must provide -data"
    }
    set titles $p(-titles)
    if {$titles == {}} {
       set titles {Name Value}
    }
    set colors $pc(colors)
    set idx 1
    if {[set t $p(-win)] != {}} {
        if {$p(-refresh) && ![winfo exists $p(-win)]} return
        $t delete all
    } else {
        while {[winfo exists [set w .__tvdatatable$idx]]} {
            incr idx
        }
        WNew Toplevel $w
        set f $w.f
        WNew Frame $f
        grid $f -row 10 -column 10 -sticky news
        grid columnconf $w 10 -weight 1
        grid rowconf $w 10 -weight 1
        set t $f.t
        WNew Scrollbar $f.sv -command "$t yview"
        WNew Scrollbar $f.sh -command "$t xview" -orient horizontal
        WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1
        grid $t $f.sv
        grid $f.sh -sticky we
        grid conf $t -sticky news
        grid conf $f.sv -sticky ns
        grid columnconf $f 0 -weight 1
        grid rowconf $f 0 -weight 1
        
    }
    #$t conf -font  {Verdana 14 bold}; $t conf -titlefont [$t cget -font]
    if {$p(-altcolor) != {}} {
        if {[set color $p(-altcolor)] == "*"} {
            set color [lindex $colors [expr {($idx-1)%[llength $colors]}]]
        }
        catch {
            $t style create textbox alt -bg $color
            $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue

        }
    }
    TreeLoad $t $data
    eval $t col conf [$t col names] -bd 1 -relief raised -autowidth 250
    $t col conf 0 -title Tag
    $t col conf Value -justify left -titlejustify left
    if {$p(-colopts) != {}} {
        foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) }
    }
    if {$p(-conf) != {}} {
        eval $t conf $p(-conf)
    }
    if {$p(-refresh) > 0} {
        set p(-win) $t
        set p(-altcolor) {}
        set p(-conf) {}
        after $p(-refresh) [concat [namespace current]::TableLoad [array get p]]
    }
    return $t
}

proc ::blt::tv::TableLoad {args} { #TYPES: win {opts -altcolor -colopts  -colprefix -conf -data -eval -refresh -subfield -split -titles -ititles -treefield -win} 
    # Load a flat table.
    variable pc
    array set p {
        -altcolor   *
        -colopts    {}
        -colprefix  F
        -conf       {}
        -data       {}
        -eval       {}
        -refresh    0
        -subfield   {}
        -split      False
        -titles     {}
        -ititles    False
        -treefield  {}
        -win        {}
    }
    array set p $args
    set data $p(-data)
    if {$p(-eval) != {}} {
        set data [eval $p(-eval)]
    }
    if {$p(-split)} {
        set data [split $data \n]
    }
    if {$data == {}} {
        error "Must provide -data"
    }
    set titles $p(-titles)
    if {$p(-ititles)} {
        set titles [lindex $data 0]
        set data [lrange $data 1 end]
    }
    set colors $pc(colors)
    set idx 1
    if {[set t $p(-win)] != {}} {
        if {$p(-refresh) && ![winfo exists $p(-win)]} return
        $t delete all
    } else {
        while {[winfo exists [set w .__tvdatatable$idx]]} {
            incr idx
        }
        WNew Toplevel $w
        set f $w.f
        WNew Frame $f
        grid $f -row 10 -column 10 -sticky news
        grid columnconf $w 10 -weight 1
        grid rowconf $w 10 -weight 1
        set t $f.t
        WNew Scrollbar $f.sv -command "$t yview"
        WNew Scrollbar $f.sh -command "$t xview" -orient horizontal
        WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1
        grid $t $f.sv
        grid $f.sh -sticky we
        grid conf $t -sticky news
        grid conf $f.sv -sticky ns
        grid columnconf $f 0 -weight 1
        grid rowconf $f 0 -weight 1
        
    }
    #$t conf -font  {Verdana 14 bold}; $t conf -titlefont [$t cget -font]
    if {$p(-altcolor) != {}} {
        if {[set color $p(-altcolor)] == "*"} {
            set color [lindex $colors [expr {($idx-1)%[llength $colors]}]]
        }
        catch {
            $t style create textbox alt -bg $color
            $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue

        }
    }
    if {$p(-treefield) != {}} {
        $t column conf 0 -relief raised -bd 1 -title $p(-treefield)
    } else {
        $t column conf 0 -hide 1
    }
    set data0 [$t column names]
    foreach i $data {
        while {[llength $data0] <= [llength $i]} {
            set cn [lindex $titles [expr {[llength $data0]-1}]]
            if {$cn == {}} {
                set cn $p(-colprefix)[llength $data0]
            }
            $t column insert end $cn  -justify left -relief raised -bd 1 -pad 10 -editopts {-autonl 1} -command [list blt::tv::SortColumn %W %C]
            set data0 [$t column names]
        }
        set d {}
        set n 0
        array unset q
        foreach j $i {
            set ii [lindex $data0 [incr n]]
            lappend d $ii $j
            set q($ii) $j
        }
        if {$p(-treefield) == {}} {
            set path #auto
        } else {
            set path $q($p(-treefield))
        }
        $t insert end $path -data $d
    }
    if {$p(-subfield) != {}} {
        foreach i [$t find] {
            set id [$t entry set $i $p(-subfield)]
            if {$id == {}} continue
            set did [$t find -name $id]
            if {$did == {}} continue
            #puts "ID($i) id=$id, did=$did"
            if {[string equal $did $i]} continue
            $t move $i into $did
        }
    }
    $t open -trees root
    bind . <Control-Alt-Insert> "console show"
    if {$p(-colopts) != {}} {
        foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) }
    }
    if {$p(-conf) != {}} {
        eval $t conf $p(-conf)
    }
    if {$p(-refresh) > 0} {
        set p(-win) $t
        set p(-altcolor) {}
        set p(-conf) {}
        after $p(-refresh) [concat [namespace current]::TableLoad [array get p]]
    }
    return $t
}

proc ::blt::tv::EditValid {wconf t newdata ind} {
    # The following uses validate to prevent invalid edit from completing.
    set nam [$t entry set $ind Name]
    if {[catch {eval $wconf [list $nam $newdata]} rv]} {
        return -code 10 $rv
    }
    return $newdata
}

proc ::blt::tv::TableWid {wconf} {
    # Edit widget configure info in a table.
    set w [lindex $wconf 0]
    if {[llength $wconf] == 1} { lappend wconf configure }
    set data [lsort -dictionary [eval $wconf]]
    set t [blt::tv::TableLoad -data $data -titles {Name DBName DBClass Default Value Type}]
    wm title [winfo toplevel $t] "Widget Info: [winfo class $w] [winfo name $w] '[lrange $wconf 1 end]' in [winfo parent $w]"
    $t col move Value DBName
    $t col move Default DBName
    eval $t col conf [$t col names] -bg LightGray
    $t col conf Value -edit 1 -titleforeground LimeGreen -titlejustify left -bg White
    $t col conf Value -validatecmd [list [namespace current]::EditValid $wconf %W %V %#]
    return $t
}

proc ::blt::tv::TreeFill {w str args} {
    # Load treeview with data indented by 4 space multiples (converts tabs to 4).
    # If -flat, load as a table and ignore indents.
    set cols [$w column names]
    set tstr [string trim $str]
    set inttl 0
    set istable [$w cget -flat]
    set sind [expr {$istable?0:1}]
    if {[llength $cols] == 1} {
        set inttl 1
        set s0 [string first \n $tstr]
        if {$s0<0} {
            set str0 $str
            set str {}
        } else {
            set str0 [string range $tstr 0 [incr s0 -1]]
            set s0 [string first \n $tstr]
            set str [string range $tstr [incr s0] end]
        }
        set cols $str0
        set titles [lrange $cols $sind end]
        foreach i $titles {
            $w column insert end $i
        }
        if {!$istable} {
            set col0 [lindex $cols 0]
            $w column conf 0 -title $col0
        }
    } else {
        set titles [lrange $cols $sind end]
        if {[lindex $cols 0] != "#0"} { error "tree col must be first" }
    }
    if {$istable} {
    } else {
        set str [string map {\t {    }} $str]
    }
    set lst [split $str \n]
    if {$istable} {
        foreach i $lst {
            set data {}
            foreach j $i k $titles {
                if {$k == {}} break
                if {$j != {}} {
                    lappend data $k $j
                }
            }
            $w insert end #auto -data $data
        }
    } else {
        set msg {}
        while {[string trim [lindex $lst 0]] == {} && [llength $lst]>1} {
            set lst [lrange $lst 1 end]
        }
        set l0 [lindex $lst 0]
        set l0a [string trimleft $l0]
        set sp0 [expr {[string length $l0]-[string length $l0a]}]
        set at 0
        set n 0
        foreach i $lst {
            incr n
            set lbl [lindex $i 0]
            set ii [lrange $i 1 end]
            set la [string trimleft $i]
            if {$la == {}} continue
            set sp [expr {[string length $i]-[string length $la]}]
            set lev [expr {($sp-$sp0)/4}]
            set mod [expr {($sp-$sp0)%4}]
            if {$mod && $msg == {}} {
                set msg "treeview data indent ($mod) not divisible by 4 in: '$i'"
            }
            set data {}
            foreach j $ii k $titles {
                if {$k == {}} {
                    set k [$w column insert end #auto]
                    lappend titles $k
                }
                if {$j != {}} {
                    lappend data $k $j
                }
            }
            if {$lev<=0 || $n==1} {
                set at 0
            } else {
                set at [$w index tail]
                while {[$w entry depth $at]>$lev} {
                    set at [$w entry parent $at]
                }
            }
            $w insert end [list $lbl] -at $at -data $data
        }
        if {$msg != {}} {
            tclLog $msg
        }
    }
}


if {$argv0 == [info script]} {
    if {[llength $argv]} {
       return [eval ::blt::tv::TableLoad $argv]
    }

  pack [treeview .tt ] -side left -fill both -expand y
  variable tree {
    A 1
    A 2
    {B - -X 1 -Y 2} 2
    {C +} {
        a 1
        b 2
        {c - -X 3}  2
        {d +} {
            x 1
        }
    }
  }

  ::blt::tv::TreeLoad .tt $tree -trim - -nice 1
  tclLog [::blt::tv::TreeDump .tt] 
  pack [treeview .tf ] -side left -fill both -expand y
  ::blt::tv::TreeFill .tf {
    A 1 2 3
    C 1 2 3
    B 1 2 3
        1 1 2 3
        2 1 2 3
            a 1 2 3
            b 1 2 3
  }
  .tf open [.tf find -istree]

  namespace eval ::blt::tv {
  TableLoad -titles  {Name Alpha Bravo Charlie Detroit Foxtrot} -data {
            {Bob 9 21 9}
            {Derick 2 1 5}
            {Bill 3 2 5 2 1}
        }
  if {$::tcl_platform(platform) == "unix"} {
     TableLoad -eval {exec df} -ititles 1 -split 1
     TableLoad -ititles 1 -treefield PID -subfield PPID -split 1 -eval {exec ps -eo comm,uid_hack,rss,sz,time,pid,ppid,tty}
     TableLoad -ititles 1 -data [split [exec ps -Alwj] \n]
     TableLoad -ititles 1 -data [array get ::env] -llength 2

     proc LoadPs {} {
        set data [split [string trim [exec ps auxw]] \n]
        set ttl [lindex $data 0]
        set lst {}
        lappend lst $ttl
        set pos [string last [lindex $ttl end] $ttl]
        foreach i [lrange $data 1 end] {
          set nl [string range $i 0 [expr {$pos-1}]]
          lappend nl [string range $i $pos end]
          lappend lst $nl
        }
        return $lst
     }
     TableLoad -ititles 1 -eval {LoadPs} -refresh 3000
     #eval TableLoad [lrange $argv $n end]
    }
    }

}