Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 365 lines (323 sloc) 15.878 kb
a1f8f16 First commit after salvaging it from the Wayback Machine
Russell Pickett authored
1 ############################################################
2 # syntax.tcl -- a syntax highlighting plugin for tkMOO-light.
3 # written by R Pickett (emerson (at) hayseed.net) with great help from reading
4 # and cut'n'pasting existing tkMOO-light plugin code.
5 # The homepage for this is <http://hayseed.net/~emerson/syntax.html>.
6 #
7 # tkMOO-light is an advanced chat/MOO client, written by Andrew Wilson.
8 # It can be found at <http://www.awns.com/tkMOO-light/>.
9 #
10 # License:
11 #
12 # This silly little blob of TCL can be used freely for just about anything
13 # you like, with these two provisions: (1) you may not remove or alter any of
14 # the text in this block of comments at the head of the file, and (2) if you
15 # make any changes to the code that you find useful or interesting or fun,
16 # you are strongly encouraged to send them back to me.
17 #
18 # History:
19 # 2002-03-05 -- 0.1.3 New: - Concept of //-style comments for moocode.
20 #
21 # 1999-11-22 -- 0.1.2 Bugfix: - Fixed KeyRelease, Return, and Up/Down bindings
22 # to be {+ <script>} syntax and therefore not
23 # override the editor's default bindings.
24 # - Fix weird problem with Up/Down bindings doing
25 # highlighting on wrong line, causing very strange
26 # wraparound behavior when cursor on last line.
27 # 1999-10-14 -- 0.1.1 Change: - Updated core syntax plugin to work with new
28 # API for the editor's load event in 0.3.21-dev2
29 #
30 # 1999-08-27 -- 0.1 New: - Added <Return>, arrows, and <Button> event
31 # catching so fast typists don't skip clean
32 # over the idle loop.
33 # - Used 0.3.21 load event callback scheme so that
34 # syntax definition plugins can decide at load time
35 # whether they want to handle an editor's text.
36 # - Related: changed the moo-code plugin to detect
37 # either MCP simpleedit 'moo-code' type OR
38 # '@program' at the head of the line, LM-style.
39 # - Added in simple syntax_sendmail.tcl plugin
40 # to demonstrate how it's done - still broken
41 # wrt MCP simpleedit.
42 # - Ugly unmatched () code added. Not at all
43 # correct yet, but proof-of-concept.
44 # Change: - Moved check_tags code into the core syntax
45 # plugin, to simplify (greatly) the creating
46 # of alternate syntax definitions. Much more
47 # to be done here, but everything's in the Right
48 # Place(tm) now.
49 # - Removed trailing '_syntax' from all
50 # proc names. Duh, they're about syntax...
51 # - Reworked regexen to use TCL 8.1 features if
52 # available. This also fixed a regex bug wrt
53 # 8.1. 8.1 is now preferred, tho not required.
54 # Bugfix: - fixed _language bug with highlighting inside
55 # a longer word, ie 'player' in 'the_player'
56 # - each iteration, tags were only being reparsed
57 # from the current cursor to lineend. Fixed.
58 #
59 # 1999-07-18 -- 0.0.4, Bugfix: - 'strsub' typo
60 # - primitives highlighting even without
61 # trailing (
62 # - nasty bug with string literals containing
63 # escaped quotation marks.
64 # Change: - Reformatted these comments ;-)
65 # New: - Added license info above.
66 # - Added syntax_moo_code_language bit for
67 # detecting special variables; also, later,
68 # for language primitives, maybe.
69 #
70 # 1999-07-03 -- 0.0.3.2, Bugfix: - editors not created with the Tools->Editor
71 # menu didn't start up the idle loop.
72 #
73 # 1999-06-29 -- 0.0.3.1, Bugfix: - primitives regex leading/trailing chars
74 #
75 # 1999-06-28 -- 0.0.3, New: - use editor's 'load' event from 0.3.20 client.
76 # - removed duplicative "edit.SCcodeedit' procedure.
77 # - changed Andrew's syntax.toggle_syntax to
78 # syntax.select_syntax.
79 # - make individual syntax_<language> plugins add
80 # their name to a global syntax_types list
81 # Change: - much moving things around to separate 'syntax'
82 # core stuff from moo-code-specific stuff. More
83 # can be done here.
84 # - make all line-based checks into regexen; iterate
85 # through them with the same blort of code instead
86 # of having several only-slightly-different
87 # procedures.
88 #
89 #
90 # 1999-06-08 -- 0.0.2, performance and namespace tweaks from Andrew. Not
91 # released.
92 #
93 # 1999-06-07 -- 0.0.1, first horrible annoying and useless public release.
94 #
95 ############################################################
96
97
98 client.register syntax start
99
100 proc syntax.start {} {
101 edit.add_edit_function "Syntax off" { syntax.select "" }
102 edit.register load syntax.do_load 70
103 }
104
105 proc syntax.do_load {w args} {
106 global syntax_db
107
108 if { [info exists syntax_db($w)] } {
109 if { $args != {} } {
110 set from_to [lindex [util.assoc [lindex $args 0] range] 1]
111 } else {
112 set from_to {}
113 }
114 syntax.select $syntax_db($w) $w $from_to
115 }
116 }
117
118 proc syntax.select {type w args} {
119 global syntax_db
120
121 set from_to [lindex $args 0]
122 if { $type == "" } {
123 catch [unset syntax_db($w)]
124 set tags [$w.t tag names]
125 foreach tag $tags {
126 if { [string match syntax_* $tag] } {
127 $w.t tag delete $tag
128 }
129 }
130 catch { after cancel $syntax_task }
131 } else {
132 set syntax_db($w) $type
133 syntax.activate $w $from_to
134 }
135 }
136
137 proc syntax.activate {w from_to} {
138 global syntax_db
139
140 set type $syntax_db($w)
141
142
143 syntax_${type}.initialize $w
144 if { $from_to == "" } {
145 set n 1
146 set last [$w.t index end]
147 } else {
148 regsub {\..*$} [lindex $from_to 0] "" n
149 regsub {\..*$} [lindex $from_to 1] "" last
150 }
151 for {set n} {$n < $last} {incr n} {
152 syntax.check_tags $w.t $n.0
153 }
154 # Start up the idle loop
155 bind $w.t <KeyRelease> {+
156 regsub {\.t$} %W "" win
157 if { [info exists syntax_db($win)] } {
158 catch { after cancel $syntax_task }
159 set syntax_task [ after 250 syntax.check_tags %W [%W index insert] ]
160 }
161 }
162 # catch people who hit some return or arrow or the like to leave the line
163 # before the idle loop can kick in.
164 bind $w.t <Return> {+ syntax.check_tags %W [ %W index insert ]}
165 bind $w.t <Up> {+ syntax.check_tags %W [ %W index insert ]}
166 bind $w.t <Down> {+ syntax.check_tags %W [ %W index insert ]}
167
168 # Uncomment following line to experiment with colors on black background.
169 #$w.t configure -bg black -fg white
170 }
171
172 proc syntax.check_tags { w line_number } {
173 global syntax_db
174
175 regsub {\.t$} $w "" win
176
177 if { ! [info exists syntax_db($win)] } { return }
178
179 set type $syntax_db($win)
180 # Line-based stuff.
181 set linestart [ $w index "$line_number linestart" ]
182 set lineend [ $w index "$line_number lineend" ]
183
184 # Clear tags on our current line; reparse every time.
185 # This is a little kludgy, since there's no easy way to get the tags
186 # just from our current line, we get a list of all tags in the editor
187 # and remove the syntax_ ones from the current line.
188 set tags [ $w tag names ]
189 foreach tag $tags {
190 if { [string match syntax_* $tag] } {
191 $w tag remove $tag $linestart $lineend
192 }
193 }
194 # Do all of the matching stuff exported in syntax_${type}_typelist
195 set typelist syntax_${type}_typelist
196 global $typelist
197 foreach chunk [ lrange [set $typelist] 0 end ] {
198 set name syntax_${type}_$chunk
199 global $name
200 set currpos $linestart
201 while { [ set currpos [ $w search -regexp -count length [set $name] $currpos $lineend ] ] != "" } {
202 #next three lines ridiculous hack to simulate proper backreferences.
203 regexp [set $name] [$w get $currpos "$currpos + $length chars" ] match catch
204 set length [string length $catch]
205 set currpos [$w index "$currpos + [string first $catch $match] chars"]
206 set newpos [$w index "$currpos + $length chars"]
207 $w tag add $name $currpos $newpos
208 set currpos $newpos
209 }
210 }
211
212 # OK, here's an ugly stab at unmatched () code
213 # Currently the algorithm is that we'll highlight the first ( or the last )
214 # in a line if they're unbalanced in number. This is not optimal. We'd
215 # like to have some good idea of where we have unbalance, and how many we
216 # have. The latter of those two seems easier to implement. Please to send
217 # thoughts on this, as I plan to expand it greatly.
218 set openfirst 0
219 set closefirst 0
220 set opencount 0
221 set closecount 0
222 set currpos $lineend
223 while {[set currpos [$w search -backward "(" $currpos $linestart]] != ""} {
224 set openfirst $currpos
225 incr opencount
226 }
227 set currpos $linestart
228 while { [ set currpos [ $w search ")" $currpos $lineend ] ] != "" } {
229 set closefirst $currpos
230 incr closecount
231 set currpos [$w index "$currpos + 1 chars"]
232 }
233 # window.displayCR "openfirst: $openfirst opencount:$opencount closefirst:$closefirst closecount:$closecount"
234 if {($opencount > $closecount)} {
235 $w tag add syntax_${type}_unmatched $openfirst
236 } elseif { ($closecount > $opencount ) } {
237 $w tag add syntax_${type}_unmatched $closefirst
238 }
239 }
240
241
242 ############################################################
243 # syntax_moo_code.tcl
244 ############################################################
245
246 client.register syntax_moo_code start
247
248 proc syntax_moo_code.start {} {
249 edit.add_edit_function "MOO Syntax" {syntax.select "moo_code"}
250 edit.register load syntax_moo_code.check
251 }
252
253
254 proc syntax_moo_code.initialize w {
255 global syntax_moo_code_primitives syntax_moo_code_specials
256 global syntax_moo_code_stringliterals syntax_moo_code_numbers
257 global syntax_moo_code_core syntax_moo_code_language
258 global syntax_moo_code_typelist syntax_moo_code_c_comments
259
260 set syntax_moo_code_typelist { primitives specials stringliterals numbers core language c_comments}
261
262 set syntax_moo_code_primitiveslist [ join {
263 abs acos add_property add_verb asin atan binary_hash
264 boot_player buffered_output_length call_function caller_perms
265 callers ceil children chparent clear_property connected_players
266 connected_seconds connection_name connection_option
267 connection_options cos cosh create crypt ctime db_disk_size
268 decode_binary delete_property delete_verb disassemble
269 dump_database encode_binary equal eval exp floatstr floor
270 flush_input force_input function_info idle_seconds index
271 is_clear_property is_member is_player kill_task length
272 listappend listdelete listen listeners listinsert listset
273 log log10 match max max_object memory_usage min move notify
274 object_bytes open_network_connection output_delimiters
275 parent pass players properties property_info queue_info
276 queued_tasks raise random read recycle renumber reset_max_object
277 resume rindex rmatch seconds_left server_log server_version
278 set_connection_option set_player_flag set_property_info
279 set_task_perms set_verb_args set_verb_code set_verb_info
280 setadd setremove shutdown sin sinh sqrt strcmp string_hash
281 strsub substitute suspend tan tanh task_id task_stack
282 ticks_left time tofloat toint toliteral tonum toobj tostr
283 trunc typeof unlisten valid value_bytes value_hash verb_args
284 verb_code verb_info verbs
285 } {|} ]
286 set syntax_moo_code_languagelist [ join {
287 INT FLOAT OBJ STR LIST ERR player this caller verb args argstr
288 dobj dobjstr prepstr iobj iobjstr NUM
289 } {|} ]
290 set syntax_moo_code_primitives "\[^a-zA-Z:_@\]($syntax_moo_code_primitiveslist)\ *\[(\]"
291 set syntax_moo_code_language "\[^a-zA-Z_\]($syntax_moo_code_languagelist)\[^a-zA-Z_\]"
292 set syntax_moo_code_specials {(;|:|\.|\(|\)|{|}|@|=|!=|<|>|\?|\||&&|\|\||\^|\+|-|\*|/)}
293 set syntax_moo_code_stringliterals {("(\\"|[^"])*("|$))}
294 set syntax_moo_code_c_comments {(//.*$)}
295 set syntax_moo_code_numbers {(#*[0-9]+)}
296 set syntax_moo_code_core {(\$[a-zA-Z0-9_]+)}
297
298 if {[info tclversion] > 8.0} {
299 set syntax_moo_code_primitives "(?:\[^\\w:@\]|^)($syntax_moo_code_primitiveslist)\ *\[(\]"
300 set syntax_moo_code_language "(?:\\W|^)($syntax_moo_code_languagelist)(?:\\W|$)"
301 }
302
303 #Need to work on nice visible tags.
304 $w.t tag configure syntax_moo_code_primitives -underline yes
305 $w.t tag configure syntax_moo_code_numbers -foreground darkgreen
306 $w.t tag configure syntax_moo_code_core -foreground darkred -underline yes
307 $w.t tag configure syntax_moo_code_specials -foreground blue -underline no
308 $w.t tag configure syntax_moo_code_language -foreground darkred -underline no
309 $w.t tag configure syntax_moo_code_stringliterals -foreground red -underline no
310 $w.t tag configure syntax_moo_code_c_comments -foreground darkblue -background grey -underline no
311
312 # For unmatched () or if/endif, etc.
313 $w.t tag configure syntax_moo_code_unmatched -foreground red -background black
314 }
315
316 proc syntax_moo_code.check {w args} {
317 global syntax_db
318
319 if { ([ edit.get_type $w ] == "moo-code" ) || ([ $w.t search "@program" 1.0 ] != "") } {
320 set syntax_db($w) moo_code
321 }
322 }
323
324 ############################################################
325 # syntax_sendmail.tcl
326 #
327 # This is a proof-of-concept syntax definition plugin, showing off the three
328 # procedures that need to exist: a <name>.start procedure to register the
329 # edit.load callback for <name>.check and add a menu item to the editor; a
330 # <name>.initialize procedure to create the regexen and associated tags,
331 # and a <name>.check procedure to do the parsing of the editor at
332 # load-time to see if you want to handle it.
333 ############################################################
334
335 client.register syntax_sendmail start
336
337 proc syntax_sendmail.start {} {
338 edit.add_edit_function "Sendmail Syntax" { syntax.select "sendmail" }
339 edit.register load syntax_sendmail.check
340 }
341
342 proc syntax_sendmail.initialize w {
343
344 global syntax_sendmail_headers syntax_sendmail_objects syntax_sendmail_parens
345 global syntax_sendmail_typelist
346
347 set syntax_sendmail_typelist { headers objects parens }
348
349 set syntax_sendmail_headers {^(From:|Subject:|To:|Reply-to:)}
350 set syntax_sendmail_objects {(#[0-9]+)}
351 set syntax_sendmail_parens {(\(|\))}
352
353 $w.t tag configure syntax_sendmail_headers -foreground darkred
354 $w.t tag configure syntax_sendmail_objects -foreground darkgreen
355 $w.t tag configure syntax_sendmail_parens -foreground blue
356 }
357
358 proc syntax_sendmail.check {w args} {
359 global syntax_db
360
361 if { [ $w.t search "@@sendmail" 1.0 ] != "" } {
362 set syntax_db($w) sendmail
363 }
364 }
Something went wrong with that request. Please try again.