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 }
