figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

tk.tcl (23142B)


      1 # tk.tcl --
      2 #
      3 # Initialization script normally executed in the interpreter for each Tk-based
      4 # application.  Arranges class bindings for widgets.
      5 #
      6 # Copyright (c) 1992-1994 The Regents of the University of California.
      7 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
      8 # Copyright (c) 1998-2000 Ajuba Solutions.
      9 #
     10 # See the file "license.terms" for information on usage and redistribution of
     11 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
     12 
     13 # Verify that we have Tk binary and script components from the same release
     14 package require -exact Tk  8.6.8
     15 
     16 # Create a ::tk namespace
     17 namespace eval ::tk {
     18     # Set up the msgcat commands
     19     namespace eval msgcat {
     20 	namespace export mc mcmax
     21         if {[interp issafe] || [catch {package require msgcat}]} {
     22             # The msgcat package is not available.  Supply our own
     23             # minimal replacement.
     24             proc mc {src args} {
     25                 return [format $src {*}$args]
     26             }
     27             proc mcmax {args} {
     28                 set max 0
     29                 foreach string $args {
     30                     set len [string length $string]
     31                     if {$len>$max} {
     32                         set max $len
     33                     }
     34                 }
     35                 return $max
     36             }
     37         } else {
     38             # Get the commands from the msgcat package that Tk uses.
     39             namespace import ::msgcat::mc
     40             namespace import ::msgcat::mcmax
     41             ::msgcat::mcload [file join $::tk_library msgs]
     42         }
     43     }
     44     namespace import ::tk::msgcat::*
     45 }
     46 # and a ::ttk namespace
     47 namespace eval ::ttk {
     48     if {$::tk_library ne ""} {
     49 	# avoid file join to work in safe interps, but this is also x-plat ok
     50 	variable library $::tk_library/ttk
     51     }
     52 }
     53 
     54 # Add Ttk & Tk's directory to the end of the auto-load search path, if it
     55 # isn't already on the path:
     56 
     57 if {[info exists ::auto_path] && ($::tk_library ne "")
     58     && ($::tk_library ni $::auto_path)
     59 } then {
     60     lappend ::auto_path $::tk_library $::ttk::library
     61 }
     62 
     63 # Turn off strict Motif look and feel as a default.
     64 
     65 set ::tk_strictMotif 0
     66 
     67 # Turn on useinputmethods (X Input Methods) by default.
     68 # We catch this because safe interpreters may not allow the call.
     69 
     70 catch {tk useinputmethods 1}
     71 
     72 # ::tk::PlaceWindow --
     73 #   place a toplevel at a particular position
     74 # Arguments:
     75 #   toplevel	name of toplevel window
     76 #   ?placement?	pointer ?center? ; places $w centered on the pointer
     77 #		widget widgetPath ; centers $w over widget_name
     78 #		defaults to placing toplevel in the middle of the screen
     79 #   ?anchor?	center or widgetPath
     80 # Results:
     81 #   Returns nothing
     82 #
     83 proc ::tk::PlaceWindow {w {place ""} {anchor ""}} {
     84     wm withdraw $w
     85     update idletasks
     86     set checkBounds 1
     87     if {$place eq ""} {
     88 	set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
     89 	set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
     90 	set checkBounds 0
     91     } elseif {[string equal -length [string length $place] $place "pointer"]} {
     92 	## place at POINTER (centered if $anchor == center)
     93 	if {[string equal -length [string length $anchor] $anchor "center"]} {
     94 	    set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
     95 	    set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
     96 	} else {
     97 	    set x [winfo pointerx $w]
     98 	    set y [winfo pointery $w]
     99 	}
    100     } elseif {[string equal -length [string length $place] $place "widget"] && \
    101 	    [winfo exists $anchor] && [winfo ismapped $anchor]} {
    102 	## center about WIDGET $anchor, widget must be mapped
    103 	set x [expr {[winfo rootx $anchor] + \
    104 		([winfo width $anchor]-[winfo reqwidth $w])/2}]
    105 	set y [expr {[winfo rooty $anchor] + \
    106 		([winfo height $anchor]-[winfo reqheight $w])/2}]
    107     } else {
    108 	set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
    109 	set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
    110 	set checkBounds 0
    111     }
    112     if {$checkBounds} {
    113 	if {$x < [winfo vrootx $w]} {
    114 	    set x [winfo vrootx $w]
    115 	} elseif {$x > ([winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w])} {
    116 	    set x [expr {[winfo vrootx $w]+[winfo vrootwidth $w]-[winfo reqwidth $w]}]
    117 	}
    118 	if {$y < [winfo vrooty $w]} {
    119 	    set y [winfo vrooty $w]
    120 	} elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} {
    121 	    set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}]
    122 	}
    123 	if {[tk windowingsystem] eq "aqua"} {
    124 	    # Avoid the native menu bar which sits on top of everything.
    125 	    if {$y < 22} {
    126 		set y 22
    127 	    }
    128 	}
    129     }
    130     wm maxsize $w [winfo vrootwidth $w] [winfo vrootheight $w]
    131     wm geometry $w +$x+$y
    132     wm deiconify $w
    133 }
    134 
    135 # ::tk::SetFocusGrab --
    136 #   swap out current focus and grab temporarily (for dialogs)
    137 # Arguments:
    138 #   grab	new window to grab
    139 #   focus	window to give focus to
    140 # Results:
    141 #   Returns nothing
    142 #
    143 proc ::tk::SetFocusGrab {grab {focus {}}} {
    144     set index "$grab,$focus"
    145     upvar ::tk::FocusGrab($index) data
    146 
    147     lappend data [focus]
    148     set oldGrab [grab current $grab]
    149     lappend data $oldGrab
    150     if {[winfo exists $oldGrab]} {
    151 	lappend data [grab status $oldGrab]
    152     }
    153     # The "grab" command will fail if another application
    154     # already holds the grab.  So catch it.
    155     catch {grab $grab}
    156     if {[winfo exists $focus]} {
    157 	focus $focus
    158     }
    159 }
    160 
    161 # ::tk::RestoreFocusGrab --
    162 #   restore old focus and grab (for dialogs)
    163 # Arguments:
    164 #   grab	window that had taken grab
    165 #   focus	window that had taken focus
    166 #   destroy	destroy|withdraw - how to handle the old grabbed window
    167 # Results:
    168 #   Returns nothing
    169 #
    170 proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} {
    171     set index "$grab,$focus"
    172     if {[info exists ::tk::FocusGrab($index)]} {
    173 	foreach {oldFocus oldGrab oldStatus} $::tk::FocusGrab($index) { break }
    174 	unset ::tk::FocusGrab($index)
    175     } else {
    176 	set oldGrab ""
    177     }
    178 
    179     catch {focus $oldFocus}
    180     grab release $grab
    181     if {$destroy eq "withdraw"} {
    182 	wm withdraw $grab
    183     } else {
    184 	destroy $grab
    185     }
    186     if {[winfo exists $oldGrab] && [winfo ismapped $oldGrab]} {
    187 	if {$oldStatus eq "global"} {
    188 	    grab -global $oldGrab
    189 	} else {
    190 	    grab $oldGrab
    191 	}
    192     }
    193 }
    194 
    195 # ::tk::GetSelection --
    196 #   This tries to obtain the default selection.  On Unix, we first try
    197 #   and get a UTF8_STRING, a type supported by modern Unix apps for
    198 #   passing Unicode data safely.  We fall back on the default STRING
    199 #   type otherwise.  On Windows, only the STRING type is necessary.
    200 # Arguments:
    201 #   w	The widget for which the selection will be retrieved.
    202 #	Important for the -displayof property.
    203 #   sel	The source of the selection (PRIMARY or CLIPBOARD)
    204 # Results:
    205 #   Returns the selection, or an error if none could be found
    206 #
    207 if {[tk windowingsystem] ne "win32"} {
    208     proc ::tk::GetSelection {w {sel PRIMARY}} {
    209 	if {[catch {
    210 	    selection get -displayof $w -selection $sel -type UTF8_STRING
    211 	} txt] && [catch {
    212 	    selection get -displayof $w -selection $sel
    213 	} txt]} then {
    214 	    return -code error -errorcode {TK SELECTION NONE} \
    215 		"could not find default selection"
    216 	} else {
    217 	    return $txt
    218 	}
    219     }
    220 } else {
    221     proc ::tk::GetSelection {w {sel PRIMARY}} {
    222 	if {[catch {
    223 	    selection get -displayof $w -selection $sel
    224 	} txt]} then {
    225 	    return -code error -errorcode {TK SELECTION NONE} \
    226 		"could not find default selection"
    227 	} else {
    228 	    return $txt
    229 	}
    230     }
    231 }
    232 
    233 # ::tk::ScreenChanged --
    234 # This procedure is invoked by the binding mechanism whenever the
    235 # "current" screen is changing.  The procedure does two things.
    236 # First, it uses "upvar" to make variable "::tk::Priv" point at an
    237 # array variable that holds state for the current display.  Second,
    238 # it initializes the array if it didn't already exist.
    239 #
    240 # Arguments:
    241 # screen -		The name of the new screen.
    242 
    243 proc ::tk::ScreenChanged screen {
    244     # Extract the display name.
    245     set disp [string range $screen 0 [string last . $screen]-1]
    246 
    247     # Ensure that namespace separators never occur in the display name (as
    248     # they cause problems in variable names). Double-colons exist in some VNC
    249     # display names. [Bug 2912473]
    250     set disp [string map {:: _doublecolon_} $disp]
    251 
    252     uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv]
    253     variable ::tk::Priv
    254 
    255     if {[info exists Priv]} {
    256 	set Priv(screen) $screen
    257 	return
    258     }
    259     array set Priv {
    260 	activeMenu	{}
    261 	activeItem	{}
    262 	afterId		{}
    263 	buttons		0
    264 	buttonWindow	{}
    265 	dragging	0
    266 	focus		{}
    267 	grab		{}
    268 	initPos		{}
    269 	inMenubutton	{}
    270 	listboxPrev	{}
    271 	menuBar		{}
    272 	mouseMoved	0
    273 	oldGrab		{}
    274 	popup		{}
    275 	postedMb	{}
    276 	pressX		0
    277 	pressY		0
    278 	prevPos		0
    279 	selectMode	char
    280     }
    281     set Priv(screen) $screen
    282     set Priv(tearoff) [string equal [tk windowingsystem] "x11"]
    283     set Priv(window) {}
    284 }
    285 
    286 # Do initial setup for Priv, so that it is always bound to something
    287 # (otherwise, if someone references it, it may get set to a non-upvar-ed
    288 # value, which will cause trouble later).
    289 
    290 tk::ScreenChanged [winfo screen .]
    291 
    292 # ::tk::EventMotifBindings --
    293 # This procedure is invoked as a trace whenever ::tk_strictMotif is
    294 # changed.  It is used to turn on or turn off the motif virtual
    295 # bindings.
    296 #
    297 # Arguments:
    298 # n1 - the name of the variable being changed ("::tk_strictMotif").
    299 
    300 proc ::tk::EventMotifBindings {n1 dummy dummy} {
    301     upvar $n1 name
    302 
    303     if {$name} {
    304 	set op delete
    305     } else {
    306 	set op add
    307     }
    308 
    309     event $op <<Cut>> <Control-Key-w> <Control-Lock-Key-W> <Shift-Key-Delete>
    310     event $op <<Copy>> <Meta-Key-w> <Meta-Lock-Key-W> <Control-Key-Insert>
    311     event $op <<Paste>> <Control-Key-y> <Control-Lock-Key-Y> <Shift-Key-Insert>
    312     event $op <<PrevChar>> <Control-Key-b> <Control-Lock-Key-B>
    313     event $op <<NextChar>> <Control-Key-f> <Control-Lock-Key-F>
    314     event $op <<PrevLine>> <Control-Key-p> <Control-Lock-Key-P>
    315     event $op <<NextLine>> <Control-Key-n> <Control-Lock-Key-N>
    316     event $op <<LineStart>> <Control-Key-a> <Control-Lock-Key-A>
    317     event $op <<LineEnd>> <Control-Key-e> <Control-Lock-Key-E>
    318     event $op <<SelectPrevChar>> <Control-Key-B> <Control-Lock-Key-b>
    319     event $op <<SelectNextChar>> <Control-Key-F> <Control-Lock-Key-f>
    320     event $op <<SelectPrevLine>> <Control-Key-P> <Control-Lock-Key-p>
    321     event $op <<SelectNextLine>> <Control-Key-N> <Control-Lock-Key-n>
    322     event $op <<SelectLineStart>> <Control-Key-A> <Control-Lock-Key-a>
    323     event $op <<SelectLineEnd>> <Control-Key-E> <Control-Lock-Key-e>
    324 }
    325 
    326 #----------------------------------------------------------------------
    327 # Define common dialogs on platforms where they are not implemented
    328 # using compiled code.
    329 #----------------------------------------------------------------------
    330 
    331 if {![llength [info commands tk_chooseColor]]} {
    332     proc ::tk_chooseColor {args} {
    333 	return [::tk::dialog::color:: {*}$args]
    334     }
    335 }
    336 if {![llength [info commands tk_getOpenFile]]} {
    337     proc ::tk_getOpenFile {args} {
    338 	if {$::tk_strictMotif} {
    339 	    return [::tk::MotifFDialog open {*}$args]
    340 	} else {
    341 	    return [::tk::dialog::file:: open {*}$args]
    342 	}
    343     }
    344 }
    345 if {![llength [info commands tk_getSaveFile]]} {
    346     proc ::tk_getSaveFile {args} {
    347 	if {$::tk_strictMotif} {
    348 	    return [::tk::MotifFDialog save {*}$args]
    349 	} else {
    350 	    return [::tk::dialog::file:: save {*}$args]
    351 	}
    352     }
    353 }
    354 if {![llength [info commands tk_messageBox]]} {
    355     proc ::tk_messageBox {args} {
    356 	return [::tk::MessageBox {*}$args]
    357     }
    358 }
    359 if {![llength [info command tk_chooseDirectory]]} {
    360     proc ::tk_chooseDirectory {args} {
    361 	return [::tk::dialog::file::chooseDir:: {*}$args]
    362     }
    363 }
    364 
    365 #----------------------------------------------------------------------
    366 # Define the set of common virtual events.
    367 #----------------------------------------------------------------------
    368 
    369 switch -exact -- [tk windowingsystem] {
    370     "x11" {
    371 	event add <<Cut>>		<Control-Key-x> <Key-F20> <Control-Lock-Key-X>
    372 	event add <<Copy>>		<Control-Key-c> <Key-F16> <Control-Lock-Key-C>
    373 	event add <<Paste>>		<Control-Key-v> <Key-F18> <Control-Lock-Key-V>
    374 	event add <<PasteSelection>>	<ButtonRelease-2>
    375 	event add <<Undo>>		<Control-Key-z> <Control-Lock-Key-Z>
    376 	event add <<Redo>>		<Control-Key-Z> <Control-Lock-Key-z>
    377 	event add <<ContextMenu>>	<Button-3>
    378 	# On Darwin/Aqua, buttons from left to right are 1,3,2.  On Darwin/X11 with recent
    379 	# XQuartz as the X server, they are 1,2,3; other X servers may differ.
    380 
    381 	event add <<SelectAll>>		<Control-Key-slash>
    382 	event add <<SelectNone>>	<Control-Key-backslash>
    383 	event add <<NextChar>>		<Right>
    384 	event add <<SelectNextChar>>	<Shift-Right>
    385 	event add <<PrevChar>>		<Left>
    386 	event add <<SelectPrevChar>>	<Shift-Left>
    387 	event add <<NextWord>>		<Control-Right>
    388 	event add <<SelectNextWord>>	<Control-Shift-Right>
    389 	event add <<PrevWord>>		<Control-Left>
    390 	event add <<SelectPrevWord>>	<Control-Shift-Left>
    391 	event add <<LineStart>>		<Home>
    392 	event add <<SelectLineStart>>	<Shift-Home>
    393 	event add <<LineEnd>>		<End>
    394 	event add <<SelectLineEnd>>	<Shift-End>
    395 	event add <<PrevLine>>		<Up>
    396 	event add <<NextLine>>		<Down>
    397 	event add <<SelectPrevLine>>	<Shift-Up>
    398 	event add <<SelectNextLine>>	<Shift-Down>
    399 	event add <<PrevPara>>		<Control-Up>
    400 	event add <<NextPara>>		<Control-Down>
    401 	event add <<SelectPrevPara>>	<Control-Shift-Up>
    402 	event add <<SelectNextPara>>	<Control-Shift-Down>
    403 	event add <<ToggleSelection>>	<Control-ButtonPress-1>
    404 
    405 	# Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is
    406 	# returned when the user presses <Shift-Tab>. In order for tab
    407 	# traversal to work, we have to add these keysyms to the PrevWindow
    408 	# event. We use catch just in case the keysym isn't recognized.
    409 
    410 	# This is needed for XFree86 systems
    411 	catch { event add <<PrevWindow>> <ISO_Left_Tab> }
    412 	# This seems to be correct on *some* HP systems.
    413 	catch { event add <<PrevWindow>> <hpBackTab> }
    414 
    415 	trace add variable ::tk_strictMotif write ::tk::EventMotifBindings
    416 	set ::tk_strictMotif $::tk_strictMotif
    417 	# On unix, we want to always display entry/text selection,
    418 	# regardless of which window has focus
    419 	set ::tk::AlwaysShowSelection 1
    420     }
    421     "win32" {
    422 	event add <<Cut>>		<Control-Key-x> <Shift-Key-Delete> <Control-Lock-Key-X>
    423 	event add <<Copy>>		<Control-Key-c> <Control-Key-Insert> <Control-Lock-Key-C>
    424 	event add <<Paste>>		<Control-Key-v> <Shift-Key-Insert> <Control-Lock-Key-V>
    425 	event add <<PasteSelection>>	<ButtonRelease-2>
    426   	event add <<Undo>>		<Control-Key-z> <Control-Lock-Key-Z>
    427 	event add <<Redo>>		<Control-Key-y> <Control-Lock-Key-Y>
    428 	event add <<ContextMenu>>	<Button-3>
    429 
    430 	event add <<SelectAll>>		<Control-Key-slash> <Control-Key-a> <Control-Lock-Key-A>
    431 	event add <<SelectNone>>	<Control-Key-backslash>
    432 	event add <<NextChar>>		<Right>
    433 	event add <<SelectNextChar>>	<Shift-Right>
    434 	event add <<PrevChar>>		<Left>
    435 	event add <<SelectPrevChar>>	<Shift-Left>
    436 	event add <<NextWord>>		<Control-Right>
    437 	event add <<SelectNextWord>>	<Control-Shift-Right>
    438 	event add <<PrevWord>>		<Control-Left>
    439 	event add <<SelectPrevWord>>	<Control-Shift-Left>
    440 	event add <<LineStart>>		<Home>
    441 	event add <<SelectLineStart>>	<Shift-Home>
    442 	event add <<LineEnd>>		<End>
    443 	event add <<SelectLineEnd>>	<Shift-End>
    444 	event add <<PrevLine>>		<Up>
    445 	event add <<NextLine>>		<Down>
    446 	event add <<SelectPrevLine>>	<Shift-Up>
    447 	event add <<SelectNextLine>>	<Shift-Down>
    448 	event add <<PrevPara>>		<Control-Up>
    449 	event add <<NextPara>>		<Control-Down>
    450 	event add <<SelectPrevPara>>	<Control-Shift-Up>
    451 	event add <<SelectNextPara>>	<Control-Shift-Down>
    452 	event add <<ToggleSelection>>	<Control-ButtonPress-1>
    453     }
    454     "aqua" {
    455 	event add <<Cut>>		<Command-Key-x> <Key-F2> <Command-Lock-Key-X>
    456 	event add <<Copy>>		<Command-Key-c> <Key-F3> <Command-Lock-Key-C>
    457 	event add <<Paste>>		<Command-Key-v> <Key-F4> <Command-Lock-Key-V>
    458 	event add <<PasteSelection>>	<ButtonRelease-3>
    459 	event add <<Clear>>		<Clear>
    460 	event add <<ContextMenu>>	<Button-2>
    461 
    462 	# Official bindings
    463 	# See http://support.apple.com/kb/HT1343
    464 	event add <<SelectAll>>		<Command-Key-a>
    465 	event add <<SelectNone>>	<Option-Command-Key-a>
    466 	event add <<Undo>>		<Command-Key-z> <Command-Lock-Key-Z>
    467 	event add <<Redo>>		<Shift-Command-Key-z> <Shift-Command-Lock-Key-z>
    468 	event add <<NextChar>>		<Right> <Control-Key-f> <Control-Lock-Key-F>
    469 	event add <<SelectNextChar>>	<Shift-Right> <Shift-Control-Key-F> <Shift-Control-Lock-Key-F>
    470 	event add <<PrevChar>>		<Left> <Control-Key-b> <Control-Lock-Key-B>
    471 	event add <<SelectPrevChar>>	<Shift-Left> <Shift-Control-Key-B> <Shift-Control-Lock-Key-B>
    472 	event add <<NextWord>>		<Option-Right>
    473 	event add <<SelectNextWord>>	<Shift-Option-Right>
    474 	event add <<PrevWord>>		<Option-Left>
    475 	event add <<SelectPrevWord>>	<Shift-Option-Left>
    476 	event add <<LineStart>>		<Home> <Command-Left> <Control-Key-a> <Control-Lock-Key-A>
    477 	event add <<SelectLineStart>>	<Shift-Home> <Shift-Command-Left> <Shift-Control-Key-A> <Shift-Control-Lock-Key-A>
    478 	event add <<LineEnd>>		<End> <Command-Right> <Control-Key-e> <Control-Lock-Key-E>
    479 	event add <<SelectLineEnd>>	<Shift-End> <Shift-Command-Right> <Shift-Control-Key-E> <Shift-Control-Lock-Key-E>
    480 	event add <<PrevLine>>		<Up> <Control-Key-p> <Control-Lock-Key-P>
    481 	event add <<SelectPrevLine>>	<Shift-Up> <Shift-Control-Key-P> <Shift-Control-Lock-Key-P>
    482 	event add <<NextLine>>		<Down> <Control-Key-n> <Control-Lock-Key-N>
    483 	event add <<SelectNextLine>>	<Shift-Down> <Shift-Control-Key-N> <Shift-Control-Lock-Key-N>
    484 	# Not official, but logical extensions of above. Also derived from
    485 	# bindings present in MS Word on OSX.
    486 	event add <<PrevPara>>		<Option-Up>
    487 	event add <<NextPara>>		<Option-Down>
    488 	event add <<SelectPrevPara>>	<Shift-Option-Up>
    489 	event add <<SelectNextPara>>	<Shift-Option-Down>
    490 	event add <<ToggleSelection>>	<Command-ButtonPress-1>
    491     }
    492 }
    493 
    494 # ----------------------------------------------------------------------
    495 # Read in files that define all of the class bindings.
    496 # ----------------------------------------------------------------------
    497 
    498 if {$::tk_library ne ""} {
    499     proc ::tk::SourceLibFile {file} {
    500         namespace eval :: [list source [file join $::tk_library $file.tcl]]
    501     }
    502     namespace eval ::tk {
    503 	SourceLibFile icons
    504 	SourceLibFile button
    505 	SourceLibFile entry
    506 	SourceLibFile listbox
    507 	SourceLibFile menu
    508 	SourceLibFile panedwindow
    509 	SourceLibFile scale
    510 	SourceLibFile scrlbar
    511 	SourceLibFile spinbox
    512 	SourceLibFile text
    513     }
    514 }
    515 
    516 # ----------------------------------------------------------------------
    517 # Default bindings for keyboard traversal.
    518 # ----------------------------------------------------------------------
    519 
    520 event add <<PrevWindow>> <Shift-Tab>
    521 event add <<NextWindow>> <Tab>
    522 bind all <<NextWindow>> {tk::TabToWindow [tk_focusNext %W]}
    523 bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]}
    524 
    525 # ::tk::CancelRepeat --
    526 # This procedure is invoked to cancel an auto-repeat action described
    527 # by ::tk::Priv(afterId).  It's used by several widgets to auto-scroll
    528 # the widget when the mouse is dragged out of the widget with a
    529 # button pressed.
    530 #
    531 # Arguments:
    532 # None.
    533 
    534 proc ::tk::CancelRepeat {} {
    535     variable ::tk::Priv
    536     after cancel $Priv(afterId)
    537     set Priv(afterId) {}
    538 }
    539 
    540 # ::tk::TabToWindow --
    541 # This procedure moves the focus to the given widget.
    542 # It sends a <<TraverseOut>> virtual event to the previous focus window,
    543 # if any, before changing the focus, and a <<TraverseIn>> event
    544 # to the new focus window afterwards.
    545 #
    546 # Arguments:
    547 # w - Window to which focus should be set.
    548 
    549 proc ::tk::TabToWindow {w} {
    550     set focus [focus]
    551     if {$focus ne ""} {
    552 	event generate $focus <<TraverseOut>>
    553     }
    554     focus $w
    555     event generate $w <<TraverseIn>>
    556 }
    557 
    558 # ::tk::UnderlineAmpersand --
    559 #	This procedure takes some text with ampersand and returns text w/o
    560 #	ampersand and position of the ampersand.  Double ampersands are
    561 #	converted to single ones.  Position returned is -1 when there is no
    562 #	ampersand.
    563 #
    564 proc ::tk::UnderlineAmpersand {text} {
    565     set s [string map {&& & & \ufeff} $text]
    566     set idx [string first \ufeff $s]
    567     return [list [string map {\ufeff {}} $s] $idx]
    568 }
    569 
    570 # ::tk::SetAmpText --
    571 #	Given widget path and text with "magic ampersands", sets -text and
    572 #	-underline options for the widget
    573 #
    574 proc ::tk::SetAmpText {widget text} {
    575     lassign [UnderlineAmpersand $text] newtext under
    576     $widget configure -text $newtext -underline $under
    577 }
    578 
    579 # ::tk::AmpWidget --
    580 #	Creates new widget, turning -text option into -text and -underline
    581 #	options, returned by ::tk::UnderlineAmpersand.
    582 #
    583 proc ::tk::AmpWidget {class path args} {
    584     set options {}
    585     foreach {opt val} $args {
    586 	if {$opt eq "-text"} {
    587 	    lassign [UnderlineAmpersand $val] newtext under
    588 	    lappend options -text $newtext -underline $under
    589 	} else {
    590 	    lappend options $opt $val
    591 	}
    592     }
    593     set result [$class $path {*}$options]
    594     if {[string match "*button" $class]} {
    595 	bind $path <<AltUnderlined>> [list $path invoke]
    596     }
    597     return $result
    598 }
    599 
    600 # ::tk::AmpMenuArgs --
    601 #	Processes arguments for a menu entry, turning -label option into
    602 #	-label and -underline options, returned by ::tk::UnderlineAmpersand.
    603 #      The cmd argument is supposed to be either "add" or "entryconfigure"
    604 #
    605 proc ::tk::AmpMenuArgs {widget cmd type args} {
    606     set options {}
    607     foreach {opt val} $args {
    608 	if {$opt eq "-label"} {
    609 	    lassign [UnderlineAmpersand $val] newlabel under
    610 	    lappend options -label $newlabel -underline $under
    611 	} else {
    612 	    lappend options $opt $val
    613 	}
    614     }
    615     $widget $cmd $type {*}$options
    616 }
    617 
    618 # ::tk::FindAltKeyTarget --
    619 #	Search recursively through the hierarchy of visible widgets to find
    620 #	button or label which has $char as underlined character.
    621 #
    622 proc ::tk::FindAltKeyTarget {path char} {
    623     set class [winfo class $path]
    624     if {$class in {
    625 	Button Checkbutton Label Radiobutton
    626 	TButton TCheckbutton TLabel TRadiobutton
    627     } && [string equal -nocase $char \
    628 	    [string index [$path cget -text] [$path cget -underline]]]} {
    629 	return $path
    630     }
    631     set subwins [concat [grid slaves $path] [pack slaves $path] \
    632 	    [place slaves $path]]
    633     if {$class eq "Canvas"} {
    634 	foreach item [$path find all] {
    635 	    if {[$path type $item] eq "window"} {
    636 		set w [$path itemcget $item -window]
    637 		if {$w ne ""} {lappend subwins $w}
    638 	    }
    639 	}
    640     } elseif {$class eq "Text"} {
    641 	lappend subwins {*}[$path window names]
    642     }
    643     foreach child $subwins {
    644 	set target [FindAltKeyTarget $child $char]
    645 	if {$target ne ""} {
    646 	    return $target
    647 	}
    648     }
    649 }
    650 
    651 # ::tk::AltKeyInDialog --
    652 #	<Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>>
    653 #	to button or label which has appropriate underlined character.
    654 #
    655 proc ::tk::AltKeyInDialog {path key} {
    656     set target [FindAltKeyTarget $path $key]
    657     if {$target ne ""} {
    658 	event generate $target <<AltUnderlined>>
    659     }
    660 }
    661 
    662 # ::tk::mcmaxamp --
    663 #	Replacement for mcmax, used for texts with "magic ampersand" in it.
    664 #
    665 
    666 proc ::tk::mcmaxamp {args} {
    667     set maxlen 0
    668     foreach arg $args {
    669 	# Should we run [mc] in caller's namespace?
    670 	lassign [UnderlineAmpersand [mc $arg]] msg
    671 	set length [string length $msg]
    672 	if {$length > $maxlen} {
    673 	    set maxlen $length
    674 	}
    675     }
    676     return $maxlen
    677 }
    678 
    679 # For now, turn off the custom mdef proc for the mac:
    680 
    681 if {[tk windowingsystem] eq "aqua"} {
    682     namespace eval ::tk::mac {
    683 	set useCustomMDEF 0
    684     }
    685 }
    686 
    687 # Run the Ttk themed widget set initialization
    688 if {$::ttk::library ne ""} {
    689     uplevel \#0 [list source $::ttk::library/ttk.tcl]
    690 }
    691 
    692 # Local Variables:
    693 # mode: tcl
    694 # fill-column: 78
    695 # End: