00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: bindings.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 5/12/2013 00022 # Brief: Handles menu bindings from configuration file 00023 ###################################################################### 00024 00025 namespace eval bindings { 00026 00027 variable base_bindings_file [file join $::tke_dir data bindings menu_bindings.[tk windowingsystem].tkedat] 00028 variable user_bindings_file [file join $::tke_home menu_bindings.[tk windowingsystem].tkedat] 00029 variable reversed_loaded 0 00030 00031 array set menu_bindings {} 00032 array set reversed_translations {} 00033 00034 ####################### 00035 # PUBLIC PROCEDURES # 00036 ####################### 00037 00038 ###################################################################### 00039 # Loads the bindings information 00040 proc load {} { 00041 00042 # Load the menu bindings file 00043 load_file 0 00044 00045 } 00046 00047 ###################################################################### 00048 # If a user bindings file exists, remove it and perform a load. 00049 proc use_default {} { 00050 00051 variable user_bindings_file 00052 00053 # If a user binding file exists, do the following 00054 if {[file exists $user_bindings_file]} { 00055 00056 # Remove the file 00057 file delete -force $user_bindings_file 00058 00059 # Reload the bindings 00060 load_file 0 00061 00062 } 00063 00064 } 00065 00066 ###################################################################### 00067 # Saves the given shortcut information to the menu binding file. 00068 proc save {max shortcuts} { 00069 00070 variable user_bindings_file 00071 00072 # Make sure the the reversed translations are loaded 00073 load_reversed_translations 00074 00075 if {![catch { open $user_bindings_file w } rc]} { 00076 00077 set last_mnu "" 00078 00079 foreach shortcut $shortcuts { 00080 set mnu_path [translate_to_en [lindex $shortcut 0]] 00081 set mnu [lindex [split $mnu_path /] 0] 00082 if {$mnu ne $last_mnu} { 00083 if {$last_mnu ne ""} { 00084 puts $rc "" 00085 } 00086 puts $rc "# [string totitle $mnu] menu bindings" 00087 set last_mnu $mnu 00088 } 00089 puts -nonewline $rc "{$mnu_path}[string repeat { } [expr $max - [string length $mnu_path]]] " 00090 if {[lindex $shortcut 1] eq ""} { 00091 puts $rc "{}" 00092 } else { 00093 puts $rc [lindex $shortcut 1] 00094 } 00095 } 00096 00097 # Close the file 00098 close $rc 00099 00100 # Next, load the file 00101 load_file 1 00102 00103 } 00104 00105 } 00106 00107 ######################## 00108 # PRIVATE PROCEDURES # 00109 ######################## 00110 00111 ###################################################################### 00112 # Polls on the bindings file in the tke home directory. Whenever it 00113 # changes modification time, re-read the file and store it in the 00114 # menu_bindings array 00115 proc load_file {skip_base {dummy 0}} { 00116 00117 variable base_bindings_file 00118 variable user_bindings_file 00119 variable menu_bindings 00120 00121 # Remove the existing bindings 00122 remove_all_bindings 00123 00124 # Read in the base bindings file. Copy it to the user bindings file, if one does not exist. 00125 if {!$skip_base} { 00126 if {[file exists $user_bindings_file]} { 00127 if {![catch { tkedat::read $base_bindings_file 0 } rc]} { 00128 array set menu_bindings $rc 00129 array set reversed [lreverse $rc] 00130 } 00131 } else { 00132 file copy -force $base_bindings_file $::tke_home 00133 } 00134 } 00135 00136 # Read in the user bindings file. 00137 if {![catch { tkedat::read $user_bindings_file 0 } rc]} { 00138 00139 # This block of code removes and default menu bindings that are in use by the user. 00140 foreach {mnu binding} $rc { 00141 if {[info exists reversed($binding)]} { 00142 catch { unset menu_bindings($reversed($binding)) } 00143 } 00144 set menu_bindings($mnu) $binding 00145 } 00146 00147 # Apply the bindings to the UI 00148 apply_all_bindings 00149 00150 } else { 00151 00152 # Remove all menu bindings if we were unable to read the user bindings file (this file should exist) 00153 array unset menu_bindings 00154 00155 } 00156 00157 } 00158 00159 ###################################################################### 00160 # This must be called prior to saving shortcut changes. It must read 00161 # the translation file and create a hash table so that we can convert 00162 # a translated string back to an English string (we will store English 00163 # menus to the bindings file to keep things working if the translation 00164 # is changed). 00165 proc load_reversed_translations {} { 00166 00167 variable reversed_translations 00168 variable reversed_loaded 00169 00170 # If we have already reversed the translations, don't continue 00171 if {$reversed_loaded > 0} { 00172 return 00173 } 00174 00175 # Get the list of translations that we support 00176 set langs [glob -directory [file join $::tke_dir data msgs] -tails *.msg] 00177 00178 # Figure out which language file is being used 00179 set lang_file "" 00180 foreach locale [msgcat::mcpreferences] { 00181 if {[lsearch $langs $locale.msg] != -1} { 00182 set lang_file $locale.msg 00183 } 00184 } 00185 00186 # Indicate that we are loaded 00187 set reversed_loaded 1 00188 00189 # If we didn't find a translation file, the strings are going to be in English anyways 00190 # so just return 00191 if {$lang_file eq ""} { 00192 return 00193 } 00194 00195 # We will remap the msgcat::mcmset procedure and create a new version of the command 00196 rename ::msgcat::mcmset ::msgcat::mcmset_orig 00197 proc ::msgcat::mcmset {lang translations} { 00198 array set bindings::reversed_translations [lreverse $translations] 00199 } 00200 source -encoding utf-8 [file join $::tke_dir data msgs $lang_file] 00201 rename ::msgcat::mcmset "" 00202 rename ::msgcat::mcmset_orig ::msgcat::mcmset 00203 00204 } 00205 00206 ###################################################################### 00207 # Translates the given menu path into the english version. 00208 proc translate_to_en {mnu_path} { 00209 00210 variable reversed_translations 00211 00212 set new_mnu_path [list] 00213 00214 foreach part [split $mnu_path /] { 00215 set suffix "" 00216 if {[string range $part end-2 end] eq "..."} { 00217 set part [string range $part 0 end-3] 00218 set suffix "..." 00219 } 00220 if {[info exists reversed_translations($part)]} { 00221 lappend new_mnu_path $reversed_translations($part)$suffix 00222 } else { 00223 lappend new_mnu_path $part$suffix 00224 } 00225 } 00226 00227 return [join $new_mnu_path /] 00228 00229 } 00230 00231 ###################################################################### 00232 # Applies the current bindings from the configuration file. 00233 proc apply_all_bindings {} { 00234 00235 variable menu_bindings 00236 variable bound_menus 00237 00238 array unset bound_menus 00239 00240 foreach {mnu_path binding} [array get menu_bindings] { 00241 if {$binding eq ""} { 00242 continue 00243 } 00244 set menu_list [split $mnu_path /] 00245 if {![catch { menus::get_menu [lrange $menu_list 0 end-1] } mnu]} { 00246 if {![catch { menus::get_menu_index $mnu [lindex $menu_list end] } menu_index] && ($menu_index ne "none")} { 00247 set value [list "" "" "" "" ""] 00248 if {[string range $binding end-1 end] eq "--"} { 00249 set binding [string range $binding 0 end-2] 00250 lset value 4 "-" 00251 } 00252 foreach elem [split $binding -] { 00253 lset value [lindex [accelerator_mapping $elem] 0] $elem 00254 } 00255 set binding [join [concat {*}$value] -] 00256 set bound_menus($mnu,$menu_index) $binding 00257 $mnu entryconfigure $menu_index -accelerator $binding 00258 bind all [accelerator_to_sequence $binding] "menus::invoke $mnu $menu_index; break" 00259 } 00260 } 00261 } 00262 00263 # Add bindings to entry, combobox and spinboxes 00264 foreach win [list TEntry TCombobox TSpinbox] { 00265 bind $win <Control-c> "event generate %W <<Copy>>; break" 00266 bind $win <Control-x> "event generate %W <<Cut>>; break" 00267 bind $win <Control-v> "event generate %W <<Paste>>; break" 00268 } 00269 00270 } 00271 00272 ###################################################################### 00273 # Removes all of the menu bindings. 00274 proc remove_all_bindings {} { 00275 00276 variable menu_bindings 00277 variable bound_menus 00278 00279 # Delete all of the accelerators and bindings 00280 foreach {mnu_index binding} [array get bound_menus] { 00281 lassign [split $mnu_index ,] mnu index 00282 catch { $mnu entryconfigure $index -accelerator "" } 00283 bind all [accelerator_to_sequence $binding] "" 00284 } 00285 00286 # Delete the menu_bindings array 00287 array unset menu_bindings 00288 00289 } 00290 00291 ###################################################################### 00292 # Returns 1 if the given menu contains an empty menu binding. 00293 proc is_cleared {mnu} { 00294 00295 variable menu_bindings 00296 00297 return [expr {[info exists menu_bindings($mnu)] && ($menu_bindings($mnu) eq "")}] 00298 00299 } 00300 00301 ###################################################################### 00302 # Convert the Tcl binding to an appropriate accelerator. 00303 proc accelerator_to_sequence {accelerator} { 00304 00305 set sequence "<" 00306 set append_dash 0 00307 set shift 0 00308 set alt 0 00309 00310 # Create character to keysym mapping 00311 array set mapping { 00312 Ctrl "Control-" 00313 Alt "Alt-" 00314 Cmd "Mod1-" 00315 Super "Mod1-" 00316 ! "exclam" 00317 \" "quotedbl" 00318 \# "numbersign" 00319 \$ "dollar" 00320 % "percent" 00321 ' "quoteright" 00322 ( "parenleft" 00323 ) "parenright" 00324 * "asterisk" 00325 + "plus" 00326 , "comma" 00327 - "minus" 00328 . "period" 00329 / "slash" 00330 : "colon" 00331 ; "semicolon" 00332 < "less" 00333 = "equal" 00334 > "greater" 00335 ? "question" 00336 @ "at" 00337 \[ "bracketleft" 00338 \\ "backslash" 00339 \] "bracketright" 00340 ^ "asciicircum" 00341 _ "underscore" 00342 ` "quoteleft" 00343 \{ "braceleft" 00344 | "bar" 00345 \} "braceright" 00346 ~ "asciitilde" 00347 & "ampersand" 00348 Space "space" 00349 } 00350 00351 array set shift_mapping { 00352 1 "exclam" 00353 2 "at" 00354 3 "numbersign" 00355 4 "dollar" 00356 5 "percent" 00357 6 "asciicircum" 00358 7 "ampersand" 00359 8 "asterisk" 00360 9 "parenleft" 00361 0 "parenright" 00362 - "underscore" 00363 = "plus" 00364 \[ "bracketleft" 00365 \] "bracketright" 00366 \\ "bar" 00367 ; "colon" 00368 ' "quotedbl" 00369 , "less" 00370 . "greater" 00371 / "question" 00372 } 00373 00374 # I don't believe there are any Alt key mappings on other platforms 00375 array set alt_mapping {} 00376 00377 # If we are on a Mac, adjust the mapping 00378 if {[tk windowingsystem] eq "aqua"} { 00379 unset mapping(Alt) 00380 array set alt_mapping { 00381 1 "exclamdown" 00382 3 "sterling" 00383 4 "cent" 00384 6 "section" 00385 7 "paragraph" 00386 9 "ordfeminine" 00387 0 "masculine" 00388 r "registered" 00389 y "yen" 00390 o "oslash" 00391 p "Amacron" 00392 \\ "guillemotleft" 00393 a "aring" 00394 s "ssharp" 00395 g "copyright" 00396 l "notsign" 00397 , "ae" 00398 c "ccedilla" 00399 m "mu" 00400 / "division" 00401 * "degree" 00402 ( "periodcentered" 00403 + "plusminus" 00404 E "acute" 00405 Y "Aacute" 00406 U "diaeresis" 00407 I "Ccircumflex" 00408 O "Ooblique" 00409 | "guillemotright" 00410 A "Aring" 00411 S "Iacute" 00412 D "Icircumflex" 00413 F "Idiaresis" 00414 G "Ubreve" 00415 H "Oacute" 00416 J "Ocircumflex" 00417 L "Ograve" 00418 : "Uacute" 00419 \" "AE" 00420 z "cedilla" 00421 C "Ccedilla" 00422 M "Acircumflex" 00423 < "macron" 00424 > "Gcircumflex" 00425 ? "questuondown" 00426 } 00427 } 00428 00429 # If the sequence detail is the minus key, this will cause problems with the parser so 00430 # remove it and append it at the end of the sequence. 00431 if {[string range $accelerator end-1 end] eq "--"} { 00432 set append_dash 1 00433 set accelerator [string range $accelerator 0 end-2] 00434 } 00435 00436 # Create the sequence 00437 foreach value [split $accelerator -] { 00438 if {$alt && !$shift && [info exists alt_mapping([string tolower $value])]} { 00439 append sequence $alt_mapping([string tolower $value]) 00440 } elseif {$alt && $shift && [info exists alt_mapping([string toupper $value])]} { 00441 append sequence $alt_mapping([string toupper $value]) 00442 } elseif {$shift && [info exists shift_mapping($value)]} { 00443 append sequence $shift_mapping($value) 00444 } elseif {[info exists mapping($value)]} { 00445 append sequence $mapping($value) 00446 } elseif {$value eq "Shift"} { 00447 append sequence "Shift-" 00448 set shift 1 00449 } elseif {$value eq "Alt"} { 00450 set alt 1 00451 } elseif {[string length $value] == 1} { 00452 if {$alt} { 00453 append sequence "Mod2-" 00454 } 00455 append sequence [string tolower $value] 00456 } else { 00457 append sequence $value 00458 } 00459 } 00460 00461 if {$append_dash} { 00462 append sequence "minus" 00463 } 00464 00465 append sequence ">" 00466 00467 return $sequence 00468 00469 } 00470 00471 ###################################################################### 00472 # Maps the given value to the displayed. 00473 proc accelerator_mapping {value} { 00474 00475 array set map { 00476 Ctrl,\u2303 0 00477 Alt,\u2325 1 00478 Shift,\u21e7 2 00479 Cmd,\u2318 3 00480 Up,\u2191 4 00481 Down,\u2193 4 00482 Left,\u2190 4 00483 Right,\u2192 4 00484 } 00485 00486 # Special-case the asterisk character 00487 if {($value eq "*") || ($value eq "?")} { 00488 return [list 4 $value] 00489 } 00490 00491 if {[set key [array names map $value,*]] ne ""} { 00492 return [list $map($key) [lindex [split $key ,] 1]] 00493 } elseif {[set key [array names map *,$value]] ne ""} { 00494 return [list $map($key) [lindex [split $key ,] 0]] 00495 } elseif {[string length $value] == 2} { 00496 return [list 4 [string index $value 1]] 00497 } else { 00498 return [list 4 $value] 00499 } 00500 00501 } 00502 00503 } 00504