1#!/usr/local/bin/wish 2 3# $Id: ftcllib.tcl,v 1.1 2000/06/26 19:23:59 cfelaco Exp $ 4 5# Ftcllib is a collection of useful procedures for Tcl/Tk programs. 6# Copyright (C) 1999 B. Christopher Felaco 7 8# This program is free software; you can redistribute it and/or 9# modify it under the terms of the GNU General Public License 10# as published by the Free Software Foundation; either version 2 11# of the License, or (at your option) any later version. 12 13# This program is distributed in the hope that it will be useful, 14# but WITHOUT ANY WARRANTY; without even the implied warranty of 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16# GNU General Public License for more details. 17 18# You should have received a copy of the GNU General Public License 19# along with this program; if not, write to the Free Software 20# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 21 22# For more information about Ftcllib and its author see: 23# URL:http://cbrowser.sourceforge.net/ 24# 25# Feel free to contact me at URL:mailto:cfelaco@users.sourceforge.net 26# with enhancements or suggestions. 27 28# $Log: ftcllib.tcl,v $ 29# Revision 1.1 2000/06/26 19:23:59 cfelaco 30# Initial source file revisions for sourceforge.net. 31# Existing revision history is based on RCS revisions made by original author 32# in private repository. 33# 34# Revision 1.1 1999/03/15 01:06:19 chris 35# Initial revision 36# 37 38# This file contains assorted Tcl/Tk utility functions. There are various 39# short convenience functions for string/list manipulation, and many Tk 40# utilities: 41# - Paned windows 42# - file viewer based on edit widget (does not allow editing) 43# - general purpose edit menu 44# - text finder for file viewer 45# - goto line dialog for file viewer 46# - "magic" scrollbars, appear only when needed 47# - scrollable history in entry fields 48# - C source code syntax highlighting 49# - blinking activity light 50#---------------------------------------------------------------------------- 51 52# Setup some aliases for those pesky string commands 53interp alias {} strcmp {} string compare 54interp alias {} strlen {} string length 55interp alias {} substring {} string range 56 57#---------------------------------------------------------------------------- 58# The following is from "Practical Programming in Tcl and Tk" Second Edition 59# by Brent B. Welch Copyright 1997 Prentice Hall. 60# 61# Enhancements: 62# - When the cursor leaves the window, reversing direction will not take 63# effect until the cursor reenters the window. 64# - A new option -background has been added to control the color of the 65# separator. 66# - Uses appropriate cursor for resizing instead of crosshair. 67#---------------------------------------------------------------------------- 68 69proc Pane_Create {f1 f2 args} { 70 71 # Map optional arguments into array values 72 set t(-orient) vertical 73 set t(-percent) 0.5 74 set t(-in) [winfo parent $f1] 75 set t(-background) black 76 set t(-minpercent) 0.0 77 set t(-maxpercent) 1.0 78 array set t $args 79 80 # Keep state in an array associated with the master frame 81 set master $t(-in) 82 upvar \#0 Pane$master pane 83 array set pane [array get t] 84 85 # Create the grip and set placement attributes that 86 # will not change. A thin divider line is achieved by 87 # making the two frames one pixel smaller in the 88 # adjustable dimension and making the main frame black. 89 90 set pane(1) $f1 91 set pane(2) $f2 92 set cursor sb_[string range $pane(-orient) 0 0]_double_arrow 93 set pane(grip) [frame $master.grip -background gray50 \ 94 -width 10 -height 10 -bd 2 -relief raised \ 95 -cursor $cursor] 96 if {[string match vert* $pane(-orient)]} { 97 set pane(D) Y ;# Adjust boundary in Y direction 98 place $pane(1) -in $master -x 0 -rely 0.0 -anchor nw \ 99 -relwidth 1.0 -height -1 100 place $pane(2) -in $master -x 0 -rely 1.0 -anchor sw \ 101 -relwidth 1.0 -height -1 102 place $pane(grip) -in $master -anchor c -relx 0.9 103 } else { 104 set pane(D) X ;# Adjust boundary in X direction 105 place $pane(1) -in $master -relx 0.0 -y 0 -anchor nw \ 106 -relheight 1.0 -width -1 107 place $pane(2) -in $master -relx 1.0 -y 0 -anchor ne \ 108 -relheight 1.0 -width -1 109 place $pane(grip) -in $master -anchor c -rely 0.8 110 } 111 $master configure -background $pane(-background) 112 113 set pane(toplevel) [winfo toplevel $master] 114 115 # Set up bindings for resize, <Configure>, and 116 # for dragging the grip. 117 118 bind $master <Configure> [list PaneGeometry $master %w %h] 119 bind $pane(grip) <ButtonPress-1> \ 120 [list PaneDrag $master %$pane(D)] 121 bind $pane(grip) <B1-Motion> \ 122 [list PaneDrag $master %$pane(D)] 123 bind $pane(grip) <ButtonRelease-1> \ 124 [list PaneStop $master] 125 126 # Do the initial layout 127 PaneGeometry $master 128} 129 130proc PaneDrag {master D} { 131 upvar \#0 Pane$master pane 132 133 set d [string tolower $pane(D)] 134 if {! [info exists pane(base)]} { 135 # Get the screen coordinate (either x or y) of the top of the pane. 136 # The vroot$d is used to correct for virtual screen managers. The 137 # root$d command on the gets the screen coordinate as opposed to the 138 # coordinate relative to the parent. 139 set pane(base) [expr [winfo vroot$d $pane(toplevel)] + \ 140 [winfo root$d $master]] 141 } 142 143 set pane(-percent) [expr double($D - $pane(base)) / $pane(size)] 144 if {$pane(-percent) < $pane(-minpercent)} { 145 set pane(-percent) $pane(-minpercent) 146 } elseif {$pane(-percent) > $pane(-maxpercent)} { 147 set pane(-percent) $pane(-maxpercent) 148 } 149 150 PaneGeometry $master 151} 152 153proc PaneStop {master} { 154 upvar \#0 Pane$master pane 155 catch {unset pane(base)} 156} 157 158proc PaneGeometry {master {width -1} {height -1}} { 159 160 upvar \#0 Pane$master pane 161 if {[strcmp $pane(D) "X"] == 0} { 162 place $pane(1) -relwidth $pane(-percent) 163 place $pane(2) -relwidth [expr 1.0 - $pane(-percent)] 164 place $pane(grip) -relx $pane(-percent) 165 166 if {$width < 0} { 167 set pane(size) [winfo width $master] 168 } else { 169 set pane(size) $width 170 } 171 } else { 172 place $pane(1) -relheight $pane(-percent) 173 place $pane(2) -relheight [expr 1.0 - $pane(-percent)] 174 place $pane(grip) -rely $pane(-percent) 175 176 if {$height < 0} { 177 set pane(size) [winfo height $master] 178 } else { 179 set pane(size) $height 180 } 181 } 182} 183 184############################################################################## 185# 186# Purpose : Setup a file viewer window with scrollbars 187# 188# Parameters : root - the root widget path 189# frame - the frame to pack the file_viewer in 190# 191# Result : NONE 192# 193############################################################################## 194 195proc setup_file_viewer {root frame} { 196 197 set_root_base $root 198 199 if {[strcmp [bind Viewer] ""] == 0} { 200 setup_viewer_bindings 201 } 202 203# # Determine the width of the first tab by calculating the width of the 204# # text_mark 205# global text_mark 206# set tabwidth [expr ([image width $text_mark] + 4) / (72 * [tk scaling])] 207# puts "tabwidth = $tabwidth" 208 set tabwidth 0.5 209 210 # Create the text widget for the viewer. 211 # The automagic scrollbar system is installed for this widget. 212 text $base.file_viewer \ 213 -height 25 -width 1 -state disabled \ 214 -wrap none \ 215 -background black -foreground grey \ 216 -selectbackground grey -selectforeground black \ 217 -insertbackground green 218 #-tabs "${tabwidth}i left 1i left 1i left 1i left" 219 220 magic_scroll $base.file_viewer $frame 221 222 # Replace the Text group with the Viewer group 223 set tags [bindtags $base.file_viewer] 224 set index [lsearch $tags Text] 225 set tags [lreplace $tags $index $index Viewer] 226 bindtags $base.file_viewer $tags 227 228 global highlight_tags 229 # Preconfigure the code highlight tags (avoids redraws) 230 $base.file_viewer tag configure quote -foreground green3 231 $base.file_viewer tag configure keyword -foreground red 232 $base.file_viewer tag configure cpp -foreground khaki4 233 $base.file_viewer tag configure typename -foreground orange 234 $base.file_viewer tag configure comment -foreground tan 235 # Make sure comment tags override any others 236 $base.file_viewer tag raise comment 237 238 # Create a tag to underline matches 239 $base.file_viewer tag configure matched_text -underline yes 240 241 # Setup the search tag 242 $base.file_viewer tag configure find -foreground black -background grey 243 244 # Setup the binding for the finder and goto 245 bind $base.file_viewer <Control-s> "browser_find_dialog $base.file_viewer" 246 bind $base.file_viewer <Control-r> "browser_find_dialog $base.file_viewer" 247 bind $base.file_viewer <Meta-g> "browser_goto $base.file_viewer" 248 249 # Setup the popup edit menu 250 setup_edit_menu $base.file_viewer.menu $base.file_viewer 251 bind $base.file_viewer <Button-3> "tk_popup $base.file_viewer.menu %X %Y" 252} 253 254############################################################################## 255# 256# Purpose : Setup the Viewer binding tag. It is identical to the Text 257# binding tag except without insertion. 258# 259# Parameters : NONE 260# 261# Result : NONE 262# 263############################################################################## 264 265proc setup_viewer_bindings {} { 266 # Copy the event bindings from Text to Viewer 267 foreach event [bind Text] { 268 bind Viewer $event [bind Text $event] 269 } 270 271 # Shut any events that can modify the text. Hopefully this is all of them. 272 # It would have been nice if all of these were already grouped into an 273 # "Editor" tags group! 274 foreach event { <Key> 275 <Key-Delete> <Key-BackSpace> <Control-Key-h> 276 <Meta-Key-Delete> <Meta-Key-BackSpace> <Meta-Key-d> 277 <Control-Key-t> <Control-Key-o> <Control-Key-k> <Control-Key-d> 278 <Key-Insert> <Key-Return> <Control-Key-i> 279 <<Clear>> <<Paste>> <<Cut>> \ 280 <Button-2> <ButtonPress-2> <ButtonRelease-2>} { 281 bind Viewer $event {} 282 } 283 284 285 # Make Tab act like normal widgets 286 bind Viewer <Key-Tab> [bind all <Tab>] 287 bind Viewer <Shift-Key-Tab> [bind all <Shift-Key-Tab>] 288 289 # Allow use of scroll mouse in viewer 290 setup_scroll_bindings Viewer 291} 292 293############################################################################## 294# 295# Purpose : Setup an Edit menu 296# 297# Parameters : menu - the menu widget to create 298# viewer - the viewer widget it operates on 299# 300# Result : NONE 301# 302############################################################################## 303 304proc setup_edit_menu {menu viewer} { 305 306 # Set up the Edit menu 307 menu $menu -postcommand "edit_menu_filter $menu $viewer" 308 set accel [lindex [event info <<Cut>>] 0]; regsub "Key-" $accel "" accel 309 $menu add command -label "Cut" -underline 1 -accel $accel \ 310 -command {clipboard_cut} 311 set accel [lindex [event info <<Copy>>] 0]; regsub "Key-" $accel "" accel 312 $menu add command -label "Copy" -underline 0 -accel $accel \ 313 -command {clipboard_copy} 314 set accel [lindex [event info <<Paste>>] 0]; regsub "Key-" $accel "" accel 315 $menu add command -label "Paste" -underline 0 -accel $accel \ 316 -command "set_query_selection $menu" 317 318 $menu add separator 319 $menu add command -label "Find..." -underline 0 -accel <Control-s> \ 320 -command "browser_find_dialog $viewer" 321 $menu add command -label "Goto line..." -underline 0 \ 322 -accel <Meta-g> -command "browser_goto $viewer" 323} 324 325############################################################################## 326# 327# Purpose : Filter the entries in the edit menu before posting. 328# 329# Parameters : menu - the menu it was invoked on 330# viewer - the viewer widget it checks 331# 332# Result : NONE 333# 334############################################################################## 335 336proc edit_menu_filter {menu viewer} { 337 global current_file 338 if {[info exists current_file($viewer)] && 339 [strlen $current_file($viewer)] > 0} { 340 $menu entryconfigure "Find..." -state normal 341 $menu entryconfigure "Goto line..." -state normal 342 } else { 343 $menu entryconfigure "Find..." -state disabled 344 $menu entryconfigure "Goto line..." -state disabled 345 } 346 347 set widget [selection own] 348 if {[strlen $widget] > 0} { 349 $menu entryconfigure "Copy" -state normal 350 if {[strcmp [winfo class $widget] "Entry"] == 0} { 351 if {[strcmp [$widget cget -state] "normal"] == 0} { 352 $menu entryconfigure "Cut" -state normal 353 } else { 354 $menu entryconfigure "Cut" -state disabled 355 } 356 } else { 357 $menu entryconfigure "Cut" -state disabled 358 } 359 } else { 360 $menu entryconfigure "Cut" -state disabled 361 $menu entryconfigure "Copy" -state disabled 362 } 363} 364 365#---------------------------------------------------------------------------- 366# The following functions for automagic scrollbars deserve some comments. 367# The basic idea is to leave the scrollbars unpacked until they are needed. 368# Once they are needed, leave them up, even if the window is scrolled to the 369# point where no lines extend out of the window. This avoids the possibility 370# of an infinite loop. If the size of the window is increased, it is safe to 371# unpack the scrollbars, because they will be repacked by the resulting 372# scrollcommand if they are needed. 373#---------------------------------------------------------------------------- 374 375############################################################################## 376# 377# Purpose : Install magic scrollbars around the given widget. 378# 379# Parameters : widget - the widget to put scrollbars on 380# frame - the frame to pack it in 381# 382# Result : NONE 383# 384############################################################################## 385 386set magic_scroll [expr [info tclversion] >= 8.0] 387 388proc magic_scroll {widget frame} { 389 390 global magic_scroll 391 392 # Create the scrollbars 393 scrollbar ${widget}_xscroll -orient h -takefocus 0 \ 394 -command [list ${widget} xview] 395 scrollbar ${widget}_yscroll -orient v -takefocus 0 \ 396 -command [list ${widget} yview] 397 398 # Use these commands to pack the scrollbars 399 set pack_xscroll [list grid ${widget}_xscroll \ 400 -in $frame -row 1 -column 0 -sticky we] 401 set pack_yscroll [list grid ${widget}_yscroll \ 402 -in $frame -row 0 -column 1 -sticky ns] 403 404 # Pack the scrollable widget 405 grid $widget -row 0 -column 0 -sticky nesw -in $frame 406 407 if {$magic_scroll} { 408 ${widget} configure \ 409 -xscrollcommand [list scroll_set ${widget}_xscroll $pack_xscroll] \ 410 -yscrollcommand [list scroll_set ${widget}_yscroll $pack_yscroll] 411 412 # Handle automagic scrollbars removal when the widget resizes 413 bind $widget <Configure> \ 414 "scroll_reconfigure %W %w %h ${widget}_xscroll ${widget}_yscroll" 415 } else { 416 ${widget} configure \ 417 -xscrollcommand [list ${widget}_xscroll set] \ 418 -yscrollcommand [list ${widget}_yscroll set] 419 420 eval $pack_xscroll 421 eval $pack_yscroll 422 } 423 424 # Configure the rows and columns 425 grid rowconfigure $frame 0 -weight 1 426 grid columnconfigure $frame 0 -weight 1 427 grid columnconfigure $frame 1 -weight 0 428} 429 430############################################################################## 431# 432# Purpose : Set the scrollbar to match the window. Pack it if it is not 433# already packed. For use as [xy]scrollcommand. 434# 435# Parameters : scrollbar - the scrollbar to modify 436# geoCmd - the command to pack the scrollbar 437# offset - the offset within the window 438# size - the overall size of the window 439# 440# Result : NONE 441# 442############################################################################## 443 444proc scroll_set {scrollbar geoCmd offset size} { 445 446 set ispacked [string length [winfo manager $scrollbar]] 447 448 if {$offset != 0.0 || $size != 1.0} { 449 if {!$ispacked} { 450 eval $geoCmd 451 } 452 } 453 $scrollbar set $offset $size 454} 455 456############################################################################## 457# 458# Purpose : Remove scrollbars when widget size increases. 459# 460# Parameters : widget - the widget being reconfigured 461# width - the new width 462# height - the new height 463# xscroll - the corresponding x scrollbar 464# yscroll - the corresponding y scrollbar 465# 466# Result : NONE 467# 468############################################################################## 469 470proc scroll_reconfigure {widget width height xscroll yscroll} { 471 global widget_width widget_height 472 473 if {[info exists widget_width($widget)] && 474 $width > $widget_width($widget)} { 475 476 set xview [$widget xview] 477 if { [lindex $xview 0] == 0.0 && [lindex $xview 1] == 1.0} { 478 unmap $xscroll 479 } 480 } 481 482 if {[info exists widget_height($widget)] && 483 $height > $widget_height($widget)} { 484 485 set yview [$widget yview] 486 if { [lindex $yview 0] == 0.0 && [lindex $yview 1] == 1.0} { 487 unmap $yscroll 488 } 489 } 490 491 # Record the new width and height 492 set widget_width($widget) $width 493 set widget_height($widget) $height 494} 495 496############################################################################### 497# 498# Purpose : Unmap a widget using whatever geometry manager was used to 499# map it. 500# 501# Parameters : widget - the widget to unmap 502# 503# Result : NONE 504# 505############################################################################## 506 507proc unmap {widget} { 508 set manager [winfo manager $widget] 509 if {[string length $manager] > 0} { 510 $manager forget $widget 511 } 512} 513 514 515############################################################################## 516# 517# Purpose : Create a dialog box for finding text in the textwidget. 518# 519# Parameters : textw - the text widget to act upon 520# 521# Result : NONE 522# 523############################################################################## 524 525proc browser_find_dialog {textw} { 526 global history_button find_hlist find_dialog current_file 527 528 set toplevel $textw.finder 529 530 if {[strcmp [$textw cget -state] "disabled"] == 0} { 531 return 532 } 533 534 if { ![winfo exists $toplevel] } { 535 toplevel $toplevel 536 537 frame $toplevel.toprow 538 pack $toplevel.toprow -side top -expand yes -fill x -pady 5 539 540 label $toplevel.l -text "Find:" 541 entry $toplevel.entry -textvariable find_text($textw) 542 menubutton $toplevel.recall -image $history_button \ 543 -menu $toplevel.recall.menu 544 menu $toplevel.recall.menu 545 pack $toplevel.l -side left -in $toplevel.toprow -padx 5 546 pack $toplevel.entry -side left -in $toplevel.toprow -expand yes -fill x 547 pack $toplevel.recall -side left -in $toplevel.toprow -padx 3 548 549 frame $toplevel.checkrow 550 pack $toplevel.checkrow -side top -pady 5 551 552 checkbutton $toplevel.regexp -variable find_regexp($textw) -text "Regexp" 553 checkbutton $toplevel.case -variable find_case($textw) -text "Case Sensitive" 554 pack $toplevel.regexp $toplevel.case -side left -in $toplevel.checkrow 555 556 frame $toplevel.buttonbar 557 pack $toplevel.buttonbar -side top -expand yes -pady 3 558 559 button $toplevel.forward -text "Forward" -underline 0 \ 560 -command "browser_find $textw -forward; focus $toplevel.forward" 561 button $toplevel.backward -text "Backward" -underline 0 \ 562 -command "browser_find $textw -backward; focus $toplevel.backward" 563 button $toplevel.close -text "Close" -underline 0 \ 564 -command "$textw tag remove find 1.0 end 565 wm withdraw $toplevel" 566 567 bind $toplevel <Control-f> "$toplevel.forward invoke" 568 bind $toplevel <Meta-f> "$toplevel.forward invoke" 569 bind $toplevel <Control-b> "$toplevel.backward invoke" 570 bind $toplevel <Meta-b> "$toplevel.backward invoke" 571 bind $toplevel <Control-s> "$toplevel.forward invoke" 572 bind $toplevel <Control-r> "$toplevel.backward invoke" 573 bind $toplevel <<Cancel>> "$toplevel.close invoke" 574 bind $toplevel <Meta-c> "$toplevel.close invoke" 575 576 bind $toplevel.entry <Return> "focus $toplevel.forward" 577 bind $toplevel.entry <Key-Up> \ 578 "field_history %W %K find_hindex find_hlist" 579 bind $toplevel.entry <Key-Down> \ 580 "field_history %W %K find_hindex find_hlist" 581 bind $toplevel.forward <Return> "%W invoke" 582 bind $toplevel.backward <Return> "%W invoke" 583 bind $toplevel.close <Return> "%W invoke" 584 585 # Ensure that the array elements are unset when the dialog is destroyed 586 bind $toplevel <Destroy> "browser_find_close" 587 588 pack $toplevel.forward $toplevel.backward $toplevel.close \ 589 -in $toplevel.buttonbar -side left -padx 10 590 591 # Initialize the start and end marks to the first position 592 $textw mark set find_start 1.0 593 $textw mark set find_end 1.0 594 595 # Initialize the recall history if unset 596 if ![info exists find_hlist] { 597 set find_hlist "" 598 $toplevel.recall configure -state disabled 599 } 600 601 # Track the dialog for each widget 602 set find_dialog($textw) $toplevel 603 604 # Populate the recall menu 605 foreach item $find_hlist { 606 $toplevel.recall.menu add command -label $item \ 607 -command [list set find_text($textw) $item] 608 } 609 610 wm title $toplevel "Find: $current_file($textw)" 611 wm minsize $toplevel 300 110 612 613 tkwait visibility $toplevel 614 615 bind $toplevel <Destroy> "browser_find_close $textw" 616 } else { 617 wm deiconify $toplevel 618 } 619 catch {raise $toplevel} 620 catch {focus -force $toplevel.entry} 621} 622 623############################################################################## 624# 625# Purpose : Cleanup when browser_find dialog is closed. 626# 627# Parameters : toplevel - the text widget associated with the dialog being 628# destroyed 629# 630# Result : NONE 631# 632############################################################################## 633 634proc browser_find_close {textw} { 635 foreach array { \ 636 find_text find_regexp find_case find_dialog} { 637 638 global $array 639 # NOTE: the backslash is needed to suppress the array substitution. 640 if [info exists $array\($textw\)] { 641 unset $array\($textw\) 642 } 643 } 644} 645 646############################################################################## 647# 648# Purpose : Find the selected text in the given text widget. 649# 650# Parameters : widget - the text widget to search in 651# direction - direction to search in 652# 653# Result : NONE 654# 655############################################################################## 656 657proc browser_find {widget {direction -forward}} { 658 global find_regexp find_case find_text find_hlist find_hindex find_dialog 659 660 $widget tag remove find 1.0 end 661 662 if {[strlen $find_text($widget)] == 0} { 663 return 664 } 665 666 # Add text to history. 667 if {[lsearch $find_hlist $find_text($widget)] < 0} { 668 set find_hlist [concat [list $find_text($widget)] $find_hlist] 669 if [info exists find_hindex] {unset find_hindex} 670 671 foreach widget [array names find_text] { 672 set finder "$widget.finder" 673 if [winfo exists $finder] { 674 $finder.recall.menu add command -label $find_text($widget) \ 675 -command [list set find_text($widget) $find_text($widget)] 676 $widget.finder.recall configure -state normal 677 } 678 } 679 } 680 681 set args "" 682 683 if {$find_regexp($widget)} { 684 lappend args "-regexp" 685 } 686 if {!$find_case($widget)} { 687 lappend args "-nocase" 688 } 689 690 # By default, use the current insertion point as the start of the search 691 set index insert 692 693 # If switching directions, make sure not to just find the same point 694 if {[string match {-b*} $direction] && 695 [$widget compare insert == find_end]} { 696 set index find_start 697 } elseif {[string match {-f*} $direction] && 698 [$widget compare insert == find_start]} { 699 set index find_end 700 } 701 702 set match [eval [concat $widget search $direction $args -count count -- \ 703 [list $find_text($widget)] $index]] 704 705 if {[strlen $match] > 0} { 706 $widget see $match 707 708 set match_end "$match +$count char" 709 $widget tag add find $match $match_end 710 711 # Set the new start and end marks 712 $widget mark set find_start $match 713 $widget mark set find_end $match_end 714 715 if {[string match {-b*} $direction]} { 716 $widget mark set insert $match 717 } elseif {[string match {-f*} $direction]} { 718 $widget mark set insert $match_end 719 } else { 720 error "bad direction, expected -backward or -forward" 721 } 722 } else { 723 tk_messageBox -type ok -parent $widget \ 724 -title "Not Found" -message "$find_text($widget) not found" 725 # Reraise and focus the find dialog. 726 if ![catch {raise $find_dialog($widget)}] { 727 focus $find_dialog($widget).entry 728 } 729 } 730} 731 732############################################################################## 733# 734# Purpose : Popup a dialog box to allow the user to jump to a particular 735# line. 736# 737# Parameters : textw - the text widget to act upon 738# 739# Result : NONE 740# 741############################################################################## 742 743proc browser_goto {textw} { 744 global goto_line 745 746 set toplevel $textw.goto 747 748 if {[strcmp [$textw cget -state] "disabled"] == 0} { 749 return 750 } 751 752 if {![winfo exists $textw.goto]} { 753 toplevel $toplevel 754 755 frame $toplevel.top_row 756 label $toplevel.label -text "Goto line:" 757 entry $toplevel.entry -textvariable goto_line($textw) -width 5 758 pack $toplevel.label -side left -in $toplevel.top_row 759 pack $toplevel.entry -side left -fill x -in $toplevel.top_row 760 pack $toplevel.top_row -side top -fill x 761 762 scale $toplevel.slider -from 1 -variable goto_line($textw) \ 763 -orient horizontal -showvalue true -bigincrement 50 764 765 pack $toplevel.slider -side top -fill x -expand yes -pady 3 -padx 3 766 767 frame $toplevel.buttonbar 768 button $toplevel.ok -text OK -width 8 \ 769 -command "$textw mark set insert \$goto_line($textw).1 770 $textw see insert 771 focus $textw 772 wm withdraw $toplevel" 773 button $toplevel.cancel -text Cancel -width 8 \ 774 -command "wm withdraw $toplevel" 775 pack $toplevel.ok $toplevel.cancel -side left -in $toplevel.buttonbar \ 776 -padx 30 777 778 pack $toplevel.buttonbar -side top 779 780 bind $toplevel <Return> "$toplevel.ok invoke" 781 bind $toplevel <<Cancel>> "$toplevel.cancel invoke" 782 783 wm geometry $toplevel 500x130 784 wm minsize $toplevel 300 135 785 wm title $toplevel "Goto Line" 786 } else { 787 wm deiconify $toplevel 788 } 789 790 set numlines [expr int([$textw index end])] 791 set tickinterval [expr $numlines / 7] 792 $toplevel.slider configure -to $numlines -tickinterval $tickinterval 793 794 set goto_line($textw) [expr int([$textw index insert])] 795 796 catch {raise $toplevel} 797 catch {focus -force $toplevel.entry} 798 # Select the line number so immediate typing will override the value. 799 $toplevel.entry select range 0 end 800} 801 802 803############################################################################## 804# 805# Purpose : Trim a history list to a certain number of entries. 806# 807# Parameters : varname - the name of the list to modify 808# maxlength - the maximum length of the list 809# 810# Result : the new value of the list 811# 812############################################################################## 813 814proc history_trim {varname {maxlength 20}} { 815 upvar $varname history 816 817 set len [llength $history] 818 if {$len > $maxlength} { 819 set history [lrange $history [expr $len - $maxlength] end] 820 } 821 return $history 822} 823 824############################################################################## 825# 826# Purpose : Utility function to determine the "base" window path from the 827# root window path. Basically, base is the prefix for other 828# widgets, while root can stand alone. 829# 830# Parameters : root - the root window parameter 831# 832# Result : NONE 833# 834############################################################################## 835 836proc set_root_base {root} { 837 # This treats "." as a special case 838 if {[strcmp $root "."] == 0} { 839 uplevel [list set base {}] 840 } else { 841 uplevel [list set base $root] 842 } 843} 844 845############################################################################## 846# 847# Purpose : Unconditionally execute a block of code after another even if 848# the first returns an error. 849# 850# Parameters : bodyform - the main text to evaluate 851# unwindform - the form to evaluate when the body returns 852# resultvar - variable to store the result in 853# 854# Result : return value of bodyform 855# 856############################################################################## 857 858proc unwind_protect {bodyform unwindform {resultvar ""}} { 859 860 set failed 0 861 if [catch {uplevel $bodyform} results] { 862 global errorInfo errorCode 863 set failed 1 864 set info $errorInfo 865 set code $errorCode 866 set message $results 867 } 868 869 uplevel $unwindform 870 871 if {$failed} { 872 error $message $info $code 873 } else { 874 if {[strlen $resultvar] > 0} { 875 upvar $resultvar var 876 set var $results 877 } 878 return $results 879 } 880} 881 882 883############################################################################## 884# 885# Purpose : Set the status message. 886# 887# Parameters : msg - the message to set 888# 889# Result : NONE 890# 891############################################################################## 892 893proc set_message {msg} { 894 global status_msg 895 set status_msg $msg 896} 897 898############################################################################## 899# 900# Purpose : Clear the file viewer in the given window. 901# 902# Parameters : root - the root of the window to operate on 903# 904# Result : NONE 905# 906############################################################################## 907 908proc display_clear {root} { 909 global current_file current_line 910 911 set_root_base $root 912 913 set textw $base.file_viewer 914 915 set current_file($textw) "" 916 set current_line($textw) "" 917 918 # Clear the display viewer and disable it 919 $textw delete 1.0 end 920 $textw configure -state disabled 921 922 # If we're doing magic scrollbars, unmap them 923 global magic_scroll 924 if {$magic_scroll} { 925 # Unmap the scrollbars if they are mapped 926 unmap $base.file_viewer_xscroll 927 unmap $base.file_viewer_yscroll 928 } 929 930 set current_results "" 931} 932 933############################################################################## 934# 935# Purpose : Create a dialog box for finding text in the textwidget. 936# 937# Parameters : textw - the text widget to act upon 938# 939# Result : NONE 940# 941############################################################################## 942 943proc browser_find_dialog {textw} { 944 global history_button find_hlist find_dialog current_file 945 946 set toplevel $textw.finder 947 948 if {[strcmp [$textw cget -state] "disabled"] == 0} { 949 return 950 } 951 952 if { ![winfo exists $toplevel] } { 953 toplevel $toplevel 954 955 frame $toplevel.toprow 956 pack $toplevel.toprow -side top -expand yes -fill x -pady 5 957 958 label $toplevel.l -text "Find:" 959 entry $toplevel.entry -textvariable find_text($textw) 960 menubutton $toplevel.recall -image $history_button \ 961 -menu $toplevel.recall.menu 962 menu $toplevel.recall.menu 963 pack $toplevel.l -side left -in $toplevel.toprow -padx 5 964 pack $toplevel.entry -side left -in $toplevel.toprow -expand yes -fill x 965 pack $toplevel.recall -side left -in $toplevel.toprow -padx 3 966 967 frame $toplevel.checkrow 968 pack $toplevel.checkrow -side top -pady 5 969 970 checkbutton $toplevel.regexp -variable find_regexp($textw) -text "Regexp" 971 checkbutton $toplevel.case -variable find_case($textw) -text "Case Sensitive" 972 pack $toplevel.regexp $toplevel.case -side left -in $toplevel.checkrow 973 974 frame $toplevel.buttonbar 975 pack $toplevel.buttonbar -side top -expand yes -pady 3 976 977 button $toplevel.forward -text "Forward" -underline 0 \ 978 -command "browser_find $textw -forward; focus $toplevel.forward" 979 button $toplevel.backward -text "Backward" -underline 0 \ 980 -command "browser_find $textw -backward; focus $toplevel.backward" 981 button $toplevel.close -text "Close" -underline 0 \ 982 -command "$textw tag remove find 1.0 end 983 wm withdraw $toplevel" 984 985 bind $toplevel <Control-f> "$toplevel.forward invoke" 986 bind $toplevel <Meta-f> "$toplevel.forward invoke" 987 bind $toplevel <Control-b> "$toplevel.backward invoke" 988 bind $toplevel <Meta-b> "$toplevel.backward invoke" 989 bind $toplevel <Control-s> "$toplevel.forward invoke" 990 bind $toplevel <Control-r> "$toplevel.backward invoke" 991 bind $toplevel <<Cancel>> "$toplevel.close invoke" 992 bind $toplevel <Meta-c> "$toplevel.close invoke" 993 994 bind $toplevel.entry <Return> "focus $toplevel.forward" 995 bind $toplevel.entry <Key-Up> \ 996 "field_history %W %K find_hindex find_hlist" 997 bind $toplevel.entry <Key-Down> \ 998 "field_history %W %K find_hindex find_hlist" 999 bind $toplevel.forward <Return> "%W invoke" 1000 bind $toplevel.backward <Return> "%W invoke" 1001 bind $toplevel.close <Return> "%W invoke" 1002 1003 # Ensure that the array elements are unset when the dialog is destroyed 1004 bind $toplevel <Destroy> "browser_find_close" 1005 1006 pack $toplevel.forward $toplevel.backward $toplevel.close \ 1007 -in $toplevel.buttonbar -side left -padx 10 1008 1009 # Initialize the start and end marks to the first position 1010 $textw mark set find_start 1.0 1011 $textw mark set find_end 1.0 1012 1013 # Initialize the recall history if unset 1014 if ![info exists find_hlist] { 1015 set find_hlist "" 1016 $toplevel.recall configure -state disabled 1017 } 1018 1019 # Track the dialog for each widget 1020 set find_dialog($textw) $toplevel 1021 1022 # Populate the recall menu 1023 foreach item $find_hlist { 1024 $toplevel.recall.menu add command -label $item \ 1025 -command [list set find_text($textw) $item] 1026 } 1027 1028 wm title $toplevel "Find: $current_file($textw)" 1029 wm minsize $toplevel 300 110 1030 1031 tkwait visibility $toplevel 1032 1033 bind $toplevel <Destroy> "browser_find_close $textw" 1034 } else { 1035 wm deiconify $toplevel 1036 } 1037 catch {raise $toplevel} 1038 catch {focus -force $toplevel.entry} 1039} 1040 1041############################################################################## 1042# 1043# Purpose : Cleanup when browser_find dialog is closed. 1044# 1045# Parameters : toplevel - the text widget associated with the dialog being 1046# destroyed 1047# 1048# Result : NONE 1049# 1050############################################################################## 1051 1052proc browser_find_close {textw} { 1053 foreach array { \ 1054 find_text find_regexp find_case find_dialog} { 1055 1056 global $array 1057 # NOTE: the backslash is needed to suppress the array substitution. 1058 if [info exists $array\($textw\)] { 1059 unset $array\($textw\) 1060 } 1061 } 1062} 1063 1064############################################################################## 1065# 1066# Purpose : Find the selected text in the given text widget. 1067# 1068# Parameters : widget - the text widget to search in 1069# direction - direction to search in 1070# 1071# Result : NONE 1072# 1073############################################################################## 1074 1075proc browser_find {widget {direction -forward}} { 1076 global find_regexp find_case find_text find_hlist find_hindex find_dialog 1077 1078 $widget tag remove find 1.0 end 1079 1080 if {[strlen $find_text($widget)] == 0} { 1081 return 1082 } 1083 1084 # Add text to history. 1085 if {[lsearch $find_hlist $find_text($widget)] < 0} { 1086 set find_hlist [concat [list $find_text($widget)] $find_hlist] 1087 if [info exists find_hindex] {unset find_hindex} 1088 1089 foreach widget [array names find_text] { 1090 set finder "$widget.finder" 1091 if [winfo exists $finder] { 1092 $finder.recall.menu add command -label $find_text($widget) \ 1093 -command [list set find_text($widget) $find_text($widget)] 1094 $widget.finder.recall configure -state normal 1095 } 1096 } 1097 } 1098 1099 set args "" 1100 1101 if {$find_regexp($widget)} { 1102 lappend args "-regexp" 1103 } 1104 if {!$find_case($widget)} { 1105 lappend args "-nocase" 1106 } 1107 1108 # By default, use the current insertion point as the start of the search 1109 set index insert 1110 1111 # If switching directions, make sure not to just find the same point 1112 if {[string match {-b*} $direction] && 1113 [$widget compare insert == find_end]} { 1114 set index find_start 1115 } elseif {[string match {-f*} $direction] && 1116 [$widget compare insert == find_start]} { 1117 set index find_end 1118 } 1119 1120 set match [eval [concat $widget search $direction $args -count count -- \ 1121 [list $find_text($widget)] $index]] 1122 1123 if {[strlen $match] > 0} { 1124 $widget see $match 1125 1126 set match_end "$match +$count char" 1127 $widget tag add find $match $match_end 1128 1129 # Set the new start and end marks 1130 $widget mark set find_start $match 1131 $widget mark set find_end $match_end 1132 1133 if {[string match {-b*} $direction]} { 1134 $widget mark set insert $match 1135 } elseif {[string match {-f*} $direction]} { 1136 $widget mark set insert $match_end 1137 } else { 1138 error "bad direction, expected -backward or -forward" 1139 } 1140 } else { 1141 tk_messageBox -type ok -parent $widget \ 1142 -title "Not Found" -message "$find_text($widget) not found" 1143 # Reraise and focus the find dialog. 1144 if ![catch {raise $find_dialog($widget)}] { 1145 focus $find_dialog($widget).entry 1146 } 1147 } 1148} 1149 1150# *** Thanks to Brian Meifert for the original basis of this highlighting code. 1151# *** It has been completely rewritten to use features of Tk7.6 and for improved 1152# *** support of C++. 1153 1154############################################################################## 1155# 1156# Purpose : Highlight C/C++ code to clarify syntax. 1157# 1158# Parameters : widget - the widget to be acted upon 1159# 1160# Result : NONE 1161# 1162############################################################################## 1163 1164set highlight_tags { 1165 comment keyword typename cpp quote 1166} 1167 1168set c_keywords "if while for return else typedef struct const static enum 1169switch case break default extern class inline protected private public virtual 1170operator using namespace template throw try catch sizeof" 1171 1172set c_typenames "void char int float double long short unsigned signed wchar_t 1173bool" 1174 1175proc c_highlights { widget } { 1176 1177 # Clear all highlight tags if the code_highlight option is off. 1178 global code_highlight 1179 if { ! $code_highlight } { 1180 global highlight_tags 1181 foreach tag $highlight_tags { 1182 $widget tag remove $tag 1.0 end 1183 } 1184 return 1185 } 1186 1187 comment_highlight $widget 1188 update idletasks 1189 1190 quote_highlight $widget 1191 update idletasks 1192 1193 global keyword_highlight c_keywords_regexp c_typenames_regexp 1194 if ![info exists c_keywords_regexp] { 1195 set c_keywords_regexp "namespace|using|operator|virtual|p(r(ivate|otected)|ublic)|default|break|c(onst|lass|a(tch|se))|s(t(atic|ruct)|witch|izeof)|t(ypedef|emplate|hrow|ry)|e(lse|num|xtern)|return|for|while|i(f|nline)" 1196 1197 set c_typenames_regexp "void|char|int|float|double|long|short|(un)?signed|wchar_t|bool" 1198 } 1199 1200 if {$keyword_highlight} { 1201 # Highlight C keywords 1202 highlight_word $c_keywords_regexp keyword $widget 1203 update idletasks 1204 1205 highlight_word $c_typenames_regexp typename $widget 1206 update idletasks 1207 1208 cpp_highlight $widget 1209 update idletasks 1210 } else { 1211 foreach tag {keyword typename cpp} { 1212 $widget tag remove $tag 1.0 end 1213 } 1214 } 1215} 1216 1217############################################################################## 1218# 1219# Purpose : Trace modifications to the code_highlight and 1220# keyword_highlight toggles to ensure the displays are 1221# consistent with the settings 1222# 1223# Parameters : variable - the variable to trace 1224# index - the index if variable is an array 1225# op - the operation performed 1226# 1227# Result : NONE 1228# 1229############################################################################## 1230 1231proc highlight_trace {variable index op} { 1232 global current_file current_line 1233 foreach textw [array names current_file] { 1234 if {[strlen $current_file($textw)] > 0} { 1235 c_highlights $textw 1236 } 1237 } 1238} 1239 1240############################################################################## 1241# 1242# Purpose : Highlight C/C++ style comments. 1243# 1244# Parameters : widget - the widget to be acted upon 1245# 1246# Result : NONE 1247# 1248############################################################################## 1249 1250proc comment_highlight {widget} { 1251 1252 set temp [$widget search -regexp {/\*|//} 1.0] 1253 while { [strlen $temp] > 0 && 1254 [$widget compare $temp < end] } { 1255 set match [$widget get $temp "$temp + 2chars"] 1256 if {[strcmp $match "//"] == 0} { 1257 set endcomment [$widget index "$temp lineend"] 1258 } else { 1259 set endcomment [$widget search -regexp {\*/} "$temp + 2chars"] 1260 if {[strlen $endcomment] == 0} { 1261 break 1262 } else { 1263 set endcomment "$endcomment + 2chars" 1264 } 1265 } 1266 if {[strlen $endcomment] != 0} { 1267 $widget tag add comment $temp "$endcomment" 1268 set temp [$widget search -regexp {/\*|//} "$endcomment" end] 1269 } else { 1270 break 1271 } 1272 } 1273} 1274 1275############################################################################## 1276# 1277# Purpose : To highlight double quoted phrases 1278# 1279# Parameters : widget - the widget to be acted upon 1280# 1281# Result : NONE 1282# 1283############################################################################## 1284 1285proc quote_highlight { widget } { 1286 1287 set pattern {[^\\']\"} 1288 1289 # Look in between commented regions for quotes 1290 foreach {start end} [concat 1.0 [$widget tag ranges comment] end] { 1291 1292 while {[set temp [$widget search -regexp -- $pattern $start $end]] != ""} { 1293 1294 set endquote [$widget search -regexp -- {[^\\]\"} "$temp + 1chars" $end] 1295 1296 if {[strlen $endquote] > 0} { 1297 set start [$widget index "$endquote + 2chars"] 1298 1299 $widget tag add quote "$temp + 1chars" $start 1300 } 1301 } 1302 } 1303} 1304 1305############################################################################## 1306# 1307# Purpose : To highlight the given words in the given text widget 1308# 1309# Parameters : word - regexp pattern to search for 1310# color - the text tag to mark the word with 1311# widget - the text widget to act on 1312# 1313# Result : NONE 1314# 1315############################################################################## 1316 1317proc highlight_word {word color widget {range_start 1.0} {range_end end}} { 1318 1319 set start $range_start 1320 set end $range_end 1321 1322 # Safety check, otherwise infinite loop could result... 1323 if {[strlen $word] <= 0} { 1324 error "Can't highlight blank pattern" 1325 } 1326 1327 while {[$widget compare $start < $end] && 1328 [set temp [$widget search -count count -regexp -- \ 1329 $word $start $end]] != ""} { 1330 1331 # Check if in a comment 1332 set crange [$widget tag prevrange comment $temp] 1333 if {[llength $crange] == 2 && 1334 [$widget compare $temp < [lindex $crange 1]]} { 1335 set start [lindex $crange 1] 1336 continue 1337 } 1338 1339 # Check if in quotes 1340 set qrange [$widget tag prevrange quote $temp] 1341 if {[llength $qrange] == 2 && 1342 [$widget compare $temp < [lindex $qrange 1]]} { 1343 set start [lindex $qrange 1] 1344 continue 1345 } 1346 1347 # Make sure that a whole word was found. 1348 if {[$widget compare [$widget index "$temp wordstart"] == "$temp"] && 1349 [$widget compare [$widget index "$temp wordend"] == \ 1350 [$widget index "$temp + ${count}chars"]]} { 1351 1352 $widget tag add "$color" $temp "$temp + ${count}chars" 1353 } 1354 1355 set start [$widget index "$temp + ${count}chars"] 1356 } 1357 1358 return 1359 1360 # Look in between commented regions for words to mark 1361 foreach {start end} [concat [list $range_start] \ 1362 [$widget tag ranges comment] \ 1363 [list $range_end]] { 1364 while {[set temp [$widget search -count count -regexp -- \ 1365 "$word" $start $end]] != ""} { 1366 1367 # Make sure that a whole word was found. 1368 if {[$widget compare [$widget index "$temp wordstart"] == "$temp"] && 1369 [$widget compare [$widget index "$temp wordend"] == \ 1370 [$widget index "$temp + ${count}chars"]]} { 1371 1372 $widget tag add "$color" $temp "$temp + ${count}chars" 1373 } 1374 set start [$widget index "$temp + ${count}chars"] 1375 } 1376 } 1377 1378 return 1379} 1380 1381############################################################################## 1382# 1383# Purpose : To highlight preprocessor statements 1384# 1385# Parameters : widget - the widget to be acted upon 1386# 1387# Result : NONE 1388# 1389############################################################################## 1390 1391proc cpp_highlight {widget} { 1392 set pattern \ 1393 [subst -nocommands -novariables \ 1394 {^[ \t\n]*\#[ \t]*(ifdef|ifndef|if|define|undef|include|endif|else)}] 1395 1396 # Look in between commented regions for words to mark 1397 foreach {start end} [concat 1.0 [$widget tag ranges comment] end] { 1398 1399 while {[$widget compare $start < $end]} { 1400 1401 set temp [$widget search -count count -regexp -- $pattern $start $end] 1402 if {[strlen $temp] > 0} { 1403 $widget tag add cpp $temp "$temp +${count} chars" 1404 } 1405 set start [$widget index "$start lineend +1 char"] 1406 } 1407 } 1408 return 1409} 1410 1411#---------------------------------------------------------------------------- 1412 1413############################################################################## 1414# 1415# Purpose : Utility function to be used as a trace. 1416# The simple boolean variable controls the state of 1417# the given entry in the given menu, 1418# 1419# Parameters : menu - the menu widget where the toggle lives 1420# entry - the label of the toggle widget 1421# varname - the name of the toggle controlling variable 1422# index - required parameter when used as trace, ignored 1423# op - required parameter when used as trace, ignored 1424# 1425# Result : NONE 1426# 1427############################################################################# 1428 1429proc toggle_trace {menu entry varname index op} { 1430 upvar $varname var 1431 if {$var} { 1432 $menu entryconfigure $entry -state normal 1433 } else { 1434 $menu entryconfigure $entry -state disabled 1435 } 1436} 1437 1438############################################################################## 1439# 1440# Purpose : Allow only a single tearoff for a menu. 1441# Use as -tearoffcommand 1442# 1443# Parameters : menu - the menu being tornoff 1444# torn - the new tearoff menu 1445# 1446# Result : NONE 1447# 1448############################################################################## 1449 1450proc single_tearoff {menu torn} { 1451 global tearoff 1452 1453 # Record the correspondence with the tearoff 1454 set tearoff($menu) $torn 1455 1456 # Disable future tearoffs 1457 $menu configure -tearoff 0 1458 1459 # Restore when the tearoff is deleted 1460 bind $torn <Destroy> \ 1461 "$menu configure -tearoff 1; 1462 unset tearoff($menu)" 1463} 1464 1465############################################################################## 1466# 1467# Purpose : Add an item to a field's scrollable history 1468# 1469# Parameters : field - the entry field to scroll 1470# direction - Up or Down 1471# indexvar - the index of the current value 1472# hlistvar - the history list variable 1473# 1474# Result : NONE 1475# 1476############################################################################## 1477 1478proc field_history_add {hlistvar indexvar value} { 1479 upvar \#0 $indexvar hindex 1480 upvar \#0 $hlistvar hlist 1481 1482 # Reset the history index mechanism, and add this to the list 1483 if [info exists hindex] {unset hindex} 1484 1485 if [info exists hlist] { 1486 # If already in the list, remove it 1487 set index [lsearch $hlist $value] 1488 if {$index >= 0} { 1489 set hlist [lreplace $hlist $index $index] 1490 } 1491 set hlist [concat [list $value] $hlist] 1492 } else { 1493 set hlist $value 1494 } 1495} 1496 1497############################################################################## 1498# 1499# Purpose : Scroll through field history with keyboard 1500# 1501# Parameters : field - the entry field to scroll 1502# direction - Up or Down 1503# indexvar - the index of the current value 1504# hlistvar - the history list variable 1505# 1506# Result : NONE 1507# 1508############################################################################## 1509 1510proc field_history {field direction indexvar hlistvar} { 1511 upvar \#0 $indexvar hindex 1512 upvar \#0 $hlistvar hlist 1513 1514 # If there's no history list, just return 1515 if ![info exists hlist] { 1516 return 1517 } 1518 1519 set last [expr [llength $hlist] - 1] 1520 1521 if [info exists hindex] { 1522 switch -- $direction { 1523 "Up" {incr hindex} 1524 "Down" {incr hindex -1} 1525 } 1526 if {$hindex > $last} { 1527 set hindex $last 1528 } 1529 if {$hindex < 0} { 1530 set hindex 0 1531 } 1532 } else { 1533 set hindex 0 1534 } 1535 1536 # Set the fields value 1537 $field delete 0 end 1538 $field insert 0 [lindex $hlist $hindex] 1539} 1540 1541############################################################################## 1542# 1543# Purpose : Blink an activity indicator every interval. 1544# 1545# Parameters : time - the interval to blink at 1546# light - the widget to use as the blinking light 1547# 1548# Result : NONE 1549# 1550############################################################################## 1551 1552proc activity_start {time light} { 1553 if {[strcmp [$light cget -background] "grey80"] == 0} { 1554 $light configure -background green 1555 } else { 1556 $light configure -background grey80 1557 } 1558 update idletasks 1559 1560 after $time "activity_start $time $light" 1561} 1562 1563############################################################################## 1564# 1565# Purpose : Stop the blinking activity indicator when the 1566# 1567# Parameters : time - the interval to blink at 1568# light - the widget to use as the blinking light 1569# 1570# Result : NONE 1571# 1572############################################################################## 1573 1574proc activity_finish {time light} { 1575 after cancel "activity_start $time $light" 1576 $light configure -background grey80 1577} 1578 1579############################################################################## 1580# 1581# Purpose : Setup the event bindings for a scroll mouse. 1582# 1583# Parameters : bindtag - the bindtag to setup 1584# 1585# Result : NONE 1586# 1587############################################################################## 1588 1589proc setup_scroll_bindings {bindtag} { 1590 bind $bindtag <Button-5> [list %W yview scroll 5 units] 1591 bind $bindtag <Button-4> [list %W yview scroll -5 units] 1592 bind $bindtag <Shift-Button-5> [list %W yview scroll 1 units] 1593 bind $bindtag <Shift-Button-4> [list %W yview scroll -1 units] 1594 bind $bindtag <Control-Button-5> [list %W yview scroll 1 pages] 1595 bind $bindtag <Control-Button-4> [list %W yview scroll -1 pages] 1596} 1597 1598