Tk Library Source Code

Check-in [60cdfbf809]
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment: * scripts/mwutil.tcl: Updated to the same version 2.15 as in Tablelist release 6.7.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 60cdfbf809264ea36ebbaf5e8294018e9f730805c3458ba3aab3abd30ffd4e12
User & Date: csaba 2019-10-21 13:27:50
Context
2019-10-21
13:28
* scripts/tclIndex: Newly generated. check-in: 18473137e7 user: csaba tags: trunk
13:27
* scripts/mwutil.tcl: Updated to the same version 2.15 as in Tablelist release 6.7. check-in: 60cdfbf809 user: csaba tags: trunk
13:27
* CHANGES.txt: Updated to reflect the changes. check-in: 1e9bbb52f6 user: csaba tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to modules/mentry/scripts/mwutil.tcl.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
...
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
...
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
...
513
514
515
516
517
518
519
520
521























































522
523
524
525
526
527
528




529
530
531
532
533
534
535
# ========================
#

namespace eval mwutil {
    #
    # Public variables:
    #
    variable version	2.12
    variable library
    if {$::tcl_version >= 8.4} {
	set library	[file dirname [file normalize [info script]]]
    } else {
	set library	[file dirname [info script]] ;# no "file normalize" yet
    }

................................................................................
    #
    # Public procedures:
    #
    namespace export	wrongNumArgs getAncestorByClass convEventFields \
			defineKeyNav processTraversal focusNext focusPrev \
			configureWidget fullConfigOpt fullOpt enumOpts \
			configureSubCmd attribSubCmd hasattribSubCmd \
			unsetattribSubCmd getScrollInfo hasFocus \

			genMouseWheelEvent windowingSystem currentTheme

    #
    # Make modified versions of the procedures tk_focusNext and
    # tk_focusPrev, to be invoked in the processTraversal command
    #
    proc makeFocusProcs {} {
	#
................................................................................
			      optValPairs initialize} {
    upvar $configSpecsName configSpecs

    #
    # Process the command-line arguments
    #
    set cmdLineOpts {}
    set savedVals {}
    set failed 0
    set count [llength $optValPairs]
    foreach {opt val} $optValPairs {
	if {[catch {fullConfigOpt $opt configSpecs} result] != 0} {
	    set failed 1
	    break
	}
................................................................................
	if {$count == 1} {
	    set result "value for \"$opt\" missing"
	    set failed 1
	    break
	}
	set opt $result
	lappend cmdLineOpts $opt
	lappend savedVals [eval $cgetCmd [list $win $opt]]
	if {[catch {eval $configCmd [list $win $opt $val]} result] != 0} {
	    set failed 1
	    break
	}
	incr count -2
    }

    if {$failed} {
	#
	# Restore the saved values
	#
	foreach opt $cmdLineOpts val $savedVals {
	    eval $configCmd [list $win $opt $val]
	}

	return -code error $result
    }

    if {$initialize} {
................................................................................
	} else {
	    return -code error "bad argument \"$what\": must be units or pages"
	}
    } else {
	return -code error "unknown option \"$opt\": must be moveto or scroll"
    }
}

#------------------------------------------------------------------------------























































# mwutil::hasFocus
#
# Returns a boolean value indicating whether the focus window is (a descendant
# of) the widget w.
#------------------------------------------------------------------------------
proc mwutil::hasFocus w {
    return [expr {[string first $w. [focus -displayof $w].] == 0}]




}

#------------------------------------------------------------------------------
# mwutil::genMouseWheelEvent
#
# Generates a mouse wheel event with the given root coordinates and delta on
# the widget w.






|







 







|
>
|







 







|







 







|











|







 









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>



|


|
>
>
>
>







15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
...
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
...
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
# ========================
#

namespace eval mwutil {
    #
    # Public variables:
    #
    variable version	2.15
    variable library
    if {$::tcl_version >= 8.4} {
	set library	[file dirname [file normalize [info script]]]
    } else {
	set library	[file dirname [info script]] ;# no "file normalize" yet
    }

................................................................................
    #
    # Public procedures:
    #
    namespace export	wrongNumArgs getAncestorByClass convEventFields \
			defineKeyNav processTraversal focusNext focusPrev \
			configureWidget fullConfigOpt fullOpt enumOpts \
			configureSubCmd attribSubCmd hasattribSubCmd \
			unsetattribSubCmd getScrollInfo getScrollInfo2 \
			isScrollable hasFocus genMouseWheelEvent \
			windowingSystem currentTheme

    #
    # Make modified versions of the procedures tk_focusNext and
    # tk_focusPrev, to be invoked in the processTraversal command
    #
    proc makeFocusProcs {} {
	#
................................................................................
			      optValPairs initialize} {
    upvar $configSpecsName configSpecs

    #
    # Process the command-line arguments
    #
    set cmdLineOpts {}
    set savedOptValPairs {}
    set failed 0
    set count [llength $optValPairs]
    foreach {opt val} $optValPairs {
	if {[catch {fullConfigOpt $opt configSpecs} result] != 0} {
	    set failed 1
	    break
	}
................................................................................
	if {$count == 1} {
	    set result "value for \"$opt\" missing"
	    set failed 1
	    break
	}
	set opt $result
	lappend cmdLineOpts $opt
	lappend savedOptValPairs $opt [eval $cgetCmd [list $win $opt]]
	if {[catch {eval $configCmd [list $win $opt $val]} result] != 0} {
	    set failed 1
	    break
	}
	incr count -2
    }

    if {$failed} {
	#
	# Restore the saved values
	#
	foreach {opt val} $savedOptValPairs {
	    eval $configCmd [list $win $opt $val]
	}

	return -code error $result
    }

    if {$initialize} {
................................................................................
	} else {
	    return -code error "bad argument \"$what\": must be units or pages"
	}
    } else {
	return -code error "unknown option \"$opt\": must be moveto or scroll"
    }
}

#------------------------------------------------------------------------------
# mwutil::getScrollInfo2
#
# Parses a list of arguments of the form "moveto <fraction>" or "scroll
# <number> units|pages" and returns the corresponding list consisting of two or
# three properly formatted elements.
#------------------------------------------------------------------------------
proc mwutil::getScrollInfo2 {cmd argList} {
    set argCount [llength $argList]
    set opt [lindex $argList 0]

    if {[string first $opt "moveto"] == 0} {
	if {$argCount != 2} {
	    wrongNumArgs "$cmd moveto fraction"
	}

	set fraction [lindex $argList 1]
	format "%f" $fraction ;# floating-point number check with error message
	return [list moveto $fraction]
    } elseif {[string first $opt "scroll"] == 0} {
	if {$argCount != 3} {
	    wrongNumArgs "$cmd scroll number units|pages"
	}

	set number [format "%d" [lindex $argList 1]]
	set what [lindex $argList 2]
	if {[string first $what "units"] == 0} {
	    return [list scroll $number units]
	} elseif {[string first $what "pages"] == 0} {
	    return [list scroll $number pages]
	} else {
	    return -code error "bad argument \"$what\": must be units or pages"
	}
    } else {
	return -code error "unknown option \"$opt\": must be moveto or scroll"
    }
}

#------------------------------------------------------------------------------
# mwutil::isScrollable
#
# Returns a boolean value indicating whether the widget w is scrollable along a
# given axis (x or y).
#------------------------------------------------------------------------------
proc mwutil::isScrollable {w axis} {
    set viewCmd ${axis}view
    return [expr {
	[catch {$w cget -${axis}scrollcommand}] == 0 &&
	[catch {$w $viewCmd} view] == 0 &&
	[catch {$w $viewCmd moveto [lindex $view 0]}] == 0 &&
	[catch {$w $viewCmd scroll 0 units}] == 0 &&
	[catch {$w $viewCmd scroll 0 pages}] == 0
    }]
}

#------------------------------------------------------------------------------
# mwutil::hasFocus
#
# Returns a boolean value indicating whether the focus window is (a descendant
# of) the widget w and has the same toplevel.
#------------------------------------------------------------------------------
proc mwutil::hasFocus w {
    set focusWin [focus -displayof $w]
    return [expr {
	[string first $w. $focusWin.] == 0 &&
	[string compare [winfo toplevel $w] [winfo toplevel $focusWin]] == 0
    }]
}

#------------------------------------------------------------------------------
# mwutil::genMouseWheelEvent
#
# Generates a mouse wheel event with the given root coordinates and delta on
# the widget w.