1
# ----------------------------------------------------------------------------
3
# This file is part of Unifix BWidget Toolkit
4
# $Id: utils.tcl,v 1.1 2004/12/03 00:31:24 tjikkun Exp $
5
# ----------------------------------------------------------------------------
8
# - GlobalVar::setvarvar
9
# - GlobalVar::getvarvar
11
# - BWidget::clonename
12
# - BWidget::get3dcolor
17
# ----------------------------------------------------------------------------
19
namespace eval GlobalVar {
24
namespace eval BWidget {
32
# ----------------------------------------------------------------------------
33
# Command GlobalVar::exists
34
# ----------------------------------------------------------------------------
35
proc GlobalVar::exists { varName } {
36
return [uplevel \#0 [list info exists $varName]]
40
# ----------------------------------------------------------------------------
41
# Command GlobalVar::setvar
42
# ----------------------------------------------------------------------------
43
proc GlobalVar::setvar { varName value } {
44
return [uplevel \#0 [list set $varName $value]]
48
# ----------------------------------------------------------------------------
49
# Command GlobalVar::getvar
50
# ----------------------------------------------------------------------------
51
proc GlobalVar::getvar { varName } {
52
return [uplevel \#0 [list set $varName]]
56
# ----------------------------------------------------------------------------
57
# Command GlobalVar::tracevar
58
# ----------------------------------------------------------------------------
59
proc GlobalVar::tracevar { cmd varName args } {
60
return [uplevel \#0 [list trace $cmd $varName] $args]
65
# ----------------------------------------------------------------------------
66
# Command BWidget::lreorder
67
# ----------------------------------------------------------------------------
68
proc BWidget::lreorder { list neworder } {
72
if { [lsearch -exact $list $e] != -1 } {
77
set len [llength $newlist]
81
if { $len == [llength $list] } {
86
if { ![info exists tabelt($e)] } {
87
set newlist [linsert $newlist $pos $e]
95
# ----------------------------------------------------------------------------
96
# Command BWidget::assert
97
# ----------------------------------------------------------------------------
98
proc BWidget::assert { exp {msg ""}} {
99
set res [uplevel 1 expr $exp]
102
return -code error "Assertion failed: {$exp}"
104
return -code error $msg
110
# ----------------------------------------------------------------------------
111
# Command BWidget::clonename
112
# ----------------------------------------------------------------------------
113
proc BWidget::clonename { menu } {
117
foreach widget [lrange [split $menu "."] 1 end] {
118
if { $found || [winfo class "$path.$widget"] == "Menu" } {
120
append menupath "#" $widget
121
append path "." $menupath
123
append menupath "#" $widget
124
append path "." $widget
131
# ----------------------------------------------------------------------------
132
# Command BWidget::getname
133
# ----------------------------------------------------------------------------
134
proc BWidget::getname { name } {
135
if { [string length $name] } {
136
set text [option get . "${name}Name" ""]
137
if { [string length $text] } {
138
return [parsetext $text]
145
# ----------------------------------------------------------------------------
146
# Command BWidget::parsetext
147
# ----------------------------------------------------------------------------
148
proc BWidget::parsetext { text } {
152
while { [string length $text] } {
153
set idx [string first "&" $text]
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}]
164
append result [string range $text 0 [expr {$idx-1}]]
165
set text [string range $text [expr {$idx+1}] end]
171
return [list $result $index]
175
# ----------------------------------------------------------------------------
176
# Command BWidget::get3dcolor
177
# ----------------------------------------------------------------------------
178
proc 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 } {
185
set tmp2 [expr {(65535+$val)/2}]
186
lappend light [expr {($tmp1 > $tmp2) ? $tmp1:$tmp2}]
188
return [list [eval format "#%04x%04x%04x" $dark] [eval format "#%04x%04x%04x" $light]]
192
# ----------------------------------------------------------------------------
193
# Command BWidget::XLFDfont
194
# ----------------------------------------------------------------------------
195
proc BWidget::XLFDfont { cmd args } {
198
set font "-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
201
set font [lindex $args 0]
202
set args [lrange $args 1 end]
205
return -code error "XLFDfont: commande incorrect: $cmd"
208
set lfont [split $font "-"]
209
if { [llength $lfont] != 15 } {
210
return -code error "XLFDfont: description XLFD incorrect: $font"
213
foreach {option value} $args {
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" }
222
set lfont [lreplace $lfont $index $index $value]
224
return [join $lfont "-"]
229
# ----------------------------------------------------------------------------
230
# Command BWidget::place
231
# ----------------------------------------------------------------------------
234
# For Windows systems with more than one monitor the available screen area may
235
# have negative positions. Geometry settings with negative numbers are used
236
# under X to place wrt the right or bottom of the screen. On windows, Tk
237
# continues to do this. However, a geometry such as 100x100+-200-100 can be
238
# used to place a window onto a secondary monitor. Passing the + gets Tk
239
# to pass the remainder unchanged so the Windows manager then handles -200
240
# which is a position on the left hand monitor.
241
# I've tested this for left, right, above and below the primary monitor.
242
# Currently there is no way to ask Tk the extent of the Windows desktop in
243
# a multi monitor system. Nor what the legal co-ordinate range might be.
245
proc BWidget::place { path w h args } {
249
set reqw [winfo reqwidth $path]
250
set reqh [winfo reqheight $path]
251
if { $w == 0 } {set w $reqw}
252
if { $h == 0 } {set h $reqh}
254
set arglen [llength $args]
256
return -code error "BWidget::place: bad number of argument"
260
set where [lindex $args 0]
261
set list [list "at" "center" "left" "right" "above" "below"]
262
set idx [lsearch $list $where]
264
return -code error [BWidget::badOptionString position $where $list]
268
# purposely removed the {} around these expressions - [PT]
269
set x [expr int([lindex $args 1])]
270
set y [expr int([lindex $args 2])]
273
return -code error "BWidget::place: incorrect position"
275
if {$::tcl_platform(platform) == "windows"} {
276
# handle windows multi-screen. -100 != +-100
277
if {[string index [lindex $args 1] 0] != "-"} {
280
if {[string index [lindex $args 2] 0] != "-"} {
292
if { $arglen == 2 } {
293
set widget [lindex $args 1]
294
if { ![winfo exists $widget] } {
295
return -code error "BWidget::place: \"$widget\" does not exist"
300
set sw [winfo screenwidth $path]
301
set sh [winfo screenheight $path]
303
if { $arglen == 2 } {
305
set x0 [expr {[winfo rootx $widget] + ([winfo width $widget] - $w)/2}]
306
set y0 [expr {[winfo rooty $widget] + ([winfo height $widget] - $h)/2}]
309
set x0 [expr {([winfo screenwidth $path] - $w)/2 - [winfo vrootx $path]}]
310
set y0 [expr {([winfo screenheight $path] - $h)/2 - [winfo vrooty $path]}]
314
if {$::tcl_platform(platform) != "windows"} {
315
if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
316
if { $x0 < 0 } {set x "+0"}
317
if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
318
if { $y0 < 0 } {set y "+0"}
321
set x0 [winfo rootx $widget]
322
set y0 [winfo rooty $widget]
323
set x1 [expr {$x0 + [winfo width $widget]}]
324
set y1 [expr {$y0 + [winfo height $widget]}]
325
if { $idx == 2 || $idx == 3 } {
327
if {$::tcl_platform(platform) != "windows"} {
328
if { $y0+$h > $sh } {set y "-0"; set y0 [expr {$sh-$h}]}
329
if { $y0 < 0 } {set y "+0"}
332
# try left, then right if out, then 0 if out
334
set x "+[expr {$x0-$sw}]"
335
} elseif { $x1+$w <= $sw } {
341
# try right, then left if out, then 0 if out
342
if { $x1+$w <= $sw } {
344
} elseif { $x0 >= $w } {
345
set x "+[expr {$x0-$sw}]"
352
if {$::tcl_platform(platform) != "windows"} {
353
if { $x0+$w > $sw } {set x "-0"; set x0 [expr {$sw-$w}]}
354
if { $x0 < 0 } {set x "+0"}
357
# try top, then bottom, then 0
359
set y "+[expr {$y0-$sh}]"
360
} elseif { $y1+$h <= $sh } {
366
# try bottom, then top, then 0
367
if { $y1+$h <= $sh } {
369
} elseif { $h <= $y0 } {
370
set y "+[expr {$y0-$sh}]"
378
wm geometry $path "${w}x${h}${x}${y}"
380
wm geometry $path "${w}x${h}"
386
# ----------------------------------------------------------------------------
387
# Command BWidget::grab
388
# ----------------------------------------------------------------------------
389
proc BWidget::grab { option path } {
392
if { $option == "release" } {
393
catch {::grab release $path}
394
while { [llength $_gstack] } {
395
set grinfo [lindex $_gstack end]
396
set _gstack [lreplace $_gstack end end]
397
foreach {oldg mode} $grinfo {
398
if { ![string equal $oldg $path] && [winfo exists $oldg] } {
399
if { $mode == "global" } {
400
catch {::grab -global $oldg}
409
set oldg [::grab current]
411
lappend _gstack [list $oldg [::grab status $oldg]]
413
if { $option == "global" } {
422
# ----------------------------------------------------------------------------
423
# Command BWidget::focus
424
# ----------------------------------------------------------------------------
425
proc BWidget::focus { option path {refocus 1} } {
428
if { $option == "release" } {
429
while { [llength $_fstack] } {
430
set oldf [lindex $_fstack end]
431
set _fstack [lreplace $_fstack end end]
432
if { ![string equal $oldf $path] && [winfo exists $oldf] } {
433
if {$refocus} {catch {::focus -force $oldf}}
437
} elseif { $option == "set" } {
438
lappend _fstack [::focus]
443
# BWidget::refocus --
445
# Helper function used to redirect focus from a container frame in
446
# a megawidget to a component widget. Only redirects focus if
447
# focus is already on the container.
450
# container container widget to redirect from.
451
# component component widget to redirect to.
456
proc BWidget::refocus {container component} {
457
if { [string equal $container [::focus]] } {
463
# BWidget::badOptionString --
465
# Helper function to return a proper error string when an option
466
# doesn't match a list of given options.
469
# type A string that represents the type of option.
470
# value The value that is in-valid.
471
# list A list of valid options.
475
proc BWidget::badOptionString {type value list} {
476
set last [lindex $list end]
477
set list [lreplace $list end end]
478
return "bad $type \"$value\": must be [join $list ", "], or $last"
482
proc BWidget::wrongNumArgsString { string } {
483
return "wrong # args: should be \"$string\""
487
proc BWidget::read_file { file } {
489
set x [read $fp [file size $file]]
495
proc BWidget::classes { class } {
499
set classes [list $class]
500
if {![info exists use($class)]} { return }
501
foreach class $use($class) {
502
eval lappend classes [classes $class]
504
return [lsort -unique $classes]
508
proc BWidget::library { args } {
511
set libs [list widget init utils]
513
foreach class $args {
515
eval lappend classes [classes $class]
518
eval lappend libs [lsort -unique $classes]
522
if {![info exists use($lib,file)]} {
523
set file [file join $::BWIDGET::LIBRARY $lib.tcl]
525
set file [file join $::BWIDGET::LIBRARY $use($lib,file).tcl]
527
append library [read_file $file]
534
proc BWidget::inuse { class } {
535
variable ::Widget::_inuse
537
if {![info exists _inuse($class)]} { return 0 }
538
return [expr $_inuse($class) > 0]
542
proc BWidget::write { filename {mode w} } {
545
if {![info exists use(classes)]} { return }
548
foreach class $use(classes) {
549
if {![inuse $class]} { continue }
550
lappend classes $class
553
set fp [open $filename $mode]
554
puts $fp [eval library $classes]
561
# BWidget::bindMouseWheel --
563
# Bind mouse wheel actions to a given widget.
566
# widget - The widget to bind.
570
proc BWidget::bindMouseWheel { widget } {
571
bind $widget <MouseWheel> {%W yview scroll [expr {-%D/24}] units}
572
bind $widget <Shift-MouseWheel> {%W yview scroll [expr {-%D/120}] pages}
573
bind $widget <Control-MouseWheel> {%W yview scroll [expr {-%D/120}] units}
575
bind $widget <Button-4> {event generate %W <MouseWheel> -delta 120}
576
bind $widget <Button-5> {event generate %W <MouseWheel> -delta -120}
added
removed
utils/BWidget-1.7.0/utils.tcl
