Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Copyright (c) 1999 Greg Bartels. All rights reserved. |
2 | # This program is free software; you can redistribute it and/or | |
3 | # modify it under the same terms as Perl itself. | |
4 | ||
5 | # Special thanks to Nick Ing-Simmons for pushing a lot of | |
6 | # my text edit functionality into Text.pm and TextUndo.pm | |
7 | # otherwise, this module would have been monstrous. | |
8 | ||
9 | # Andy Worhal had it wrong, its "fifteen megabytes of fame" | |
10 | # -Greg Bartels | |
11 | ||
12 | package Tk::TextEdit; | |
13 | ||
14 | ||
15 | use vars qw($VERSION); | |
16 | $VERSION = '3.004'; # $Id: //depot/Tk8/Tk/TextEdit.pm#4 $ | |
17 | ||
18 | use Tk qw (Ev); | |
19 | use AutoLoader; | |
20 | ||
21 | use Text::Tabs; | |
22 | ||
23 | use base qw(Tk::TextUndo); | |
24 | ||
25 | Construct Tk::Widget 'TextEdit'; | |
26 | ||
27 | ####################################################################### | |
28 | ####################################################################### | |
29 | sub ClassInit | |
30 | { | |
31 | my ($class,$mw) = @_; | |
32 | $class->SUPER::ClassInit($mw); | |
33 | ||
34 | $mw->bind($class,'<F5>', 'IndentSelectedLines'); | |
35 | $mw->bind($class,'<F6>', 'UnindentSelectedLines'); | |
36 | ||
37 | $mw->bind($class,'<F7>', 'CommentSelectedLines'); | |
38 | $mw->bind($class,'<F8>', 'UncommentSelectedLines'); | |
39 | ||
40 | return $class; | |
41 | } | |
42 | ||
43 | # 8 horizontal pixels in the "space" character in default font. | |
44 | my $tab_multiplier = 8; | |
45 | ||
46 | sub debug_code_f1 | |
47 | { | |
48 | my $w=shift; | |
49 | } | |
50 | ||
51 | sub debug_code_f2 | |
52 | { | |
53 | my $w=shift; | |
54 | } | |
55 | ||
56 | ####################################################################### | |
57 | ####################################################################### | |
58 | sub InitObject | |
59 | { | |
60 | my ($w) = @_; | |
61 | $w->SUPER::InitObject; | |
62 | ||
63 | $w->{'INDENT_STRING'} = "\t"; # Greg mode=>"\t", Nick mode=>" " | |
64 | $w->{'LINE_COMMENT_STRING'} = "#"; # assuming perl comments | |
65 | ||
66 | my %pair_descriptor_hash = | |
67 | ( | |
68 | 'PARENS' => [ 'multiline', '(', ')', "[()]" ], | |
69 | 'CURLIES' => [ 'multiline', '{', '}', "[{}]" ], | |
70 | 'BRACES' => [ 'multiline', '[', ']', "[][]" ], | |
71 | 'DOUBLEQUOTE' => [ 'singleline', "\"","\"" ], | |
72 | 'SINGLEQUOTE' => [ 'singleline', "'","'" ], | |
73 | ); | |
74 | ||
75 | $w->{'HIGHLIGHT_PAIR_DESCRIPTOR_HASH_REF'}=\%pair_descriptor_hash; | |
76 | ||
77 | $w->tagConfigure | |
78 | ('CURSOR_HIGHLIGHT_PARENS', -foreground=>'white', -background=>'violet'); | |
79 | $w->tagConfigure | |
80 | ('CURSOR_HIGHLIGHT_CURLIES', -foreground=>'white', -background=>'blue'); | |
81 | $w->tagConfigure | |
82 | ('CURSOR_HIGHLIGHT_BRACES', -foreground=>'white', -background=>'purple'); | |
83 | $w->tagConfigure | |
84 | ('CURSOR_HIGHLIGHT_DOUBLEQUOTE', -foreground=>'black', -background=>'green'); | |
85 | $w->tagConfigure | |
86 | ('CURSOR_HIGHLIGHT_SINGLEQUOTE', -foreground=>'black', -background=>'grey'); | |
87 | ||
88 | $w->tagConfigure('BLOCK_HIGHLIGHT_PARENS', -background=>'red'); | |
89 | $w->tagConfigure('BLOCK_HIGHLIGHT_CURLIES', -background=>'orange'); | |
90 | $w->tagConfigure('BLOCK_HIGHLIGHT_BRACES', -background=>'red'); | |
91 | $w->tagConfigure('BLOCK_HIGHLIGHT_DOUBLEQUOTE', -background=>'red'); | |
92 | $w->tagConfigure('BLOCK_HIGHLIGHT_SINGLEQUOTE', -background=>'red'); | |
93 | ||
94 | $w->tagRaise('BLOCK_HIGHLIGHT_PARENS','CURSOR_HIGHLIGHT_PARENS'); | |
95 | $w->tagRaise('BLOCK_HIGHLIGHT_CURLIES','CURSOR_HIGHLIGHT_CURLIES'); | |
96 | $w->tagRaise('BLOCK_HIGHLIGHT_BRACES','CURSOR_HIGHLIGHT_BRACES'); | |
97 | $w->tagRaise('BLOCK_HIGHLIGHT_DOUBLEQUOTE','CURSOR_HIGHLIGHT_DOUBLEQUOTE'); | |
98 | $w->tagRaise('BLOCK_HIGHLIGHT_SINGLEQUOTE','CURSOR_HIGHLIGHT_SINGLEQUOTE'); | |
99 | ||
100 | $w->{'UPDATE_WIDGET_PERIOD'}=300; # how much time between each call. | |
101 | $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}=80; | |
102 | $w->SetGUICallbackIndex(0); | |
103 | $w->schedule_next_callback; | |
104 | ||
105 | } | |
106 | ||
107 | ####################################################################### | |
108 | ||
109 | sub cancel_current_gui_callback_and_restart_from_beginning | |
110 | { | |
111 | my ($w)=@_; | |
112 | if(defined($w->{'UPDATE_WIDGET_AFTER_REFERENCE'})) | |
113 | {$w->{'UPDATE_WIDGET_AFTER_REFERENCE'}->cancel();} | |
114 | $w->SetGUICallbackIndex(0); | |
115 | ||
116 | $w->schedule_next_callback; | |
117 | } | |
118 | ||
119 | sub schedule_next_callback | |
120 | { | |
121 | my ($w)=@_; | |
122 | return if $w->NoMoreGUICallbacksToCall; #stops infinite recursive call. | |
123 | $w->{'UPDATE_WIDGET_AFTER_REFERENCE'} = $w->after | |
124 | ($w->{'UPDATE_WIDGET_PERIOD'}, | |
125 | sub | |
126 | { | |
127 | $w->CallNextGUICallback; | |
128 | $w->schedule_next_callback; | |
129 | } | |
130 | ); | |
131 | ||
132 | } | |
133 | ||
134 | ||
135 | ####################################################################### | |
136 | # use these methods to pass the TextEdit widget an anonymous array | |
137 | # of code references. | |
138 | # any time the widget changes that requires the display to be updated, | |
139 | # then these code references will be scheduled in sequence for calling. | |
140 | # splitting them up allows them to be prioritized by order, | |
141 | # and prevents the widget from "freezing" too long if they were | |
142 | # one large callback. scheduling them apart allows the widget time | |
143 | # to respond to user inputs. | |
144 | ####################################################################### | |
145 | sub SetGUICallbacks | |
146 | { | |
147 | my ($w,$callback_array_ref) = @_; | |
148 | $w->{GUI_CALLBACK_ARRAY_REF}=$callback_array_ref; | |
149 | $w->SetGUICallbackIndex(0); | |
150 | } | |
151 | ||
152 | sub GetGUICallbacks | |
153 | { | |
154 | return shift->{GUI_CALLBACK_ARRAY_REF}; | |
155 | } | |
156 | ||
157 | sub SetGUICallbackIndex | |
158 | { | |
159 | my ($w, $val)=@_; | |
160 | $w->{GUI_CALLBACK_ARRAY_INDEX}=$val; | |
161 | } | |
162 | ||
163 | sub GetGUICallbackIndex | |
164 | { | |
165 | return shift->{GUI_CALLBACK_ARRAY_INDEX}; | |
166 | } | |
167 | ||
168 | sub IncrementGUICallbackIndex | |
169 | { | |
170 | shift->{GUI_CALLBACK_ARRAY_INDEX} += 1; | |
171 | } | |
172 | ||
173 | sub NoMoreGUICallbacksToCall | |
174 | { | |
175 | my ($w) = @_; | |
176 | return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_REF}); | |
177 | return 0 unless defined ($w->{GUI_CALLBACK_ARRAY_INDEX}); | |
178 | my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; | |
179 | my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; | |
180 | return $arr_ind >= @$arr_ref; | |
181 | } | |
182 | ||
183 | sub CallNextGUICallback | |
184 | { | |
185 | my ($w) = @_; | |
186 | return if $w->NoMoreGUICallbacksToCall; | |
187 | my $arr_ref = $w->{GUI_CALLBACK_ARRAY_REF}; | |
188 | my $arr_ind = $w->{GUI_CALLBACK_ARRAY_INDEX}; | |
189 | &{$arr_ref->[$arr_ind]}; | |
190 | $w->IncrementGUICallbackIndex; | |
191 | } | |
192 | ||
193 | ||
194 | ####################################################################### | |
195 | ####################################################################### | |
196 | ||
197 | sub insert | |
198 | { | |
199 | my $w = shift; | |
200 | $w->SUPER::insert(@_); | |
201 | $w->cancel_current_gui_callback_and_restart_from_beginning; | |
202 | } | |
203 | ||
204 | sub delete | |
205 | { | |
206 | my $w = shift; | |
207 | $w->SUPER::delete(@_); | |
208 | $w->cancel_current_gui_callback_and_restart_from_beginning; | |
209 | } | |
210 | ||
211 | sub SetCursor | |
212 | { | |
213 | my $w = shift; | |
214 | $w->SUPER::SetCursor(@_); | |
215 | $w->cancel_current_gui_callback_and_restart_from_beginning; | |
216 | } | |
217 | ||
218 | sub OverstrikeMode | |
219 | { | |
220 | my ($w,$mode) = @_; | |
221 | if (defined($mode)) | |
222 | { | |
223 | $w->SUPER::OverstrikeMode($mode); | |
224 | $w->cancel_current_gui_callback_and_restart_from_beginning; | |
225 | } | |
226 | return $w->SUPER::OverstrikeMode; | |
227 | } | |
228 | ||
229 | ||
230 | ####################################################################### | |
231 | # use yview on scrollbar to get fractional coordinates. | |
232 | # scale this by the total length of the text to find the | |
233 | # approximate start line of widget and end line of widget. | |
234 | ####################################################################### | |
235 | sub GetScreenWindowCoordinates | |
236 | { | |
237 | my $w = shift; | |
238 | my ($top_frac, $bot_frac) = $w->yview; | |
239 | my $end_index = $w->index('end'); | |
240 | my ($lines,$columns) = split (/\./,$end_index); | |
241 | my $window = $w->{'WINDOW_PLUS_AND_MINUS_VALUE'}; | |
242 | my $top_line = int(($top_frac * $lines) - $window); | |
243 | $top_line = 0 if ($top_line < 0); | |
244 | my $bot_line = int(($bot_frac * $lines) + $window); | |
245 | $bot_line = $lines if ($bot_line > $lines); | |
246 | my $top_index = $top_line . '.0'; | |
247 | my $bot_index = $bot_line . '.0'; | |
248 | ||
249 | $_[0] = $top_index; | |
250 | $_[1] = $bot_index; | |
251 | } | |
252 | ||
253 | ######################################################################## | |
254 | # take two indices as inputs. | |
255 | # if they are on the same line or same column (accounting for tabs) | |
256 | # then return 1 | |
257 | # else return 0 | |
258 | # (assume indices passed in are in line.column format) | |
259 | ######################################################################## | |
260 | sub IndicesLookGood | |
261 | { | |
262 | my ($w, $start, $end, $singleline) = @_; | |
263 | ||
264 | return 0 unless ( (defined($start)) and (defined($end))); | |
265 | ||
266 | my ($start_line, $start_column) = split (/\./,$start); | |
267 | my ($end_line, $end_column) = split (/\./,$end); | |
268 | ||
269 | ########################## | |
270 | # good if on the same line | |
271 | ########################## | |
272 | return 1 if ($start_line == $end_line); | |
273 | ||
274 | ########################## | |
275 | # if not on same line and its a singleline, its bad | |
276 | ########################## | |
277 | return 0 if $singleline; | |
278 | ||
279 | ||
280 | # get both lines, convert the tabs to spaces, and get the new column. | |
281 | # see if they line up or not. | |
282 | my $string; | |
283 | $string = $w->get($start_line.'.0', $start_line.'.0 lineend'); | |
284 | $string = substr($string, 0, $start_column+1); | |
285 | $string = expand($string); | |
286 | $start_column = length($string); | |
287 | ||
288 | $string = $w->get($end_line.'.0', $end_line.'.0 lineend'); | |
289 | $string = substr($string, 0, $end_column +1); | |
290 | $string = expand($string); | |
291 | $end_column = length($string); | |
292 | ||
293 | ########################## | |
294 | # good if on the same column (adjusting for tabs) | |
295 | ########################## | |
296 | return 1 if ($start_column == $end_column); | |
297 | ||
298 | # otherwise its bad | |
299 | return 0; | |
300 | } | |
301 | ||
302 | ######################################################################## | |
303 | # if searching backward, count paranthesis until find a start parenthesis | |
304 | # which does not have a forward match. | |
305 | # | |
306 | # (<= search backward will return this index | |
307 | # () | |
308 | # START X HERE | |
309 | # ( ( ) () ) | |
310 | # )<== search forward will return this index | |
311 | # | |
312 | # if searching forward, count paranthesis until find a end parenthesis | |
313 | # which does not have a rearward match. | |
314 | ######################################################################## | |
315 | sub searchForBaseCharacterInPair | |
316 | { | |
317 | my | |
318 | ( | |
319 | $w, $top_index, $searchfromindex, $bot_index, | |
320 | $direction, $startchar, $endchar, $charpair | |
321 | )=@_; | |
322 | my ($plus_one_char, $search_end_index, $index_offset, $done_index); | |
323 | if ($direction eq '-forward') | |
324 | { | |
325 | $plus_one_char = $endchar; | |
326 | $search_end_index = $bot_index; | |
327 | $index_offset = ' +1c'; | |
328 | $done_index = $w->index('end'); | |
329 | } | |
330 | else | |
331 | { | |
332 | $plus_one_char = $startchar; | |
333 | $search_end_index = $top_index; | |
334 | $index_offset = ''; | |
335 | $done_index = '1.0'; | |
336 | } | |
337 | ||
338 | my $at_done_index = 0; | |
339 | my $count = 0; | |
340 | my $char; | |
341 | while(1) | |
342 | { | |
343 | $searchfromindex = $w->search | |
344 | ($direction, '-regexp', $charpair, $searchfromindex, $search_end_index ); | |
345 | ||
346 | last unless(defined($searchfromindex)); | |
347 | $char = $w->get($searchfromindex, $w->index($searchfromindex.' +1c')); | |
348 | if ($char eq $plus_one_char) | |
349 | {$count += 1;} | |
350 | else | |
351 | {$count -= 1;} | |
352 | last if ($count==1); | |
353 | # boundary condition exists when first char in widget is the match char | |
354 | # need to be able to determine if search tried to go past index '1.0' | |
355 | # if so, set index to undef and return. | |
356 | if ( $at_done_index ) | |
357 | { | |
358 | $searchfromindex = undef; | |
359 | last; | |
360 | } | |
361 | $at_done_index = 1 if ($searchfromindex eq $done_index); | |
362 | $searchfromindex=$w->index($searchfromindex . $index_offset); | |
363 | } | |
364 | return $searchfromindex; | |
365 | } | |
366 | ||
367 | ######################################################################## | |
368 | # highlight a character pair that most closely brackets the cursor. | |
369 | # allows you to pick and choose which ones you want to do. | |
370 | ######################################################################## | |
371 | ||
372 | sub HighlightParenthesisAroundCursor | |
373 | { | |
374 | my ($w)=@_; | |
375 | $w->HighlightSinglePairBracketingCursor | |
376 | ( '(', ')', '[()]', 'CURSOR_HIGHLIGHT_PARENS','BLOCK_HIGHLIGHT_PARENS',0); | |
377 | } | |
378 | ||
379 | sub HighlightCurlyBracesAroundCursor | |
380 | { | |
381 | my ($w)=@_; | |
382 | $w->HighlightSinglePairBracketingCursor | |
383 | ( '{', '}', '[{}]', 'CURSOR_HIGHLIGHT_CURLIES','BLOCK_HIGHLIGHT_CURLIES',0); | |
384 | } | |
385 | ||
386 | sub HighlightBracesAroundCursor | |
387 | { | |
388 | my ($w)=@_; | |
389 | $w->HighlightSinglePairBracketingCursor | |
390 | ( '[', ']','[][]', 'CURSOR_HIGHLIGHT_BRACES','BLOCK_HIGHLIGHT_BRACES',0); | |
391 | } | |
392 | ||
393 | sub HighlightDoubleQuotesAroundCursor | |
394 | { | |
395 | my ($w)=@_; | |
396 | $w->HighlightSinglePairBracketingCursor | |
397 | ( "\"", "\"", "\"", 'CURSOR_HIGHLIGHT_DOUBLEQUOTE','BLOCK_HIGHLIGHT_DOUBLEQUOTE',1); | |
398 | } | |
399 | ||
400 | sub HighlightSingleQuotesAroundCursor | |
401 | { | |
402 | my ($w)=@_; | |
403 | $w->HighlightSinglePairBracketingCursor | |
404 | ( "'", "'", "'", 'CURSOR_HIGHLIGHT_SINGLEQUOTE','BLOCK_HIGHLIGHT_SINGLEQUOTE',1); | |
405 | } | |
406 | ||
407 | ######################################################################## | |
408 | # highlight all the character pairs that most closely bracket the cursor. | |
409 | ######################################################################## | |
410 | sub HighlightAllPairsBracketingCursor | |
411 | { | |
412 | my ($w)=@_; | |
413 | $w->HighlightParenthesisAroundCursor; | |
414 | $w->HighlightCurlyBracesAroundCursor; | |
415 | $w->HighlightBracesAroundCursor; | |
416 | $w->HighlightDoubleQuotesAroundCursor; | |
417 | $w->HighlightSingleQuotesAroundCursor; | |
418 | } | |
419 | ||
420 | ######################################################################## | |
421 | # search for a pair of matching characters that bracket the | |
422 | # cursor and tag them with the given tagname. | |
423 | # startchar might be '[' | |
424 | # endchar would then be ']' | |
425 | # tagname is a name of a tag, which has already been | |
426 | # configured to highlight however the user wants them to behave. | |
427 | # error tagname is the tag to highlight the chars with if there | |
428 | # is a problem of some kind. | |
429 | # singleline indicates whether the character pairs must occur | |
430 | # on a single line. quotation marks are single line characters usually. | |
431 | ######################################################################## | |
432 | sub HighlightSinglePairBracketingCursor | |
433 | { | |
434 | my | |
435 | ( | |
436 | $w, $startchar, $endchar, $charpair, | |
437 | $good_tagname, $bad_tagname, $single_line | |
438 | ) = @_; | |
439 | $single_line=0 unless defined($single_line); | |
440 | $w->tagRemove($good_tagname, '1.0','end'); | |
441 | $w->tagRemove($bad_tagname, '1.0','end'); | |
442 | my $top_index; my $bot_index; | |
443 | my $cursor = $w->index('insert'); | |
444 | if ($single_line) | |
445 | { | |
446 | $top_index = $w->index($cursor.' linestart'); | |
447 | $bot_index = $w->index($cursor.' lineend'); | |
448 | } | |
449 | else | |
450 | { | |
451 | $w->GetScreenWindowCoordinates($top_index, $bot_index); | |
452 | } | |
453 | ||
454 | # search backward for the startchar | |
455 | # $top_index, $searchfromindex, $bot_index, | |
456 | # $direction, $startchar, $endchar, $charpair | |
457 | ||
458 | my $startindex = $w->searchForBaseCharacterInPair | |
459 | ( | |
460 | $top_index, $cursor, $bot_index, | |
461 | '-backward', $startchar, $endchar, $charpair | |
462 | ); | |
463 | ||
464 | # search forward for the endchar | |
465 | my $endindex = $w->searchForBaseCharacterInPair | |
466 | ( | |
467 | $top_index, $cursor, $bot_index, | |
468 | '-forward', $startchar, $endchar, $charpair | |
469 | ); | |
470 | return unless ((defined $startindex) and (defined $endindex)); | |
471 | ||
472 | my $final_tag = $bad_tagname; | |
473 | if ($w->IndicesLookGood( $startindex, $endindex, $single_line)) | |
474 | { | |
475 | $final_tag = $good_tagname; | |
476 | } | |
477 | ||
478 | $w->tagAdd($final_tag, $startindex, $w->index($startindex.'+1c') ); | |
479 | $w->tagAdd($final_tag, $endindex, $w->index( $endindex.'+1c') ); | |
480 | } | |
481 | ||
482 | #################################################################### | |
483 | sub IndentSelectedLines | |
484 | { | |
485 | my($w)=@_; | |
486 | $w->insertStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); | |
487 | } | |
488 | ||
489 | sub UnindentSelectedLines | |
490 | { | |
491 | my($w)=@_; | |
492 | $w->deleteStringAtStartOfSelectedLines($w->{'INDENT_STRING'}); | |
493 | } | |
494 | ||
495 | sub CommentSelectedLines | |
496 | { | |
497 | my($w)=@_; | |
498 | $w->insertStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); | |
499 | } | |
500 | ||
501 | sub UncommentSelectedLines | |
502 | { | |
503 | my($w)=@_; | |
504 | $w->deleteStringAtStartOfSelectedLines($w->{'LINE_COMMENT_STRING'}); | |
505 | } | |
506 | ||
507 | ||
508 | 1; | |
509 | __END__ |