util/X86LINUX64/lib/blt2.5/tvutil.tcl

   1 # BLT TreeView Utilities.
   2 # Load and dump treeview to XTL form.
   3
   4 namespace eval ::blt::tv {
   5   variable pc
   6   set pc(colors) {LightBlue Aquamarine Khaki LightCyan Cornsilk LightYellow Lavender Azure}
   7 }
   8
   9 proc ::blt::tv::_TreeLoad {w tl {id 0}} {
  10     upvar 1 p p
  11     foreach {i j} $tl {
  12         set tag [lindex $i 0]
  13         if {[llength $i]==1} {
  14             set lbl [expr {$j == {}?$i:$j}]
  15             if {$j == {}} {
  16                 $w insert end $tag -at $id
  17             } else {
  18                 $w insert end $tag -at $id -data [list $p(-datacol) $j]
  19             }
  20         } else {
  21             set tind [lindex $i 1]
  22             array unset data
  23             foreach {k l} [lrange $i 2 end] {
  24                 if {$p(-trim) != {}} { set k [string trimleft $k $p(-trim)] }
  25                 set data($k) $l
  26             }
  27             set cns [$w col names]
  28             foreach k [array names data] {
  29                 if {[lsearch -exact $cns $k]<0} {
  30                     $w col insert end $k
  31                     foreach m {-relief -bd} { $w col conf $k $m [$w col cget 0 $m] }
  32                 }
  33             }
  34             if {$tind != "+"} {
  35                 set data($p(-datacol)) $j
  36             }
  37             set nid [$w insert end $tag -at $id -data [array get data]]
  38             switch -- $tind {
  39                 + {
  40                     if {$p(-defer)} {
  41                         $w entry conf $nid -forcetree 1 -opencommand [concat [list ::blt::tv::TreeLoad $w $j] [array get p] -id $nid -nice 0]
  42                     } else {
  43                         _TreeLoad $w $j $nid
  44                     }
  45                 }
  46                 - - {} {}
  47                 default {
  48                     tclLog "Tag '$tind' is not '+' or '-' in: $i $j"
  49                 }
  50             }
  51         }
  52     }
  53 }
  54
  55 proc ::blt::tv::TreeLoad {w tl args} { #TYPES: . Win . {opts -trim -nice -defer -id -datacol}
  56     # Load treeview from an XTL.
  57     array set p {-trim {} -nice 0 -defer 1 -id 0 -datacol Value}
  58     array set p $args
  59     if {$p(-id) && [$w entry children $p(-id)] != {}} return
  60     if {[lsearch -exact [$w col names] $p(-datacol)]<0} {
  61       $w col insert end $p(-datacol)
  62     }
  63     $w conf -allowduplicates 1
  64     busy hold $w
  65     update
  66     set rc [catch {_TreeLoad $w $tl $p(-id)} rv]
  67     busy release $w
  68     update
  69     if {$p(-nice)} {
  70         $w style create textbox alt -bg LightBlue
  71         $w conf -underline 1 -altstyle alt -bg White -selectbackground SteelBlue -nofocusselectbackground SteelBlue
  72         eval $w col conf [$w col names] -bd 1 -relief raised
  73     }
  74     return -code $rc $rv
  75 }
  76
  77 proc ::blt::tv::_TreeDump1 {w node} {
  78     upvar 1 p p rc rc
  79     set val {}
  80     set i $node
  81     if {$p(-label)} {
  82        set tag [$w entry cget $i -label]
  83     } else {
  84        set tag [$w get $i]
  85     }
  86     set avals {}
  87     if {$p(-aval) != {}} {
  88        catch { set avals [$w entry set $i $p(-aval)] }
  89     } else {
  90        set avals [$w entry cget $i -data]
  91     }
  92     foreach {j k} $avals {
  93         if {$j == "#0"} {
  94             set val $k
  95         } else {
  96             set j $p(-prefix)$j
  97             set data($j) $k
  98         }
  99     }
 100     if {$p(-vval) != {}} {
 101        catch { set val [$w entry set $i $p(-vval)] }
 102     }
 103     if {[$w entry isleaf $i]} {
 104         if {[array size data]} {
 105             set tattr [concat [list $tag -] [array get data]]
 106         } elseif {[string match #* $tag]} {
 107             set tattr $tag
 108         } else {
 109             set tattr [list $tag]
 110         }
 111         lappend rc $tattr $val
 112     } else {
 113         set tattr [concat [list $tag +] [array get data]]
 114         lappend rc $tattr [_TreeDump $w $i]
 115     }
 116 }
 117
 118 proc ::blt::tv::_TreeDump {w node} {
 119     upvar 1 p p
 120     set rc {}
 121     foreach i [$w entry children $node] {
 122          _TreeDump1 $w $i
 123     }
 124     return $rc
 125 }
 126
 127 proc ::blt::tv::FmtTree {lst {ind "    "} {sp {}}} {
 128     set rc {}
 129     set n 0
 130     foreach {atag val} $lst {
 131         incr n
 132         if {[string index $rc end] != "\n"} { append rc \n }
 133         if {[lindex $atag 1] == "+"} {
 134             set src [FmtTree $val $ind "$sp$ind"]
 135             append rc $sp [list $atag $src] \n
 136         } else {
 137             append rc $sp [list $atag $val] \n
 138         }
 139     }
 140     return $rc[string range $sp 0 end-[string length $ind]]
 141 }
 142
 143 proc ::blt::tv::TreeDump {w args} { #TYPES: . Win {opts -prefix -fmt -label -aval -vval -start -notop}
 144     # Dump a treeview to XTL.
 145     array set p {-prefix {} -fmt 1 -label 1 -aval {} -vval {} -start 0 -notop 0}
 146     array set p $args
 147     if {!$p(-notop)} {
 148         set rc [_TreeDump1 $w $p(-start)]
 149     } else {
 150         set rc [_TreeDump $w $p(-start)]
 151     }
 152     if {$p(-fmt)} { set rc [FmtTree $rc] }
 153     return $rc
 154 }
 155
 156 proc ::blt::tv::WNew {cmd args} {
 157     # Use style commands if possible.
 158     if {[info exists ::Tk::Wins]} {
 159         return [eval $cmd new $args]
 160     }
 161     return [eval $cmd $args]
 162 }
 163
 164
 165 proc ::blt::tv::XTLLoad {args} { #TYPES: win {opts -altcolor -colopts -conf -data -eval -refresh -titles -win}
 166     # Load a flat table.
 167     array set p {
 168         -altcolor   *
 169         -colopts    {}
 170         -conf       {}
 171         -data       {}
 172         -eval       {}
 173         -refresh    0
 174         -titles     {}
 175         -win        {}
 176     }
 177     variable pc
 178     array set p $args
 179     set data $p(-data)
 180     if {$p(-eval) != {}} {
 181         set data [eval $p(-eval)]
 182     }
 183     if {$data == {}} {
 184         error "Must provide -data"
 185     }
 186     set titles $p(-titles)
 187     if {$titles == {}} {
 188        set titles {Name Value}
 189     }
 190     set colors $pc(colors)
 191     set idx 1
 192     if {[set t $p(-win)] != {}} {
 193         if {$p(-refresh) && ![winfo exists $p(-win)]} return
 194         $t delete all
 195     } else {
 196         while {[winfo exists [set w .__tvdatatable$idx]]} {
 197             incr idx
 198         }
 199         WNew Toplevel $w
 200         set f $w.f
 201         WNew Frame $f
 202         grid $f -row 10 -column 10 -sticky news
 203         grid columnconf $w 10 -weight 1
 204         grid rowconf $w 10 -weight 1
 205         set t $f.t
 206         WNew Scrollbar $f.sv -command "$t yview"
 207         WNew Scrollbar $f.sh -command "$t xview" -orient horizontal
 208         WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1
 209         grid $t $f.sv
 210         grid $f.sh -sticky we
 211         grid conf $t -sticky news
 212         grid conf $f.sv -sticky ns
 213         grid columnconf $f 0 -weight 1
 214         grid rowconf $f 0 -weight 1
 215
 216     }
 217     #$t conf -font  {Verdana 14 bold}; $t conf -titlefont [$t cget -font]
 218     if {$p(-altcolor) != {}} {
 219         if {[set color $p(-altcolor)] == "*"} {
 220             set color [lindex $colors [expr {($idx-1)%[llength $colors]}]]
 221         }
 222         catch {
 223             $t style create textbox alt -bg $color
 224             $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue
 225
 226         }
 227     }
 228     TreeLoad $t $data
 229     eval $t col conf [$t col names] -bd 1 -relief raised -autowidth 250
 230     $t col conf 0 -title Tag
 231     $t col conf Value -justify left -titlejustify left
 232     if {$p(-colopts) != {}} {
 233         foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) }
 234     }
 235     if {$p(-conf) != {}} {
 236         eval $t conf $p(-conf)
 237     }
 238     if {$p(-refresh) > 0} {
 239         set p(-win) $t
 240         set p(-altcolor) {}
 241         set p(-conf) {}
 242         after $p(-refresh) [concat [namespace current]::TableLoad [array get p]]
 243     }
 244     return $t
 245 }
 246
 247 proc ::blt::tv::TableLoad {args} { #TYPES: win {opts -altcolor -colopts  -colprefix -conf -data -eval -refresh -subfield -split -titles -ititles -treefield -win}
 248     # Load a flat table.
 249     variable pc
 250     array set p {
 251         -altcolor   *
 252         -colopts    {}
 253         -colprefix  F
 254         -conf       {}
 255         -data       {}
 256         -eval       {}
 257         -refresh    0
 258         -subfield   {}
 259         -split      False
 260         -titles     {}
 261         -ititles    False
 262         -treefield  {}
 263         -win        {}
 264     }
 265     array set p $args
 266     set data $p(-data)
 267     if {$p(-eval) != {}} {
 268         set data [eval $p(-eval)]
 269     }
 270     if {$p(-split)} {
 271         set data [split $data \n]
 272     }
 273     if {$data == {}} {
 274         error "Must provide -data"
 275     }
 276     set titles $p(-titles)
 277     if {$p(-ititles)} {
 278         set titles [lindex $data 0]
 279         set data [lrange $data 1 end]
 280     }
 281     set colors $pc(colors)
 282     set idx 1
 283     if {[set t $p(-win)] != {}} {
 284         if {$p(-refresh) && ![winfo exists $p(-win)]} return
 285         $t delete all
 286     } else {
 287         while {[winfo exists [set w .__tvdatatable$idx]]} {
 288             incr idx
 289         }
 290         WNew Toplevel $w
 291         set f $w.f
 292         WNew Frame $f
 293         grid $f -row 10 -column 10 -sticky news
 294         grid columnconf $w 10 -weight 1
 295         grid rowconf $w 10 -weight 1
 296         set t $f.t
 297         WNew Scrollbar $f.sv -command "$t yview"
 298         WNew Scrollbar $f.sh -command "$t xview" -orient horizontal
 299         WNew TreeView $t -width 600 -autocreate 1 -yscrollcommand "$f.sv set" -xscrollcommand "$f.sh set" -bg white -underline 1
 300         grid $t $f.sv
 301         grid $f.sh -sticky we
 302         grid conf $t -sticky news
 303         grid conf $f.sv -sticky ns
 304         grid columnconf $f 0 -weight 1
 305         grid rowconf $f 0 -weight 1
 306
 307     }
 308     #$t conf -font  {Verdana 14 bold}; $t conf -titlefont [$t cget -font]
 309     if {$p(-altcolor) != {}} {
 310         if {[set color $p(-altcolor)] == "*"} {
 311             set color [lindex $colors [expr {($idx-1)%[llength $colors]}]]
 312         }
 313         catch {
 314             $t style create textbox alt -bg $color
 315             $t conf -altstyle alt -selectbackground SteelBlue -nofocusselectbackground SteelBlue
 316
 317         }
 318     }
 319     if {$p(-treefield) != {}} {
 320         $t column conf 0 -relief raised -bd 1 -title $p(-treefield)
 321     } else {
 322         $t column conf 0 -hide 1
 323     }
 324     set data0 [$t column names]
 325     foreach i $data {
 326         while {[llength $data0] <= [llength $i]} {
 327             set cn [lindex $titles [expr {[llength $data0]-1}]]
 328             if {$cn == {}} {
 329                 set cn $p(-colprefix)[llength $data0]
 330             }
 331             $t column insert end $cn  -justify left -relief raised -bd 1 -pad 10 -editopts {-autonl 1} -command [list blt::tv::SortColumn %W %C]
 332             set data0 [$t column names]
 333         }
 334         set d {}
 335         set n 0
 336         array unset q
 337         foreach j $i {
 338             set ii [lindex $data0 [incr n]]
 339             lappend d $ii $j
 340             set q($ii) $j
 341         }
 342         if {$p(-treefield) == {}} {
 343             set path #auto
 344         } else {
 345             set path $q($p(-treefield))
 346         }
 347         $t insert end $path -data $d
 348     }
 349     if {$p(-subfield) != {}} {
 350         foreach i [$t find] {
 351             set id [$t entry set $i $p(-subfield)]
 352             if {$id == {}} continue
 353             set did [$t find -name $id]
 354             if {$did == {}} continue
 355             #puts "ID($i) id=$id, did=$did"
 356             if {[string equal $did $i]} continue
 357             $t move $i into $did
 358         }
 359     }
 360     $t open -trees root
 361     bind . <Control-Alt-Insert> "console show"
 362     if {$p(-colopts) != {}} {
 363         foreach i [$t col names] { eval [list $t column conf $i] $p(-colopts) }
 364     }
 365     if {$p(-conf) != {}} {
 366         eval $t conf $p(-conf)
 367     }
 368     if {$p(-refresh) > 0} {
 369         set p(-win) $t
 370         set p(-altcolor) {}
 371         set p(-conf) {}
 372         after $p(-refresh) [concat [namespace current]::TableLoad [array get p]]
 373     }
 374     return $t
 375 }
 376
 377 proc ::blt::tv::EditValid {wconf t newdata ind} {
 378     # The following uses validate to prevent invalid edit from completing.
 379     set nam [$t entry set $ind Name]
 380     if {[catch {eval $wconf [list $nam $newdata]} rv]} {
 381         return -code 10 $rv
 382     }
 383     return $newdata
 384 }
 385
 386 proc ::blt::tv::TableWid {wconf} {
 387     # Edit widget configure info in a table.
 388     set w [lindex $wconf 0]
 389     if {[llength $wconf] == 1} { lappend wconf configure }
 390     set data [lsort -dictionary [eval $wconf]]
 391     set t [blt::tv::TableLoad -data $data -titles {Name DBName DBClass Default Value Type}]
 392     wm title [winfo toplevel $t] "Widget Info: [winfo class $w] [winfo name $w] '[lrange $wconf 1 end]' in [winfo parent $w]"
 393     $t col move Value DBName
 394     $t col move Default DBName
 395     eval $t col conf [$t col names] -bg LightGray
 396     $t col conf Value -edit 1 -titleforeground LimeGreen -titlejustify left -bg White
 397     $t col conf Value -validatecmd [list [namespace current]::EditValid $wconf %W %V %#]
 398     return $t
 399 }
 400
 401 proc ::blt::tv::TreeFill {w str args} {
 402     # Load treeview with data indented by 4 space multiples (converts tabs to 4).
 403     # If -flat, load as a table and ignore indents.
 404     set cols [$w column names]
 405     set tstr [string trim $str]
 406     set inttl 0
 407     set istable [$w cget -flat]
 408     set sind [expr {$istable?0:1}]
 409     if {[llength $cols] == 1} {
 410         set inttl 1
 411         set s0 [string first \n $tstr]
 412         if {$s0<0} {
 413             set str0 $str
 414             set str {}
 415         } else {
 416             set str0 [string range $tstr 0 [incr s0 -1]]
 417             set s0 [string first \n $tstr]
 418             set str [string range $tstr [incr s0] end]
 419         }
 420         set cols $str0
 421         set titles [lrange $cols $sind end]
 422         foreach i $titles {
 423             $w column insert end $i
 424         }
 425         if {!$istable} {
 426             set col0 [lindex $cols 0]
 427             $w column conf 0 -title $col0
 428         }
 429     } else {
 430         set titles [lrange $cols $sind end]
 431         if {[lindex $cols 0] != "#0"} { error "tree col must be first" }
 432     }
 433     if {$istable} {
 434     } else {
 435         set str [string map {\t {    }} $str]
 436     }
 437     set lst [split $str \n]
 438     if {$istable} {
 439         foreach i $lst {
 440             set data {}
 441             foreach j $i k $titles {
 442                 if {$k == {}} break
 443                 if {$j != {}} {
 444                     lappend data $k $j
 445                 }
 446             }
 447             $w insert end #auto -data $data
 448         }
 449     } else {
 450         set msg {}
 451         while {[string trim [lindex $lst 0]] == {} && [llength $lst]>1} {
 452             set lst [lrange $lst 1 end]
 453         }
 454         set l0 [lindex $lst 0]
 455         set l0a [string trimleft $l0]
 456         set sp0 [expr {[string length $l0]-[string length $l0a]}]
 457         set at 0
 458         set n 0
 459         foreach i $lst {
 460             incr n
 461             set lbl [lindex $i 0]
 462             set ii [lrange $i 1 end]
 463             set la [string trimleft $i]
 464             if {$la == {}} continue
 465             set sp [expr {[string length $i]-[string length $la]}]
 466             set lev [expr {($sp-$sp0)/4}]
 467             set mod [expr {($sp-$sp0)%4}]
 468             if {$mod && $msg == {}} {
 469                 set msg "treeview data indent ($mod) not divisible by 4 in: '$i'"
 470             }
 471             set data {}
 472             foreach j $ii k $titles {
 473                 if {$k == {}} {
 474                     set k [$w column insert end #auto]
 475                     lappend titles $k
 476                 }
 477                 if {$j != {}} {
 478                     lappend data $k $j
 479                 }
 480             }
 481             if {$lev<=0 || $n==1} {
 482                 set at 0
 483             } else {
 484                 set at [$w index tail]
 485                 while {[$w entry depth $at]>$lev} {
 486                     set at [$w entry parent $at]
 487                 }
 488             }
 489             $w insert end [list $lbl] -at $at -data $data
 490         }
 491         if {$msg != {}} {
 492             tclLog $msg
 493         }
 494     }
 495 }
 496
 497
 498 if {$argv0 == [info script]} {
 499     if {[llength $argv]} {
 500        return [eval ::blt::tv::TableLoad $argv]
 501     }
 502
 503   pack [treeview .tt ] -side left -fill both -expand y
 504   variable tree {
 505     A 1
 506     A 2
 507     {B - -X 1 -Y 2} 2
 508     {C +} {
 509         a 1
 510         b 2
 511         {c - -X 3}  2
 512         {d +} {
 513             x 1
 514         }
 515     }
 516   }
 517
 518   ::blt::tv::TreeLoad .tt $tree -trim - -nice 1
 519   tclLog [::blt::tv::TreeDump .tt]
 520   pack [treeview .tf ] -side left -fill both -expand y
 521   ::blt::tv::TreeFill .tf {
 522     A 1 2 3
 523     C 1 2 3
 524     B 1 2 3
 525         1 1 2 3
 526         2 1 2 3
 527             a 1 2 3
 528             b 1 2 3
 529   }
 530   .tf open [.tf find -istree]
 531
 532   namespace eval ::blt::tv {
 533   TableLoad -titles  {Name Alpha Bravo Charlie Detroit Foxtrot} -data {
 534             {Bob 9 21 9}
 535             {Derick 2 1 5}
 536             {Bill 3 2 5 2 1}
 537         }
 538   if {$::tcl_platform(platform) == "unix"} {
 539      TableLoad -eval {exec df} -ititles 1 -split 1
 540      TableLoad -ititles 1 -treefield PID -subfield PPID -split 1 -eval {exec ps -eo comm,uid_hack,rss,sz,time,pid,ppid,tty}
 541      TableLoad -ititles 1 -data [split [exec ps -Alwj] \n]
 542      TableLoad -ititles 1 -data [array get ::env] -llength 2
 543
 544      proc LoadPs {} {
 545         set data [split [string trim [exec ps auxw]] \n]
 546         set ttl [lindex $data 0]
 547         set lst {}
 548         lappend lst $ttl
 549         set pos [string last [lindex $ttl end] $ttl]
 550         foreach i [lrange $data 1 end] {
 551           set nl [string range $i 0 [expr {$pos-1}]]
 552           lappend nl [string range $i $pos end]
 553           lappend lst $nl
 554         }
 555         return $lst
 556      }
 557      TableLoad -ititles 1 -eval {LoadPs} -refresh 3000
 558      #eval TableLoad [lrange $argv $n end]
 559     }
 560     }
 561
 562 }