lib/gui_script/ctext.tcl

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