1proc GUI_Init_Phase_1 {} { 2 # Create the Main Window Frame 3 frame .mainwindow 4 # Create the Window List 5 QListBox::create .windowlist totop -background $::dynamic::theme_windowlist_background -selectbackground $::dynamic::theme_windowlist_selectbackground -selectforeground $::dynamic::theme_windowlist_selectforeground -foreground $::dynamic::theme_windowlist_foreground -width $::dynamic::theme_windowlist_width -font $::dynamic::theme_windowlist_font 6 QListBox::addcolor .windowlist normal 0 $::dynamic::theme_windowlist_foreground $::dynamic::theme_windowlist_background 7 QListBox::addcolor .windowlist active 1000 $::dynamic::theme_windowlist_activeforeground $::dynamic::theme_windowlist_activebackground 8} 9 10proc GUI_Init_Phase_2 {} { 11 # Execute in a global context so it's easier to access config variables. 12 uplevel "#0" { 13 # Create the Button Bar and Menu Bar Frames 14 frame .buttonbar -border 1 -relief sunken 15 frame .menubar 16 17 # Pack the frames vertically tiled 18 pack .buttonbar -fill x 19 pack .windowlist -side left -fill y 20 pack .mainwindow -expand 1 -fill both 21 22 # Create and Configure RAW Window 23 frame .raw 24 scrollbar .raw.text_vscroll -command ".raw.text yview" 25 text .raw.text -height 0 -width 0 -wrap word -yscroll ".raw.text_vscroll set" 26 pack .raw.text_vscroll -side right -fill y 27 pack .raw.text -fill both -expand 1 28 place .raw -in .mainwindow -relwidth 1.0 -relheight 1.0 29 .raw.text configure -font "-adobe-courier-medium-r-normal--0-0-75-75-m-0-iso8859-1" 30 31 # Set up the Button bar 32 button .buttonbar.close -text "Close" -command {closewindow [currentwindow]} 33 button .buttonbar.condis 34 condis "Start a New Server" "source $env(HOME)/.quirc/newserver.tcl" 35 36 button .buttonbar.menu -text "Menu" -relief raised 37 38 .buttonbar.menu configure -command {tk_popup .menumaintext [expr [winfo rootx .buttonbar.menu]+20] [expr [winfo rooty .buttonbar.menu]+10]} 39 40 #bind .buttonbar.menu <Button-1> {tk_popup .menumaintext %X %Y} 41 42 pack .buttonbar.close .buttonbar.condis .buttonbar.menu -side left 43 44 # Configure the colors for the buttons 45 .buttonbar configure -background $::dynamic::theme_buttonbar_background 46 47 .buttonbar.condis configure -activebackground $::dynamic::theme_button_condis_activebackground 48 .buttonbar.condis configure -background $::dynamic::theme_button_condis_background 49 .buttonbar.condis configure -activeforeground $::dynamic::theme_button_condis_activeforeground 50 .buttonbar.condis configure -foreground $::dynamic::theme_button_condis_foreground 51 52 .buttonbar.close configure -activebackground $::dynamic::theme_button_close_activebackground 53 .buttonbar.close configure -background $::dynamic::theme_button_close_background 54 .buttonbar.close configure -activeforeground $::dynamic::theme_button_close_activeforeground 55 .buttonbar.close configure -foreground $::dynamic::theme_button_close_foreground 56 57 .buttonbar.menu configure -activebackground $::dynamic::theme_button_menu_activebackground 58 .buttonbar.menu configure -background $::dynamic::theme_button_menu_background 59 .buttonbar.menu configure -activeforeground $::dynamic::theme_button_menu_activeforeground 60 .buttonbar.menu configure -foreground $::dynamic::theme_button_menu_foreground 61 62 # Set up the virtual events 63 event add <<Enter>> <Return> <KP_Enter> 64 event add <<Shift-Enter>> <Shift-Return> <Shift-KP_Enter> 65 event add <<Alt-Enter>> <Alt-Return> <Alt-KP_Enter> 66 event add <<Control-Enter>> <Control-Return> <Control-KP_Enter> 67 event add <<Action-1>> <Button-1> <B1-Motion> 68 69 # Set up the Windowlist popup menu 70# bind .windowlist <Button-3> "tk_popup .menuwindowlist %X %Y" 71 72# if { $type=="channel" } { 73# bind $pathname.nicks <Button-3> " 74# if { \[llength \[$pathname.nicks curselection]]<2 } { 75# $pathname.nicks selection clear 0 end 76# $pathname.nicks selection set @%x,%y 77# } else { 78# $pathname.nicks selection set @%x,%y 79# } 80# tk_popup .menuchannelnicks$serverindex %X %Y 81# " 82# } 83# if { $type=="main" } { 84# proc ::tk_menuSetFocus(.menumaintext) {args} {} 85# proc ::tk_menuSetFocus(.menumainentry) {args} {} 86# if { ![winfo exists .menumaintext] } { 87# menu .menumaintext 88# } 89# if { ![winfo exists .menumainentry] } { 90# menu .menumainentry 91# } 92# } 93 94 95 # Set the starting geometry for the toplevel window 96 wm geometry . $::dynamic::default_geometry 97 } 98} 99 100proc Init_Window { pathname name index type serverindex } { 101 # This procedure is run when a new window is created. It handles all the 102 # generic Tk configuration that needs to be done for that window. 103 if { [title $pathname]=="" } { 104 title $pathname "QuIRC v[version] - What do you think?" 105 } 106 if { $type=="status" || $type=="main" } { 107 QListBox::insert .windowlist $index $name 108 } else { 109 QListBox::insert .windowlist $index "$::dynamic::theme_windowlist_indent$name" 110 } 111 frame $pathname 112 if { $type=="channel" } { 113 listbox $pathname.nicks -selectmode extended -exportselection no 114 $pathname.nicks configure -background $::dynamic::theme_nicklist_background -foreground $::dynamic::theme_nicklist_foreground -font $::dynamic::theme_nicklist_font 115 $pathname.nicks configure -width $::dynamic::theme_nicklist_width 116 if { $::dynamic::nicklist_scrollbar } { 117 $pathname.nicks configure -yscrollcommand "$pathname.nicks_yscroll set" 118 scrollbar $pathname.nicks_yscroll -command "$pathname.nicks yview" 119 } 120 if { $::dynamic::nicklist_side == "right" } { 121 if { $::dynamic::nicklist_scrollbar } { 122 pack $pathname.nicks_yscroll -side $::dynamic::nicklist_side -fill y 123 } 124 pack $pathname.nicks -side $::dynamic::nicklist_side -fill y 125 } else { 126 pack $pathname.nicks -side $::dynamic::nicklist_side -fill y 127 if { $::dynamic::nicklist_scrollbar } { 128 pack $pathname.nicks_yscroll -side $::dynamic::nicklist_side -fill y 129 } 130 } 131 } 132 scrollbar $pathname.text_vscroll -command "$pathname.text yview" 133 text $pathname.text -height 0 -width 0 -wrap word -yscroll "$pathname.text_vscroll set" -state disabled 134 entry $pathname.entry 135 pack $pathname.entry -fill x -side bottom 136 pack $pathname.text_vscroll -side right -fill y 137 pack $pathname.text -fill both -expand 1 138 configtags $pathname.text [set ::dynamic::theme_${type}_font_normal] [set ::dynamic::theme_${type}_font_bold] 139 $pathname.text configure -font [set ::dynamic::theme_${type}_font_normal] 140 $pathname.text configure -state normal 141 for { set n 0 } { $n < $::dynamic::blank_lines_before_text } { incr n } { 142 $pathname.text insert end \n 143 } 144 $pathname.text configure -state disabled 145 $pathname.text yview moveto 1 146 place $pathname -in .mainwindow -relwidth 1.0 -relheight 1.0 147 $pathname.text configure -foreground $::dynamic::theme_color([set ::dynamic::theme_${type}_foreground]) 148 $pathname.text configure -background $::dynamic::theme_color([set ::dynamic::theme_${type}_background]) 149 $pathname.text configure -selectbackground [set ::dynamic::theme_${type}_selectbackground] 150 $pathname.text configure -selectforeground [set ::dynamic::theme_${type}_selectforeground] 151 $pathname.text configure -selectborderwidth [set ::dynamic::theme_${type}_selectborderwidth] 152 $pathname.entry configure -foreground [set ::dynamic::theme_${type}_entry_foreground] 153 $pathname.entry configure -background [set ::dynamic::theme_${type}_entry_background] 154 $pathname.entry configure -font [set ::dynamic::theme_${type}_entry_font] 155 $pathname.entry configure -insertbackground [set ::dynamic::theme_${type}_entry_insertbackground] 156 157 bind $pathname.entry <<Shift-Enter>> "$pathname.entry insert insert \\n" 158 bind $pathname.entry <<Enter>> "parseentry $pathname" 159 bind $pathname.entry <Control-c> "$pathname.entry insert insert \"\\x03\"" 160 bind $pathname.entry <Control-l> "$pathname.entry insert insert \"\\x02\"" 161 bind $pathname.entry <Control-u> "$pathname.entry insert insert \"\\x1f\"" 162 bind $pathname.entry <Control-underscore> "$pathname.entry insert insert \"\\x1f\"" 163 bind $pathname.entry <KeyPress> "if {\"%K\"!=\"Shift_L\"&&\"%K\"!=\"Shift_R\"&&\"%K\"!=\"Prior\"&&\"%K\"!=\"Next\"} \"$pathname.text see end\"" 164 bind $pathname.entry <KeyPress-Tab> "n_complete; break" 165 bind $pathname.entry <KeyPress-Escape> "dcc_abort; break" 166 bind $pathname.text <Button-2> "focus $pathname.entry; event generate $pathname.entry <KeyPress-Insert>" 167 168 if { $type!="status"&&$type!="main" } { 169 bind $pathname.entry <<Control-Enter>> " 170 foreach line \[split \[$pathname.entry get] \"\\n\"] { 171 if {\$line!=\"\"} { say \"\$line\" } 172 } 173 $pathname.entry delete 0 end 174 " 175 bind $pathname.entry <<Alt-Enter>> " 176 foreach line \[split \[$pathname.entry get] \"\\n\"] { 177 if {\$line!=\"\"} { say \"\[string trim \$line]\" } 178 } 179 $pathname.entry delete 0 end 180 " 181 } 182 183 # Set up the popup menus 184 bind $pathname.text <Button-3> "tk_popup .menu${type}text$serverindex %X %Y" 185 bind $pathname.entry <Button-3> "tk_popup .menu${type}entry$serverindex %X %Y" 186 if { $type=="channel" } { 187 bind $pathname.nicks <Button-3> " 188 if { \[llength \[$pathname.nicks curselection]]<2 } { 189 $pathname.nicks selection clear 0 end 190 $pathname.nicks selection set @%x,%y 191 } else { 192 $pathname.nicks selection set @%x,%y 193 } 194 tk_popup .menuchannelnicks$serverindex %X %Y 195 " 196 } 197 if { $type=="main" } { 198 proc ::tk_menuSetFocus(.menumaintext) {args} {} 199 proc ::tk_menuSetFocus(.menumainentry) {args} {} 200 if { ![winfo exists .menumaintext] } { 201 menu .menumaintext 202 } 203 if { ![winfo exists .menumainentry] } { 204 menu .menumainentry 205 } 206 } 207 if { $type=="status" } { 208 proc ::tk_menuSetFocus(.menustatustext$serverindex) {args} {} 209 proc ::tk_menuSetFocus(.menustatusentry$serverindex) {args} {} 210 proc ::tk_menuSetFocus(.menuquerytext$serverindex) {args} {} 211 proc ::tk_menuSetFocus(.menuqueryentry$serverindex) {args} {} 212 proc ::tk_menuSetFocus(.menuchattext$serverindex) {args} {} 213 proc ::tk_menuSetFocus(.menuchatentry$serverindex) {args} {} 214 proc ::tk_menuSetFocus(.menufilestext$serverindex) {args} {} 215 proc ::tk_menuSetFocus(.menufilesentry$serverindex) {args} {} 216 proc ::tk_menuSetFocus(.menuchanneltext$serverindex) {args} {} 217 proc ::tk_menuSetFocus(.menuchannelentry$serverindex) {args} {} 218 proc ::tk_menuSetFocus(.menuchannelnicks$serverindex) {args} {} 219 menu .menustatustext$serverindex 220 menu .menustatusentry$serverindex 221 menu .menuquerytext$serverindex 222 menu .menuqueryentry$serverindex 223 menu .menuchattext$serverindex 224 menu .menuchatentry$serverindex 225 menu .menufilestext$serverindex 226 menu .menufilesentry$serverindex 227 menu .menuchanneltext$serverindex 228 menu .menuchannelentry$serverindex 229 menu .menuchannelnicks$serverindex 230 } 231 232 # Make timestamp invisible initially 233 if { [info tclversion]>=8.3 } { 234 if { !$::dynamic::timestamp } { 235 $pathname.text tag configure timestamp -elide 1 236 } 237 } 238 239 #URL tag stuff 240 241 $pathname.text tag configure URL -underline 1 242 $pathname.text tag bind URL <Button-1> "after 1 openurl $pathname.text" 243 $pathname.text tag bind URL <Enter> "$pathname.text configure -cursor hand2" 244 $pathname.text tag bind URL <Leave> "$pathname.text configure -cursor xterm" 245 246 247 # Report that main window is completed for use in bgerror 248 if { $type=="main" } { 249 bind .main <Destroy> {set ::internal::done_main_window 0} 250 set ::internal::done_main_window 1 251 } 252} 253 254proc QColorChooser { command } { 255 # Command will be passed a number between 0 and 15 if a color is picked. 256 # If the window is just closed, command will not be called. 257 toplevel .colorchooser 258 wm title .colorchooser "Color" 259 for { set n 0 } { $n < 16 } { incr n } { 260 label .colorchooser.label$n -text " " -background $::dynamic::theme_color($n) -relief raised 261 bind .colorchooser.label$n <Button-1> "destroy .colorchooser; $command $n" 262 } 263 for { set y 0 } { $y < 4 } { incr y } { 264 for { set x 0 } { $x < 4 } { incr x } { 265 grid .colorchooser.label[expr $y*4+$x] -column [expr $x+1] -row [expr $y+1] 266 } 267 } 268} 269 270namespace eval QEntryBox { 271 proc create { title message script {width 300} } { 272 while { [winfo exists [set wn .ranwin[expr int(rand()*1000000)]]] } {} 273 toplevel $wn 274 wm title $wn $title 275 pack [message $wn.message -text $message -width $width] 276 pack [entry $wn.entry] 277 set script [parseformat $script [list [list g "\[$wn.entry get]"]] 278 set script "\{$script; destroy $wn\}" 279 bind $wn <<Enter>> "eval $script" 280 bind $wn <KeyPress-Escape> "destroy $wn" 281 pack [button $wn.buttonok -text "OK" -default active -command "eval $script"] -side left 282 pack [button $wn.buttoncancel -text "Cancel" -command "destroy $wn"] -side right 283 focus $wn.entry 284 return $wn 285 } 286} 287 288namespace eval QPasswordBox { 289 proc create { title message script {width 300} } { 290 while { [winfo exists [set wn .ranwin[expr int(rand()*1000000)]]] } {} 291 toplevel $wn 292 wm title $wn $title 293 pack [message $wn.message -text $message -width $width] 294 pack [entry $wn.entry -show *] 295 set script [parseformat $script [list [list g "\[$wn.entry get]"]] 296 set script "\{$script; destroy $wn\}" 297 bind $wn <<Enter>> "eval $script" 298 bind $wn <KeyPress-Escape> "destroy $wn" 299 pack [button $wn.buttonok -text "OK" -default active -command "eval $script"] -side left 300 pack [button $wn.buttoncancel -text "Cancel" -command "destroy $wn"] -side right 301 focus $wn.entry 302 return $wn 303 } 304} 305 306namespace eval QListBox { 307 set tagindex 0 308 array set colors {} 309 array set priorities {} 310 array set selected {} 311 312 proc killtags { windowname first } { 313 foreach tagtype [$windowname tag names $first] { 314 if { $tagtype != "selected" } { 315 $windowname tag delete $tagtype 316 } 317 } 318 } 319 proc create { windowname command args } { 320 set background black 321 set foreground white 322 set selectbackground red 323 set selectforeground black 324 set font "helvetica" 325 set width 100 326 set ::QListBox::priorities($windowname) {} 327 set ::QListBox::selected($windowname) -1 328 for { set n 0 } { $n < [llength $args] } { incr n } { 329 switch -- [lindex $args $n] { 330 -background { 331 incr n 332 set background [lindex $args $n] 333 } 334 -foreground { 335 incr n 336 set foreground [lindex $args $n] 337 } 338 -selectbackground { 339 incr n 340 set selectbackground [lindex $args $n] 341 } 342 -selectforeground { 343 incr n 344 set selectforeground [lindex $args $n] 345 } 346 -font { 347 incr n 348 set font [lindex $args $n] 349 } 350 -width { 351 incr n 352 set width [lindex $args $n] 353 } 354 default { 355 puts "ERROR!!!" 356 } 357 } 358 } 359 frame $windowname -width $width 360 grid propagate $windowname 0 361 # No Scrollbars 362 grid [text $windowname.t -state disabled -exportselection no -background $background -foreground $foreground -selectbackground $background -selectforeground $foreground -selectborderwidth 0 -font $font -wrap none -width 0 -height 0 -cursor left_ptr] -column 1 -row 1 -sticky nesw 363 # Scrollbars 364 #grid [text $windowname.t -state disabled -exportselection no -background $background -foreground $foreground -selectbackground $background -selectforeground $foreground -selectborderwidth 0 -font $font -yscroll "$windowname.y set" -xscroll "$windowname.x set" -wrap none -width 0 -height 0 -cursor left_ptr] -column 1 -row 1 -sticky nesw 365 #grid [scrollbar $windowname.y -command "$windowname.t yview"] -column 2 -row 1 -sticky nesw 366 #grid [scrollbar $windowname.x -orient horizontal -command "$windowname.t xview"] -column 1 -row 2 -sticky new 367 grid columnconfigure $windowname 1 -weight 1 368 grid rowconfigure $windowname 1 -weight 1 369 $windowname.t tag configure selected -background $selectbackground -foreground $selectforeground 370 bind $windowname.t <B1-Motion> "$windowname.t tag remove selected 0.0 end; $windowname.t tag add selected \"@%x,%y linestart\" \"@%x,%y lineend\"; $command \[expr \[lindex \[split \[$windowname.t tag ranges selected] \".\"] 0]-1]; break;" 371 bind $windowname.t <1> "$windowname.t tag remove selected 0.0 end; $windowname.t tag add selected \"@%x,%y linestart\" \"@%x,%y lineend\"; $command \[expr \[lindex \[split \[$windowname.t tag ranges selected] \".\"] 0]-1]; break;" 372 $windowname configure -width $width 373 return $windowname 374 } 375 proc insert { windowname index item } { 376 incr index 377 $windowname.t configure -state normal 378 $windowname.t insert end "\n" 379 $windowname.t insert $index.0 "$item\n" 380 $windowname.t delete "end - 2 c" end 381 $windowname.t configure -state disabled 382 set ::QListBox::priorities($windowname) [linsert $::QListBox::priorities($windowname) [expr $index - 1] 0] 383 #$windowname.t tag remove selected 0.0 end 384 #$windowname.t tag add selected $index.0 $index.end 385 } 386 proc delete { windowname index } { 387 incr index 388 $windowname.t configure -state normal 389 $windowname.t insert end "\n" 390 $windowname.t delete $index.0 [expr $index+1].0 391 $windowname.t delete "end - 2 c" end 392 $windowname.t configure -state disabled 393 set ::QListBox::priorities($windowname) [lreplace $::QListBox::priorities($windowname) [expr $index - 1] [expr $index - 1]] 394 } 395 proc addcolor { windowname name priority args } { 396 if { [llength $args] != 1 && [llength $args] != 2 } { 397 error "Usage: QListBox::addcolor <name> <priority> <foreground> \[<background>\]" 398 } 399 set ::QListBox::colors($name) [list $priority $args] 400 } 401 proc colorize { windowname index name } { 402 # If we're working with the selected window, return. We don't want to 403 # return when we're killing the color though. 404 if { $::QListBox::selected($windowname) == $index && 405 $name != "normal" } { return } 406 407 if { [array names ::QListBox::colors -exact $name] == "" } { 408 error "The $name color was not previously added with addcolor." 409 } 410 411 incr index 412 if { $index>=[lindex [split [$windowname.t index end] "."] 0] || $index<1} { 413 error "Illegal window index given to colorize" 414 } 415 416 # Extract the colors and priority 417 set priority [lindex $::QListBox::colors($name) 0] 418 set cols [lindex $::QListBox::colors($name) 1] 419 420 # Grab the priority from the priority list for this window. 421 set prilist $::QListBox::priorities($windowname) 422 set oldpriority [lindex $prilist [expr $index - 1]] 423 424 # Only if the new priority is greater than or equal to the old priority 425 # or if the new priority is to cancel the coloring do we not return. 426 if { $oldpriority > $priority && $priority != 0 } { return } 427 428 set ::QListBox::priorities($windowname) [lreplace $prilist [expr $index - 1] [expr $index - 1] $priority] 429 430 killtags $windowname.t $index.0 431 if { [llength $cols] > 1 } { 432 $windowname.t tag configure $::QListBox::tagindex -foreground [lindex $cols 0] -background [lindex $cols 1] 433 } else { 434 $windowname.t tag configure $::QListBox::tagindex -foreground [lindex $cols 0] 435 } 436 $windowname.t tag add $::QListBox::tagindex $index.0 $index.end 437 $windowname.t tag raise selected 438 incr ::QListBox::tagindex 439 } 440 proc select { windowname index } { 441 set ::QListBox::selected($windowname) $index 442 incr index 443 $windowname.t tag remove selected 0.0 end 444 if { [$windowname.t get $index.0 $index.[string length $::dynamic::theme_windowlist_indent]]!=$::dynamic::theme_windowlist_indent } { 445 $windowname.t tag add selected $index.0 $index.end 446 } else { 447 $windowname.t tag add selected $index.[string length $::dynamic::theme_windowlist_indent] $index.end 448 } 449 } 450} 451 452#bind . <1> { destroy .f.y } 453#bind . <Control-1> { grid [scrollbar .f.y] -column 2 -row 1 -sticky nesw } 454#bind . <2> { destroy .f.x } 455#bind . <Control-2> { grid [scrollbar .f.x -orient horizontal] -column 1 -row 2 -sticky new } 456 457 458# The following is modified version of D. Richard Hipp's tree widget. 459 460# Copyright (C) 1997,1998 D. Richard Hipp 461# 462# This library is free software; you can redistribute it and/or 463# modify it under the terms of the GNU Library General Public 464# License as published by the Free Software Foundation; either 465# version 2 of the License, or (at your option) any later version. 466# 467# This library is distributed in the hope that it will be useful, 468# but WITHOUT ANY WARRANTY; without even the implied warranty of 469# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 470# Library General Public License for more details. 471# 472# You should have received a copy of the GNU Library General Public 473# License along with this library; if not, write to the 474# Free Software Foundation, Inc., 59 Temple Place - Suite 330, 475# Boston, MA 02111-1307, USA. 476# 477# Author contact information: 478# drh@acm.org 479# http://www.hwaci.com/drh/ 480# 481# $Revision: 1.31 $ 482# 483option add *highlightThickness 0 484 485switch $tcl_platform(platform) { 486 unix { 487 set Tree(font) \ 488 -adobe-helvetica-medium-r-normal-*-11-80-100-100-p-56-iso8859-1 489 } 490 windows { 491 set Tree(font) \ 492 -adobe-helvetica-medium-r-normal-*-14-100-100-100-p-76-iso8859-1 493 } 494} 495 496# 497# Create a new tree widget. $args become the configuration arguments to 498# the canvas widget from which the tree is constructed. 499# 500proc Tree:create {w args} { 501 global Tree 502 eval canvas $w -bg white $args 503 bind $w <Destroy> "Tree:delitem $w /" 504 Tree:dfltconfig $w / 505 Tree:buildwhenidle $w 506 set Tree($w:selection) {} 507 set Tree($w:selidx) {} 508} 509 510# Initialize a element of the tree. 511# Internal use only 512# 513proc Tree:dfltconfig {w v} { 514 global Tree 515 set Tree($w:$v:children) {} 516 set Tree($w:$v:open) 0 517 set Tree($w:$v:icon) {} 518 set Tree($w:$v:tags) {} 519} 520 521# 522# Pass configuration options to the tree widget 523# 524proc Tree:config {w args} { 525 eval $w config $args 526} 527 528# 529# Insert a new element $v into the tree $w. 530# 531proc Tree:newitem {w v args} { 532 global Tree 533 set dir [file dirname $v] 534 set n [file tail $v] 535 if {![info exists Tree($w:$dir:open)]} { 536 Tree:newitem $w $dir $args 537 # error "parent item \"$dir\" is missing" 538 } 539 set i [lsearch -exact $Tree($w:$dir:children) $n] 540 if {$i>=0} { 541 error "item \"$v\" already exists" 542 } 543 lappend Tree($w:$dir:children) $n 544 set Tree($w:$dir:children) [lsort $Tree($w:$dir:children)] 545 Tree:dfltconfig $w $v 546 foreach {op arg} $args { 547 switch -exact -- $op { 548 -image {set Tree($w:$v:icon) $arg} 549 -tags {set Tree($w:$v:tags) $arg} 550 } 551 } 552 Tree:buildwhenidle $w 553} 554 555# 556# Delete element $v from the tree $w. If $v is /, then the widget is 557# deleted. 558# 559proc Tree:delitem {w v} { 560 global Tree 561 if {![info exists Tree($w:$v:open)]} return 562 if {[string compare $v /]==0} { 563 # delete the whole widget 564 catch {destroy $w} 565 foreach t [array names Tree $w:*] { 566 unset Tree($t) 567 } 568 return 569 } 570 foreach c $Tree($w:$v:children) { 571 catch {Tree:delitem $w $v/$c} 572 } 573 unset Tree($w:$v:open) 574 unset Tree($w:$v:children) 575 unset Tree($w:$v:icon) 576 set dir [file dirname $v] 577 set n [file tail $v] 578 set i [lsearch -exact $Tree($w:$dir:children) $n] 579 if {$i>=0} { 580 set Tree($w:$dir:children) [lreplace $Tree($w:$dir:children) $i $i] 581 } 582 Tree:buildwhenidle $w 583} 584 585# 586# Change the selection to the indicated item 587# 588proc Tree:setselection {w v} { 589 global Tree 590 set Tree($w:selection) $v 591 Tree:drawselection $w 592} 593 594# 595# Retrieve the current selection 596# 597proc Tree:getselection w { 598 global Tree 599 return $Tree($w:selection) 600} 601 602# 603# Bitmaps used to show which parts of the tree can be opened. 604# 605set maskdata "#define solid_width 9\n#define solid_height 9" 606append maskdata { 607 static unsigned char solid_bits[] = { 608 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 0xff, 0x01, 609 0xff, 0x01, 0xff, 0x01, 0xff, 0x01 610 }; 611} 612set data "#define open_width 9\n#define open_height 9" 613append data { 614 static unsigned char open_bits[] = { 615 0xff, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x7d, 0x01, 0x01, 0x01, 616 0x01, 0x01, 0x01, 0x01, 0xff, 0x01 617 }; 618} 619image create bitmap Tree:openbm -data $data -maskdata $maskdata \ 620 -foreground black -background white 621set data "#define closed_width 9\n#define closed_height 9" 622append data { 623 static unsigned char closed_bits[] = { 624 0xff, 0x01, 0x01, 0x01, 0x11, 0x01, 0x11, 0x01, 0x7d, 0x01, 0x11, 0x01, 625 0x11, 0x01, 0x01, 0x01, 0xff, 0x01 626 }; 627} 628image create bitmap Tree:closedbm -data $data -maskdata $maskdata \ 629 -foreground black -background white 630 631# Internal use only. 632# Draw the tree on the canvas 633proc Tree:build w { 634 global Tree 635 $w delete all 636 catch {unset Tree($w:buildpending)} 637 set Tree($w:y) 30 638 Tree:buildlayer $w / 10 639 $w config -scrollregion [$w bbox all] 640 Tree:drawselection $w 641} 642 643# Internal use only. 644# Build a single layer of the tree on the canvas. Indent by $in pixels 645proc Tree:buildlayer {w v in} { 646 global Tree 647 if {$v=="/"} { 648 set vx {} 649 } else { 650 set vx $v 651 } 652 set start [expr $Tree($w:y)-10] 653 foreach c $Tree($w:$v:children) { 654 set y $Tree($w:y) 655 incr Tree($w:y) 17 656 $w create line $in $y [expr $in+10] $y -fill gray50 657 set icon $Tree($w:$vx/$c:icon) 658 set taglist x 659 foreach tag $Tree($w:$vx/$c:tags) { 660 lappend taglist $tag 661 } 662 set x [expr $in+12] 663 if {[string length $icon]>0} { 664 set k [$w create image $x $y -image $icon -anchor w -tags $taglist] 665 incr x 20 666 set Tree($w:tag:$k) $vx/$c 667 } 668 set j [$w create text $x $y -text $c -font $Tree(font) \ 669 -anchor w -tags $taglist] 670 set Tree($w:tag:$j) $vx/$c 671 set Tree($w:$vx/$c:tag) $j 672 if {[string length $Tree($w:$vx/$c:children)]} { 673 if {$Tree($w:$vx/$c:open)} { 674 set j [$w create image $in $y -image Tree:openbm] 675 $w bind $j <1> "set Tree([escape $w:$vx/$c:open]) 0; Tree:build $w" 676 Tree:buildlayer $w $vx/$c [expr $in+18] 677 } else { 678 set j [$w create image $in $y -image Tree:closedbm] 679 $w bind $j <1> "set Tree([escape $w:$vx/$c:open]) 1; Tree:build $w" 680 } 681 } 682 } 683 if { [llength $Tree($w:$v:children)] } { 684 set j [$w create line $in $start $in [expr $y+1] -fill gray50 ] 685 $w lower $j 686 } 687} 688 689# Open a branch of a tree 690# 691proc Tree:open {w v} { 692 global Tree 693 if {[info exists Tree($w:$v:open)] && $Tree($w:$v:open)==0 694 && [info exists Tree($w:$v:children)] 695 && [string length $Tree($w:$v:children)]>0} { 696 set Tree($w:$v:open) 1 697 Tree:build $w 698 } 699} 700 701proc Tree:close {w v} { 702 global Tree 703 if {[info exists Tree($w:$v:open)] && $Tree($w:$v:open)==1} { 704 set Tree($w:$v:open) 0 705 Tree:build $w 706 } 707} 708 709# Internal use only. 710# Draw the selection highlight 711proc Tree:drawselection w { 712 global Tree 713 if {[string length $Tree($w:selidx)]} { 714 $w delete $Tree($w:selidx) 715 } 716 set v $Tree($w:selection) 717 if {[string length $v]==0} return 718 if {![info exists Tree($w:$v:tag)]} return 719 set bbox [$w bbox $Tree($w:$v:tag)] 720 if {[llength $bbox]==4} { 721 set i [eval $w create rectangle $bbox -fill skyblue -outline {{}}] 722 set Tree($w:selidx) $i 723 $w lower $i 724 } else { 725 set Tree($w:selidx) {} 726 } 727} 728 729# Internal use only 730# Call Tree:build then next time we're idle 731proc Tree:buildwhenidle w { 732 global Tree 733 if {![info exists Tree($w:buildpending)]} { 734 set Tree($w:buildpending) 1 735 after idle "Tree:build $w" 736 } 737} 738 739# 740# Return the full pathname of the label for widget $w that is located 741# at real coordinates $x, $y 742# 743proc Tree:labelat {w x y} { 744 set x [$w canvasx $x] 745 set y [$w canvasy $y] 746 global Tree 747 foreach m [$w find overlapping $x $y $x $y] { 748 if {[info exists Tree($w:tag:$m)]} { 749 return $Tree($w:tag:$m) 750 } 751 } 752 return "" 753} 754