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