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: syntax.tcl 00020 # Author: Trevor Williams (trevorw@sgi.com) 00021 # Date: 06/11/2013 00022 # Brief: Namespace that handles proper syntax highlighting. 00023 ###################################################################### 00024 00025 namespace eval syntax { 00026 00027 variable filetypes {} 00028 variable current_lang [msgcat::mc "None"] 00029 variable assoc_file 00030 variable syntax_menus {} 00031 00032 array set lang_template { 00033 filepatterns {} 00034 vimsyntax {} 00035 reference {} 00036 embedded {} 00037 matchcharsallowed {} 00038 escapes 1 00039 tabsallowed 0 00040 linewrap 0 00041 casesensitive 0 00042 delimiters {} 00043 indent {} 00044 unindent {} 00045 reindent {} 00046 icomment {} 00047 lcomments {} 00048 bcomments {} 00049 strings {} 00050 keywords {} 00051 functions {} 00052 variables {} 00053 symbols {} 00054 numbers {} 00055 punctuation {} 00056 precompile {} 00057 miscellaneous1 {} 00058 miscellaneous2 {} 00059 miscellaneous3 {} 00060 highlighter {} 00061 meta {} 00062 readmeta {} 00063 advanced {} 00064 formatting {} 00065 } 00066 array set highlight_types { 00067 HighlightKeywords addwords 00068 HighlightRegexp addregexp 00069 HighlightCharStart addcharstart 00070 } 00071 array set langs {} 00072 array set curr_lang {} 00073 array set associations {} 00074 00075 ###################################################################### 00076 # Loads the syntax information. 00077 proc load {} { 00078 00079 variable langs 00080 variable filetypes 00081 variable assoc_file 00082 00083 # Load the tke_dir syntax files 00084 set sfiles [utils::glob_install [file join $::tke_dir data syntax] *.syntax] 00085 00086 # Load the tke_home syntax files 00087 set sfiles [concat $sfiles [glob -nocomplain -directory [file join $::tke_home syntax] *.syntax]] 00088 00089 # Get the syntax information from all of the files in the user's syntax directory. 00090 foreach sfile $sfiles { 00091 add_syntax $sfile 00092 } 00093 00094 # Create the association filename 00095 set assoc_file [file join $::tke_home lang_assoc.tkedat] 00096 00097 # Add all of the syntax plugins 00098 plugins::add_all_syntax 00099 00100 # Create preference trace on language hiding and syntax menu 00101 trace add variable preferences::prefs(General/DisabledLanguages) write [list syntax::handle_syntax_menu] 00102 trace add variable preferences::prefs(View/ShowLanguagesSubmenu) write [list syntax::handle_syntax_menu] 00103 00104 } 00105 00106 ###################################################################### 00107 # Called whenever the given text widget is destroyed. 00108 proc handle_destroy_txt {txt} { 00109 00110 variable curr_lang 00111 00112 catch { unset curr_lang($txt) } 00113 00114 } 00115 00116 ###################################################################### 00117 # Handle any changes to the General/DisabledLanguages preference 00118 # variable. 00119 proc handle_syntax_menu {name1 name2 op} { 00120 00121 variable syntax_menus 00122 00123 # Populate the syntax menus to match the required view type 00124 foreach syntax_menu $syntax_menus { 00125 populate_syntax_menu $syntax_menu syntax::set_current_language syntax::current_lang [msgcat::mc "None"] [get_enabled_languages] 00126 } 00127 00128 # Make sure that the syntax menus are updated 00129 update_syntax_menus 00130 00131 } 00132 00133 ###################################################################### 00134 # Adds the given syntax file to the total list. 00135 proc add_syntax {sfile {interp ""}} { 00136 00137 variable langs 00138 variable lang_template 00139 variable filetypes 00140 00141 # Get the name of the syntax 00142 set name [file rootname [file tail $sfile]] 00143 00144 # See if the syntax type should be hidden from users 00145 set hidden [expr {[string index $name 0] eq "_"}] 00146 00147 # Initialize the language array 00148 array set lang_array [array get lang_template] 00149 00150 # Read the file 00151 if {![catch { open $sfile r } rc]} { 00152 00153 # Read in the file information 00154 set contents [read $rc] 00155 close $rc 00156 00157 # Parse the file contents but if there was an error, just return without adding the syntax 00158 if {[catch { array set lang_array $contents } rc]} { 00159 return 00160 } 00161 00162 if {!$hidden} { 00163 00164 # Format the extension information 00165 set extensions [list] 00166 foreach pattern $lang_array(filepatterns) { 00167 if {[regexp {^\.\w+$} [set extension [file extension $pattern]]]} { 00168 lappend extensions $extension 00169 } 00170 } 00171 set lang_array(extensions) $extensions 00172 00173 if {[llength $extensions] > 0} { 00174 lappend filetypes [list "$name Files" $extensions TEXT] 00175 } 00176 00177 # Sort the filetypes by name 00178 set filetypes [lsort -index 0 $filetypes] 00179 00180 # Add the language to the command launcher 00181 launcher::register [format "%s: %s" [msgcat::mc "Syntax"] $name] [list syntax::set_current_language $name] 00182 00183 } 00184 00185 # Add the interpreter 00186 set lang_array(interp) $interp 00187 00188 # Add the language and the command launcher 00189 set langs($name) [array get lang_array] 00190 00191 } 00192 00193 } 00194 00195 ###################################################################### 00196 # Deletes the given syntax file from the total list. 00197 proc delete_syntax {sfile} { 00198 00199 variable langs 00200 variable filetypes 00201 00202 # Get the name of the syntax 00203 set name [file rootname [file tail $sfile]] 00204 00205 # Delete the syntax 00206 if {[set index [lsearch -index 0 $filetypes $name]] != -1} { 00207 set filetypes [lreplace $filetypes $index $index] 00208 } 00209 00210 # Delete the langs 00211 unset langs($name) 00212 00213 # Unregister the language with the launcher 00214 launcher::unregister [format "%s: %s" [msgcat::mc "Syntax"] $name] 00215 00216 } 00217 00218 ###################################################################### 00219 # Returns a list of all supported languages. 00220 proc get_all_languages {} { 00221 00222 variable langs 00223 00224 return [array names langs] 00225 00226 } 00227 00228 ###################################################################### 00229 # Returns a list of all enabled languages. 00230 proc get_enabled_languages {} { 00231 00232 variable langs 00233 00234 # Get the list of disabled languages 00235 set dis_langs [preferences::get General/DisabledLanguages] 00236 00237 # If we don't have any disabled languages, just return the full list 00238 if {[llength $dis_langs] == 0} { 00239 return [get_all_languages] 00240 } 00241 00242 set enabled [list] 00243 foreach lang [get_all_languages] { 00244 if {[lsearch $dis_langs $lang] == -1} { 00245 lappend enabled $lang 00246 } 00247 } 00248 00249 return $enabled 00250 00251 } 00252 00253 ###################################################################### 00254 # Given the specified filename, returns the language name that supports 00255 # it. If multiple languages respond, use the first match. 00256 proc get_default_language {filename} { 00257 00258 variable langs 00259 variable assoc_file 00260 00261 # Make sure that the filename is an absolute pathname 00262 set filename [file normalize $filename] 00263 00264 # Check to see if the user has specified a language override for files like 00265 # the filename. 00266 if {![catch { tkedat::read $assoc_file 0 } rc]} { 00267 array set associations $rc 00268 set key [file dirname $filename],[file extension $filename] 00269 if {[info exists associations($key)]} { 00270 return $associations($key) 00271 } 00272 } 00273 00274 # Get the list of extension overrides 00275 array set overrides [preferences::get {General/LanguagePatternOverrides}] 00276 00277 set maxlen 0 00278 set best_match [msgcat::mc "None"] 00279 00280 foreach lang [array names langs] { 00281 array set lang_array $langs($lang) 00282 set patterns $lang_array(filepatterns) 00283 set excluded 0 00284 if {[info exists overrides($lang)]} { 00285 set epatterns [list] 00286 foreach pattern $overrides($lang) { 00287 switch [string index $pattern 0] { 00288 "+" { lappend patterns [string range $pattern 1 end] } 00289 "-" { lappend epatterns [string range $pattern 1 end] } 00290 } 00291 } 00292 foreach pattern $epatterns { 00293 if {[string match -nocase $pattern [file tail $filename]]} { 00294 set excluded 1 00295 break 00296 } 00297 } 00298 } 00299 if {!$excluded} { 00300 foreach pattern $patterns { 00301 if {[string match -nocase [file join * $pattern] $filename]} { 00302 if {[string length $pattern] > $maxlen} { 00303 set maxlen [string length $pattern] 00304 set best_match $lang 00305 } 00306 } 00307 } 00308 } 00309 } 00310 00311 return $best_match 00312 00313 } 00314 00315 ###################################################################### 00316 # Returns the name of the language which supports the given vim syntax 00317 # identifier. If no match is found, the value of "None" is returned. 00318 proc get_vim_language {vimsyntax} { 00319 00320 variable langs 00321 00322 foreach lang [array names langs] { 00323 array set lang_array $langs($lang) 00324 if {[lsearch $lang_array(vimsyntax) $vimsyntax] != -1} { 00325 return $lang 00326 } 00327 } 00328 00329 return [msgcat::mc "None"] 00330 00331 } 00332 00333 ###################################################################### 00334 # Retrieves the language of the current text widget. 00335 proc get_language {txt} { 00336 00337 variable curr_lang 00338 00339 if {[info exists curr_lang($txt)]} { 00340 return $curr_lang($txt) 00341 } 00342 00343 return [msgcat::mc "None"] 00344 00345 } 00346 00347 ###################################################################### 00348 # Returns the language information for just the given language. 00349 proc get_lang_references {language} { 00350 00351 variable langs 00352 00353 array set lang_array $langs($language) 00354 00355 set refs [list] 00356 foreach item $lang_array(reference) { 00357 lassign $item name url 00358 lappend refs [list "$language: $name" $url] 00359 } 00360 00361 return $refs 00362 00363 } 00364 00365 ###################################################################### 00366 # Returns the language's reference information, including any embedded 00367 # language reference information. If no reference documentation is 00368 # available, returns the empty string. 00369 proc get_references {language} { 00370 00371 variable langs 00372 00373 set refs [list] 00374 00375 if {[info exists langs($language)]} { 00376 00377 # Add primary language references 00378 set refs [get_lang_references $language] 00379 00380 # Add embedded language references 00381 array set lang_array $langs($language) 00382 foreach embedded $lang_array(embedded) { 00383 set sublang [lindex $embedded 0] 00384 if {[info exists langs($sublang)]} { 00385 lappend refs {*}[get_lang_references $sublang] 00386 } 00387 } 00388 00389 } 00390 00391 return $refs 00392 00393 } 00394 00395 ###################################################################### 00396 # Sets the syntax language for the current text widget. 00397 proc set_current_language {language args} { 00398 00399 # Get information about the current tab 00400 gui::get_info {} current txt fname 00401 00402 # Save the directory, extension and selected language 00403 if {$fname ne "Untitled"} { 00404 save_language_association [file dirname $fname] [file extension $fname] $language 00405 } 00406 00407 # Set the language of the current buffer 00408 set_language $txt $language {*}$args 00409 00410 # Update the menubutton text 00411 [set gui::widgets(info_syntax)] configure -text $language 00412 00413 # Set the focus back to the text editor 00414 gui::set_txt_focus [gui::last_txt_focus] 00415 00416 } 00417 00418 ###################################################################### 00419 # Sets the language of the given text widget to the given language. 00420 # Options: 00421 # -highlight (0 | 1) Specifies whether syntax highlighting should be performed 00422 proc set_language {txt language args} { 00423 00424 variable langs 00425 variable curr_lang 00426 variable current_lang 00427 00428 array set opts { 00429 -highlight 1 00430 } 00431 array set opts $args 00432 00433 # Clear the syntax highlighting for the widget 00434 if {$opts(-highlight)} { 00435 $txt syntax delete all 00436 $txt syntax addblockcomments {} {} 00437 $txt syntax addlinecomments {} {} 00438 $txt syntax addstrings {} {} 00439 ctext::setAutoMatchChars $txt {} {} 00440 } 00441 00442 # Set default indent/unindent strings 00443 indent::set_indent_expressions $txt.t {} {} {} 00444 00445 # Apply the new syntax highlighting syntax, if one exists for the given language 00446 if {[info exists langs($language)]} { 00447 00448 if {[catch { 00449 00450 array set lang_array $langs($language) 00451 00452 # Get the command prefix and create a namespace for the language, if necessary 00453 if {$lang_array(interp) ne ""} { 00454 set cmd_prefix "syntax::exec_plugin_command $lang_array(interp)" 00455 set lang_ns "" 00456 $lang_array(interp) alias $txt $txt 00457 } else { 00458 set cmd_prefix "" 00459 set lang_ns [string tolower $language] 00460 } 00461 00462 # Set the case sensitivity, delimiter characters and wrap mode 00463 $txt configure -casesensitive $lang_array(casesensitive) -escapes $lang_array(escapes) 00464 if {$lang_array(delimiters) ne ""} { 00465 $txt configure -delimiters $lang_array(delimiters) 00466 } 00467 00468 # Set the wrap mode 00469 switch [preferences::get View/EnableLineWrapping] { 00470 syntax { $txt configure -wrap [expr {$lang_array(linewrap) ? "word" : "none"}] } 00471 enable { $txt configure -wrap "word" } 00472 disable { $txt configure -wrap "none" } 00473 } 00474 00475 # Add the language keywords 00476 $txt syntax addclass keywords -fgtheme keywords 00477 $txt syntax addwords class keywords $lang_array(keywords) 00478 00479 # Add the rest of the sections 00480 set_language_section $txt symbols $lang_array(symbols) "" $cmd_prefix $lang_ns 00481 set_language_section $txt functions $lang_array(functions) "" $cmd_prefix $lang_ns 00482 set_language_section $txt variables $lang_array(variables) "" $cmd_prefix $lang_ns 00483 set_language_section $txt punctuation $lang_array(punctuation) "" 00484 set_language_section $txt numbers $lang_array(numbers) "" 00485 set_language_section $txt precompile $lang_array(precompile) "" 00486 set_language_section $txt miscellaneous1 $lang_array(miscellaneous1) "" 00487 set_language_section $txt miscellaneous2 $lang_array(miscellaneous2) "" 00488 set_language_section $txt miscellaneous3 $lang_array(miscellaneous3) "" 00489 set_language_section $txt highlighter $lang_array(highlighter) "" 00490 set_language_section $txt meta $lang_array(meta) "" 00491 set_language_section $txt readmeta $lang_array(readmeta) "" 00492 set_language_section $txt advanced $lang_array(advanced) "" $cmd_prefix $lang_ns 00493 00494 # Add the comments, strings and indentations 00495 ctext::clearCommentStringPatterns $txt 00496 $txt syntax addblockcomments {} $lang_array(bcomments) 00497 $txt syntax addlinecomments {} $lang_array(lcomments) 00498 $txt syntax addstrings {} $lang_array(strings) 00499 ctext::setIndentation $txt {} $lang_array(indent) indent 00500 ctext::setIndentation $txt {} $lang_array(unindent) unindent 00501 00502 set reindentStarts [list] 00503 set reindents [list] 00504 foreach reindent $lang_array(reindent) { 00505 lappend reindentStarts [lindex $reindent 0] 00506 lappend reindents {*}[lrange $reindent 1 end] 00507 } 00508 ctext::setIndentation $txt {} $reindentStarts reindentStart 00509 ctext::setIndentation $txt {} $reindents reindent 00510 00511 # Add the FIXME 00512 # $txt syntax addclass fixme -fgtheme miscellaneous1 00513 # $txt syntax addwords class fixme FIXME 00514 00515 # Set the indent/unindent regular expressions 00516 indent::set_indent_expressions $txt.t $lang_array(indent) $lang_array(unindent) $lang_array(reindent) 00517 00518 # Set the completer options for the given language 00519 ctext::setAutoMatchChars $txt {} $lang_array(matchcharsallowed) 00520 completer::set_auto_match_chars $txt.t {} $lang_array(matchcharsallowed) 00521 00522 foreach embedded $lang_array(embedded) { 00523 lassign $embedded sublang embed_tokens 00524 if {$embed_tokens ne ""} { 00525 $txt syntax addembedlang $sublang $embed_tokens 00526 add_sublanguage $txt $sublang $cmd_prefix "" $embed_tokens 00527 } else { 00528 add_sublanguage $txt $sublang $cmd_prefix "" {} 00529 } 00530 } 00531 00532 # Set the snippets for the current text widget 00533 snippets::set_language $language 00534 snippets::set_expandtabs $txt [expr $lang_array(tabsallowed) ? 0 : 1] 00535 00536 } rc]} { 00537 gui::set_error_message [format "%s (%s)" [msgcat::mc "Syntax error in syntax file"] $language] $rc 00538 puts $::errorInfo 00539 } 00540 00541 } 00542 00543 # Save the language 00544 set curr_lang($txt) $language 00545 00546 # Re-highlight 00547 if {$opts(-highlight)} { 00548 $txt syntax highlight 1.0 end 00549 folding::restart $txt 00550 } 00551 00552 } 00553 00554 ###################################################################### 00555 # Add sublanguage features to current text widget. 00556 proc add_sublanguage {txt language cmd_prefix parent embed_patterns} { 00557 00558 variable langs 00559 00560 array set lang_array $langs($language) 00561 00562 # Adjust the language value if we are not performing a full insertion 00563 if {$embed_patterns eq ""} { 00564 set lang_ns [string tolower $language] 00565 set language $parent 00566 } elseif {$cmd_prefix ne ""} { 00567 set lang_ns "" 00568 } else { 00569 set lang_ns [string tolower $language] 00570 } 00571 00572 # Add the keywords 00573 $txt syntax addwords class keywords $lang_array(keywords) $language 00574 00575 # Add the rest of the sections 00576 set_language_section $txt symbols $lang_array(symbols) $language $cmd_prefix $lang_ns 00577 set_language_section $txt functions $lang_array(functions) $language $cmd_prefix $lang_ns 00578 set_language_section $txt variables $lang_array(variables) $language $cmd_prefix $lang_ns 00579 set_language_section $txt punctuation $lang_array(punctuation) $language 00580 set_language_section $txt miscellaneous1 $lang_array(miscellaneous1) $language 00581 set_language_section $txt miscellaneous2 $lang_array(miscellaneous2) $language 00582 set_language_section $txt miscellaneous3 $lang_array(miscellaneous3) $language 00583 set_language_section $txt highlighter $lang_array(highlighter) $language 00584 set_language_section $txt meta $lang_array(meta) $language 00585 set_language_section $txt readmeta $lang_array(readmeta) $language 00586 set_language_section $txt advanced $lang_array(advanced) $language $cmd_prefix $lang_ns 00587 00588 if {$embed_patterns ne ""} { 00589 00590 # Let's convert the embed_patterns list into start/end pattern lists 00591 foreach embed_pattern $embed_patterns { 00592 lassign $embed_pattern embed_start embed_end 00593 lappend embed_starts $embed_start 00594 lappend embed_ends $embed_end 00595 } 00596 00597 # Add the rest of the sections 00598 set_language_section $txt numbers $lang_array(numbers) $language 00599 set_language_section $txt precompile $lang_array(precompile) $language 00600 00601 # Add the comments, strings and indentations 00602 $txt syntax addblockcomments $language $lang_array(bcomments) 00603 $txt syntax addlinecomments $language $lang_array(lcomments) 00604 $txt syntax addstrings $language $lang_array(strings) 00605 ctext::setIndentation $txt $language [list {*}$embed_starts {*}$lang_array(indent)] indent 00606 ctext::setIndentation $txt $language [list {*}$embed_ends {*}$lang_array(unindent)] unindent 00607 00608 set reindentStarts [list] 00609 set reindents [list] 00610 foreach reindent $lang_array(reindent) { 00611 lappend reindentStarts [lindex $reindent 0] 00612 lappend reindents {*}[lrange $reindent 1 end] 00613 } 00614 ctext::setIndentation $txt $language $reindentStarts reindentStart 00615 ctext::setIndentation $txt $language $reindents reindent 00616 00617 # Add the FIXME 00618 # $txt syntax addwords class fixme FIXME $language 00619 00620 # Set the indent/unindent regular expressions 00621 indent::set_indent_expressions $txt.t $lang_array(indent) $lang_array(unindent) $lang_array(reindent) 00622 00623 # Set the completer options for the given language 00624 ctext::setAutoMatchChars $txt $language $lang_array(matchcharsallowed) 00625 completer::set_auto_match_chars $txt.t $language $lang_array(matchcharsallowed) 00626 00627 # Set the snippets for the current text widget 00628 snippets::set_language $language 00629 00630 } 00631 00632 # Add any mixed languages 00633 foreach embedded $lang_array(embedded) { 00634 lassign $embedded sublang embed_tokens 00635 if {$embed_tokens eq ""} { 00636 add_sublanguage $txt $sublang $cmd_prefix $language {} 00637 } 00638 } 00639 00640 } 00641 00642 ###################################################################### 00643 # Calls the proper 00644 proc add_highlight_type {txt type valtype value syntax lang} { 00645 00646 variable highlight_types 00647 00648 if {[info exists highlight_types($type)]} { 00649 $txt syntax $highlight_types($type) $valtype $value $syntax $lang 00650 } else { 00651 return -code error "Unknown syntax type $type" 00652 } 00653 00654 } 00655 00656 ###################################################################### 00657 # Adds syntax highlighting for a given type 00658 proc set_language_section {txt section section_list lang {cmd_prefix ""} {lang_ns ""}} { 00659 00660 variable meta_tags 00661 00662 switch $section { 00663 "advanced" - 00664 "symbols" - 00665 "functions" - 00666 "variables" { 00667 if {($section eq "functions") || ($section eq "variables")} { 00668 $txt syntax addclass $section -fgtheme $section 00669 } 00670 while {[llength $section_list]} { 00671 set section_list [lassign $section_list type] 00672 switch -glob $type { 00673 "HighlightClass" { 00674 if {$section eq "advanced"} { 00675 set section_list [lassign $section_list name modifiers] 00676 $txt syntax addclass $name {*}$modifiers 00677 } 00678 } 00679 "HighlightProc" { 00680 if {$section eq "advanced"} { 00681 set section_list [lassign $section_list name body] 00682 if {([llength $section_list] > 0) && ![string match Highlight* [lindex $section_list 0]]} { 00683 set params $body 00684 set section_list [lassign $section_list body] 00685 } else { 00686 set params [list txt row str varlist ins] 00687 } 00688 if {$lang_ns ne ""} { 00689 namespace eval $lang_ns [list proc $name $params [subst -nocommands -novariables $body]] 00690 } 00691 } 00692 } 00693 "HighlightEndProc" - 00694 "TclEnd" - 00695 "IgnoreEnd" { 00696 # This is not invalid syntax but is not used for anything in this namespace 00697 } 00698 "Highlight*" { 00699 set section_list [lassign $section_list syntax command] 00700 if {$command ne ""} { 00701 if {$cmd_prefix ne ""} { 00702 add_highlight_type $txt $type command "$cmd_prefix $command" $syntax $lang 00703 } elseif {[string first :: $command] != -1} { 00704 add_highlight_type $txt $type command $command $syntax $lang 00705 } else { 00706 add_highlight_type $txt $type command syntax::${lang_ns}::$command $syntax $lang 00707 } 00708 } else { 00709 set classname [expr {($section eq "advanced") ? "none" : $section}] 00710 $txt syntax addclass $classname -fgtheme $classname 00711 add_highlight_type $txt $type class $classname $syntax $lang 00712 } 00713 } 00714 "TclBegin" { 00715 set section_list [lassign $section_list content] 00716 namespace eval $lang_ns $content 00717 } 00718 "IgnoreBegin" { 00719 set section_list [lrange $section_list 1 end] 00720 } 00721 default { 00722 return -code error "Syntax error found in $section section -- bad type $type" 00723 } 00724 } 00725 } 00726 } 00727 "highlighter" { 00728 foreach {type syntax modifiers} $section_list { 00729 if {$syntax ne ""} { 00730 set class $section 00731 if {[llength $modifiers] > 0} { 00732 append class -[join $modifiers -] 00733 } 00734 $txt syntax addclass $class -fgtheme background -bgtheme $section -fontopts $modifiers 00735 add_highlight_type $txt $type class $class $syntax $lang 00736 } 00737 } 00738 } 00739 default { 00740 foreach {type syntax modifiers} $section_list { 00741 if {$syntax ne ""} { 00742 set class $section 00743 if {[llength $modifiers] > 0} { 00744 append class -[join $modifiers -] 00745 } 00746 $txt syntax addclass $class -fgtheme $section -fontopts $modifiers -meta [expr {($class eq "meta") || ($class eq "readmeta")}] 00747 add_highlight_type $txt $type class $class $syntax $lang 00748 } 00749 } 00750 } 00751 } 00752 00753 } 00754 00755 ###################################################################### 00756 # This should be called whenever the current language is changed. This 00757 # will update the syntax menu states to make them consistent with the 00758 # current language. 00759 proc update_syntax_menus {} { 00760 00761 variable syntax_menus 00762 variable current_lang 00763 00764 foreach mnu $syntax_menus { 00765 if {[$mnu type 1] eq "cascade"} { 00766 for {set i 1} {$i < [$mnu index last]} {incr i} { 00767 $mnu entryconfigure $i -image menu_nocheck 00768 } 00769 if {$current_lang ne [msgcat::mc "None"]} { 00770 $mnu entryconfigure [string toupper [string index $current_lang 0]] -image menu_check 00771 } 00772 } 00773 } 00774 00775 } 00776 00777 ###################################################################### 00778 # Repopulates the specified syntax selection menu. 00779 proc populate_syntax_menu {mnu command varname dflt languages} { 00780 00781 variable langs 00782 variable letters 00783 00784 # Clear the menu 00785 $mnu delete 0 end 00786 00787 # If the user wants to view languages in a submenu, organize them that way 00788 if {[preferences::get View/ShowLanguagesSubmenu] && [winfo exists $mnu.submenuA]} { 00789 array unset letters 00790 foreach lang [lsort [lsearch -inline -not -all $languages _*]] { 00791 lappend letters([string toupper [string index $lang 0]]) $lang 00792 } 00793 $mnu add radiobutton -label [format "<%s>" $dflt] -variable $varname -value $dflt -command [list {*}$command $dflt] 00794 foreach letter [lsort [array names letters]] { 00795 $mnu add cascade -compound left -label $letter -image menu_nocheck -menu $mnu.submenu$letter 00796 } 00797 return 00798 } 00799 00800 # Figure out the height of a menu entry 00801 menu .__tmpMenu 00802 .__tmpMenu add command -label "foobar" 00803 .__tmpMenu add command -label "foobar" 00804 update 00805 set max_entries [expr ([winfo screenheight .] / [set rheight [winfo reqheight .__tmpMenu]]) * 2] 00806 destroy .__tmpMenu 00807 00808 # Calculate the number of needed columns 00809 set len [expr [array size langs] + 1] 00810 set cols 1 00811 while {[expr ($len / $cols) > $max_entries]} { 00812 incr cols 00813 } 00814 00815 # If we are running in Aqua, don't perform the column break 00816 set dobreak [expr {[tk windowingsystem] ne "aqua"}] 00817 00818 # Populate the menu with the available languages 00819 $mnu add radiobutton -label [format "<%s>" $dflt] -variable $varname -value $dflt -command [list {*}$command $dflt] 00820 set i 0 00821 foreach lang [lsort [lsearch -inline -not -all $languages _*]] { 00822 $mnu add radiobutton -label $lang -variable $varname \ 00823 -value $lang -command [list {*}$command $lang] -columnbreak [expr (($len / $cols) == $i) && $dobreak] 00824 set i [expr (($len / $cols) == $i) ? 0 : ($i + 1)] 00825 } 00826 00827 } 00828 00829 ###################################################################### 00830 # Called just prior to posting the menu. 00831 proc post_menu {} { 00832 00833 variable current_lang 00834 00835 # Gets the current language 00836 gui::get_info {} current lang 00837 00838 set current_lang $lang 00839 00840 } 00841 00842 ###################################################################### 00843 # Displays language submenu. 00844 proc post_submenu {mnu letter} { 00845 00846 variable letters 00847 00848 # Clear the menu 00849 $mnu delete 0 end 00850 00851 # Populate the menu with the available languages 00852 foreach lang $letters($letter) { 00853 $mnu add radiobutton -label $lang -variable syntax::current_lang -value $lang -command [list syntax::set_current_language $lang] 00854 } 00855 00856 } 00857 00858 ###################################################################### 00859 # Create a menubutton containing a list of all available languages. 00860 proc create_menu {w} { 00861 00862 variable syntax_menus 00863 00864 # Create the menubutton menu 00865 lappend syntax_menus [menu ${w}Menu -tearoff 0 -postcommand syntax::post_menu] 00866 00867 # Create submenus 00868 foreach letter [list A B C D E F G H I J K L M N O P Q R S T U V W X Y Z] { 00869 menu ${w}Menu.submenu$letter -tearoff 0 -postcommand [list syntax::post_submenu ${w}Menu.submenu$letter $letter] 00870 } 00871 00872 # Populate the menu 00873 populate_syntax_menu ${w}Menu syntax::set_current_language syntax::current_lang [msgcat::mc "None"] [get_enabled_languages] 00874 00875 # Register the menu 00876 theme::register_widget ${w}Menu menus 00877 00878 return ${w}Menu 00879 00880 } 00881 00882 ###################################################################### 00883 # Updates the menubutton with the current language. 00884 proc update_button {w} { 00885 00886 variable curr_lang 00887 variable current_lang 00888 00889 # Get the current language 00890 set current_lang $curr_lang([gui::current_txt]) 00891 00892 # Update the syntax menus 00893 update_syntax_menus 00894 00895 # Configures the current language for the specified text widget 00896 $w configure -text $current_lang 00897 00898 } 00899 00900 ###################################################################### 00901 # Returns a list containing three items. The first item is a regular 00902 # expression that matches the string(s) to indicate that an indentation 00903 # should occur on the following line. The second item is a regular 00904 # expression that matches the string(s) to indicate that an unindentation 00905 # should occur on the following line. The third item is a regular 00906 # expression that matches the string(s) to indicate that a reindentation 00907 # should occur on the following line. All of these expressions come 00908 # from the syntax file for the current language. 00909 proc get_indentation_expressions {txt} { 00910 00911 variable langs 00912 variable curr_lang 00913 00914 if {![info exists curr_lang($txt)]} { 00915 return [list {} {} {}] 00916 } 00917 00918 # Get the language array for the current language. 00919 array set lang_array $langs($curr_lang($txt)) 00920 00921 return [list $lang_array(indent) $lang_array(unindent) $lang_array(reindent)] 00922 00923 } 00924 00925 ###################################################################### 00926 # Returns the full list of available file patterns. 00927 proc get_filetypes {} { 00928 00929 variable filetypes 00930 00931 # Add an "All Files" to the beginning of the filetypes list 00932 set filetypes [list [list "All Files" "*"] {*}$filetypes] 00933 00934 return $filetypes 00935 00936 } 00937 00938 ###################################################################### 00939 # Retrieves the extensions for the current text widget. 00940 proc get_extensions {{language ""}} { 00941 00942 variable langs 00943 variable curr_lang 00944 00945 if {$language eq ""} { 00946 set language $curr_lang([gui::current_txt]) 00947 } 00948 00949 # Get the current language 00950 if {$language eq [msgcat::mc "None"]} { 00951 return [list] 00952 } else { 00953 array set lang_array $langs($language) 00954 return $lang_array(extensions) 00955 } 00956 00957 } 00958 00959 ###################################################################### 00960 # Returns the file patterns from the syntax file for the specified 00961 # language (or for the language associated with the current editor if 00962 # not specified). 00963 proc get_file_patterns {{language ""}} { 00964 00965 variable langs 00966 variable curr_lang 00967 00968 if {$language eq ""} { 00969 set language $curr_lang([gui::current_txt]) 00970 } 00971 00972 if {$language eq [msgcat::mc "None"]} { 00973 return [list] 00974 } else { 00975 array set lang_array $langs($language) 00976 return $lang_array(filepatterns) 00977 } 00978 00979 } 00980 00981 ###################################################################### 00982 # Retrieves the value of tabsallowed in the current syntax. 00983 proc get_tabs_allowed {txt} { 00984 00985 variable langs 00986 variable curr_lang 00987 00988 # Get the current language 00989 if {[set language $curr_lang($txt)] eq [msgcat::mc "None"]} { 00990 return 1 00991 } else { 00992 array set lang_array $langs($language) 00993 return $lang_array(tabsallowed) 00994 } 00995 00996 } 00997 00998 ###################################################################### 00999 # Retrieves the value of lcomment in the current syntax. 01000 proc get_comments {txt} { 01001 01002 variable langs 01003 variable curr_lang 01004 01005 # Get the current language 01006 if {[set language $curr_lang($txt)] eq [msgcat::mc "None"]} { 01007 return [list [list] [list] [list]] 01008 } else { 01009 array set lang_array $langs($language) 01010 return [list $lang_array(icomment) $lang_array(lcomments) $lang_array(bcomments)] 01011 } 01012 01013 } 01014 01015 ###################################################################### 01016 # Retrieves the values stored in the formatting array. 01017 proc get_formatting {txt} { 01018 01019 variable langs 01020 variable curr_lang 01021 01022 # Get the current language 01023 if {[set language $curr_lang($txt)] eq [msgcat::mc "None"]} { 01024 return [list] 01025 } else { 01026 array set lang_array $langs($language) 01027 return $lang_array(formatting) 01028 } 01029 01030 } 01031 01032 ###################################################################### 01033 # Returns the information for syntax-file symbols. 01034 proc get_syntax_symbol {txt row str varlist ins} { 01035 01036 array set vars $varlist 01037 01038 if {[lindex $vars(0) 0] == 0} { 01039 return [list __symbols: {*}$vars(0)] 01040 } 01041 01042 return "" 01043 01044 } 01045 01046 ###################################################################### 01047 # Returns the information for symbols that are preceded by the word 01048 # specified with startpos/endpos. 01049 proc get_prefixed_symbol {txt row str varlist ins} { 01050 01051 array set vars $varlist 01052 01053 if {[regexp -indices -start [expr [lindex $vars(0) 1] + 1] -- {[a-zA-Z0-9_:]+} $str name]} { 01054 return [list __symbols:[string range $str {*}$vars(0)] {*}$name] 01055 } 01056 01057 return "" 01058 01059 } 01060 01061 ###################################################################### 01062 # Returns the information for syntax file functions. 01063 proc get_syntax_function {txt row str varlist ins} { 01064 01065 array set vars $varlist 01066 01067 return [list [list functions {*}$vars(1)] ""] 01068 01069 } 01070 01071 ###################################################################### 01072 # Parses an XML tag. 01073 proc get_xml_tag {txt row str varlist ins} { 01074 01075 array set vars $varlist 01076 01077 return [list [list tag {*}$vars(1)] ""] 01078 01079 } 01080 01081 ###################################################################### 01082 # Returns the XML attribute to highlight. 01083 proc get_xml_attribute {txt row str varlist ins} { 01084 01085 array set vars $varlist 01086 01087 return [list [list attribute {*}$vars(1)] ""] 01088 01089 } 01090 01091 ###################################################################### 01092 # Save the language associations to the association file. 01093 proc save_language_association {dname ext language} { 01094 01095 variable assoc_file 01096 variable associations 01097 01098 array set associations [list] 01099 01100 if {![catch { tkedat::read $assoc_file 0 } rc]} { 01101 array set associations $rc 01102 } 01103 01104 # Set the association 01105 set associations($dname,$ext) $language 01106 01107 # Write the association file 01108 catch { tkedat::write $assoc_file [array get associations] 0 } 01109 01110 } 01111 01112 ###################################################################### 01113 # Executes the plugin command and returns the result. 01114 proc exec_plugin_command {interp command txt row str varlist ins} { 01115 01116 return [$interp eval [list $command $txt $row $str $varlist $ins]] 01117 01118 } 01119 01120 }