1# ----------------------------------------------------------------------------
2#  utils.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: utils.tcl,v 1.18 2009/10/25 20:55:36 oberdorfer 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#     - BWidget::bindMiddleMouseMovement
18#     - BWidget::getSystemFontProperties
19#     - BWidget::createSystemFonts
20# ----------------------------------------------------------------------------
21
22namespace eval GlobalVar {
23    proc use {} {}
24}
25
26
27namespace eval BWidget {
28    variable _top
29    variable _gstack {}
30    variable _fstack {}
31    proc use {} {}
32}
33
34
35# ----------------------------------------------------------------------------
36#  Command GlobalVar::exists
37# ----------------------------------------------------------------------------
38proc GlobalVar::exists { varName } {
39    return [uplevel \#0 [list info exists $varName]]
40}
41
42
43# ----------------------------------------------------------------------------
44#  Command GlobalVar::setvar
45# ----------------------------------------------------------------------------
46proc GlobalVar::setvar { varName value } {
47    return [uplevel \#0 [list set $varName $value]]
48}
49
50
51# ----------------------------------------------------------------------------
52#  Command GlobalVar::getvar
53# ----------------------------------------------------------------------------
54proc GlobalVar::getvar { varName } {
55    return [uplevel \#0 [list set $varName]]
56}
57
58
59# ----------------------------------------------------------------------------
60#  Command GlobalVar::tracevar
61# ----------------------------------------------------------------------------
62proc GlobalVar::tracevar { cmd varName args } {
63    return [uplevel \#0 [list trace $cmd $varName] $args]
64}
65
66
67
68# ----------------------------------------------------------------------------
69#  Command BWidget::lreorder
70# ----------------------------------------------------------------------------
71proc BWidget::lreorder { list neworder } {
72    set pos     0
73    set newlist {}
74    foreach e $neworder {
75        if { [lsearch -exact $list $e] != -1 } {
76            lappend newlist $e
77            set tabelt($e)  1
78        }
79    }
80    set len [llength $newlist]
81    if { !$len } {
82        return $list
83    }
84    if { $len == [llength $list] } {
85        return $newlist
86    }
87    set pos 0
88    foreach e $list {
89        if { ![info exists tabelt($e)] } {
90            set newlist [linsert $newlist $pos $e]
91        }
92        incr pos
93    }
94    return $newlist
95}
96
97
98# ----------------------------------------------------------------------------
99#  Command BWidget::assert
100# ----------------------------------------------------------------------------
101proc BWidget::assert { exp {msg ""}} {
102    set res [uplevel 1 expr $exp]
103    if { !$res} {
104        if { $msg == "" } {
105            return -code error "Assertion failed: {$exp}"
106        } else {
107            return -code error $msg
108        }
109    }
110}
111
112
113# ----------------------------------------------------------------------------
114#  Command BWidget::clonename
115# ----------------------------------------------------------------------------
116proc BWidget::clonename { menu } {
117    set path     ""
118    set menupath ""
119    set found    0
120    foreach widget [lrange [split $menu "."] 1 end] {
121        if { $found || [winfo class "$path.$widget"] == "Menu" } {
122            set found 1
123            append menupath "#" $widget
124            append path "." $menupath
125        } else {
126            append menupath "#" $widget
127            append path "." $widget
128        }
129    }
130    return $path
131}
132
133
134# ----------------------------------------------------------------------------
135#  Command BWidget::getname
136# ----------------------------------------------------------------------------
137proc BWidget::getname { name } {
138    if { [string length $name] } {
139        set text [option get . "${name}Name" ""]
140        if { [string length $text] } {
141            return [parsetext $text]
142        }
143    }
144    return {}
145 }
146
147
148# ----------------------------------------------------------------------------
149#  Command BWidget::parsetext
150# ----------------------------------------------------------------------------
151proc BWidget::parsetext { text } {
152    set result ""
153    set index  -1
154    set start  0
155    while { [string length $text] } {
156        set idx [string first "&" $text]
157        if { $idx == -1 } {
158            append result $text
159            set text ""
160        } else {
161            set char [string index $text [expr {$idx+1}]]
162            if { $char == "&" } {
163                append result [string range $text 0 $idx]
164                set    text   [string range $text [expr {$idx+2}] end]
165                set    start  [expr {$start+$idx+1}]
166            } else {
167                append result [string range $text 0 [expr {$idx-1}]]
168                set    text   [string range $text [expr {$idx+1}] end]
169                incr   start  $idx
170                set    index  $start
171            }
172        }
173    }
174    return [list $result $index]
175}
176
177
178# ----------------------------------------------------------------------------
179#  Command BWidget::get3dcolor
180# ----------------------------------------------------------------------------
181proc BWidget::get3dcolor { path bgcolor } {
182    set fmt "#%04x%04x%04x"
183
184    foreach val [winfo rgb $path $bgcolor] {
185        lappend dark [expr {60*$val/100}]
186        set tmp1 [expr {14*$val/10}]
187        if { $tmp1 > 65535 } {
188            set tmp1 65535
189        }
190        set tmp2 [expr {(65535+$val)/2}]
191        lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
192    }
193    return [list [eval format $fmt $dark] [eval format $fmt $light]]
194}
195
196
197# ----------------------------------------------------------------------------
198#  Command BWidget::XLFDfont
199# ----------------------------------------------------------------------------
200proc BWidget::XLFDfont { cmd args } {
201    switch -- $cmd {
202        create {
203            set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
204        }
205        configure {
206            set font [lindex $args 0]
207            set args [lrange $args 1 end]
208        }
209        default {
210            return -code error "XLFDfont: commande incorrect: $cmd"
211        }
212    }
213    set lfont [split $font "-"]
214    if { [llength $lfont] != 15 } {
215        return -code error "XLFDfont: description XLFD incorrect: $font"
216    }
217
218    foreach {option value} $args {
219        switch -- $option {
220            -foundry { set index 1 }
221            -family  { set index 2 }
222            -weight  { set index 3 }
223            -slant   { set index 4 }
224            -size    { set index 7 }
225            default  { return -code error "XLFDfont: option incorrecte: $option" }
226        }
227        set lfont [lreplace $lfont $index $index $value]
228    }
229    return [join $lfont "-"]
230}
231
232
233# ----------------------------------------------------------------------------
234#  Command BWidget::place
235# ----------------------------------------------------------------------------
236#
237# Notes:
238#  For Windows systems with more than one monitor the available screen area may
239#  have negative positions. Geometry settings with negative numbers are used
240#  under X to place wrt the right or bottom of the screen. On windows, Tk
241#  continues to do this. However, a geometry such as 100x100+-200-100 can be
242#  used to place a window onto a secondary monitor. Passing the + gets Tk
243#  to pass the remainder unchanged so the Windows manager then handles -200
244#  which is a position on the left hand monitor.
245#  I've tested this for left, right, above and below the primary monitor.
246#  Currently there is no way to ask Tk the extent of the Windows desktop in
247#  a multi monitor system. Nor what the legal co-ordinate range might be.
248#
249proc BWidget::place { path w h args } {
250    variable _top
251
252    update idletasks
253
254    # If the window is not mapped, it may have any current size.
255    # Then use required size, but bound it to the screen width.
256    # This is mostly inexact, because any toolbars will still be removed
257    # which may reduce size.
258    if { $w == 0 && [winfo ismapped $path] } {
259        set w [winfo width $path]
260    } else {
261        if { $w == 0 } {
262            set w [winfo reqwidth $path]
263        }
264        set vsw [winfo vrootwidth  $path]
265        if { $w > $vsw } { set w $vsw }
266    }
267
268    if { $h == 0 && [winfo ismapped $path] } {
269        set h [winfo height $path]
270    } else {
271        if { $h == 0 } {
272            set h [winfo reqheight $path]
273        }
274        set vsh [winfo vrootheight $path]
275        if { $h > $vsh } { set h $vsh }
276    }
277
278    set arglen [llength $args]
279    if { $arglen > 3 } {
280        return -code error "BWidget::place: bad number of argument"
281    }
282
283    if { $arglen > 0 } {
284        set where [lindex $args 0]
285	set list  [list "at" "center" "left" "right" "above" "below"]
286        set idx   [lsearch $list $where]
287        if { $idx == -1 } {
288	    return -code error [BWidget::badOptionString position $where $list]
289        }
290        if { $idx == 0 } {
291            set err [catch {
292                # purposely removed the {} around these expressions - [PT]
293                set x [expr int([lindex $args 1])]
294                set y [expr int([lindex $args 2])]
295            }]
296            if { $err } {
297                return -code error "BWidget::place: incorrect position"
298            }
299            if {$::tcl_platform(platform) == "windows"} {
300                # handle windows multi-screen. -100 != +-100
301                if {[string index [lindex $args 1] 0] != "-"} {
302                    set x "+$x"
303                }
304                if {[string index [lindex $args 2] 0] != "-"} {
305                    set y "+$y"
306                }
307            } else {
308                if { $x >= 0 } {
309                    set x "+$x"
310                }
311                if { $y >= 0 } {
312                    set y "+$y"
313                }
314            }
315        } else {
316            if { $arglen == 2 } {
317                set widget [lindex $args 1]
318                if { ![winfo exists $widget] } {
319                    return -code error "BWidget::place: \"$widget\" does not exist"
320                }
321	    } else {
322		set widget .
323	    }
324            set sw [winfo screenwidth  $path]
325            set sh [winfo screenheight $path]
326            if { $idx == 1 } {
327                if { $arglen == 2 } {
328                    # center to widget
329                    set x0 [expr {[winfo rootx $widget] + ([winfo width  $widget] - $w)/2}]
330                    set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
331                } else {
332                    # center to screen
333                    set x0 [expr {($sw - $w)/2 - [winfo vrootx $path]}]
334                    set y0 [expr {($sh - $h)/2 - [winfo vrooty $path]}]
335                }
336                set x "+$x0"
337                set y "+$y0"
338                if {$::tcl_platform(platform) != "windows"} {
339                    if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
340                    if { $x0 < 0 }      {set x "+0"}
341                    if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
342                    if { $y0 < 0 }      {set y "+0"}
343                }
344            } else {
345                set x0 [winfo rootx $widget]
346                set y0 [winfo rooty $widget]
347                set x1 [expr {$x0 + [winfo width  $widget]}]
348                set y1 [expr {$y0 + [winfo height $widget]}]
349                if { $idx == 2 || $idx == 3 } {
350                    set y "+$y0"
351                    if {$::tcl_platform(platform) != "windows"} {
352                        if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
353                        if { $y0 < 0 }      {set y "+0"}
354                    }
355                    if { $idx == 2 } {
356                        # try left, then right if out, then 0 if out
357                        if { $x0 >= $w } {
358                            set x [expr {$x0-$w}]
359                        } elseif { $x1+$w <= $sw } {
360                            set x "+$x1"
361                        } else {
362                            set x "+0"
363                        }
364                    } else {
365                        # try right, then left if out, then 0 if out
366                        if { $x1+$w <= $sw } {
367                            set x "+$x1"
368                        } elseif { $x0 >= $w } {
369                            set x [expr {$x0-$w}]
370                        } else {
371                            set x "-0"
372                        }
373                    }
374                } else {
375                    set x "+$x0"
376                    if {$::tcl_platform(platform) != "windows"} {
377                        if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
378                        if { $x0 < 0 }      {set x "+0"}
379                    }
380                    if { $idx == 4 } {
381                        # try top, then bottom, then 0
382                        if { $h <= $y0 } {
383                            set y [expr {$y0-$h}]
384                        } elseif { $y1+$h <= $sh } {
385                            set y "+$y1"
386                        } else {
387                            set y "+0"
388                        }
389                    } else {
390                        # try bottom, then top, then 0
391                        if { $y1+$h <= $sh } {
392                            set y "+$y1"
393                        } elseif { $h <= $y0 } {
394                            set y [expr {$y0-$h}]
395                        } else {
396                            set y "-0"
397                        }
398                    }
399                }
400            }
401        }
402
403        ## If there's not a + or - in front of the number, we need to add one.
404        if {[string is integer [string index $x 0]]} { set x +$x }
405        if {[string is integer [string index $y 0]]} { set y +$y }
406
407        wm geometry $path "${w}x${h}${x}${y}"
408    } else {
409        wm geometry $path "${w}x${h}"
410    }
411    update idletasks
412}
413
414
415# ----------------------------------------------------------------------------
416#  Command BWidget::grab
417# ----------------------------------------------------------------------------
418proc BWidget::grab { option path } {
419    variable _gstack
420
421    if { $option == "release" } {
422        catch {::grab release $path}
423        while { [llength $_gstack] } {
424            set grinfo  [lindex $_gstack end]
425            set _gstack [lreplace $_gstack end end]
426            foreach {oldg mode} $grinfo {
427                if { ![string equal $oldg $path] && [winfo exists $oldg] } {
428                    if { $mode == "global" } {
429                        catch {::grab -global $oldg}
430                    } else {
431                        catch {::grab $oldg}
432                    }
433                    return
434                }
435            }
436        }
437    } else {
438        set oldg [::grab current]
439        if { $oldg != "" } {
440            lappend _gstack [list $oldg [::grab status $oldg]]
441        }
442        if { $option == "global" } {
443            ::grab -global $path
444        } else {
445            ::grab $path
446        }
447    }
448}
449
450
451# ----------------------------------------------------------------------------
452#  Command BWidget::focus
453# ----------------------------------------------------------------------------
454proc BWidget::focus { option path {refocus 1} } {
455    variable _fstack
456
457    if { $option == "release" } {
458        while { [llength $_fstack] } {
459            set oldf [lindex $_fstack end]
460            set _fstack [lreplace $_fstack end end]
461            if { ![string equal $oldf $path] && [winfo exists $oldf] } {
462                if {$refocus} {catch {::focus -force $oldf}}
463                return
464            }
465        }
466    } elseif { $option == "set" } {
467        lappend _fstack [::focus]
468        ::focus -force $path
469    }
470}
471
472# BWidget::refocus --
473#
474#	Helper function used to redirect focus from a container frame in
475#	a megawidget to a component widget.  Only redirects focus if
476#	focus is already on the container.
477#
478# Arguments:
479#	container	container widget to redirect from.
480#	component	component widget to redirect to.
481#
482# Results:
483#	None.
484
485proc BWidget::refocus {container component} {
486    if { [string equal $container [::focus]] } {
487	::focus $component
488    }
489    return
490}
491
492## These mirror tk::(Set|Restore)FocusGrab
493
494# BWidget::SetFocusGrab --
495#   swap out current focus and grab temporarily (for dialogs)
496# Arguments:
497#   grab	new window to grab
498#   focus	window to give focus to
499# Results:
500#   Returns nothing
501#
502proc BWidget::SetFocusGrab {grab {focus {}}} {
503    variable _focusGrab
504    set index "$grab,$focus"
505
506    lappend _focusGrab($index) [::focus]
507    set oldGrab [::grab current $grab]
508    lappend _focusGrab($index) $oldGrab
509    if {[winfo exists $oldGrab]} {
510	lappend _focusGrab($index) [::grab status $oldGrab]
511    }
512    # The "grab" command will fail if another application
513    # already holds the grab.  So catch it.
514    catch {::grab $grab}
515    if {[winfo exists $focus]} {
516	::focus $focus
517    }
518}
519
520# BWidget::RestoreFocusGrab --
521#   restore old focus and grab (for dialogs)
522# Arguments:
523#   grab	window that had taken grab
524#   focus	window that had taken focus
525#   destroy	destroy|withdraw - how to handle the old grabbed window
526# Results:
527#   Returns nothing
528#
529proc BWidget::RestoreFocusGrab {grab focus {destroy destroy}} {
530    variable _focusGrab
531    set index "$grab,$focus"
532    if {[info exists _focusGrab($index)]} {
533	foreach {oldFocus oldGrab oldStatus} $_focusGrab($index) break
534	unset _focusGrab($index)
535    } else {
536	set oldGrab ""
537    }
538
539    catch {::focus $oldFocus}
540    ::grab release $grab
541    if {[string equal $destroy "withdraw"]} {
542	wm withdraw $grab
543    } else {
544	::destroy $grab
545    }
546    if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
547	if {[string equal $oldStatus "global"]} {
548	    ::grab -global $oldGrab
549	} else {
550	    ::grab $oldGrab
551	}
552    }
553}
554
555# BWidget::badOptionString --
556#
557#	Helper function to return a proper error string when an option
558#       doesn't match a list of given options.
559#
560# Arguments:
561#	type	A string that represents the type of option.
562#	value	The value that is in-valid.
563#       list	A list of valid options.
564#
565# Results:
566#	None.
567proc BWidget::badOptionString {type value list} {
568    set last [lindex $list end]
569    set list [lreplace $list end end]
570    return "bad $type \"$value\": must be [join $list ", "], or $last"
571}
572
573
574proc BWidget::wrongNumArgsString { string } {
575    return "wrong # args: should be \"$string\""
576}
577
578
579proc BWidget::read_file { file } {
580    set fp [open $file]
581    set x  [read $fp [file size $file]]
582    close $fp
583    return $x
584}
585
586
587proc BWidget::classes { class } {
588    variable use
589
590    ${class}::use
591    set classes [list $class]
592    if {![info exists use($class)]} { return }
593    foreach class $use($class) {
594        if {![string equal $class "-classonly"]} {
595            eval lappend classes [classes $class]
596        }
597    }
598    return [lsort -unique $classes]
599}
600
601
602proc BWidget::library { args } {
603    variable use
604
605    set libs    [list widget init utils]
606    set classes [list]
607    foreach class $args {
608	${class}::use
609        eval lappend classes [classes $class]
610    }
611
612    eval lappend libs [lsort -unique $classes]
613
614    set library ""
615    foreach lib $libs {
616	if {![info exists use($lib,file)]} {
617	    set file [file join $::BWIDGET::LIBRARY $lib.tcl]
618	} else {
619	    set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl]
620	}
621        append library [read_file $file]
622    }
623
624    return $library
625}
626
627
628proc BWidget::inuse { class } {
629    variable ::Widget::_inuse
630
631    if {![info exists _inuse($class)]} { return 0 }
632    return [expr $_inuse($class) > 0]
633}
634
635
636proc BWidget::write { filename {mode w} } {
637    variable use
638
639    if {![info exists use(classes)]} { return }
640
641    set classes [list]
642    foreach class $use(classes) {
643	if {![inuse $class]} { continue }
644	lappend classes $class
645    }
646
647    set fp [open $filename $mode]
648    puts $fp [eval library $classes]
649    close $fp
650
651    return
652}
653
654
655# BWidget::bindMouseWheel --
656#
657#	Bind mouse wheel actions to a given widget.
658#
659# Arguments:
660#	widget - The widget to bind.
661#
662# Results:
663#	None.
664proc BWidget::bindMouseWheel { widget } {
665    if {[bind all <MouseWheel>] eq ""} {
666	# style::as and Tk 8.5 have global bindings
667	# Only enable these if no global binding for MouseWheel exists
668	bind $widget <MouseWheel> \
669	    {%W yview scroll [expr {-%D/24}]  units}
670	bind $widget <Shift-MouseWheel> \
671	    {%W yview scroll [expr {-%D/120}] pages}
672	bind $widget <Control-MouseWheel> \
673	    {%W yview scroll [expr {-%D/120}] units}
674    }
675
676    if {[bind all <Button-4>] eq ""} {
677	# style::as and Tk 8.5 have global bindings
678	# Only enable these if no global binding for them exists
679	bind $widget <Button-4> {event generate %W <MouseWheel> -delta  120}
680	bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120}
681    }
682}
683
684
685# ----------------------------------------------------------------------------
686# support for middle mouse button movement
687# ----------------------------------------------------------------------------
688
689proc BWidget::bindMiddleMouseMovement { widget } {
690  variable __private
691
692  bind $widget <2> {
693     set BWidget::__private(x) %x
694     set BWidget::__private(y) %y
695     %W configure -cursor fleur
696  }
697  bind $widget <B2-ButtonRelease> {
698     %W configure -cursor ""
699  }
700
701  bind $widget <B2-Motion> {
702      set scrollspeed 2
703      set xdir 1
704      set ydir 1
705      if { %x > $BWidget::__private(x) } {set xdir -1}
706      if { %y > $BWidget::__private(y) } {set ydir -1}
707      catch {%W xview scroll [expr $xdir * $scrollspeed] units}
708      catch {%W yview scroll [expr $ydir * $scrollspeed] units}
709  }
710}
711
712
713# ----------------------------------------------------------------------------
714# utility function for font support
715# ----------------------------------------------------------------------------
716
717proc ::BWidget::getSystemFontProperties {} {
718
719    array set fp {
720        family   "Courier New"
721        stdsize  12
722        headingsize 10
723	captionsize 12
724        tooltipsize 10
725        wheading normal
726        wcaption normal
727    }
728
729    if {$::tcl_version >= 8.4} {
730             set plat [tk windowingsystem]
731    } else { set plat $::tcl_platform(platform) }
732
733
734    switch -exact -- [string tolower $plat] {
735        "win32" - "windows" {
736            if {$::tcl_platform(osVersion) >= 5.0} {
737                     set fp(family) "Tahoma"
738            } else { set fp(family) "MS Sans Serif" }
739            set fp(stdsize) 8
740	    set fp(headingsize) 8
741	    set fp(captionsize) 8
742	    set fp(tooltipsize) 8
743            set fp(wcaption) bold
744	}
745        "classic" - "aqua" {
746            set fp(family) "Lucida Grande"
747            set fp(stdsize) 13
748	    set fp(headingsize) 11
749	    set fp(captionsize) 13
750            set fp(tooltipsize) 12
751	    set fp(wcaption) bold
752        }
753        "x11" {
754            if { ![catch {tk::pkgconfig get fontsystem} fs] &&
755                  [string equal $fs "xft"] } {
756                     set fp(family) "sans-serif"
757            } else { set fp(family) "Helvetica" }
758            set fp(stdsize) -12
759            set fp(headingsize) -12
760            set fp(captionsize) -14
761            set fp(tooltipsize) -10
762	    set fp(wheading) bold
763            set fp(wcaption) bold
764        }
765    }
766    return [array get fp]
767}
768
769
770# under tk >= 8.5 / tile 0.8,
771# the following predefined fonts are available:
772#    TkCaptionFont TkDefaultFont TkFixedFont TkHeadingFont
773#    TkIconFont TkMenuFont TkSmallCaptionFont TkTextFont TkTooltipFont
774# to be compatible with older versions and to make sure,
775# those fonts are available at runtime, we need to ensure that they exist:
776
777proc ::BWidget::createSystemFonts {} {
778  variable vars
779
780    array set fp [getSystemFontProperties]
781    set fnames [font names]
782
783    foreach fname { TkCaptionFont TkDefaultFont TkFixedFont TkHeadingFont
784                    TkIconFont TkMenuFont TkSmallCaptionFont TkTextFont
785		    TkTooltipFont } {
786
787        if {[lsearch $fnames $fname] == -1} {
788            font create $fname -family $fp(family) -size $fp(stdsize)
789
790	    switch -- $fname {
791	      TkCaptionFont {
792	          font configure $fname \
793	              -size $fp(captionsize) -weight $fp(wcaption)
794	      }
795	      TkHeadingFont {
796	          font configure $fname \
797	              -size $fp(headingsize) -weight $fp(wheading)
798	      }
799	      TkTooltipFont {
800	          font configure $fname -size $fp(tooltipsize)
801	      }
802	    }
803        }
804    }
805}
806
807