Context Navigation

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

Rev	Line
[6d7779d]	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
	15	namespace eval ctext {}
	16
	17	#win is used as a unique token to create arrays for each ctext instance
	18	proc 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
	24	proc 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
	144	proc ctext::event:yscroll {win clientData args} {
	145	ctext::linemapUpdate $win
	146
	147	if {$clientData == ""} {
	148	return
	149	}
	150	uplevel #0 $clientData $args
	151	}
	152
	153	proc 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.
	165	proc 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
	264	proc 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
	519	proc 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
	533	proc 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
	586	proc 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
	630	proc 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	}
	635	proc ctext::disableComments {win} {
	636	catch {$win tag delete _cComment}
	637	#BEGIN Bayes:
	638	catch {$win tag delete _cQuote}
	639	# END Bayes:
	640	}
	641
	642	proc 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
	729	proc 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.
	741	proc 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
	754	proc 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
	765	proc 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
	775	proc 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
	794	proc 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
	805	proc 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
	820	proc 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
	845	proc 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
	865	proc 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.
	888	proc ctext::update {} {
	889
	890	}
	891
	892	proc 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
	1016	proc 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
	1053	proc 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
	1094	proc 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.

Context Navigation

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

Download in other formats: