1# Copyright (c) 1993 by Sanjay Ghemawat 2############################################################################# 3# Support operations 4 5#### Customization support #### 6 7# Load the specified proc if it has not already been loaded 8proc require {proc} { 9 if ![string compare [info commands $proc] $proc] return 10 11 global auto_index 12 if [info exists auto_index($proc)] { 13 uplevel #0 $auto_index($proc) 14 } 15} 16 17# Redefine procedure body but keep argument list unchanged 18proc redefine_proc {proc code} { 19 # Resurrect argument list 20 set args {} 21 foreach a [info args $proc] { 22 if [info default $proc $a def] { 23 lappend args [list $a $def] 24 } else { 25 lappend args $a 26 } 27 } 28 proc $proc $args $code 29} 30 31# Append code to procedure body 32proc after_proc {proc code} { 33 redefine_proc $proc "[info body $proc]\n$code" 34} 35 36# Prepend code to procedure body 37proc before_proc {proc code} { 38 redefine_proc $proc "$code\n[info body $proc]" 39} 40 41#### Special options #### 42proc tcllib_load_options {} { 43 if [string match *color* [winfo screenvisual .]] { 44 set small_bd 1 45 set big_bd 2 46 } else { 47 set small_bd 2 48 set big_bd 3 49 } 50 51 option add *Inset.BorderWidth $big_bd startupFile 52 foreach spec { 53 Pane Entry Scrollbar Button Checkbutton Radiobutton Menubutton Menu 54 } { 55 option add *$spec.BorderWidth $small_bd startupFile 56 } 57 58 option add *Pane.Relief raised startupFile 59 option add *Inset.Relief groove startupFile 60 option add *Entry.Relief sunken startupFile 61 option add *Scrollbar.Relief raised startupFile 62 option add *Button.padX 1m startupFile 63} 64 65# effects Make frame containing buttons. 66# The created buttons are packed in a new frame called "frame". 67# "spec" is a list of button specifications. Each specification 68# is a list with two elements. The first element is the text 69# string for the button, and the second element is the command 70# to which the created button is bound. 71# "default" should be an index into the specification list. The 72# corresponding button is wrapped inside a border to indicate that 73# it is the default. 74 75proc make_buttons {frame default spec} { 76 frame $frame -class Pane 77 78 set i 0 79 foreach s $spec { 80 set str [lindex $s 0] 81 set cmd [lindex $s 1] 82 83 if {$i == $default} { 84 frame $frame.def$i -relief sunken -bd 1 85 button $frame.b$i -text $str -command $cmd 86 pack $frame.b$i -in $frame.def$i -side left -padx 2m -pady 2m 87 pack $frame.def$i -side left -expand 1 -padx 1m -pady 1m 88 } else { 89 button $frame.b$i -text $str -command $cmd 90 pack $frame.b$i -side left -expand 1 -padx 3m -pady 3m 91 } 92 93 incr i 94 } 95} 96 97# Set geometry so that toplevel shows up in same virtual window as leader 98proc set_geometry {leader w g} { 99 if ![regexp {^([+-])([0-9]+)([+-])([0-9]+)$} $g junk sx x sy y] { 100 return 101 } 102 103 if ![string compare $sx -] { 104 set x [expr [winfo screenwidth $w] - $x] 105 } 106 if ![string compare $sy -] { 107 set y [expr [winfo screenheight $w] - $y] 108 } 109 110 if ![string compare $leader {}] { 111 set leader $w 112 } 113 set x [expr $x - [winfo vrootx $leader]] 114 set y [expr $y - [winfo vrooty $leader]] 115 wm geometry $w +$x+$y 116} 117 118############################################################################# 119# Dialog Interaction Mechanism 120# 121# Commands 122# 123# dialog_run <leader> <window> <var> 124# requires <window> is a toplevel. 125# <leader> is either {}, or a window. 126# effects Run dialog in <window> until global variable <var> 127# is modified. If <leader> is {}, the dialog is 128# centered on the screen. Otherwise, the dialog is 129# centered on <leader>. 130 131proc dialog_run {leader window var {focuswin ""}} { 132 global [regsub {\(.*\)$} $var {}] 133 134 # Wait for window geometry to be computed if possible 135 update idletasks 136 137 # Center window over leader 138 if {$leader == {}} { 139 set x [expr ([winfo screenwidth $window]-[winfo reqwidth $window])/2] 140 set y [expr ([winfo screenheight $window]-[winfo reqheight $window])/2] 141 set_geometry $leader $window +$x+$y 142 } else { 143 set lx [expr [winfo rootx $leader] + [winfo vrootx $leader]] 144 set ly [expr [winfo rooty $leader] + [winfo vrooty $leader]] 145 set x [expr $lx+[winfo width $leader]/2] 146 set y [expr $ly+[winfo height $leader]/2] 147 set x [expr $x-[winfo reqwidth $window]/2] 148 set y [expr $y-[winfo reqheight $window]/2] 149 wm geometry $window +$x+$y 150 } 151 152 wm transient $window $leader 153 wm deiconify $window 154 155 if ![string compare $focuswin {}] {set focuswin $window} 156 set oldfocus [focus] 157 catch {grab set $window} 158 focus $focuswin 159 vwait $var 160 grab release $window 161 catch {focus $oldfocus} 162 wm withdraw $window 163 update 164} 165 166############################################################################# 167# Font/color query routines 168 169# effects - Return width of "text" in "font". Add "pad" on each side. 170proc text_width {font text {pad 0}} { 171 global font_cache 172 text_cache_load $font $text 173 return [expr $font_cache(w:$font,$text) + 2*$pad] 174} 175 176# effects - Return height of "text" in "font". Add "pad" on each side. 177proc text_height {font text {pad 0}} { 178 global font_cache 179 text_cache_load $font $text 180 return [expr $font_cache(h:$font,$text) + 2*$pad] 181} 182 183# effects - Load cache with width and height of "text" rendered in "font". 184proc text_cache_load {font text} { 185 global font_cache 186 if [info exists font_cache(w:$font,$text)] return 187 188 # Get the width 189 set f .__text_loader 190 if ![winfo exists $f] {canvas $f} 191 192 set i [$f create text 0 0 -text $text -font $font] 193 set b [$f bbox $i] 194 $f delete $i 195 196 set font_cache(w:$font,$text) [expr [lindex $b 2] - [lindex $b 0] + 1] 197 set font_cache(h:$font,$text) [expr [lindex $b 3] - [lindex $b 1] + 1] 198} 199 200# effects - Return true iff specified font exists. 201proc font_exists {font} { 202 global font_cache 203 if ![info exists font_cache(exists:$font)] { 204 # Have not checked this font yet. Try to use it. 205 set f .__font_loader 206 if ![winfo exists $f] {label $f -text X} 207 208 set font_cache(exists:$font) 0 209 if ![catch {set i [$f configure -font $font]}] { 210 set font_cache(exists:$font) 1 211 } 212 } 213 214 return $font_cache(exists:$font) 215} 216 217# effects - Return true iff specified color exists. 218proc color_exists {color} { 219 global color_cache 220 if ![info exists color_cache(exists:$color)] { 221 # Have not checked this color yet. Try to use it. 222 set f .__font_loader 223 if ![winfo exists $f] {label $f -text X} 224 225 set color_cache(exists:$color) 0 226 if ![catch {set i [$f configure -foreground $color]}] { 227 set color_cache(exists:$color) 1 228 } 229 } 230 231 return $color_cache(exists:$color) 232} 233 234#### Debugging support #### 235 236# effects - Print stack trace on stderr 237proc stack_trace {} { 238 set level [info level] 239 while {$level > 0} { 240 set info [info level $level] 241 puts stderr [join $info] 242 incr level -1 243 } 244 puts stderr "=====" 245} 246 247#### File IO #### 248 249# effects Read contents of file and return as a string. 250proc file_read {file} { 251 set input [open $file r] 252 if [catch {set string [read -nonewline $input]} result] { 253 catch {close $input} 254 error $result 255 } 256 catch {close $input} 257 return $string 258} 259