source: trunk/BWidget-1.2.1/utils.tcl @ 984

Last change on this file since 984 was 931, checked in by toby, 11 years ago

include rest of files
File size: 13.3 KB
Line 
1# ------------------------------------------------------------------------------
2#  utils.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: utils.tcl,v 1.6 1999/07/09 08:10:39 eric Exp $
5# ------------------------------------------------------------------------------
6#  Index of commands:
7#     - GlobalVar::exists
8#     - GlobalVar::setvarvar
9#     - GlobalVar::getvarvar
10#     - BWidget::assert
11#     - BWidget::clonename
12#     - BWidget::get3dcolor
13#     - BWidget::XLFDfont
14#     - BWidget::place
15#     - BWidget::grab
16#     - BWidget::focus
17# ------------------------------------------------------------------------------
18
19namespace eval GlobalVar {
20    proc use {} {}
21}
22
23
24namespace eval BWidget {
25    variable _top
26    variable _gstack {}
27    variable _fstack {}
28    proc use {} {}
29}
30
31
32# ------------------------------------------------------------------------------
33#  Command GlobalVar::exists
34# ------------------------------------------------------------------------------
35proc GlobalVar::exists { varName } {
36    return [uplevel \#0 [list info exists $varName]]
37}
38
39
40# ------------------------------------------------------------------------------
41#  Command GlobalVar::setvar
42# ------------------------------------------------------------------------------
43proc GlobalVar::setvar { varName value } {
44    return [uplevel \#0 [list set $varName $value]]
45}
46
47
48# ------------------------------------------------------------------------------
49#  Command GlobalVar::getvar
50# ------------------------------------------------------------------------------
51proc GlobalVar::getvar { varName } {
52    return [uplevel \#0 [list set $varName]]
53}
54
55
56# ------------------------------------------------------------------------------
57#  Command GlobalVar::tracevar
58# ------------------------------------------------------------------------------
59proc GlobalVar::tracevar { cmd varName args } {
60    return [uplevel \#0 trace $cmd [list $varName] $args]
61}
62
63
64
65# ------------------------------------------------------------------------------
66#  Command BWidget::lreorder
67# ------------------------------------------------------------------------------
68proc BWidget::lreorder { list neworder } {
69    set pos     0
70    set newlist {}
71    foreach e $neworder {
72        if { [lsearch -exact $list $e] != -1 } {
73            lappend newlist $e
74            set tabelt($e)  1
75        }
76    }
77    set len [llength $newlist]
78    if { !$len } {
79        return $list
80    }
81    if { $len == [llength $list] } {
82        return $newlist
83    }
84    set pos 0
85    foreach e $list {
86        if { ![info exists tabelt($e)] } {
87            set newlist [linsert $newlist $pos $e]
88        }
89        incr pos
90    }
91    return $newlist
92}
93
94
95# ------------------------------------------------------------------------------
96#  Command BWidget::assert
97# ------------------------------------------------------------------------------
98proc BWidget::assert { exp {msg ""}} {
99    set res [uplevel expr $exp]
100    if { !$res} {
101        if { $msg == "" } {
102            return -code error "Assertion failed: {$exp}"
103        } else {
104            return -code error $msg
105        }
106    }
107}
108
109
110# ------------------------------------------------------------------------------
111#  Command BWidget::clonename
112# ------------------------------------------------------------------------------
113proc BWidget::clonename { menu } {
114    set path     ""
115    set menupath ""
116    set found    0
117    foreach widget [lrange [split $menu "."] 1 end] {
118        if { $found || [winfo class "$path.$widget"] == "Menu" } {
119            set found 1
120            append menupath "#" $widget
121            append path "." $menupath
122        } else {
123            append menupath "#" $widget
124            append path "." $widget
125        }   
126    }
127    return $path
128}
129
130
131# ------------------------------------------------------------------------------
132#  Command BWidget::getname
133# ------------------------------------------------------------------------------
134proc BWidget::getname { name } {
135    if { [string length $name] } {
136        set text [option get . "${name}Name" ""]
137        if { [string length $text] } {
138            return [parsetext $text]
139        }
140    }
141    return {}
142 }
143
144
145# ------------------------------------------------------------------------------
146#  Command BWidget::parsetext
147# ------------------------------------------------------------------------------
148proc BWidget::parsetext { text } {
149    set result ""
150    set index  -1
151    set start  0
152    while { [string length $text] } {
153        set idx [string first "&" $text]
154        if { $idx == -1 } {
155            append result $text
156            set text ""
157        } else {
158            set char [string index $text [expr {$idx+1}]]
159            if { $char == "&" } {
160                append result [string range $text 0 $idx]
161                set    text   [string range $text [expr {$idx+2}] end]
162                set    start  [expr {$start+$idx+1}]
163            } else {
164                append result [string range $text 0 [expr {$idx-1}]]
165                set    text   [string range $text [expr {$idx+1}] end]
166                incr   start  $idx
167                set    index  $start
168            }
169        }
170    }
171    return [list $result $index]
172}
173
174
175# ------------------------------------------------------------------------------
176#  Command BWidget::get3dcolor
177# ------------------------------------------------------------------------------
178proc BWidget::get3dcolor { path bgcolor } {
179    foreach val [winfo rgb $path $bgcolor] {
180        lappend dark [expr 60*$val/100]
181        set tmp1 [expr 14*$val/10]
182        if { $tmp1 > 65535 } {
183            set tmp1 65535
184        }
185        set tmp2 [expr (65535+$val)/2]
186        lappend light [expr ($tmp1 > $tmp2) ? $tmp1:$tmp2]
187    }
188    return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
189}
190
191
192# ------------------------------------------------------------------------------
193#  Command BWidget::XLFDfont
194# ------------------------------------------------------------------------------
195proc BWidget::XLFDfont { cmd args } {
196    switch -- $cmd {
197        create {
198            set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
199        }
200        configure {
201            set font [lindex $args 0]
202            set args [lrange $args 1 end]
203        }
204        default {
205            return -code error "XLFDfont: commande incorrecte: $cmd"
206        }
207    }
208    set lfont [split $font "-"]
209    if { [llength $lfont] != 15 } {
210        return -code error "XLFDfont: description XLFD incorrecte: $font"
211    }
212
213    foreach {option value} $args {
214        switch -- $option {
215            -foundry { set index 1 }
216            -family  { set index 2 }
217            -weight  { set index 3 }
218            -slant   { set index 4 }
219            -size    { set index 7 }
220            default  { return -code error "XLFDfont: option incorrecte: $option" }
221        }
222        set lfont [lreplace $lfont $index $index $value]
223    }
224    return [join $lfont "-"]
225}
226
227
228
229# ------------------------------------------------------------------------------
230#  Command BWidget::place
231# ------------------------------------------------------------------------------
232proc BWidget::place { path w h args } {
233    variable _top
234
235    update idletasks
236    set reqw [winfo reqwidth  $path]
237    set reqh [winfo reqheight $path]
238    if { $w == 0 } {set w $reqw}
239    if { $h == 0 } {set h $reqh}
240
241    set arglen [llength $args]
242    if { $arglen > 3 } {
243        return -code error "BWidget::place: bad number of argument"
244    }
245
246    if { $arglen > 0 } {
247        set where [lindex $args 0]
248        set idx   [lsearch {"at" "center" "left" "right" "above" "below"} $where]
249        if { $idx == -1 } {
250            return -code error "BWidget::place: incorrect position \"$where\""
251        }
252        if { $idx == 0 } {
253            set err [catch {
254                set x [expr {int([lindex $args 1])}]
255                set y [expr {int([lindex $args 2])}]
256            }]
257            if { $err } {
258                return -code error "BWidget::place: incorrect position"
259            }
260            if { $x >= 0 } {
261                set x "+$x"
262            }
263            if { $y >= 0 } {
264                set y "+$y"
265            }
266        } else {
267            if { $arglen == 2 } {
268                set widget [lindex $args 1]
269                if { ![winfo exists $widget] } {
270                    return -code error "BWidget::place: \"$widget\" does not exist"
271                }
272            }
273            set sw [winfo screenwidth  $path]
274            set sh [winfo screenheight $path]
275            if { $idx == 1 } {
276                if { $arglen == 2 } {
277                    # center to widget
278                    set x0 [expr [winfo rootx $widget] + ([winfo width  $widget] - $w)/2]
279                    set y0 [expr [winfo rooty $widget] + ([winfo height $widget] - $h)/2]
280                } else {
281                    # center to screen
282                    set x0 [expr ([winfo screenwidth  $path] - $w)/2 - [winfo vrootx $path]]
283                    set y0 [expr ([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]]
284                }
285                set x "+$x0"
286                set y "+$y0"
287                if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
288                if { $x0 < 0 }      {set x "+0"}
289                if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
290                if { $y0 < 0 }      {set y "+0"}
291            } else {
292                set x0 [winfo rootx $widget]
293                set y0 [winfo rooty $widget]
294                set x1 [expr {$x0 + [winfo width  $widget]}]
295                set y1 [expr {$y0 + [winfo height $widget]}]
296                if { $idx == 2 || $idx == 3 } {
297                    set y "+$y0"
298                    if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
299                    if { $y0 < 0 }      {set y "+0"}
300                    if { $idx == 2 } {
301                        # try left, then right if out, then 0 if out
302                        if { $x0 >= $w } {
303                            set x [expr {$x0-$sw}]
304                        } elseif { $x1+$w <= $sw } {
305                            set x "+$x1"
306                        } else {
307                            set x "+0"
308                        }
309                    } else {
310                        # try right, then left if out, then 0 if out
311                        if { $x1+$w <= $sw } {
312                            set x "+$x1"
313                        } elseif { $x0 >= $w } {
314                            set x [expr {$x0-$sw}]
315                        } else {
316                            set x "-0"
317                        }
318                    }
319                } else {
320                    set x "+$x0"
321                    if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
322                    if { $x0 < 0 }      {set x "+0"}
323                    if { $idx == 4 } {
324                        # try top, then bottom, then 0
325                        if { $h <= $y0 } {
326                            set y [expr {$y0-$sh}]
327                        } elseif { $y1+$h <= $sh } {
328                            set y "+$y1"
329                        } else {
330                            set y "+0"
331                        }
332                    } else {
333                        # try bottom, then top, then 0
334                        if { $y1+$h <= $sh } {
335                            set y "+$y1"
336                        } elseif { $h <= $y0 } {
337                            set y [expr {$y0-$sh}]
338                        } else {
339                            set y "-0"
340                        }
341                    }
342                }
343            }
344        }
345        wm geometry $path "${w}x${h}${x}${y}"
346    } else {
347        wm geometry $path "${w}x${h}"
348    }
349    update idletasks
350}
351
352
353# ------------------------------------------------------------------------------
354#  Command BWidget::grab
355# ------------------------------------------------------------------------------
356proc BWidget::grab { option path } {
357    variable _gstack
358
359    if { $option == "release" } {
360        catch {::grab release $path}
361        while { [llength $_gstack] } {
362            set grinfo  [lindex $_gstack end]
363            set _gstack [lreplace $_gstack end end]
364            foreach {oldg mode} $grinfo {
365                if { [string compare $oldg $path] && [winfo exists $oldg] } {
366                    if { $mode == "global" } {
367                        catch {::grab -global $oldg}
368                    } else {
369                        catch {::grab $oldg}
370                    }
371                    return
372                }
373            }
374        }
375    } else {
376        set oldg [::grab current]
377        if { $oldg != "" } {
378            lappend _gstack [list $oldg [::grab status $oldg]]
379        }
380        if { $option == "global" } {
381            ::grab -global $path
382        } else {
383            ::grab $path
384        }
385    }
386}
387
388
389# ------------------------------------------------------------------------------
390#  Command BWidget::focus
391# ------------------------------------------------------------------------------
392proc BWidget::focus { option path } {
393    variable _fstack
394
395    if { $option == "release" } {
396        while { [llength $_fstack] } {
397            set oldf [lindex $_fstack end]
398            set _fstack [lreplace $_fstack end end]
399            if { [string compare $oldf $path] && [winfo exists $oldf] } {
400                catch {::focus -force $oldf}
401                return
402            }
403        }
404    } elseif { $option == "set" } {
405        lappend _fstack [::focus]
406        ::focus -force $path
407    }
408}
Note: See TracBrowser for help on using the repository browser.