source: tol/tolbase/lib/toltk/ctext.tcl @ 8d687fe

1941-docker-image-to-testdevel
Last change on this file since 8d687fe was 6d7779d, checked in by Jorge Pérez <josp.jorge@…>, 18 years ago

initial import

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