1# By George Peter Staplin 2# See also the README for a list of contributors 3# RCS: @(#) $Id: ctext.tcl,v 1.7 2008/08/19 21:08:27 georgeps Exp $ 4 5package require Tk 6package provide ctext 3.2 7 8namespace eval ctext {} 9 10#win is used as a unique token to create arrays for each ctext instance 11proc ctext::getAr {win suffix name} { 12 set arName __ctext[set win][set suffix] 13 uplevel [list upvar #0 $arName $name] 14 return $arName 15} 16 17proc ctext {win args} { 18 if {[llength $args] & 1} { 19 return -code error "invalid number of arguments given to ctext (uneven number after window) : $args" 20 } 21 22 frame $win -class Ctext 23 24 set tmp [text .__ctextTemp] 25 26 ctext::getAr $win config ar 27 28 set ar(-fg) [$tmp cget -foreground] 29 set ar(-bg) [$tmp cget -background] 30 set ar(-font) [$tmp cget -font] 31 set ar(-relief) [$tmp cget -relief] 32 destroy $tmp 33 set ar(-yscrollcommand) "" 34 set ar(-linemap) 1 35 set ar(-linemapfg) $ar(-fg) 36 set ar(-linemapbg) $ar(-bg) 37 set ar(-linemap_mark_command) {} 38 set ar(-linemap_markable) 1 39 set ar(-linemap_select_fg) black 40 set ar(-linemap_select_bg) yellow 41 set ar(-highlight) 1 42 set ar(win) $win 43 set ar(modified) 0 44 set ar(commentsAfterId) "" 45 set ar(highlightAfterId) "" 46 set ar(blinkAfterId) "" 47 48 set ar(ctextFlags) [list -yscrollcommand -linemap -linemapfg -linemapbg \ 49-font -linemap_mark_command -highlight -linemap_markable -linemap_select_fg \ 50-linemap_select_bg] 51 52 array set ar $args 53 54 foreach flag {foreground background} short {fg bg} { 55 if {[info exists ar(-$flag)] == 1} { 56 set ar(-$short) $ar(-$flag) 57 unset ar(-$flag) 58 } 59 } 60 61 #Now remove flags that will confuse text and those that need modification: 62 foreach arg $ar(ctextFlags) { 63 if {[set loc [lsearch $args $arg]] >= 0} { 64 set args [lreplace $args $loc [expr {$loc + 1}]] 65 } 66 } 67 68 text $win.l -font $ar(-font) -width 1 -height 1 \ 69 -relief $ar(-relief) -fg $ar(-linemapfg) \ 70 -bg $ar(-linemapbg) -takefocus 0 71 72 set topWin [winfo toplevel $win] 73 bindtags $win.l [list $win.l $topWin all] 74 75 if {$ar(-linemap) == 1} { 76 grid $win.l -sticky ns -row 0 -column 0 77 } 78 79 set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $ar(-yscrollcommand)]]] 80 81 #escape $win, because it could have a space 82 eval text \$win.t -font \$ar(-font) $args 83 84 grid $win.t -row 0 -column 1 -sticky news 85 grid rowconfigure $win 0 -weight 100 86 grid columnconfigure $win 1 -weight 100 87 88 bind $win.t <Configure> [list ctext::linemapUpdate $win] 89 bind $win.l <ButtonPress-1> [list ctext::linemapToggleMark $win %y] 90 bind $win.t <KeyRelease-Return> [list ctext::linemapUpdate $win] 91 rename $win __ctextJunk$win 92 rename $win.t $win._t 93 94 bind $win <Destroy> [list ctext::event:Destroy $win %W] 95 bindtags $win.t [linsert [bindtags $win.t] 0 $win] 96 97 interp alias {} $win {} ctext::instanceCmd $win 98 interp alias {} $win.t {} $win 99 100 #If the user wants C comments they should call ctext::enableComments 101 ctext::disableComments $win 102 ctext::modified $win 0 103 ctext::buildArgParseTable $win 104 105 return $win 106} 107 108proc ctext::event:yscroll {win clientData args} { 109 ctext::linemapUpdate $win 110 111 if {$clientData == ""} { 112 return 113 } 114 uplevel #0 $clientData $args 115} 116 117proc ctext::event:Destroy {win dWin} { 118 if {![string equal $win $dWin]} { 119 return 120 } 121 122 ctext::getAr $win config configAr 123 124 catch {after cancel $configAr(commentsAfterId)} 125 catch {after cancel $configAr(highlightAfterId)} 126 catch {after cancel $configAr(blinkAfterId)} 127 128 catch {rename $win {}} 129 interp alias {} $win.t {} 130 ctext::clearHighlightClasses $win 131 array unset [ctext::getAr $win config ar] 132} 133 134#This stores the arg table within the config array for each instance. 135#It's used by the configure instance command. 136proc ctext::buildArgParseTable win { 137 set argTable [list] 138 139 lappend argTable any -linemap_mark_command { 140 set configAr(-linemap_mark_command) $value 141 break 142 } 143 144 lappend argTable {1 true yes} -linemap { 145 grid $self.l -sticky ns -row 0 -column 0 146 grid columnconfigure $self 0 \ 147 -minsize [winfo reqwidth $self.l] 148 set configAr(-linemap) 1 149 break 150 } 151 152 lappend argTable {0 false no} -linemap { 153 grid forget $self.l 154 grid columnconfigure $self 0 -minsize 0 155 set configAr(-linemap) 0 156 break 157 } 158 159 lappend argTable any -yscrollcommand { 160 set cmd [list $self._t config -yscrollcommand [list ctext::event:yscroll $self $value]] 161 162 if {[catch $cmd res]} { 163 return $res 164 } 165 set configAr(-yscrollcommand) $value 166 break 167 } 168 169 lappend argTable any -linemapfg { 170 if {[catch {winfo rgb $self $value} res]} { 171 return -code error $res 172 } 173 $self.l config -fg $value 174 set configAr(-linemapfg) $value 175 break 176 } 177 178 lappend argTable any -linemapbg { 179 if {[catch {winfo rgb $self $value} res]} { 180 return -code error $res 181 } 182 $self.l config -bg $value 183 set configAr(-linemapbg) $value 184 break 185 } 186 187 lappend argTable any -font { 188 if {[catch {$self.l config -font $value} res]} { 189 return -code error $res 190 } 191 $self._t config -font $value 192 set configAr(-font) $value 193 break 194 } 195 196 lappend argTable {0 false no} -highlight { 197 set configAr(-highlight) 0 198 break 199 } 200 201 lappend argTable {1 true yes} -highlight { 202 set configAr(-highlight) 1 203 break 204 } 205 206 lappend argTable {0 false no} -linemap_markable { 207 set configAr(-linemap_markable) 0 208 break 209 } 210 211 lappend argTable {1 true yes} -linemap_markable { 212 set configAr(-linemap_markable) 1 213 break 214 } 215 216 lappend argTable any -linemap_select_fg { 217 if {[catch {winfo rgb $self $value} res]} { 218 return -code error $res 219 } 220 set configAr(-linemap_select_fg) $value 221 $self.l tag configure lmark -foreground $value 222 break 223 } 224 225 lappend argTable any -linemap_select_bg { 226 if {[catch {winfo rgb $self $value} res]} { 227 return -code error $res 228 } 229 set configAr(-linemap_select_bg) $value 230 $self.l tag configure lmark -background $value 231 break 232 } 233 234 ctext::getAr $win config ar 235 set ar(argTable) $argTable 236} 237 238proc ctext::commentsAfterIdle {win} { 239 ctext::getAr $win config configAr 240 241 if {"" eq $configAr(commentsAfterId)} { 242 set configAr(commentsAfterId) [after idle [list ctext::comments $win [set afterTriggered 1]]] 243 } 244} 245 246proc ctext::highlightAfterIdle {win lineStart lineEnd} { 247 ctext::getAr $win config configAr 248 249 if {"" eq $configAr(highlightAfterId)} { 250 set configAr(highlightAfterId) [after idle [list ctext::highlight $win $lineStart $lineEnd [set afterTriggered 1]]] 251 } 252} 253 254proc ctext::instanceCmd {self cmd args} { 255 #slightly different than the RE used in ctext::comments 256 set commentRE {\"|\\|'|/|\*} 257 258 switch -glob -- $cmd { 259 append { 260 if {[catch {$self._t get sel.first sel.last} data] == 0} { 261 clipboard append -displayof $self $data 262 } 263 } 264 265 cget { 266 set arg [lindex $args 0] 267 ctext::getAr $self config configAr 268 269 foreach flag $configAr(ctextFlags) { 270 if {[string match ${arg}* $flag]} { 271 return [set configAr($flag)] 272 } 273 } 274 return [$self._t cget $arg] 275 } 276 277 conf* { 278 ctext::getAr $self config configAr 279 280 if {0 == [llength $args]} { 281 set res [$self._t configure] 282 set del [lsearch -glob $res -yscrollcommand*] 283 set res [lreplace $res $del $del] 284 foreach flag $configAr(ctextFlags) { 285 lappend res [list $flag [set configAr($flag)]] 286 } 287 return $res 288 } 289 290 array set flags {} 291 foreach flag $configAr(ctextFlags) { 292 set loc [lsearch $args $flag] 293 if {$loc < 0} { 294 continue 295 } 296 297 if {[llength $args] <= ($loc + 1)} { 298 #.t config -flag 299 return [set configAr($flag)] 300 } 301 302 set flagArg [lindex $args [expr {$loc + 1}]] 303 set args [lreplace $args $loc [expr {$loc + 1}]] 304 set flags($flag) $flagArg 305 } 306 307 foreach {valueList flag cmd} $configAr(argTable) { 308 if {[info exists flags($flag)]} { 309 foreach valueToCheckFor $valueList { 310 set value [set flags($flag)] 311 if {[string equal "any" $valueToCheckFor]} $cmd \ 312 elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd 313 } 314 } 315 } 316 317 if {[llength $args]} { 318 #we take care of configure without args at the top of this branch 319 uplevel 1 [linsert $args 0 $self._t configure] 320 } 321 } 322 323 copy { 324 tk_textCopy $self 325 } 326 327 cut { 328 if {[catch {$self.t get sel.first sel.last} data] == 0} { 329 clipboard clear -displayof $self.t 330 clipboard append -displayof $self.t $data 331 $self delete [$self.t index sel.first] [$self.t index sel.last] 332 ctext::modified $self 1 333 } 334 } 335 336 delete { 337 #delete n.n ?n.n 338 339 set argsLength [llength $args] 340 341 #first deal with delete n.n 342 if {$argsLength == 1} { 343 set deletePos [lindex $args 0] 344 set prevChar [$self._t get $deletePos] 345 346 $self._t delete $deletePos 347 set char [$self._t get $deletePos] 348 349 set prevSpace [ctext::findPreviousSpace $self._t $deletePos] 350 set nextSpace [ctext::findNextSpace $self._t $deletePos] 351 352 set lineStart [$self._t index "$deletePos linestart"] 353 set lineEnd [$self._t index "$deletePos + 1 chars lineend"] 354 355 #This pattern was used in 3.1. We may want to investigate using it again 356 #eventually to reduce flicker. It caused a bug with some patterns. 357 #if {[string equal $prevChar "#"] || [string equal $char "#"]} { 358 # set removeStart $lineStart 359 # set removeEnd $lineEnd 360 #} else { 361 # set removeStart $prevSpace 362 # set removeEnd $nextSpace 363 #} 364 set removeStart $lineStart 365 set removeEnd $lineEnd 366 367 foreach tag [$self._t tag names] { 368 if {[string equal $tag "_cComment"] != 1} { 369 $self._t tag remove $tag $removeStart $removeEnd 370 } 371 } 372 373 set checkStr "$prevChar[set char]" 374 375 if {[regexp $commentRE $checkStr]} { 376 ctext::commentsAfterIdle $self 377 } 378 379 ctext::highlightAfterIdle $self $lineStart $lineEnd 380 ctext::linemapUpdate $self 381 } elseif {$argsLength == 2} { 382 #now deal with delete n.n ?n.n? 383 set deleteStartPos [lindex $args 0] 384 set deleteEndPos [lindex $args 1] 385 386 set data [$self._t get $deleteStartPos $deleteEndPos] 387 388 set lineStart [$self._t index "$deleteStartPos linestart"] 389 set lineEnd [$self._t index "$deleteEndPos + 1 chars lineend"] 390 eval \$self._t delete $args 391 392 foreach tag [$self._t tag names] { 393 if {[string equal $tag "_cComment"] != 1} { 394 $self._t tag remove $tag $lineStart $lineEnd 395 } 396 } 397 398 if {[regexp $commentRE $data]} { 399 ctext::commentsAfterIdle $self 400 } 401 402 ctext::highlightAfterIdle $self $lineStart $lineEnd 403 if {[string first "\n" $data] >= 0} { 404 ctext::linemapUpdate $self 405 } 406 } else { 407 return -code error "invalid argument(s) sent to $self delete: $args" 408 } 409 ctext::modified $self 1 410 } 411 412 fastdelete { 413 eval \$self._t delete $args 414 ctext::modified $self 1 415 ctext::linemapUpdate $self 416 } 417 418 fastinsert { 419 eval \$self._t insert $args 420 ctext::modified $self 1 421 ctext::linemapUpdate $self 422 } 423 424 highlight { 425 ctext::highlight $self [lindex $args 0] [lindex $args 1] 426 ctext::comments $self 427 } 428 429 insert { 430 if {[llength $args] < 2} { 431 return -code error "please use at least 2 arguments to $self insert" 432 } 433 434 set insertPos [lindex $args 0] 435 set prevChar [$self._t get "$insertPos - 1 chars"] 436 set nextChar [$self._t get $insertPos] 437 set lineStart [$self._t index "$insertPos linestart"] 438 set prevSpace [ctext::findPreviousSpace $self._t ${insertPos}-1c] 439 set data [lindex $args 1] 440 eval \$self._t insert $args 441 442 set nextSpace [ctext::findNextSpace $self._t insert] 443 set lineEnd [$self._t index "insert lineend"] 444 445 if {[$self._t compare $prevSpace < $lineStart]} { 446 set prevSpace $lineStart 447 } 448 449 if {[$self._t compare $nextSpace > $lineEnd]} { 450 set nextSpace $lineEnd 451 } 452 453 foreach tag [$self._t tag names] { 454 if {[string equal $tag "_cComment"] != 1} { 455 $self._t tag remove $tag $prevSpace $nextSpace 456 } 457 } 458 459 set REData $prevChar 460 append REData $data 461 append REData $nextChar 462 if {[regexp $commentRE $REData]} { 463 ctext::commentsAfterIdle $self 464 } 465 466 ctext::highlightAfterIdle $self $lineStart $lineEnd 467 468 switch -- $data { 469 "\}" { 470 ctext::matchPair $self "\\\{" "\\\}" "\\" 471 } 472 "\]" { 473 ctext::matchPair $self "\\\[" "\\\]" "\\" 474 } 475 "\)" { 476 ctext::matchPair $self "\\(" "\\)" "" 477 } 478 "\"" { 479 ctext::matchQuote $self 480 } 481 } 482 ctext::modified $self 1 483 ctext::linemapUpdate $self 484 } 485 486 paste { 487 tk_textPaste $self 488 ctext::modified $self 1 489 } 490 491 edit { 492 set subCmd [lindex $args 0] 493 set argsLength [llength $args] 494 495 ctext::getAr $self config ar 496 497 if {"modified" == $subCmd} { 498 if {$argsLength == 1} { 499 return $ar(modified) 500 } elseif {$argsLength == 2} { 501 set value [lindex $args 1] 502 set ar(modified) $value 503 } else { 504 return -code error "invalid arg(s) to $self edit modified: $args" 505 } 506 } else { 507 #Tk 8.4 has other edit subcommands that I don't want to emulate. 508 return [uplevel 1 [linsert $args 0 $self._t $cmd]] 509 } 510 } 511 512 default { 513 return [uplevel 1 [linsert $args 0 $self._t $cmd]] 514 } 515 } 516} 517 518proc ctext::tag:blink {win count {afterTriggered 0}} { 519 if {$count & 1} { 520 $win tag configure __ctext_blink -foreground [$win cget -bg] -background [$win cget -fg] 521 } else { 522 $win tag configure __ctext_blink -foreground [$win cget -fg] -background [$win cget -bg] 523 } 524 525 ctext::getAr $win config configAr 526 if {$afterTriggered} { 527 set configAr(blinkAfterId) "" 528 } 529 530 if {$count == 4} { 531 $win tag delete __ctext_blink 1.0 end 532 return 533 } 534 535 incr count 536 if {"" eq $configAr(blinkAfterId)} { 537 set configAr(blinkAfterId) [after 50 [list ctext::tag:blink $win $count [set afterTriggered 1]]] 538 } 539} 540 541proc ctext::matchPair {win str1 str2 escape} { 542 set prevChar [$win get "insert - 2 chars"] 543 544 if {[string equal $prevChar $escape]} { 545 #The char that we thought might be the end is actually escaped. 546 return 547 } 548 549 set searchRE "[set str1]|[set str2]" 550 set count 1 551 552 set pos [$win index "insert - 1 chars"] 553 set endPair $pos 554 set lastFound "" 555 while 1 { 556 set found [$win search -backwards -regexp $searchRE $pos] 557 558 if {$found == "" || [$win compare $found > $pos]} { 559 return 560 } 561 562 if {$lastFound != "" && [$win compare $found == $lastFound]} { 563 #The search wrapped and found the previous search 564 return 565 } 566 567 set lastFound $found 568 set char [$win get $found] 569 set prevChar [$win get "$found - 1 chars"] 570 set pos $found 571 572 if {[string equal $prevChar $escape]} { 573 continue 574 } elseif {[string equal $char [subst $str2]]} { 575 incr count 576 } elseif {[string equal $char [subst $str1]]} { 577 incr count -1 578 if {$count == 0} { 579 set startPair $found 580 break 581 } 582 } else { 583 #This shouldn't happen. I may in the future make it return -code error 584 puts stderr "ctext seems to have encountered a bug in ctext::matchPair" 585 return 586 } 587 } 588 589 $win tag add __ctext_blink $startPair 590 $win tag add __ctext_blink $endPair 591 ctext::tag:blink $win 0 592} 593 594proc ctext::matchQuote {win} { 595 set endQuote [$win index insert] 596 set start [$win index "insert - 1 chars"] 597 598 if {[$win get "$start - 1 chars"] == "\\"} { 599 #the quote really isn't the end 600 return 601 } 602 set lastFound "" 603 while 1 { 604 set startQuote [$win search -backwards \" $start] 605 if {$startQuote == "" || [$win compare $startQuote > $start]} { 606 #The search found nothing or it wrapped. 607 return 608 } 609 610 if {$lastFound != "" && [$win compare $lastFound == $startQuote]} { 611 #We found the character we found before, so it wrapped. 612 return 613 } 614 set lastFound $startQuote 615 set start [$win index "$startQuote - 1 chars"] 616 set prevChar [$win get $start] 617 618 if {$prevChar == "\\"} { 619 continue 620 } 621 break 622 } 623 624 if {[$win compare $endQuote == $startQuote]} { 625 #probably just \" 626 return 627 } 628 629 $win tag add __ctext_blink $startQuote $endQuote 630 ctext::tag:blink $win 0 631} 632 633proc ctext::enableComments {win} { 634 $win tag configure _cComment -foreground khaki 635} 636proc ctext::disableComments {win} { 637 catch {$win tag delete _cComment} 638} 639 640proc ctext::comments {win {afterTriggered 0}} { 641 if {[catch {$win tag cget _cComment -foreground}]} { 642 #C comments are disabled 643 return 644 } 645 646 if {$afterTriggered} { 647 ctext::getAr $win config configAr 648 set configAr(commentsAfterId) "" 649 } 650 651 set startIndex 1.0 652 set commentRE {\\\\|\"|\\\"|\\'|'|/\*|\*/} 653 set commentStart 0 654 set isQuote 0 655 set isSingleQuote 0 656 set isComment 0 657 $win tag remove _cComment 1.0 end 658 while 1 { 659 set index [$win search -count length -regexp $commentRE $startIndex end] 660 661 if {$index == ""} { 662 break 663 } 664 665 set endIndex [$win index "$index + $length chars"] 666 set str [$win get $index $endIndex] 667 set startIndex $endIndex 668 669 if {$str == "\\\\"} { 670 continue 671 } elseif {$str == "\\\""} { 672 continue 673 } elseif {$str == "\\'"} { 674 continue 675 } elseif {$str == "\"" && $isComment == 0 && $isSingleQuote == 0} { 676 if {$isQuote} { 677 set isQuote 0 678 } else { 679 set isQuote 1 680 } 681 } elseif {$str == "'" && $isComment == 0 && $isQuote == 0} { 682 if {$isSingleQuote} { 683 set isSingleQuote 0 684 } else { 685 set isSingleQuote 1 686 } 687 } elseif {$str == "/*" && $isQuote == 0 && $isSingleQuote == 0} { 688 if {$isComment} { 689 #comment in comment 690 break 691 } else { 692 set isComment 1 693 set commentStart $index 694 } 695 } elseif {$str == "*/" && $isQuote == 0 && $isSingleQuote == 0} { 696 if {$isComment} { 697 set isComment 0 698 $win tag add _cComment $commentStart $endIndex 699 $win tag raise _cComment 700 } else { 701 #comment end without beginning 702 break 703 } 704 } 705 } 706} 707 708proc ctext::addHighlightClass {win class color keywords} { 709 set ref [ctext::getAr $win highlight ar] 710 foreach word $keywords { 711 set ar($word) [list $class $color] 712 } 713 $win tag configure $class 714 715 ctext::getAr $win classes classesAr 716 set classesAr($class) [list $ref $keywords] 717} 718 719#For [ ] { } # etc. 720proc ctext::addHighlightClassForSpecialChars {win class color chars} { 721 set charList [split $chars ""] 722 723 set ref [ctext::getAr $win highlightSpecialChars ar] 724 foreach char $charList { 725 set ar($char) [list $class $color] 726 } 727 $win tag configure $class 728 729 ctext::getAr $win classes classesAr 730 set classesAr($class) [list $ref $charList] 731} 732 733proc ctext::addHighlightClassForRegexp {win class color re} { 734 set ref [ctext::getAr $win highlightRegexp ar] 735 736 set ar($class) [list $re $color] 737 $win tag configure $class 738 739 ctext::getAr $win classes classesAr 740 set classesAr($class) [list $ref $class] 741} 742 743#For things like $blah 744proc ctext::addHighlightClassWithOnlyCharStart {win class color char} { 745 set ref [ctext::getAr $win highlightCharStart ar] 746 747 set ar($char) [list $class $color] 748 $win tag configure $class 749 750 ctext::getAr $win classes classesAr 751 set classesAr($class) [list $ref $char] 752} 753 754proc ctext::deleteHighlightClass {win classToDelete} { 755 ctext::getAr $win classes classesAr 756 757 if {![info exists classesAr($classToDelete)]} { 758 return -code error "$classToDelete doesn't exist" 759 } 760 761 foreach {ref keyList} [set classesAr($classToDelete)] { 762 upvar #0 $ref refAr 763 foreach key $keyList { 764 if {![info exists refAr($key)]} { 765 continue 766 } 767 unset refAr($key) 768 } 769 } 770 unset classesAr($classToDelete) 771} 772 773proc ctext::getHighlightClasses win { 774 ctext::getAr $win classes classesAr 775 776 array names classesAr 777} 778 779proc ctext::findNextChar {win index char} { 780 set i [$win index "$index + 1 chars"] 781 set lineend [$win index "$i lineend"] 782 while 1 { 783 set ch [$win get $i] 784 if {[$win compare $i >= $lineend]} { 785 return "" 786 } 787 if {$ch == $char} { 788 return $i 789 } 790 set i [$win index "$i + 1 chars"] 791 } 792} 793 794proc ctext::findNextSpace {win index} { 795 set i [$win index $index] 796 set lineStart [$win index "$i linestart"] 797 set lineEnd [$win index "$i lineend"] 798 #Sometimes the lineend fails (I don't know why), so add 1 and try again. 799 if {[$win compare $lineEnd == $lineStart]} { 800 set lineEnd [$win index "$i + 1 chars lineend"] 801 } 802 803 while {1} { 804 set ch [$win get $i] 805 806 if {[$win compare $i >= $lineEnd]} { 807 set i $lineEnd 808 break 809 } 810 811 if {[string is space $ch]} { 812 break 813 } 814 set i [$win index "$i + 1 chars"] 815 } 816 return $i 817} 818 819proc ctext::findPreviousSpace {win index} { 820 set i [$win index $index] 821 set lineStart [$win index "$i linestart"] 822 while {1} { 823 set ch [$win get $i] 824 825 if {[$win compare $i <= $lineStart]} { 826 set i $lineStart 827 break 828 } 829 830 if {[string is space $ch]} { 831 break 832 } 833 834 set i [$win index "$i - 1 chars"] 835 } 836 return $i 837} 838 839proc ctext::clearHighlightClasses {win} { 840 #no need to catch, because array unset doesn't complain 841 #puts [array exists ::ctext::highlight$win] 842 843 ctext::getAr $win highlight ar 844 array unset ar 845 846 ctext::getAr $win highlightSpecialChars ar 847 array unset ar 848 849 ctext::getAr $win highlightRegexp ar 850 array unset ar 851 852 ctext::getAr $win highlightCharStart ar 853 array unset ar 854 855 ctext::getAr $win classes ar 856 array unset ar 857} 858 859#This is a proc designed to be overwritten by the user. 860#It can be used to update a cursor or animation while 861#the text is being highlighted. 862proc ctext::update {} { 863 864} 865 866proc ctext::highlight {win start end {afterTriggered 0}} { 867 ctext::getAr $win config configAr 868 869 if {$afterTriggered} { 870 set configAr(highlightAfterId) "" 871 } 872 873 if {!$configAr(-highlight)} { 874 return 875 } 876 877 set si $start 878 set twin "$win._t" 879 880 #The number of times the loop has run. 881 set numTimesLooped 0 882 set numUntilUpdate 600 883 884 ctext::getAr $win highlight highlightAr 885 ctext::getAr $win highlightSpecialChars highlightSpecialCharsAr 886 ctext::getAr $win highlightRegexp highlightRegexpAr 887 ctext::getAr $win highlightCharStart highlightCharStartAr 888 889 while 1 { 890 set res [$twin search -count length -regexp -- {([^\s\(\{\[\}\]\)\.\t\n\r;\"'\|,]+)} $si $end] 891 if {$res == ""} { 892 break 893 } 894 895 set wordEnd [$twin index "$res + $length chars"] 896 set word [$twin get $res $wordEnd] 897 set firstOfWord [string index $word 0] 898 899 if {[info exists highlightAr($word)] == 1} { 900 set wordAttributes [set highlightAr($word)] 901 foreach {tagClass color} $wordAttributes break 902 903 $twin tag add $tagClass $res $wordEnd 904 $twin tag configure $tagClass -foreground $color 905 906 } elseif {[info exists highlightCharStartAr($firstOfWord)] == 1} { 907 set wordAttributes [set highlightCharStartAr($firstOfWord)] 908 foreach {tagClass color} $wordAttributes break 909 910 $twin tag add $tagClass $res $wordEnd 911 $twin tag configure $tagClass -foreground $color 912 } 913 set si $wordEnd 914 915 incr numTimesLooped 916 if {$numTimesLooped >= $numUntilUpdate} { 917 ctext::update 918 set numTimesLooped 0 919 } 920 } 921 922 foreach {ichar tagInfo} [array get highlightSpecialCharsAr] { 923 set si $start 924 foreach {tagClass color} $tagInfo break 925 926 while 1 { 927 set res [$twin search -- $ichar $si $end] 928 if {"" == $res} { 929 break 930 } 931 set wordEnd [$twin index "$res + 1 chars"] 932 933 $twin tag add $tagClass $res $wordEnd 934 $twin tag configure $tagClass -foreground $color 935 set si $wordEnd 936 937 incr numTimesLooped 938 if {$numTimesLooped >= $numUntilUpdate} { 939 ctext::update 940 set numTimesLooped 0 941 } 942 } 943 } 944 945 foreach {tagClass tagInfo} [array get highlightRegexpAr] { 946 set si $start 947 foreach {re color} $tagInfo break 948 while 1 { 949 set res [$twin search -count length -regexp -- $re $si $end] 950 if {"" == $res} { 951 break 952 } 953 954 set wordEnd [$twin index "$res + $length chars"] 955 $twin tag add $tagClass $res $wordEnd 956 $twin tag configure $tagClass -foreground $color 957 set si $wordEnd 958 959 incr numTimesLooped 960 if {$numTimesLooped >= $numUntilUpdate} { 961 ctext::update 962 set numTimesLooped 0 963 } 964 } 965 } 966} 967 968proc ctext::linemapToggleMark {win y} { 969 ctext::getAr $win config configAr 970 971 if {!$configAr(-linemap_markable)} { 972 return 973 } 974 975 set markChar [$win.l index @0,$y] 976 set lineSelected [lindex [split $markChar .] 0] 977 set line [$win.l get $lineSelected.0 $lineSelected.end] 978 979 if {$line == ""} { 980 return 981 } 982 983 ctext::getAr $win linemap linemapAr 984 985 if {[info exists linemapAr($line)] == 1} { 986 #It's already marked, so unmark it. 987 array unset linemapAr $line 988 ctext::linemapUpdate $win 989 set type unmarked 990 } else { 991 #This means that the line isn't toggled, so toggle it. 992 array set linemapAr [list $line {}] 993 $win.l tag add lmark $markChar [$win.l index "$markChar lineend"] 994 $win.l tag configure lmark -foreground $configAr(-linemap_select_fg) \ 995-background $configAr(-linemap_select_bg) 996 set type marked 997 } 998 999 if {[string length $configAr(-linemap_mark_command)]} { 1000 uplevel #0 [linsert $configAr(-linemap_mark_command) end $win $type $line] 1001 } 1002} 1003 1004#args is here because -yscrollcommand may call it 1005proc ctext::linemapUpdate {win args} { 1006 if {[winfo exists $win.l] != 1} { 1007 return 1008 } 1009 1010 set pixel 0 1011 set lastLine {} 1012 set lineList [list] 1013 set fontMetrics [font metrics [$win._t cget -font]] 1014 set incrBy [expr {1 + ([lindex $fontMetrics 5] / 2)}] 1015 1016 while {$pixel < [winfo height $win.l]} { 1017 set idx [$win._t index @0,$pixel] 1018 1019 if {$idx != $lastLine} { 1020 set line [lindex [split $idx .] 0] 1021 set lastLine $idx 1022 lappend lineList $line 1023 } 1024 incr pixel $incrBy 1025 } 1026 1027 ctext::getAr $win linemap linemapAr 1028 1029 $win.l delete 1.0 end 1030 set lastLine {} 1031 foreach line $lineList { 1032 if {$line == $lastLine} { 1033 $win.l insert end "\n" 1034 } else { 1035 if {[info exists linemapAr($line)]} { 1036 $win.l insert end "$line\n" lmark 1037 } else { 1038 $win.l insert end "$line\n" 1039 } 1040 } 1041 set lastLine $line 1042 } 1043 set endrow [lindex [split [$win._t index end-1c] .] 0] 1044 $win.l configure -width [string length $endrow] 1045} 1046 1047proc ctext::modified {win value} { 1048 ctext::getAr $win config ar 1049 set ar(modified) $value 1050 event generate $win <<Modified>> 1051 return $value 1052} 1053