| 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__ |