00001 # RCS: @(#) $Id: ctext.tcl,v 1.9 2011/04/18 19:49:48 andreas_kupries Exp $ 00002 00003 package require Tk 00004 package provide ctext 5.0 00005 00006 # Override the tk::TextSetCursor to add a <<CursorChanged>> event 00007 rename ::tk::TextSetCursor ::tk::TextSetCursorOrig 00008 proc ::tk::TextSetCursor {w pos args} { 00009 set ins [$w index insert] 00010 ::tk::TextSetCursorOrig $w $pos 00011 event generate $w <<CursorChanged>> -data [list $ins {*}$args] 00012 } 00013 00014 # Override the tk::TextButton1 to add a <<CursorChanged>> event 00015 rename ::tk::TextButton1 ::tk::TextSetButton1Orig 00016 proc ::tk::TextButton1 {w x y args} { 00017 set ins [$w index insert] 00018 ::tk::TextSetButton1Orig $w $x $y 00019 event generate $w <<CursorChanged>> -data [list $ins {*}$args] 00020 } 00021 00022 namespace eval ctext { 00023 00024 array set REs { 00025 words {[^\s\(\{\[\}\]\)\.\t\n\r;:=\"'\|,<>]+} 00026 brackets {[][()\{\}<>]} 00027 } 00028 array set bracket_map {\( parenL \) parenR \{ curlyL \} curlyR \[ squareL \] squareR < angledL > angledR} 00029 array set bracket_map2 {\( paren \) paren \{ curly \} curly \[ square \] square < angled > angled} 00030 array set data {} 00031 00032 variable temporary {} 00033 variable right_click 3 00034 00035 if {[tk windowingsystem] eq "aqua"} { 00036 set right_click 2 00037 } 00038 00039 proc create {win args} { 00040 00041 variable data 00042 variable right_click 00043 variable REs 00044 00045 if {[llength $args] & 1} { 00046 return -code error "Invalid number of arguments given to ctext (uneven number after window) : $args" 00047 } 00048 00049 frame $win -class Ctext ;# -padx 1 -pady 1 00050 00051 set tmp [text .__ctextTemp] 00052 00053 set data($win,config,-fg) [$tmp cget -foreground] 00054 set data($win,config,-bg) [$tmp cget -background] 00055 set data($win,config,-font) [$tmp cget -font] 00056 set data($win,config,-relief) [$tmp cget -relief] 00057 set data($win,config,-unhighlightcolor) [$win cget -bg] 00058 destroy $tmp 00059 set data($win,config,-xscrollcommand) "" 00060 set data($win,config,-yscrollcommand) "" 00061 set data($win,config,-highlightcolor) "yellow" 00062 set data($win,config,-linemap) 1 00063 set data($win,config,-linemapfg) $data($win,config,-fg) 00064 set data($win,config,-linemapbg) $data($win,config,-bg) 00065 set data($win,config,-linemap_mark_command) {} 00066 set data($win,config,-linemap_markable) 1 00067 set data($win,config,-linemap_mark_color) orange 00068 set data($win,config,-linemap_cursor) left_ptr 00069 set data($win,config,-linemap_relief) $data($win,config,-relief) 00070 set data($win,config,-linemap_minwidth) 1 00071 set data($win,config,-linemap_type) absolute 00072 set data($win,config,-linemap_align) left 00073 set data($win,config,-linemap_separator) auto 00074 set data($win,config,-linemap_separator_color) red 00075 set data($win,config,-highlight) 1 00076 set data($win,config,-lmargin) 0 00077 set data($win,config,-warnwidth) "" 00078 set data($win,config,-warnwidth_bg) red 00079 set data($win,config,-casesensitive) 1 00080 set data($win,config,-escapes) 1 00081 set data($win,config,-peer) "" 00082 set data($win,config,-undo) 0 00083 set data($win,config,-maxundo) 0 00084 set data($win,config,-autoseparators) 0 00085 set data($win,config,-diff_mode) 0 00086 set data($win,config,-diffsubbg) "pink" 00087 set data($win,config,-diffaddbg) "light green" 00088 set data($win,config,-folding) 0 00089 set data($win,config,-delimiters) $REs(words) 00090 set data($win,config,-matchchar) 0 00091 set data($win,config,-matchchar_bg) $data($win,config,-fg) 00092 set data($win,config,-matchchar_fg) $data($win,config,-bg) 00093 set data($win,config,-matchaudit) 0 00094 set data($win,config,-matchaudit_bg) "red" 00095 set data($win,config,-theme) [list] 00096 set data($win,config,-hidemeta) 0 00097 set data($win,config,re_opts) "" 00098 set data($win,config,win) $win 00099 set data($win,config,modified) 0 00100 set data($win,config,lastUpdate) 0 00101 set data($win,config,csl_array) [list] 00102 set data($win,config,csl_markers) [list] 00103 set data($win,config,csl_tag_pair) [list] 00104 set data($win,config,csl_tags) [list] 00105 set data($win,config,langs) [list {}] 00106 set data($win,config,gutters) [list] 00107 set data($win,config,undo_hist) [list] 00108 set data($win,config,undo_hist_size) 0 00109 set data($win,config,undo_sep_last) -1 00110 set data($win,config,undo_sep_next) -1 00111 set data($win,config,undo_sep_size) 0 00112 set data($win,config,undo_sep_count) 0 00113 set data($win,config,redo_hist) [list] 00114 set data($win,config,linemap_cmd_ip) 0 00115 set data($win,config,meta_classes) [list] 00116 00117 set data($win,config,ctextFlags) [list -xscrollcommand -yscrollcommand -linemap -linemapfg -linemapbg \ 00118 -font -linemap_mark_command -highlight -warnwidth -warnwidth_bg -linemap_markable \ 00119 -linemap_cursor -highlightcolor -folding -delimiters -matchchar -matchchar_bg -matchchar_fg -matchaudit -matchaudit_bg \ 00120 -linemap_mark_color -linemap_relief -linemap_minwidth -linemap_type -linemap_align \ 00121 -linemap_separator -linemap_separator_color -casesensitive -peer -theme -hidemeta \ 00122 -undo -maxundo -autoseparators -diff_mode -diffsubbg -diffaddbg -escapes -spacing3 -lmargin] 00123 00124 # Set args 00125 foreach {name value} $args { 00126 set data($win,config,$name) $value 00127 } 00128 00129 set data($win,fontwidth) [font measure $data($win,config,-font) -displayof . "0"] 00130 set data($win,fontdescent) [font metrics $data($win,config,-font) -displayof . -descent] 00131 00132 foreach flag {foreground background} short {fg bg} { 00133 if {[info exists data($win,config,-$flag)] == 1} { 00134 set data($win,config,-$short) $data($win,config,-$flag) 00135 unset data($win,config,-$flag) 00136 } 00137 } 00138 00139 # Now remove flags that will confuse text and those that need 00140 # modification: 00141 foreach arg $data($win,config,ctextFlags) { 00142 if {[set loc [lsearch $args $arg]] >= 0} { 00143 set args [lreplace $args $loc [expr {$loc + 1}]] 00144 } 00145 } 00146 00147 # Initialize the starting linemap ID 00148 set data($win,linemap,id) 0 00149 00150 canvas $win.l -relief $data($win,config,-relief) -bd 0 \ 00151 -bg $data($win,config,-linemapbg) -takefocus 0 -highlightthickness 0 00152 frame $win.f -width 1 -bd 0 -relief flat -bg $data($win,config,-linemap_separator_color) 00153 00154 set args [concat $args [list -yscrollcommand [list ctext::event:yscroll $win $data($win,config,-yscrollcommand)]] \ 00155 [list -xscrollcommand [list ctext::event:xscroll $win $data($win,config,-xscrollcommand)]]] 00156 00157 if {$data($win,config,-peer) eq ""} { 00158 text $win.t -font $data($win,config,-font) -bd 0 -highlightthickness 0 {*}$args 00159 } else { 00160 $data($win,config,-peer)._t peer create $win.t -font $data($win,config,-font) -bd 0 -highlightthickness 0 {*}$args 00161 } 00162 00163 frame $win.t.w -width 1 -bd 0 -relief flat -bg $data($win,config,-warnwidth_bg) 00164 00165 if {$data($win,config,-warnwidth) ne ""} { 00166 place $win.t.w -x [expr $data($win,config,-lmargin) + [font measure [$win.t cget -font] -displayof . [string repeat "m" $data($win,config,-warnwidth)]]] -relheight 1.0 00167 } 00168 00169 grid rowconfigure $win 0 -weight 100 00170 grid columnconfigure $win 2 -weight 100 00171 grid $win.l -row 0 -column 0 -sticky ns 00172 grid $win.f -row 0 -column 1 -sticky ns 00173 grid $win.t -row 0 -column 2 -sticky news 00174 00175 # Hide the linemap and separator if we are specified to do so 00176 if {!$data($win,config,-linemap) && !$data($win,config,-linemap_markable) && !$data($win,config,-folding)} { 00177 grid remove $win.l 00178 grid remove $win.f 00179 } 00180 00181 # Add the layer tags 00182 $win.t tag configure _visibleH 00183 $win.t tag configure _visibleL 00184 $win.t tag configure _invisible 00185 $win.t tag lower _visibleH sel 00186 $win.t tag lower _visibleL _visibleH 00187 $win.t tag lower _invisible _visibleL 00188 00189 # Add default classes 00190 $win.t tag configure __escape 00191 $win.t tag configure __prewhite 00192 $win.t tag configure rmargin 00193 $win.t tag configure lmargin 00194 $win.t tag lower __escape _invisible 00195 $win.t tag lower __prewhite _invisible 00196 $win.t tag lower rmargin _invisible 00197 $win.t tag lower lmargin _invisible 00198 00199 # If -matchchar is set, create the tag 00200 if {$data($win,config,-matchchar)} { 00201 $win.t tag configure matchchar -foreground $data($win,config,-matchchar_fg) -background $data($win,config,-matchchar_bg) 00202 $win.t tag lower matchchar sel 00203 } 00204 00205 00206 bind $win.t <Configure> [list ctext::linemapUpdate $win] 00207 bind $win.t <<CursorChanged>> [list ctext::linemapUpdate $win] 00208 bind $win.l <Button-$right_click> [list ctext::linemapToggleMark $win %x %y] 00209 bind $win.l <MouseWheel> [list event generate $win.t <MouseWheel> -delta %D] 00210 bind $win.l <4> [list event generate $win.t <4>] 00211 bind $win.l <5> [list event generate $win.t <5>] 00212 bind $win.t <Destroy> [list ctext::event:Destroy $win] 00213 00214 bindtags $win.t [linsert [bindtags $win.t] 0 $win] 00215 00216 return $win 00217 00218 } 00219 00220 proc event:xscroll {win clientData args} { 00221 00222 variable data 00223 00224 if {$clientData == ""} { 00225 return 00226 } 00227 00228 uplevel \#0 $clientData $args 00229 00230 lassign $args first last 00231 00232 if {$first > 0} { 00233 set first_line [lindex [split [$win.t index @0,0] .] 0] 00234 set last_line [lindex [split [$win.t index @0,[winfo height $win.t]] .] 0] 00235 set longest 0 00236 for {set i $first_line} {$i <= $last_line} {incr i} { 00237 if {[set len [lindex [split [$win.t index $i.end] .] 1]] > $longest} { 00238 set longest $len 00239 } 00240 } 00241 set cwidth [font measure [$win._t cget -font] -displayof . "m"] 00242 set missing [expr round( ($longest * $cwidth) * $first )] 00243 } else { 00244 set missing 0 00245 } 00246 00247 # Adjust the warning width line, if one was requested 00248 set_warnwidth $win [expr 0 - $missing] 00249 00250 } 00251 00252 proc event:yscroll {win clientData args} { 00253 00254 linemapUpdate $win 00255 00256 if {$clientData == ""} { 00257 return 00258 } 00259 00260 uplevel \#0 $clientData $args 00261 00262 } 00263 00264 proc event:Destroy {win} { 00265 00266 variable data 00267 00268 bgproc::killall ctext::* 00269 00270 catch { rename $win {} } 00271 interp alias {} $win.t {} 00272 array unset data $win,* 00273 00274 } 00275 00276 # This stores the arg table within the config array for each instance. 00277 # It's used by the configure instance command. 00278 proc buildArgParseTable win { 00279 00280 variable data 00281 00282 set argTable [list] 00283 00284 lappend argTable any -background { 00285 if {[catch { winfo rgb $win $value } res]} { 00286 return -code error $res 00287 } 00288 set data($win,config,-background) $value 00289 $win.t configure -bg $value 00290 update_linemap_separator $win 00291 break 00292 } 00293 00294 lappend argTable any -linemap_separator { 00295 set data($win,config,-linemap_separator) $value 00296 update_linemap_separator $win 00297 break 00298 } 00299 00300 lappend argTable any -linemap_separator_color { 00301 if {[catch {winfo rgb $win $value} res]} { 00302 return -code error $res 00303 } 00304 set data($win,config,-linemap_separator_color) $value 00305 $win.f configure -bg $value 00306 update_linemap_separator $win 00307 break 00308 } 00309 00310 lappend argTable {1 true yes} -linemap { 00311 set data($win,config,-linemap) 1 00312 catch { 00313 grid $win.l 00314 grid $win.f 00315 } 00316 set update_linemap 1 00317 break 00318 } 00319 00320 lappend argTable {0 false no} -linemap { 00321 set data($win,config,-linemap) 0 00322 if {([llength $data($win,config,gutters)] == 0) && !$data($win,config,-linemap_markable) && !$data($win,config,-folding)} { 00323 catch { 00324 grid remove $win.l 00325 grid remove $win.f 00326 } 00327 } else { 00328 set update_linemap 1 00329 } 00330 break 00331 } 00332 00333 lappend argTable any -linemap_mark_command { 00334 set data($win,config,-linemap_mark_command) $value 00335 break 00336 } 00337 00338 lappend argTable {1 true yes} -folding { 00339 set data($win,config,-folding) 1 00340 catch { 00341 grid $win.l 00342 grid $win.f 00343 } 00344 set update_linemap 1 00345 break 00346 } 00347 00348 lappend argTable {0 false no} -folding { 00349 set data($win,config,-folding) 0 00350 if {([llength $data($win,config,gutters)] == 0) && !$data($win,config,-linemap_markable) && !$data($win,config,-linemap)} { 00351 catch { 00352 grid remove $win.l 00353 grid remove $win.f 00354 } 00355 } else { 00356 set update_linemap 1 00357 } 00358 break 00359 } 00360 00361 lappend argTable any -xscrollcommand { 00362 set cmd [list $win._t config -xscrollcommand [list ctext::event:xscroll $win $value]] 00363 if {[catch $cmd res]} { 00364 return $res 00365 } 00366 set data($win,config,-xscrollcommand) $value 00367 break 00368 } 00369 00370 lappend argTable any -yscrollcommand { 00371 set cmd [list $win._t config -yscrollcommand [list ctext::event:yscroll $win $value]] 00372 if {[catch $cmd res]} { 00373 return $res 00374 } 00375 set data($win,config,-yscrollcommand) $value 00376 break 00377 } 00378 00379 lappend argTable any -spacing3 { 00380 if {[catch { $win._t config -spacing3 $value } res]} { 00381 return $res 00382 } 00383 } 00384 00385 lappend argTable any -linemapfg { 00386 if {[catch {winfo rgb $win $value} res]} { 00387 return -code error $res 00388 } 00389 $win.l itemconfigure unmarked -fill $value 00390 set data($win,config,-linemapfg) $value 00391 break 00392 } 00393 00394 lappend argTable any -linemapbg { 00395 if {[catch {winfo rgb $win $value} res]} { 00396 return -code error $res 00397 } 00398 $win.l config -bg $value 00399 set data($win,config,-linemapbg) $value 00400 break 00401 } 00402 00403 lappend argTable any -linemap_relief { 00404 if {[catch {$win.l config -relief $value} res]} { 00405 return -code error $res 00406 } 00407 set data($win,config,-linemap_relief) $value 00408 break 00409 } 00410 00411 lappend argTable any -font { 00412 $win._t config -font $value 00413 set data($win,config,-font) $value 00414 set data($win,fontwidth) [font measure $value -displayof $win "0"] 00415 set data($win,fontdescent) [font metrics $data($win,config,-font) -displayof $win -descent] 00416 set update_linemap 1 00417 set_warnwidth $win 00418 break 00419 } 00420 00421 lappend argTable {0 false no} -highlight { 00422 set data($win,config,-highlight) 0 00423 break 00424 } 00425 00426 lappend argTable {1 true yes} -highlight { 00427 set data($win,config,-highlight) 1 00428 break 00429 } 00430 00431 lappend argTable any -lmargin { 00432 if {[string is integer $value] && ($value >= 0)} { 00433 set data($win,config,-lmargin) $value 00434 set_warnwidth $win 00435 $win tag configure lmargin -lmargin1 $value -lmargin2 $value 00436 } else { 00437 return -code error "Error: -lmargin option must be an integer value greater or equal to zero" 00438 } 00439 break 00440 } 00441 00442 lappend argTable any -warnwidth { 00443 set data($win,config,-warnwidth) $value 00444 set_warnwidth $win 00445 break 00446 } 00447 00448 lappend argTable any -warnwidth_bg { 00449 if {[catch {winfo rgb $win $value} res]} { 00450 return -code error $res 00451 } 00452 set data($win,config,-warnwidth_bg) $value 00453 $win.t.w configure -bg $value 00454 break 00455 } 00456 00457 lappend argTable any -highlightcolor { 00458 if {[catch {winfo rgb $win $value} res]} { 00459 return -code error $res 00460 } 00461 set data($win,config,-highlightcolor) $value 00462 break 00463 } 00464 00465 lappend argTable {0 false no} -linemap_markable { 00466 set data($win,config,-linemap_markable) 0 00467 break 00468 } 00469 00470 lappend argTable {1 true yes} -linemap_markable { 00471 set data($win,config,-linemap_markable) 1 00472 break 00473 } 00474 00475 lappend argTable any -linemap_mark_color { 00476 if {[catch {winfo rgb $win $value} res]} { 00477 return -code error $res 00478 } 00479 set data($win,config,-linemap_mark_color) $value 00480 set update_linemap 1 00481 break 00482 } 00483 00484 lappend argTable {0 false no} -casesensitive { 00485 set data($win,config,-casesensitive) 0 00486 set data($win,config,re_opts) "-nocase" 00487 break 00488 } 00489 00490 lappend argTable {1 true yes} -casesensitive { 00491 set data($win,config,-casesensitive) 1 00492 set data($win,config,re_opts) "" 00493 break 00494 } 00495 00496 lappend argTable {0 false no} -escapes { 00497 set data($win,config,-escapes) 0 00498 break 00499 } 00500 00501 lappend argTable {1 true yes} -escapes { 00502 set data($win,config,-escapes) 1 00503 break 00504 } 00505 00506 lappend argTable {any} -linemap_minwidth { 00507 if {![string is integer $value]} { 00508 return -code error "-linemap_minwidth argument must be an integer value" 00509 } 00510 set data($win,config,-linemap_minwidth) $value 00511 set update_linemap 1 00512 break 00513 } 00514 00515 lappend argTable {absolute relative} -linemap_type { 00516 if {[lsearch [list absolute relative] $value] == -1} { 00517 return -code error "-linemap_type argument must be either 'absolute' or 'relative'" 00518 } 00519 set data($win,config,-linemap_type) $value 00520 set update_linemap 1 00521 break 00522 } 00523 00524 lappend argTable {left right} -linemap_align { 00525 set data($win,config,-linemap_align) $value 00526 set update_linemap 1 00527 break; 00528 } 00529 00530 lappend argTable {0 false no} -undo { 00531 set data($win,config,-undo) 0 00532 break 00533 } 00534 00535 lappend argTable {1 true yes} -undo { 00536 set data($win,config,-undo) 1 00537 break 00538 } 00539 00540 lappend argTable {any} -maxundo { 00541 if {![string is integer $value]} { 00542 return -code error "-maxundo argument must be an integer value" 00543 } 00544 set data($win,config,-maxundo) $value 00545 undo_manage $win 00546 break 00547 } 00548 00549 lappend argTable {0 false no} -autoseparators { 00550 set data($win,config,-autoseparators) 0 00551 break 00552 } 00553 00554 lappend argTable {1 true yes} -autoseparators { 00555 set data($win,config,-autoseparators) 1 00556 break 00557 } 00558 00559 lappend argTable {any} -diffsubbg { 00560 set data($win,config,-diffsubbg) $value 00561 foreach tag [lsearch -inline -all -glob [$win._t tag names] diff:B:D:*] { 00562 $win._t tag configure $tag -background $value 00563 } 00564 break 00565 } 00566 00567 lappend argTable {any} -diffaddbg { 00568 set data($win,config,-diffaddbg) $value 00569 foreach tag [lsearch -inline -all -glob [$win._t tag names] diff:A:D:*] { 00570 $win._t tag configure $tag -background $value 00571 } 00572 break 00573 } 00574 00575 lappend argTable {any} -delimiters { 00576 set data($win,config,-delimiters) $value 00577 break 00578 } 00579 00580 lappend argTable {0 false no} -matchchar { 00581 set data($win,config,-matchchar) 0 00582 catch { $win tag delete matchchar } 00583 break 00584 } 00585 00586 lappend argTable {1 true yes} -matchchar { 00587 set data($win,config,-matchchar) 1 00588 $win tag configure matchchar -foreground $data($win,config,-matchchar_fg) -background $data($win,config,-matchchar_bg) 00589 break 00590 } 00591 00592 lappend argTable {any} -matchchar_fg { 00593 set data($win,config,-matchchar_fg) $value 00594 $win tag configure matchchar -foreground $data($win,config,-matchchar_fg) -background $data($win,config,-matchchar_bg) 00595 break 00596 } 00597 00598 lappend argTable {any} -matchchar_bg { 00599 set data($win,config,-matchchar_bg) $value 00600 $win tag configure matchchar -foreground $data($win,config,-matchchar_fg) -background $data($win,config,-matchchar_bg) 00601 break 00602 } 00603 00604 lappend argTable {0 false no} -matchaudit { 00605 set data($win,config,-matchaudit) 0 00606 foreach type [list curly square paren angled] { 00607 catch { $win tag remove missing:$type 1.0 end } 00608 } 00609 break 00610 } 00611 00612 lappend argTable {1 true yes} -matchaudit { 00613 set data($win,config,-matchaudit) 1 00614 checkAllBrackets $win 00615 break 00616 } 00617 00618 lappend argTable {any} -matchaudit_bg { 00619 set data($win,config,-matchaudit_bg) $value 00620 foreach type [list curly square paren angled] { 00621 if {[lsearch [$win tag names] missing:$type] != -1} { 00622 $win tag configure missing:$type -background $value 00623 $win tag raise missing:$type _visibleH 00624 } 00625 } 00626 break 00627 } 00628 00629 lappend argTable any -theme { 00630 set data($win,config,-theme) $value 00631 foreach key [array names data $win,classopts,*] { 00632 lassign [split $key ,] dummy1 dummy2 class 00633 applyClassTheme $win $class 00634 } 00635 } 00636 00637 lappend argTable {0 false no} -hidemeta { 00638 set data($win,config,-hidemeta) 0 00639 updateMetaChars $win 00640 break 00641 } 00642 00643 lappend argTable {1 true yes} -hidemeta { 00644 set data($win,config,-hidemeta) 1 00645 updateMetaChars $win 00646 break 00647 } 00648 00649 set data($win,config,argTable) $argTable 00650 00651 } 00652 00653 ###################################################################### 00654 # Shows/hides the linemap separator depending on the value of linemap_separator. 00655 proc update_linemap_separator {win} { 00656 00657 variable data 00658 00659 # If the linemap is not being displayed, return now 00660 if {[lsearch [grid slaves $win] $win.l] == -1} { 00661 return 00662 } 00663 00664 switch $data($win,config,-linemap_separator) { 00665 1 - 00666 yes - 00667 true { 00668 grid $win.f 00669 } 00670 auto { 00671 catch { 00672 set lm [winfo rgb $win $data($win,config,-linemapbg)] 00673 set bg [winfo rgb $win $data($win,config,-background)] 00674 if {$lm ne $bg} { 00675 grid $win.f 00676 } else { 00677 grid remove $win.f 00678 } 00679 } 00680 } 00681 default { 00682 grid remove $win.f 00683 } 00684 } 00685 00686 } 00687 00688 proc inCommentStringHelper {win index pattern} { 00689 00690 set names [$win tag names $index] 00691 00692 return [expr {[string map [list $pattern {}] $names] ne $names}] 00693 00694 } 00695 00696 proc inLineComment {win index} { 00697 00698 return [inCommentStringHelper $win $index __comstr1l] 00699 00700 } 00701 00702 proc inBlockComment {win index} { 00703 00704 return [inCommentStringHelper $win $index __comstr1c] 00705 00706 } 00707 00708 proc inComment {win index} { 00709 00710 return [inCommentStringHelper $win $index __comstr1] 00711 00712 } 00713 00714 proc inBackTick {win index} { 00715 00716 return [inCommentStringHelper $win $index __comstr0b] 00717 00718 } 00719 00720 proc inSingleQuote {win index} { 00721 00722 return [inCommentStringHelper $win $index __comstr0s] 00723 00724 } 00725 00726 proc inDoubleQuote {win index} { 00727 00728 return [inCommentStringHelper $win $index __comstr0d] 00729 00730 } 00731 00732 proc inTripleBackTick {win index} { 00733 00734 return [inCommentStringHelper $win $index __comstr0B] 00735 00736 } 00737 00738 proc inTripleSingleQuote {win index} { 00739 00740 return [inCommentStringHelper $win $index __comstr0S] 00741 00742 } 00743 00744 proc inTripleDoubleQuote {win index} { 00745 00746 return [inCommentStringHelper $win $index __comstr0D] 00747 00748 } 00749 00750 proc inString {win index} { 00751 00752 return [inCommentStringHelper $win $index __comstr0] 00753 00754 } 00755 00756 proc inCommentString {win index} { 00757 00758 return [inCommentStringHelper $win $index __comstr] 00759 00760 } 00761 00762 proc inCommentStringRangeHelper {win index pattern prange} { 00763 00764 if {[set curr_tag [lsearch -inline -glob [$win tag names $index] $pattern]] ne ""} { 00765 upvar 2 $prange range 00766 set range [$win tag prevrange $curr_tag $index+1c] 00767 return 1 00768 } 00769 00770 return 0 00771 00772 } 00773 00774 proc inLineCommentRange {win index prange} { 00775 00776 return [inCommentStringRangeHelper $win $index __comstr1l $prange] 00777 00778 } 00779 00780 proc inBlockCommentRange {win index prange} { 00781 00782 return [inCommentStringRangeHelper $win $index __comstr1c* $prange] 00783 00784 } 00785 00786 proc inCommentRange {win index prange} { 00787 00788 return [inCommentStringRangeHelper $win $index __comstr1* $prange] 00789 00790 } 00791 00792 proc commentCharRanges {win index} { 00793 00794 if {[set curr_tag [lsearch -inline -glob [$win tag names $index] __comstr1*]] ne ""} { 00795 set range [$win tag prevrange $curr_tag $index+1c] 00796 if {[string index $curr_tag 9] eq "l"} { 00797 set start_tag [lsearch -inline -glob [$win tag names [lindex $range 0]] __lCommentStart:*] 00798 lappend ranges {*}[$win tag prevrange $start_tag [lindex $range 0]+1c] [lindex $range 1] 00799 } else { 00800 set start_tag [lsearch -inline -glob [$win tag names [lindex $range 0]] __cCommentStart:*] 00801 set end_tag [lsearch -inline -glob [$win tag names [lindex $range 1]-1c] __cCommentEnd:*] 00802 lappend ranges {*}[$win tag prevrange $start_tag [lindex $range 0]+1c] 00803 lappend ranges {*}[$win tag prevrange $end_tag [lindex $range 1]] 00804 } 00805 return $ranges 00806 } 00807 00808 return [list] 00809 00810 } 00811 00812 proc inBackTickRange {win index prange} { 00813 00814 return [inCommentStringRangeHelper $win $index __comstr0b* $prange] 00815 00816 } 00817 00818 proc inSingleQuoteRange {win index prange} { 00819 00820 return [inCommentStringRangeHelper $win $index __comstr0s* $prange] 00821 00822 } 00823 00824 proc inDoubleQuoteRange {win index prange} { 00825 00826 return [inCommentStringRangeHelper $win $index __comstr0d* $prange] 00827 00828 } 00829 00830 proc inTripleBackTickRange {win index prange} { 00831 00832 return [inCommentStringRangeHelper $win $index __comstr0B* $prange] 00833 00834 } 00835 00836 proc inTripleSingleQuoteRange {win index prange} { 00837 00838 return [inCommentStringRangeHelper $win $index __comstr0S* $prange] 00839 00840 } 00841 00842 proc inTripleDoubleQuoteRange {win index prange} { 00843 00844 return [inCommentStringRangeHelper $win $index __comstr0D* $prange] 00845 00846 } 00847 00848 proc inStringRange {win index prange} { 00849 00850 return [inCommentStringRangeHelper $win $index __comstr0* $prange] 00851 00852 } 00853 00854 proc inCommentStringRange {win index prange} { 00855 00856 return [inCommentStringRangeHelper $win $index __comstr* $prange] 00857 00858 } 00859 00860 ###################################################################### 00861 # Returns the text range for a bracketed block of text. 00862 proc inBlockRange {win type index prange} { 00863 00864 upvar $prange range 00865 00866 set range [list "" ""] 00867 00868 # Search backwards 00869 if {[lsearch [$win._t tag names $index] __${type}L] == -1} { 00870 set startpos $index 00871 } else { 00872 set startpos "$index+1c" 00873 } 00874 00875 if {[set left [getMatchBracket $win ${type}L $startpos]] ne ""} { 00876 set right [getMatchBracket $win ${type}R $left] 00877 if {($right eq "") || [$win._t compare $right < $index]} { 00878 return 0 00879 } else { 00880 set range [list [$win._t index $left] [$win._t index $right]] 00881 return 1 00882 } 00883 } 00884 00885 return 0 00886 00887 } 00888 00889 proc handleFocusIn {win} { 00890 00891 variable data 00892 00893 __ctextJunk$win configure -bg $data($win,config,-highlightcolor) 00894 00895 } 00896 00897 proc handleFocusOut {win} { 00898 00899 variable data 00900 00901 __ctextJunk$win configure -bg $data($win,config,-unhighlightcolor) 00902 00903 } 00904 00905 proc set_border_color {win color} { 00906 00907 __ctextJunk$win configure -bg $color 00908 00909 } 00910 00911 # Returns 1 if the character at the given index is escaped; otherwise, returns 0. 00912 proc isEscaped {win index} { 00913 00914 set names [$win tag names $index-1c] 00915 00916 return [expr {[string map {__escape {}} $names] ne $names}] 00917 00918 } 00919 00920 # Debugging procedure only 00921 proc undo_display {win} { 00922 00923 variable data 00924 00925 puts "Undo History (size: $data($win,config,undo_hist_size), sep_size: $data($win,config,undo_sep_size)):" 00926 00927 for {set i 0} {$i < $data($win,config,undo_hist_size)} {incr i} { 00928 puts -nonewline " [lindex $data($win,config,undo_hist) $i] " 00929 if {$data($win,config,undo_sep_next) == $i} { 00930 puts -nonewline " sep_next" 00931 } 00932 if {$data($win,config,undo_sep_last) == $i} { 00933 puts -nonewline " sep_last" 00934 } 00935 puts "" 00936 } 00937 00938 } 00939 00940 proc undo_separator {win} { 00941 00942 variable data 00943 00944 # puts "START undo_separator" 00945 # undo_display $win 00946 00947 # If a separator is being added (and it was not already added), add it 00948 if {$data($win,config,undo_sep_last) != ($data($win,config,undo_hist_size) - 1)} { 00949 00950 # Set the separator 00951 lset data($win,config,undo_hist) end 4 -1 00952 00953 # Get the last index of the undo history list 00954 set last_index [expr $data($win,config,undo_hist_size) - 1] 00955 00956 # Add the separator 00957 if {$data($win,config,undo_sep_next) == -1} { 00958 set data($win,config,undo_sep_next) $last_index 00959 } else { 00960 lset data($win,config,undo_hist) $data($win,config,undo_sep_last) 4 [expr $last_index - $data($win,config,undo_sep_last)] 00961 } 00962 00963 # Set the last separator index 00964 set data($win,config,undo_sep_last) $last_index 00965 00966 # Increment the separator size 00967 incr data($win,config,undo_sep_size) 00968 00969 # Increment the separator count 00970 incr data($win,config,undo_sep_count) 00971 00972 } 00973 00974 # If the number of separators exceeds the maximum length, shorten the undo history list 00975 undo_manage $win 00976 00977 # puts "END undo_separator" 00978 # undo_display $win 00979 00980 } 00981 00982 proc undo_manage {win} { 00983 00984 variable data 00985 00986 # If we need to make the undo history list shorter 00987 if {($data($win,config,-maxundo) > 0) && ([set to_remove [expr $data($win,config,undo_sep_size) - $data($win,config,-maxundo)]] > 0)} { 00988 00989 # Get the separators to remove 00990 set index $data($win,config,undo_sep_next) 00991 for {set i 1} {$i < $to_remove} {incr i} { 00992 incr index [lindex $data($win,config,undo_hist) $index 4] 00993 } 00994 00995 # Set the next separator index 00996 set data($win,config,undo_sep_next) [expr [lindex $data($win,config,undo_hist) $index 4] - 1] 00997 00998 # Reset the last separator index 00999 set data($win,config,undo_sep_last) [expr $data($win,config,undo_sep_last) - ($index + 1)] 01000 01001 # Set the separator size 01002 incr data($win,config,undo_sep_size) [expr 0 - $to_remove] 01003 01004 # Shorten the undo history list 01005 set data($win,config,undo_hist) [lreplace $data($win,config,undo_hist) 0 $index] 01006 01007 # Set the undo history size 01008 incr data($win,config,undo_hist_size) [expr 0 - ($index + 1)] 01009 01010 } 01011 01012 } 01013 01014 proc undo_insert {win insert_pos str_len cursor} { 01015 01016 variable data 01017 01018 if {!$data($win,config,-undo)} { 01019 return 01020 } 01021 01022 # puts "START undo_insert, insert_pos: $insert_pos, str_len: $str_len, cursor: $cursor" 01023 # undo_display $win 01024 01025 set end_pos [$win index "$insert_pos+${str_len}c"] 01026 01027 # Combine elements, if possible 01028 if {[llength $data($win,config,undo_hist)] > 0} { 01029 lassign [lindex $data($win,config,undo_hist) end] cmd val1 val2 hcursor sep 01030 if {$sep == 0} { 01031 if {($cmd eq "d") && ($val2 eq $insert_pos)} { 01032 lset data($win,config,undo_hist) end 2 $end_pos 01033 set data($win,config,redo_hist) [list] 01034 return 01035 } 01036 } 01037 } 01038 01039 # Add to the undo history 01040 lappend data($win,config,undo_hist) [list d $insert_pos $end_pos $cursor 0] 01041 incr data($win,config,undo_hist_size) 01042 01043 # Clear the redo history 01044 set data($win,config,redo_hist) [list] 01045 01046 # puts "END undo_insert" 01047 # undo_display $win 01048 01049 } 01050 01051 proc undo_delete {win start_pos end_pos} { 01052 01053 variable data 01054 01055 if {!$data($win,config,-undo)} { 01056 return 01057 } 01058 01059 # puts "START undo_delete, start_pos: $start_pos, end_pos: $end_pos" 01060 # undo_display $win 01061 01062 set str [$win get $start_pos $end_pos] 01063 01064 # Combine elements, if possible 01065 if {[llength $data($win,config,undo_hist)] > 0} { 01066 lassign [lindex $data($win,config,undo_hist) end] cmd val1 val2 cursor sep 01067 if {$sep == 0} { 01068 if {$cmd eq "i"} { 01069 if {$val1 eq $end_pos} { 01070 lset data($win,config,undo_hist) end 1 $start_pos 01071 lset data($win,config,undo_hist) end 2 "$str$val2" 01072 set data($win,config,redo_hist) [list] 01073 return 01074 } elseif {$val1 eq $start_pos} { 01075 lset data($win,config,undo_hist) end 2 "$val2$str" 01076 set data($win,config,redo_hist) [list] 01077 return 01078 } 01079 } elseif {($cmd eq "d") && ($val2 eq $end_pos)} { 01080 lset data($win,config,undo_hist) end 2 $start_pos 01081 lset data($win,config,redo_hist) [list] 01082 return 01083 } 01084 } 01085 } 01086 01087 # Add to the undo history 01088 lappend data($win,config,undo_hist) [list i $start_pos $str [$win index insert] 0] 01089 incr data($win,config,undo_hist_size) 01090 01091 # Clear the redo history 01092 set data($win,config,redo_hist) [list] 01093 01094 # puts "END undo_delete" 01095 # undo_display $win 01096 01097 } 01098 01099 proc undo_get_cursor_hist {win} { 01100 01101 variable data 01102 01103 set cursors [list] 01104 01105 if {[set index $data($win,config,undo_sep_next)] != -1} { 01106 01107 set sep 0 01108 01109 while {$sep != -1} { 01110 lassign [lindex $data($win,config,undo_hist) $index] cmd val1 val2 cursor sep 01111 lappend cursors $cursor 01112 incr index $sep 01113 } 01114 01115 } 01116 01117 return $cursors 01118 01119 } 01120 01121 proc undo {win} { 01122 01123 variable data 01124 01125 # puts "START undo" 01126 # undo_display $win 01127 01128 if {[llength $data($win,config,undo_hist)] > 0} { 01129 01130 set i 0 01131 set last_cursor 1.0 01132 set insert 0 01133 set ranges [list] 01134 set do_tags [list] 01135 set changed "" 01136 set sep_dec 0 01137 01138 foreach element [lreverse $data($win,config,undo_hist)] { 01139 01140 lassign $element cmd val1 val2 cursor sep 01141 01142 if {$sep} { 01143 if {$i == 0} { 01144 set sep_dec -1 01145 } else { 01146 break 01147 } 01148 } 01149 01150 switch $cmd { 01151 i { 01152 $win._t insert $val1 $val2 01153 append changed $val2 01154 set val2 [$win index "$val1+[string length $val2]c"] 01155 comments_do_tag $win $val1 $val2 do_tags 01156 set_rmargin $win $val1 $val2 01157 lappend data($win,config,redo_hist) [list d $val1 $val2 $cursor $sep] 01158 set insert 1 01159 } 01160 d { 01161 set str [$win get $val1 $val2] 01162 append changed $str 01163 comments_chars_deleted $win $val1 $val2 do_tags 01164 $win._t delete $val1 $val2 01165 lappend data($win,config,redo_hist) [list i $val1 $str $cursor $sep] 01166 } 01167 } 01168 01169 $win._t tag add hl [$win._t index "$val1 linestart"] [$win._t index "$val2 lineend"] 01170 01171 set last_cursor $cursor 01172 01173 incr i 01174 01175 } 01176 01177 # Get the list of affected lines that need to be re-highlighted 01178 set ranges [$win._t tag ranges hl] 01179 $win._t tag delete hl 01180 01181 # Perform the highlight 01182 if {[llength $ranges] > 0} { 01183 if {[highlightAll $win $ranges $insert $do_tags]} { 01184 checkAllBrackets $win 01185 } else { 01186 checkAllBrackets $win $changed 01187 } 01188 } 01189 01190 set data($win,config,undo_hist) [lreplace $data($win,config,undo_hist) end-[expr $i - 1] end] 01191 incr data($win,config,undo_hist_size) [expr 0 - $i] 01192 01193 # Set the last sep of the undo_hist list to -1 to indicate the end of the list 01194 if {$data($win,config,undo_hist_size) > 0} { 01195 lset data($win,config,undo_hist) end 4 -1 01196 } 01197 01198 # Update undo separator info 01199 set data($win,config,undo_sep_next) [expr ($data($win,config,undo_hist_size) == 0) ? -1 : $data($win,config,undo_sep_next)] 01200 set data($win,config,undo_sep_last) [expr $data($win,config,undo_hist_size) - 1] 01201 incr data($win,config,undo_sep_size) -1 01202 incr data($win,config,undo_sep_count) $sep_dec 01203 01204 ::tk::TextSetCursor $win.t $last_cursor 01205 modified $win 1 [list undo $ranges ""] 01206 01207 } 01208 01209 # puts "END undo" 01210 # undo_display $win 01211 01212 } 01213 01214 proc redo {win} { 01215 01216 variable data 01217 01218 if {[llength $data($win,config,redo_hist)] > 0} { 01219 01220 set i 0 01221 set insert 0 01222 set do_tags [list] 01223 set ranges [list] 01224 set changed "" 01225 01226 foreach element [lreverse $data($win,config,redo_hist)] { 01227 01228 lassign $element cmd val1 val2 cursor sep 01229 01230 switch $cmd { 01231 i { 01232 $win._t insert $val1 $val2 01233 append changed $val2 01234 set val2 [$win index "$val1+[string length $val2]c"] 01235 comments_do_tag $win.t $val1 $val2 do_tags 01236 set_rmargin $win $val1 $val2 01237 lappend data($win,config,undo_hist) [list d $val1 $val2 $cursor $sep] 01238 if {$cursor != $val2} { 01239 set cursor $val2 01240 } 01241 set insert 1 01242 } 01243 d { 01244 set str [$win get $val1 $val2] 01245 append changed $str 01246 comments_chars_deleted $win $val1 $val2 do_tags 01247 $win._t delete $val1 $val2 01248 lappend data($win,config,undo_hist) [list i $val1 $str $cursor $sep] 01249 if {$cursor != $val1} { 01250 set cursor $val1 01251 } 01252 } 01253 } 01254 01255 $win._t tag add hl [$win._t index "$val1 linestart"] [$win._t index "$val2 lineend"] 01256 01257 incr i 01258 01259 if {$sep} { 01260 break 01261 } 01262 01263 } 01264 01265 # Get the list of affected lines that need to be re-highlighted 01266 set ranges [$win._t tag ranges hl] 01267 $win._t tag delete hl 01268 01269 # Highlight the code 01270 if {[llength $ranges] > 0} { 01271 if {[highlightAll $win $ranges $insert $do_tags]} { 01272 checkAllBrackets $win 01273 } else { 01274 checkAllBrackets $win $changed 01275 } 01276 } 01277 01278 set data($win,config,redo_hist) [lreplace $data($win,config,redo_hist) end-[expr $i - 1] end] 01279 01280 # Set the sep field of the last separator field to match the number of elements added to 01281 # the undo_hist list. 01282 if {$data($win,config,undo_sep_last) >= 0} { 01283 lset data($win,config,undo_hist) $data($win,config,undo_sep_last) 4 $i 01284 } 01285 01286 # Update undo separator structures 01287 incr data($win,config,undo_hist_size) $i 01288 set data($win,config,undo_sep_next) [expr ($data($win,config,undo_sep_next) == -1) ? [expr $data($win,config,undo_hist_size) - 1] : $data($win,config,undo_sep_next)] 01289 set data($win,config,undo_sep_last) [expr $data($win,config,undo_hist_size) - 1] 01290 incr data($win,config,undo_sep_size) 01291 incr data($win,config,undo_sep_count) 01292 01293 ::tk::TextSetCursor $win.t $cursor 01294 modified $win 1 [list redo $ranges ""] 01295 01296 } 01297 01298 } 01299 01300 proc getGutterTags {win pos} { 01301 01302 set alltags [$win tag names $pos] 01303 set tags [lsearch -inline -all -glob $alltags gutter:*] 01304 lappend tags {*}[lsearch -inline -all -glob $alltags lmark*] 01305 01306 return $tags 01307 01308 } 01309 01310 ###################################################################### 01311 # Move all gutter tags from the old column 0 of the given row to the new 01312 # column 0 character. 01313 proc handleInsertAt0 {win startpos datalen} { 01314 01315 if {[lindex [split $startpos .] 1] == 0} { 01316 set endpos [$win index "$startpos+${datalen}c"] 01317 foreach tag [getGutterTags $win $endpos] { 01318 $win tag add $tag $startpos 01319 $win tag remove $tag $endpos 01320 } 01321 } 01322 01323 } 01324 01325 proc handleDeleteAt0Helper {win firstpos endpos} { 01326 01327 foreach tag [getGutterTags $win $firstpos] { 01328 $win._t tag add $tag $endpos 01329 } 01330 01331 } 01332 01333 ###################################################################### 01334 # Preserve gutter tags that will be deleted in column 0, moving them to 01335 # what will be the new column 0 after the deletion takes place. 01336 proc handleDeleteAt0 {win startpos endpos} { 01337 01338 lassign [split $startpos .] startrow startcol 01339 lassign [split $endpos .] endrow endcol 01340 01341 if {$startrow == $endrow} { 01342 if {$startcol == 0} { 01343 handleDeleteAt0Helper $win $startrow.0 $endpos 01344 } 01345 } elseif {$endcol != 0} { 01346 handleDeleteAt0Helper $win $endrow.0 $endpos 01347 } 01348 01349 } 01350 01351 ###################################################################### 01352 # Called prior to the deletion of the text for a text replacement. 01353 proc handleReplaceDeleteAt0 {win startpos endpos} { 01354 01355 lassign [split $startpos .] startrow startcol 01356 lassign [split $endpos .] endrow endcol 01357 01358 if {$startrow == $endrow} { 01359 if {$startcol == 0} { 01360 return [list 0 [getGutterTags $win $startrow.0]] 01361 } 01362 } elseif {$endcol != 0} { 01363 return [list 1 [getGutterTags $win $endrow.0]] 01364 } 01365 01366 return [list 0 [list]] 01367 01368 } 01369 01370 proc handleReplaceInsert {win startpos datalen tags} { 01371 01372 if {[lindex $tags 0]} { 01373 set insertpos [$win._t index "$startpos+${datalen}c"] 01374 } else { 01375 set insertpos $startpos 01376 } 01377 01378 foreach tag $tags { 01379 $win._t tag add $tag $insertpos 01380 } 01381 01382 } 01383 01384 proc instanceCmd {win cmd args} { 01385 01386 variable data 01387 01388 switch -glob -- $cmd { 01389 append { return [command_append $win {*}$args] } 01390 cget { return [command_cget $win {*}$args] } 01391 conf* { return [command_configure $win {*}$args] } 01392 copy { return [command_copy $win {*}$args] } 01393 cut { return [command_cut $win {*}$args] } 01394 delete { return [command_delete $win {*}$args] } 01395 diff { return [command_diff $win {*}$args] } 01396 edit { return [command_edit $win {*}$args] } 01397 fastdelete { return [command_fastdelete $win {*}$args] } 01398 fastinsert { return [command_fastinsert $win {*}$args] } 01399 fastreplace { return [command_fastreplace $win {*}$args] } 01400 gutter { return [command_gutter $win {*}$args] } 01401 highlight { return [command_highlight $win {*}$args] } 01402 insert { return [command_insert $win {*}$args] } 01403 is { return [command_is $win {*}$args] } 01404 replace { return [command_replace $win {*}$args] } 01405 paste { return [command_paste $win {*}$args] } 01406 peer { return [command_peer $win {*}$args] } 01407 syntax { return [command_syntax $win {*}$args] } 01408 tag { return [command_tag $win {*}$args] } 01409 language { return [command_language $win {*}$args] } 01410 default { return [uplevel 1 [linsert $args 0 $win._t $cmd]] } 01411 } 01412 01413 } 01414 01415 proc command_append {win args} { 01416 01417 variable data 01418 01419 switch [llength $args] { 01420 1 - 01421 2 { 01422 catch { clipboard append -displayof $win [$win._t get {*}$args] } 01423 } 01424 default { 01425 catch { clipboard append -displayof $win [$win._t get sel.first sel.last] } 01426 } 01427 } 01428 01429 } 01430 01431 proc command_cget {win args} { 01432 01433 variable data 01434 01435 set arg [lindex $args 0] 01436 01437 foreach flag $data($win,config,ctextFlags) { 01438 if {[string match ${arg}* $flag]} { 01439 return [set data($win,config,$flag)] 01440 } 01441 } 01442 01443 return [$win._t cget $arg] 01444 01445 } 01446 01447 proc command_configure {win args} { 01448 01449 variable data 01450 01451 if {[llength $args] == 0} { 01452 set res [$win._t configure] 01453 foreach opt [list -xscrollcommand* -yscrollcommand* -autoseparators*] { 01454 set del [lsearch -glob $res $opt] 01455 set res [lreplace $res $del $del] 01456 } 01457 foreach flag $data($win,config,ctextFlags) { 01458 lappend res [list $flag [set data($win,config,$flag)]] 01459 } 01460 return $res 01461 } 01462 01463 array set flags {} 01464 foreach flag $data($win,config,ctextFlags) { 01465 set loc [lsearch $args $flag] 01466 if {$loc < 0} { 01467 continue 01468 } 01469 01470 if {[llength $args] <= ($loc + 1)} { 01471 return [list $flag [set data($win,config,$flag)]] 01472 } 01473 01474 set flagArg [lindex $args [expr {$loc + 1}]] 01475 set args [lreplace $args $loc [expr {$loc + 1}]] 01476 set flags($flag) $flagArg 01477 } 01478 01479 # Parse the argument list and process the value changes 01480 set update_linemap 0 01481 foreach {valueList flag cmd} $data($win,config,argTable) { 01482 if {[info exists flags($flag)]} { 01483 foreach valueToCheckFor $valueList { 01484 set value [set flags($flag)] 01485 if {[string equal "any" $valueToCheckFor]} $cmd \ 01486 elseif {[string equal $valueToCheckFor [set flags($flag)]]} $cmd 01487 } 01488 } 01489 } 01490 01491 # If we need to update the linemap, do it now 01492 if {$update_linemap} { 01493 linemapUpdate $win 1 01494 } 01495 01496 if {[llength $args]} { 01497 uplevel 1 [linsert $args 0 $win._t configure] 01498 } 01499 01500 } 01501 01502 proc command_copy {win args} { 01503 01504 variable data 01505 01506 # Get the start and end indices 01507 if {![catch {$win.t index sel.first} start_index]} { 01508 set end_index [$win.t index sel.last] 01509 } else { 01510 set start_index [$win.t index "insert linestart"] 01511 set end_index [$win.t index "insert+1l linestart"] 01512 } 01513 01514 # Clear and copy the data to the clipboard 01515 clipboard clear -displayof $win.t 01516 clipboard append -displayof $win.t [$win.t get $start_index $end_index] 01517 01518 } 01519 01520 proc command_cut {win args} { 01521 01522 variable data 01523 01524 # Get the start and end indices 01525 if {![catch {$win.t index sel.first} start_index]} { 01526 set end_index [$win.t index sel.last] 01527 } else { 01528 set start_index [$win.t index "insert linestart"] 01529 set end_index [$win.t index "insert+1l linestart"] 01530 } 01531 01532 # Clear and copy the data to the clipboard 01533 clipboard clear -displayof $win.t 01534 clipboard append -displayof $win.t [$win.t get $start_index $end_index] 01535 01536 # Delete the text 01537 $win delete $start_index $end_index 01538 01539 } 01540 01541 proc command_delete {win args} { 01542 01543 variable data 01544 01545 set moddata [list] 01546 if {[lindex $args 0] eq "-moddata"} { 01547 set args [lassign $args dummy moddata] 01548 } 01549 01550 set startPos [$win._t index [lindex $args 0]] 01551 if {[llength $args] == 1} { 01552 set endPos [$win._t index $startPos+1c] 01553 } else { 01554 set endPos [$win._t index [lindex $args 1]] 01555 } 01556 set ranges [list [$win._t index "$startPos linestart"] [$win._t index "$startPos lineend"]] 01557 set deldata [$win._t get $startPos $endPos] 01558 set do_tags [list] 01559 01560 undo_delete $win $startPos $endPos 01561 handleDeleteAt0 $win $startPos $endPos 01562 linemapCheckOnDelete $win $startPos $endPos 01563 comments_chars_deleted $win $startPos $endPos do_tags 01564 01565 $win._t delete $startPos $endPos 01566 01567 if {[highlightAll $win $ranges 0 $do_tags]} { 01568 checkAllBrackets $win 01569 } else { 01570 checkAllBrackets $win $deldata 01571 } 01572 modified $win 1 [list delete $ranges $moddata] 01573 01574 event generate $win.t <<CursorChanged>> 01575 01576 } 01577 01578 proc command_diff {win args} { 01579 01580 variable data 01581 01582 set args [lassign $args subcmd] 01583 if {!$data($win,config,-diff_mode)} { 01584 return -code error "diff $subcmd called when -diff_mode is false" 01585 } 01586 switch -glob $subcmd { 01587 add { 01588 if {[llength $args] != 2} { 01589 return -code error "diff add takes two arguments: startline linecount" 01590 } 01591 01592 lassign $args tline count 01593 01594 # Get the current diff:A tag 01595 set tag [lsearch -inline -glob [$win._t tag names $tline.0] diff:A:*] 01596 01597 # Get the beginning and ending position 01598 lassign [$win._t tag ranges $tag] start_pos end_pos 01599 01600 # Get the line number embedded in the tag 01601 set fline [expr [lindex [split $tag :] 3] + [$win._t count -lines $start_pos $tline.0]] 01602 01603 # Replace the diff:B tag 01604 $win._t tag remove $tag $tline.0 $end_pos 01605 01606 # Add new tags 01607 set pos [$win._t index "$tline.0+${count}l linestart"] 01608 $win._t tag add diff:A:D:$fline $tline.0 $pos 01609 $win._t tag add diff:A:S:$fline $pos $end_pos 01610 01611 # Colorize the *D* tag 01612 $win._t tag configure diff:A:D:$fline -background $data($win,config,-diffaddbg) 01613 $win._t tag lower diff:A:D:$fline _invisible 01614 } 01615 line { 01616 if {[llength $args] != 2} { 01617 return -code error "diff line takes two arguments: txtline type" 01618 } 01619 if {[set type_index [lsearch [list add sub] [lindex $args 1]]] == -1} { 01620 return -code error "diff line second argument must be add or sub" 01621 } 01622 set tag [lsearch -inline -glob [$win._t tag names [lindex $args 0].0] diff:[lindex [list B A] $type_index]:*] 01623 lassign [split $tag :] dummy index type line 01624 if {$type eq "S"} { 01625 incr line [$win._t count -lines [lindex [$win._t tag ranges $tag] 0] [lindex $args 0].0] 01626 } 01627 return $line 01628 } 01629 ranges { 01630 if {[llength $args] != 1} { 01631 return -code error "diff ranges takes one argument: type" 01632 } 01633 if {[lsearch [list add sub both] [lindex $args 0]] == -1} { 01634 return -code error "diff ranges argument must be add, sub or both" 01635 } 01636 set ranges [list] 01637 if {[lsearch [list add both] [lindex $args 0]] != -1} { 01638 foreach tag [lsearch -inline -all -glob [$win._t tag names] diff:A:D:*] { 01639 lappend ranges {*}[$win._t tag ranges $tag] 01640 } 01641 } 01642 if {[lsearch [list sub both] [lindex $args 0]] != -1} { 01643 foreach tag [lsearch -inline -all -glob [$win._t tag names] diff:B:D:*] { 01644 lappend ranges {*}[$win._t tag ranges $tag] 01645 } 01646 } 01647 return [lsort -dictionary $ranges] 01648 } 01649 reset { 01650 foreach name [lsearch -inline -all -glob [$win._t tag names] diff:*] { 01651 lassign [split $name :] dummy which type 01652 if {($which eq "B") && ($type eq "D") && ([llength [set ranges [$win._t tag ranges $name]]] > 0)} { 01653 $win._t delete {*}$ranges 01654 } 01655 $win._t tag delete $name 01656 } 01657 $win._t tag add diff:A:S:1 1.0 end 01658 $win._t tag add diff:B:S:1 1.0 end 01659 } 01660 sub { 01661 if {[llength $args] != 3} { 01662 return -code error "diff sub takes three arguments: startline linecount str" 01663 } 01664 01665 lassign $args tline count str 01666 01667 # Get the current diff: tags 01668 set tagA [lsearch -inline -glob [$win._t tag names $tline.0] diff:A:*] 01669 set tagB [lsearch -inline -glob [$win._t tag names $tline.0] diff:B:*] 01670 01671 # Get the beginning and ending positions 01672 lassign [$win._t tag ranges $tagA] start_posA end_posA 01673 lassign [$win._t tag ranges $tagB] start_posB end_posB 01674 01675 # Get the line number embedded in the tag 01676 set fline [expr [lindex [split $tagB :] 3] + [$win._t count -lines $start_posB $tline.0]] 01677 01678 # Remove the diff: tags 01679 $win._t tag remove $tagA $start_posA $end_posA 01680 $win._t tag remove $tagB $start_posB $end_posB 01681 01682 # Calculate the end position of the change 01683 set pos [$win._t index "$tline.0+${count}l linestart"] 01684 01685 # Insert the string and highlight it 01686 $win._t insert $tline.0 $str 01687 $win highlight -insert 1 $tline.0 $pos 01688 01689 # Add the tags 01690 $win._t tag add $tagA $start_posA [$win._t index "$end_posA+${count}l linestart"] 01691 $win._t tag add $tagB $start_posB $tline.0 01692 $win._t tag add diff:B:D:$fline $tline.0 $pos 01693 $win._t tag add diff:B:S:$fline $pos [$win._t index "$end_posB+${count}l linestart"] 01694 01695 # Colorize the *D* tag 01696 $win._t tag configure diff:B:D:$fline -background $data($win,config,-diffsubbg) 01697 $win._t tag lower diff:B:D:$fline _invisible 01698 } 01699 } 01700 linemapUpdate $win 1 01701 01702 } 01703 01704 proc command_fastdelete {win args} { 01705 01706 variable data 01707 01708 set moddata [list] 01709 set do_update 1 01710 set do_undo 1 01711 while {[string index [lindex $args 0] 0] eq "-"} { 01712 switch [lindex $args 0] { 01713 "-moddata" { set args [lassign $args dummy moddata] } 01714 "-update" { set args [lassign $args dummy do_update] } 01715 "-undo" { set args [lassign $args dummy do_undo] } 01716 } 01717 } 01718 01719 if {[llength $args] == 1} { 01720 set startPos [$win._t index [lindex $args 0]] 01721 set endPos [$win._t index "$startPos+1c"] 01722 linemapCheckOnDelete $win $startPos 01723 } else { 01724 set startPos [$win._t index [lindex $args 0]] 01725 set endPos [$win._t index [lindex $args 1]] 01726 linemapCheckOnDelete $win $startPos $endPos 01727 } 01728 01729 if {$do_undo} { 01730 undo_delete $win $startPos $endPos 01731 } 01732 handleDeleteAt0 $win $startPos $endPos 01733 01734 $win._t delete {*}$args 01735 01736 if {$do_update} { 01737 modified $win 1 [list delete [list $startPos $endPos] $moddata] 01738 event generate $win.t <<CursorChanged>> 01739 } 01740 01741 } 01742 01743 proc command_fastinsert {win args} { 01744 01745 variable data 01746 01747 set moddata [list] 01748 set do_update 1 01749 set do_undo 1 01750 while {[string index [lindex $args 0] 0] eq "-"} { 01751 switch [lindex $args 0] { 01752 "-moddata" { set args [lassign $args dummy moddata] } 01753 "-update" { set args [lassign $args dummy do_update] } 01754 "-undo" { set args [lassign $args dummy do_undo] } 01755 } 01756 } 01757 01758 set startPos [$win._t index [lindex $args 0]] 01759 set chars [string length [lindex $args 1]] 01760 set cursor [$win._t index insert] 01761 01762 $win._t insert {*}$args 01763 01764 set endPos [$win._t index "$startPos+${chars}c"] 01765 01766 if {$do_undo} { 01767 undo_insert $win $startPos $chars $cursor 01768 } 01769 handleInsertAt0 $win._t $startPos $chars 01770 set_rmargin $win $startPos $endPos 01771 01772 if {$do_update} { 01773 modified $win 1 [list insert [list $startPos $endPos] $moddata] 01774 event generate $win.t <<CursorChanged>> 01775 } 01776 01777 } 01778 01779 proc command_fastreplace {win args} { 01780 01781 variable data 01782 01783 if {[llength $args] < 3} { 01784 return -code error "please use at least 3 arguments to $win replace" 01785 } 01786 01787 set moddata [list] 01788 set do_update 1 01789 set do_undo 1 01790 while {[string index [lindex $args 0] 0] eq "-"} { 01791 switch [lindex $args 0] { 01792 "-moddata" { set args [lassign $args dummy moddata] } 01793 "-update" { set args [lassign $args dummy do_update] } 01794 "-undo" { set args [lassign $args dummy do_undo] } 01795 } 01796 } 01797 01798 set startPos [$win._t index [lindex $args 0]] 01799 set endPos [$win._t index [lindex $args 1]] 01800 set datlen [string length [lindex $args 2]] 01801 set cursor [$win._t index insert] 01802 01803 if {$do_undo} { 01804 undo_delete $win $startPos $endPos 01805 } 01806 01807 set tags [handleReplaceDeleteAt0 $win $startPos $endPos] 01808 01809 # Perform the text replacement 01810 $win._t replace {*}$args 01811 01812 handleReplaceInsert $win $startPos $datlen $tags 01813 set_rmargin $win $startPos [$win._t index "$startPos+${datlen}c"] 01814 01815 if {$do_undo} { 01816 undo_insert $win $startPos $datlen $cursor 01817 } 01818 01819 if {$do_update} { 01820 modified $win 1 [list replace [list $startPos $endPos] $moddata] 01821 event generate $win.t <<CursorChanged>> 01822 } 01823 01824 } 01825 01826 proc command_highlight {win args} { 01827 01828 variable data 01829 01830 set moddata [list] 01831 set insert 0 01832 set dotags "" 01833 set modified 0 01834 set ranges [list] 01835 01836 while {[string index [lindex $args 0] 0] eq "-"} { 01837 switch [lindex $args 0] { 01838 "-moddata" { set args [lassign $args dummy moddata] } 01839 "-insert" { set args [lassign $args dummy insert] } 01840 "-dotags" { set args [lassign $args dummy dotags] } 01841 "-modified" { set args [lassign $args dummy]; set modified 1 } 01842 default { 01843 return -code error "Unknown option specified ([lindex $args 0])" 01844 } 01845 } 01846 } 01847 01848 foreach {start end} $args { 01849 lappend ranges [$win._t index "$start linestart"] [$win._t index "$end lineend"] 01850 } 01851 01852 highlightAll $win $ranges $insert $dotags 01853 modified $win $modified [list highlight $ranges $moddata] 01854 01855 } 01856 01857 proc command_insert {win args} { 01858 01859 variable data 01860 01861 if {[llength $args] < 2} { 01862 return -code error "please use at least 2 arguments to $win insert" 01863 } 01864 01865 set moddata [list] 01866 if {[lindex $args 0] eq "-moddata"} { 01867 set args [lassign $args dummy moddata] 01868 } 01869 01870 set insertPos [$win._t index [lindex $args 0]] 01871 set cursor [$win._t index insert] 01872 set dat "" 01873 set do_tags [list] 01874 01875 if {[lindex $args 0] eq "end"} { 01876 set lineStart [$win._t index "$insertPos-1c linestart"] 01877 } else { 01878 set lineStart [$win._t index "$insertPos linestart"] 01879 } 01880 01881 # Gather the data 01882 foreach {chars taglist} [lrange $args 1 end] { 01883 append dat $chars 01884 } 01885 set datlen [string length $dat] 01886 01887 # Add the embedded language tag to the arguments if taglists are present 01888 if {([llength $args] >= 3) && ([set lang [getLang $win $insertPos]] ne "")} { 01889 set tag_index 2 01890 foreach {chars taglist} [lrange $args 1 end] { 01891 lappend taglist __Lang:$lang 01892 lset args $tag_index $taglist 01893 incr tag_index 2 01894 } 01895 } 01896 01897 $win._t insert {*}$args 01898 01899 set lineEnd [$win._t index "${insertPos}+${datlen}c lineend"] 01900 01901 undo_insert $win $insertPos $datlen $cursor 01902 handleInsertAt0 $win._t $insertPos $datlen 01903 set_rmargin $win $insertPos "$insertPos+${datlen}c" 01904 comments_do_tag $win $insertPos "$insertPos+${datlen}c" do_tags 01905 01906 # Highlight text and bracket auditing 01907 if {[highlightAll $win [list $lineStart $lineEnd] 1 $do_tags]} { 01908 checkAllBrackets $win 01909 } else { 01910 checkAllBrackets $win $dat 01911 } 01912 modified $win 1 [list insert [list $lineStart $lineEnd] $moddata] 01913 01914 event generate $win.t <<CursorChanged>> 01915 01916 } 01917 01918 # Answers questions about a given index 01919 proc command_is {win args} { 01920 01921 if {[llength $args] < 2} { 01922 return -code error "Incorrect arguments passed to ctext is command" 01923 } 01924 01925 lassign $args type extra index 01926 01927 switch $type { 01928 escaped { return [isEscaped $win [$win._t index $extra]] } 01929 firstchar { 01930 set index [$win._t index $extra] 01931 set prewhite [$win._t tag prevrange __prewhite "$index+1c"] 01932 return [expr {($prewhite ne "") && [$win._t compare [lindex $prewhite 1] == "$index+1c"]}] 01933 } 01934 curly - 01935 square - 01936 paren - 01937 angled { 01938 if {[lsearch [list left right any] $extra] == -1} { 01939 set index [$win._t index $extra] 01940 set extra "any" 01941 } else { 01942 set index [$win._t index $index] 01943 } 01944 array set chars [list left L right R any *] 01945 return [expr [lsearch [$win._t tag names $index] __$type$chars($extra)] != -1] 01946 } 01947 double - 01948 single - 01949 btick - 01950 tripledouble - 01951 triplesingle - 01952 triplebtick { 01953 if {[lsearch [list left right any] $extra] == -1} { 01954 set index [$win._t index $extra] 01955 set extra "any" 01956 } else { 01957 set index [$win._t index $index] 01958 } 01959 array set chars [list double d single s btick b tripledouble D triplesingle S triplebtick B] 01960 return [isQuote $win $chars($type) $index $extra] 01961 } 01962 indent - 01963 unindent - 01964 reindent - 01965 reindentStart { 01966 return [expr [lsearch [$win._t tag names $extra] __$type] != -1] 01967 } 01968 insquare - 01969 incurly - 01970 inparen - 01971 inangled { 01972 if {$index ne ""} { 01973 upvar 2 $index range 01974 } 01975 return [inBlockRange $win [string range $type 2 end] $extra range] 01976 } 01977 indouble - 01978 insingle - 01979 inbtick - 01980 intripledouble - 01981 intriplesingle - 01982 intriplebtick - 01983 inblockcomment - 01984 inlinecomment - 01985 incomment - 01986 instring - 01987 incommentstring { 01988 array set procs { 01989 indouble DoubleQuote 01990 insingle SingleQuote 01991 inbtick BackTick 01992 intripledouble TripleDoubleQuote 01993 intriplesingle TripleSingleQuote 01994 intriplebtick TripleBackTick 01995 inblockcomment BlockComment 01996 inlinecomment LineComment 01997 incomment Comment 01998 instring String 01999 incommentstring CommentString 02000 } 02001 if {$index ne ""} { 02002 upvar 2 $index range 02003 return [in$procs($type)Range $win [$win._t index $extra] range] 02004 } else { 02005 return [in$procs($type) $win [$win._t index $extra]] 02006 } 02007 } 02008 inclass { 02009 if {$extra eq ""} { 02010 return -code error "Calling ctext is inclass without specifying a class name" 02011 } 02012 if {[lsearch -exact [$win._t tag names $extra] __$index] != -1} { 02013 set range [$win._t tag prevrange __$extra "[$win._t index $index]+1c"] 02014 return 1 02015 } else { 02016 return 0 02017 } 02018 } 02019 default { 02020 return -code error "Unsupported is command type specified" 02021 } 02022 } 02023 02024 } 02025 02026 proc isQuote {win char index side} { 02027 02028 if {$side eq ""} { 02029 set side "any" 02030 } elseif {[lsearch [list left right any] $side] == -1} { 02031 return -code error "ctext 'is' command $type called with an illegal side value" 02032 } 02033 02034 if {[lsearch [$win._t tag names $index] __${char}Quote*] != -1} { 02035 if {$side eq "any"} { 02036 return 1 02037 } else { 02038 set tag [lsearch -inline [$win._t tag names $index] __comstr0${char}*] 02039 set range [$win._t tag prevrange $tag "$index+1c"] 02040 return [expr {($side eq "left") ? [$win._t compare [lindex $range 0] == $index] : [$win._t compare [lindex $range 1] == "$index+1c"]}] 02041 } 02042 } 02043 02044 return 0 02045 02046 } 02047 02048 proc command_replace {win args} { 02049 02050 variable data 02051 02052 if {[llength $args] < 3} { 02053 return -code error "please use at least 3 arguments to $win replace" 02054 } 02055 02056 set moddata [list] 02057 if {[lindex $args 0] eq "-moddata"} { 02058 set args [lassign $args dummy moddata] 02059 } 02060 02061 set startPos [$win._t index [lindex $args 0]] 02062 set endPos [$win._t index [lindex $args 1]] 02063 set dat "" 02064 foreach {chars taglist} [lrange $args 2 end] { 02065 append dat $chars 02066 } 02067 set datlen [string length $dat] 02068 set deldata [$win._t get $startPos $endPos] 02069 set cursor [$win._t index insert] 02070 set do_tags [list] 02071 02072 undo_delete $win $startPos $endPos 02073 comments_chars_deleted $win $startPos $endPos do_tags 02074 set tags [handleReplaceDeleteAt0 $win $startPos $endPos] 02075 02076 # Perform the text replacement 02077 $win._t replace {*}$args 02078 02079 handleReplaceInsert $win $startPos $datlen $tags 02080 undo_insert $win $startPos $datlen $cursor 02081 02082 set lineStart [$win._t index "$startPos linestart"] 02083 set lineEnd [$win._t index "$startPos+[expr $datlen + 1]c lineend"] 02084 02085 if {[llength $do_tags] == 0} { 02086 comments_do_tag $win $startPos "$startPos+${datlen}c" do_tags 02087 } 02088 set_rmargin $win $startPos "$startPos+${datlen}c" 02089 02090 set comstr [highlightAll $win [list $lineStart $lineEnd] 1 $do_tags] 02091 if {$comstr == 2} { 02092 checkAllBrackets $win 02093 } elseif {$comstr == 1} { 02094 checkAllBrackets $win [$win._t get $startPos $lineEnd] 02095 } else { 02096 checkAllBrackets $win "$deldata$dat" 02097 } 02098 modified $win 1 [list replace [list $startPos $endPos] $moddata] 02099 02100 event generate $win.t <<CursorChanged>> 02101 02102 } 02103 02104 proc command_paste {win args} { 02105 02106 variable data 02107 02108 set moddata [list] 02109 if {[lindex $args 0] eq "-moddata"} { 02110 set args [lassign $args dummy moddata] 02111 } 02112 02113 set insertPos [$win._t index insert] 02114 set datalen [string length [clipboard get]] 02115 02116 tk_textPaste $win 02117 02118 handleInsertAt0 $win._t $insertPos $datalen 02119 modified $win 1 [list insert [list $insertPos [$win._t index "$insertPos+${datalen}c"]] $moddata] 02120 event generate $win.t <<CursorChanged>> 02121 02122 } 02123 02124 proc command_peer {win args} { 02125 02126 variable data 02127 02128 switch [lindex $args 0] { 02129 names { 02130 set names [list] 02131 foreach name [$win._t peer names] { 02132 lappend names [winfo parent $name] 02133 } 02134 return $names 02135 } 02136 default { 02137 return -code error "unknown peer subcommand: [lindex $args 0]" 02138 } 02139 } 02140 02141 } 02142 02143 # This command helps process any syntax highlighting functionality of this widget. 02144 proc command_syntax {win args} { 02145 02146 variable data 02147 02148 set args [lassign $args subcmd] 02149 02150 switch $subcmd { 02151 add { $win._t tag add __[lindex $args 0] {*}[lrange $args 1 end] } 02152 addclass { addHighlightClass $win {*}$args } 02153 addwords { addHighlightKeywords $win {*}$args } 02154 addregexp { addHighlightRegexp $win {*}$args } 02155 addcharstart { addHighlightWithOnlyCharStart $win {*}$args } 02156 addlinecomments { addLineCommentPatterns $win {*}$args } 02157 addblockcomments { addBlockCommentPatterns $win {*}$args } 02158 addstrings { addStringPatterns $win {*}$args } 02159 addembedlang { addEmbedLangPattern $win {*}$args } 02160 search { highlightSearch $win {*}$args } 02161 delete { 02162 switch [lindex $args 0] { 02163 class - 02164 classes { 02165 foreach class [lrange $args 1 end] { 02166 deleteHighlightClass $win $class 02167 } 02168 } 02169 command - 02170 commands { 02171 foreach command [lrange $args 1 end] { 02172 deleteHighlightCommand $win $command 02173 } 02174 } 02175 all { 02176 foreach class [getHighlightClasses $win] { 02177 deleteHighlightClass $win $class 02178 } 02179 deleteHighlightCommand $win * 02180 } 02181 default { 02182 return -code error "Unknown syntax delete specifier ([lindex $args 0])" 02183 } 02184 } 02185 } 02186 classes { return [getHighlightClasses $win {*}$args] } 02187 metaclasses { return $data($win,config,meta_classes) } 02188 clear { 02189 switch [llength $args] { 02190 0 { 02191 foreach class [getHighlightClasses $win] { 02192 $win tag remove __$class 1.0 end 02193 } 02194 } 02195 1 { 02196 $win tag remove __[lindex $args 0] 1.0 end 02197 } 02198 2 { 02199 foreach class [getHighlightClasses $win] { 02200 $win tag remove __$class {*}$args 02201 } 02202 } 02203 3 { 02204 $win tag remove __[lindex $args 0] {*}[lrange $args 1 end] 02205 } 02206 default { 02207 return -code error "Invalid arguments passed to syntax clear command" 02208 } 02209 } 02210 } 02211 contains { return [expr [lsearch [$win._t tag names [lindex $args 1]] __[lindex $args 0]] != -1] } 02212 nextrange { return [$win tag nextrange __[lindex $args 0] {*}[lrange $args 1 end]] } 02213 prevrange { return [$win tag prevrange __[lindex $args 0] {*}[lrange $args 1 end]] } 02214 ranges { return [$win tag ranges __[lindex $args 0]] } 02215 highlight { 02216 set i 0 02217 while {[string index [lindex $args $i] 0] eq "-"} { incr i 2 } 02218 array set opts { 02219 -moddata {} 02220 -insert 0 02221 -dotags {} 02222 -modified 0 02223 } 02224 array set opts [lrange $args 0 [expr $i - 1]] 02225 set ranges [list] 02226 foreach {start end} [lrange $args $i end] { 02227 lappend ranges [$win._t index "$start linestart"] [$win._t index "$end lineend"] 02228 } 02229 highlightAll $win $ranges $opts(-insert) $opts(-dotags) 02230 modified $win $opts(-modified) [list highlight $ranges $opts(-moddata)] 02231 } 02232 configure { return [$win._t tag configure __[lindex $args 0] {*}[lrange $args 1 end]] } 02233 cget { return [$win._t tag cget __[lindex $args 0] {*}[lrange $args 1 end]] } 02234 default { 02235 return -code error [format "%s ($subcmd)" [msgcat::mc "Unknown ctext syntax subcommand"]] 02236 } 02237 } 02238 02239 } 02240 02241 # We need to guarantee that embedded language tags are always listed as lowest 02242 # priority, so if someone calls the lower tag subcommand, we need to make sure 02243 # that it won't be placed lower than an embedded language tag. 02244 proc command_tag {win args} { 02245 02246 variable range_cache 02247 02248 set args [lassign $args subcmd] 02249 02250 switch $subcmd { 02251 place { 02252 set args [lassign $args tag] 02253 if {[llength $args] == 0} { 02254 array set opts [$win._t tag configure $tag] 02255 if {$opts(-background) ne ""} { 02256 $win._t tag lower $tag _visibleH 02257 } elseif {($opts(-foreground) ne "") || ($opts(-font) ne "")} { 02258 $win._t tag lower $tag _visibleL 02259 } else { 02260 $win._t tag lower $tag _invisible 02261 } 02262 } else { 02263 switch [lindex $args 0] { 02264 visible1 { $win._t tag lower $tag _visibleH } 02265 visible2 { $win._t tag raise $tag _visibleL } 02266 visible3 { $win._t tag lower $tag _visibleL } 02267 visible4 { $win._t tag raise $tag _invisible } 02268 invisible { $win._t tag lower $tag _invisible } 02269 priority { $win._t tag raise $tag _visibleH } 02270 default { return -code error "Invalid tag place value ([lindex $args 0])" } 02271 } 02272 } 02273 } 02274 nextrange - 02275 prevrange { 02276 set args0 [set args1 [lassign $args tag]] 02277 set indent_tags [list __indent __unindent __reindent __reindentStart] 02278 set bracket_tags [list __curlyL __curlyR __squareL __squareR __parenL __parenR __angledL __angledR] 02279 if {[string map [list $tag {}] $indent_tags] ne $indent_tags} { 02280 if {$subcmd eq "nextrange"} { 02281 lassign [$win._t tag nextrange ${tag}0 {*}$args0] s0 e0 02282 while {($s0 ne "") && ([inCommentString $win $s0] || [isEscaped $win $s0])} { 02283 lset args0 0 $e0 02284 lassign [$win._t tag nextrange ${tag}0 {*}$args0] s0 e0 02285 } 02286 lassign [$win._t tag nextrange ${tag}1 {*}$args1] s1 e1 02287 while {($s1 ne "") && ([inCommentString $win $s1] || [isEscaped $win $s1])} { 02288 lset args1 0 $e1 02289 lassign [$win._t tag nextrange ${tag}0 {*}$args1] s1 e1 02290 } 02291 } else { 02292 lassign [$win._t tag prevrange ${tag}0 {*}$args0] s0 e0 02293 while {($s0 ne "") && ([inCommentString $win $s0] || [isEscaped $win $s0])} { 02294 lset args0 0 $s0 02295 lassign [$win._t tag prevrange ${tag}0 {*}$args0] s0 e0 02296 } 02297 lassign [$win._t tag prevrange ${tag}1 {*}$args1] s1 e1 02298 while {($s1 ne "") && ([inCommentString $win $s1] || [isEscaped $win $s1])} { 02299 lset args1 0 $s1 02300 lassign [$win._t tag prevrange ${tag}0 {*}$args1] s1 e1 02301 } 02302 } 02303 if {$s0 eq ""} { 02304 if {$s1 eq ""} { 02305 return "" 02306 } else { 02307 return [list $s1 $e1] 02308 } 02309 } else { 02310 if {$s1 eq ""} { 02311 return [list $s0 $e0] 02312 } else { 02313 if {[$win._t compare $s0 [expr {($subcmd eq "nextrange") ? "<" : ">"}] $s1]} { 02314 return [list $s0 $e0] 02315 } else { 02316 return [list $s1 $e1] 02317 } 02318 } 02319 } 02320 } elseif {[string map [list $tag {}] $bracket_tags] ne $bracket_tags} { 02321 if {$subcmd eq "nextrange"} { 02322 lassign [$win._t tag nextrange $tag {*}$args0] s e 02323 while {($s ne "") && ([inCommentString $win $s] || ([isEscaped $win $s] && ([$win._t index "$s+1c"] eq $e)))} { 02324 lset args0 0 $e 02325 lassign [$win._t tag nextrange $tag {*}$args0] s e 02326 } 02327 } else { 02328 lassign [$win._t tag prevrange $tag {*}$args0] s e 02329 if {($s ne "") && ![inCommentString $win $s] && [isEscaped $win $s] && [$win._t compare "$s+1c" == [lindex $args0 0]]} { 02330 lassign [$win._t tag prevrange $tag $s {*}[lrange $args0 1 end]] s e 02331 } 02332 while {($s ne "") && ([inCommentString $win $s] || ([isEscaped $win $s] && ([$win._t index "$s+1c"] eq $e)))} { 02333 lset args0 0 $s 02334 lassign [$win._t tag prevrange $tag {*}$args0] s e 02335 } 02336 } 02337 if {$s eq ""} { 02338 return "" 02339 } elseif {[isEscaped $win $s]} { 02340 return [list [$win._t index "$s+1c"] $e] 02341 } else { 02342 return [list $s $e] 02343 } 02344 } else { 02345 return [$win._t tag $subcmd $tag {*}$args0] 02346 } 02347 } 02348 ranges { 02349 set tag [lindex $args 0] 02350 set bracket_tags [list __curlyL __curlyR __squareL __squareR __parenL __parenR __angledL __angledR] 02351 if {[string map [list $tag {}] $bracket_tags] ne $bracket_tags} { 02352 if {![info exists range_cache($win,$tag)]} { 02353 set range_cache($win,$tag) [list] 02354 foreach {s e} [$win._t tag ranges $tag] { 02355 if {![inCommentString $win $s]} { 02356 if {![isEscaped $win $s] || ([set s [$win._t index "$s+1c"]] ne $e)} { 02357 lappend range_cache($win,$tag) $s $e 02358 } 02359 } 02360 } 02361 } 02362 return $range_cache($win,$tag) 02363 } else { 02364 return [$win._t tag ranges $tag] 02365 } 02366 } 02367 default { 02368 return [$win._t tag $subcmd {*}$args] 02369 } 02370 } 02371 02372 } 02373 02374 proc command_edit {win args} { 02375 02376 variable data 02377 02378 switch [lindex $args 0] { 02379 modified { 02380 switch [llength $args] { 02381 1 { 02382 return $data($win,config,modified) 02383 } 02384 2 { 02385 set value [lindex $args 1] 02386 set data($win,config,modified) $value 02387 } 02388 default { 02389 return -code error "invalid arg(s) to $win edit modified: $args" 02390 } 02391 } 02392 } 02393 undo { 02394 undo $win 02395 } 02396 redo { 02397 redo $win 02398 } 02399 undoable { 02400 return [expr $data($win,config,undo_hist_size) > 0] 02401 } 02402 redoable { 02403 return [expr [llength $data($win,config,redo_hist)] > 0] 02404 } 02405 separator { 02406 if {[llength $data($win,config,undo_hist)] > 0} { 02407 undo_separator $win 02408 } 02409 } 02410 undocount { 02411 if {$data($win,config,undo_hist_size) == 0} { 02412 return 0 02413 } else { 02414 return [expr $data($win,config,undo_sep_count) + (([lindex $data($win,config,undo_hist) end 4] == 0) ? 1 : 0)] 02415 } 02416 } 02417 reset { 02418 set data($win,config,undo_hist) [list] 02419 set data($win,config,undo_hist_size) 0 02420 set data($win,config,undo_sep_next) -1 02421 set data($win,config,undo_sep_last) -1 02422 set data($win,config,undo_sep_size) 0 02423 set data($win,config,undo_sep_count) 0 02424 set data($win,config,redo_hist) [list] 02425 set data($win,config,modified) false 02426 } 02427 cursorhist { 02428 return [undo_get_cursor_hist $win] 02429 } 02430 default { 02431 return [uplevel 1 [linsert $args 0 $win._t $cmd]] 02432 } 02433 } 02434 02435 } 02436 02437 proc command_gutter {win args} { 02438 02439 variable data 02440 02441 set args [lassign $args subcmd] 02442 switch -glob $subcmd { 02443 create { 02444 set value_list [lassign $args gutter_name] 02445 set gutter_tags [list] 02446 foreach {name opts} $value_list { 02447 array set sym_opts $opts 02448 set sym [expr {[info exists sym_opts(-symbol)] ? $sym_opts(-symbol) : ""}] 02449 set gutter_tag "gutter:$gutter_name:$name:$sym" 02450 if {[info exists sym_opts(-fg)]} { 02451 set data($win,gutterfg,$gutter_tag) $sym_opts(-fg) 02452 } 02453 if {[info exists sym_opts(-onenter)]} { 02454 $win.l bind $gutter_tag <Enter> [list ctext::execute_gutter_cmd $win %y $sym_opts(-onenter)] 02455 } 02456 if {[info exists sym_opts(-onleave)]} { 02457 $win.l bind $gutter_tag <Leave> [list ctext::execute_gutter_cmd $win %y $sym_opts(-onleave)] 02458 } 02459 if {[info exists sym_opts(-onclick)]} { 02460 $win.l bind $gutter_tag <Button-1> [list ctext::execute_gutter_cmd $win %y $sym_opts(-onclick)] 02461 } 02462 if {[info exists sym_opts(-onshiftclick)]} { 02463 $win.l bind $gutter_tag <Shift-Button-1> [list ctext::execute_gutter_cmd $win %y $sym_opts(-onshiftclick)] 02464 } 02465 if {[info exists sym_opts(-oncontrolclick)]} { 02466 $win.l bind $gutter_tag <Control-Button-1> [list ctext::execute_gutter_cmd $win %y $sym_opts(-oncontrolclick)] 02467 } 02468 lappend gutter_tags $gutter_tag 02469 array unset sym_opts 02470 } 02471 lappend data($win,config,gutters) [list $gutter_name $gutter_tags 0] 02472 linemapUpdate $win 1 02473 } 02474 destroy { 02475 set gutter_name [lindex $args 0] 02476 if {[set index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] != -1} { 02477 $win._t tag delete {*}[lindex $data($win,config,gutters) $index 1] 02478 set data($win,config,gutters) [lreplace $data($win,config,gutters) $index $index] 02479 array unset data $win,gutterfg,gutter:$gutter_name:* 02480 linemapUpdate $win 1 02481 } 02482 } 02483 hide { 02484 set gutter_name [lindex $args 0] 02485 if {[set index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] != -1} { 02486 if {[llength $args] == 1} { 02487 return [lindex $data($win,config,gutters) $index 2] 02488 } else { 02489 lset data($win,config,gutters) $index 2 [lindex $args 1] 02490 linemapUpdate $win 1 02491 } 02492 } elseif {[llength $args] == 1} { 02493 return -code error "Unable to find gutter name ($gutter_name)" 02494 } 02495 } 02496 del* { 02497 lassign $args gutter_name sym_list 02498 set update_needed 0 02499 if {[set gutter_index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] == -1} { 02500 return -code error "Unable to find gutter name ($gutter_name)" 02501 } 02502 foreach symname $sym_list { 02503 set gutters [lindex $data($win,config,gutters) $gutter_index 1] 02504 if {[set index [lsearch -glob $gutters "gutter:$gutter_name:$symname:*"]] != -1} { 02505 $win._t tag delete [lindex $gutters $index] 02506 set gutters [lreplace $gutters $index $index] 02507 array unset data $win,gutterfg,gutter:$gutter_name:$symname:* 02508 lset data($win,config,gutters) $gutter_index 1 $gutters 02509 set update_needed 1 02510 } 02511 } 02512 if {$update_needed} { 02513 linemapUpdate $win 1 02514 } 02515 } 02516 set { 02517 set args [lassign $args gutter_name] 02518 set update_needed 0 02519 if {[set gutter_index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] != -1} { 02520 foreach {name line_nums} $args { 02521 if {[set gutter_tag [lsearch -inline -glob [lindex $data($win,config,gutters) $gutter_index 1] gutter:$gutter_name:$name:*]] ne ""} { 02522 foreach line_num $line_nums { 02523 if {[set curr_tag [lsearch -inline -glob [$win._t tag names $line_num.0] gutter:$gutter_name:*]] ne ""} { 02524 if {$curr_tag ne $gutter_tag} { 02525 $win._t tag delete $curr_tag 02526 $win._t tag add $gutter_tag $line_num.0 02527 set update_needed 1 02528 } 02529 } else { 02530 $win._t tag add $gutter_tag $line_num.0 02531 set update_needed 1 02532 } 02533 } 02534 } 02535 } 02536 } 02537 if {$update_needed} { 02538 linemapUpdate $win 1 02539 } 02540 } 02541 get { 02542 if {[llength $args] == 1} { 02543 set gutter_name [lindex $args 0] 02544 set symbols [list] 02545 if {[set gutter_index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] != -1} { 02546 foreach gutter_tag [lindex $data($win,config,gutters) $gutter_index 1] { 02547 set lines [list] 02548 foreach {first last} [$win._t tag ranges $gutter_tag] { 02549 lappend lines [lindex [split $first .] 0] 02550 } 02551 lappend symbols [lindex [split $gutter_tag :] 2] $lines 02552 } 02553 } 02554 return $symbols 02555 } elseif {[llength $args] == 2} { 02556 set gutter_name [lindex $args 0] 02557 if {[string is integer [lindex $args 1]]} { 02558 set line_num [lindex $args 1] 02559 if {[set tag [lsearch -inline -glob [$win._t tag names $line_num.0] gutter:$gutter_name:*]] ne ""} { 02560 return [lindex [split $tag :] 2] 02561 } else { 02562 return "" 02563 } 02564 } else { 02565 set lines [list] 02566 if {[set tag [lsearch -inline -glob [$win._t tag names] gutter:$gutter_name:[lindex $args 1]:*]] ne ""} { 02567 foreach {first last} [$win._t tag ranges $tag] { 02568 lappend lines [lindex [split $first .] 0] 02569 } 02570 } 02571 return $lines 02572 } 02573 } 02574 } 02575 clear { 02576 set last [lassign $args gutter_name first] 02577 if {[set gutter_index [lsearch -index 0 $data($win,config,gutters) $gutter_name]] != -1} { 02578 if {$last eq ""} { 02579 foreach gutter_tag [lindex $data($win,config,gutters) $gutter_index 1] { 02580 $win._t tag remove $gutter_tag $first.0 02581 } 02582 } else { 02583 foreach gutter_tag [lindex $data($win,config,gutters) $gutter_index 1] { 02584 $win._t tag remove $gutter_tag $first.0 [$win._t index $last.0+1c] 02585 } 02586 } 02587 linemapUpdate $win 1 02588 } 02589 } 02590 cget { 02591 lassign $args gutter_name sym_name opt 02592 if {[set index [lsearch -exact -index 0 $data($win,config,gutters) $gutter_name]] == -1} { 02593 return -code error "Unable to find gutter name ($gutter_name)" 02594 } 02595 if {[set gutter_tag [lsearch -inline -glob [lindex $data($win,config,gutters) $index 1] "gutter:$gutter_name:$sym_name:*"]] eq ""} { 02596 return -code error "Unknown symbol ($sym_name) specified" 02597 } 02598 switch $opt { 02599 -symbol { return [lindex [split $gutter_tag :] 3] } 02600 -fg { return [expr {[info exists data($win,gutterfg,$gutter_tag)] ? $data($win,gutterfg,$gutter_tag) : ""}] } 02601 -onenter { return [lrange [$win.l bind $gutter_tag <Enter>] 0 end-1] } 02602 -onleave { return [lrange [$win.l bind $gutter_tag <Leave>] 0 end-1] } 02603 -onclick { return [lrange [$win.l bind $gutter_tag <Button-1>] 0 end-1] } 02604 -onshiftclick { return [lrange [$win.l bind $gutter_tag <Shift-Button-1>] 0 end-1] } 02605 -oncontrolclick { return [lrange [$win.l bind $gutter_tag <Control-Button-1>] 0 end-1] } 02606 default { 02607 return -code error "Unknown gutter option ($opt) specified" 02608 } 02609 } 02610 } 02611 conf* { 02612 set args [lassign $args gutter_name] 02613 if {[set index [lsearch -exact -index 0 $data($win,config,gutters) $gutter_name]] == -1} { 02614 return -code error "Unable to find gutter name ($gutter_name)" 02615 } 02616 if {[llength $args] < 2} { 02617 if {[llength $args] == 0} { 02618 set match_tag "gutter:$gutter_name:*" 02619 } else { 02620 set match_tag "gutter:$gutter_name:[lindex $args 0]:*" 02621 } 02622 foreach gutter_tag [lsearch -inline -all -glob [lindex $data($win,config,gutters) $index 1] $match_tag] { 02623 lassign [split $gutter_tag :] dummy1 dummy2 symname sym 02624 set symopts [list] 02625 if {$sym ne ""} { 02626 lappend symopts -symbol $sym 02627 } 02628 if {[info exists data($win,gutterfg,$gutter_tag)]} { 02629 lappend symopts -fg $data($win,gutterfg,$gutter_tag) 02630 } 02631 if {[set cmd [lrange [$win.l bind $gutter_tag <Enter>] 0 end-1]] ne ""} { 02632 lappend symopts -onenter $cmd 02633 } 02634 if {[set cmd [lrange [$win.l bind $gutter_tag <Leave>] 0 end-1]] ne ""} { 02635 lappend symopts -onleave $cmd 02636 } 02637 if {[set cmd [lrange [$win.l bind $gutter_tag <Button-1>] 0 end-1]] ne ""} { 02638 lappend symopts -onclick $cmd 02639 } 02640 if {[set cmd [lrange [$win.l bind $gutter_tag <Shift-Button-1>] 0 end-1]] ne ""} { 02641 lappend symopts -onshiftclick $cmd 02642 } 02643 if {[set cmd [lrange [$win.l bind $gutter_tag <Control-Button-1>] 0 end-1]] ne ""} { 02644 lappend symopts -oncontrolclick $cmd 02645 } 02646 lappend gutters $symname $symopts 02647 } 02648 return $gutters 02649 } else { 02650 set args [lassign $args symname] 02651 set update_needed 0 02652 if {[set gutter_tag [lsearch -inline -glob [lindex $data($win,config,gutters) $index 1] "gutter:$gutter_name:$symname:*"]] eq ""} { 02653 return -code error "Unable to find gutter symbol name ($symname)" 02654 } 02655 foreach {opt value} $args { 02656 switch -glob $opt { 02657 -sym* { 02658 set ranges [$win._t tag ranges $gutter_tag] 02659 set opts [$win._t tag configure $gutter_tag] 02660 $win._t tag delete $gutter_tag 02661 set gutter_tag "gutter:$gutter_name:$symname:$value" 02662 $win._t tag configure $gutter_tag {*}$opts 02663 $win._t tag add $gutter_tag {*}$ranges 02664 set update_needed 1 02665 } 02666 -fg { 02667 if {$value ne ""} { 02668 set data($win,gutterfg,$gutter_tag) $value 02669 } else { 02670 array unset data $win,gutterfg,$gutter_tag 02671 } 02672 set update_needed 1 02673 } 02674 -onenter { 02675 $win.l bind $gutter_tag <Enter> [list ctext::execute_gutter_cmd $win %y $value] 02676 } 02677 -onleave { 02678 $win.l bind $gutter_tag <Leave> [list ctext::execute_gutter_cmd $win %y $value] 02679 } 02680 -onclick { 02681 $win.l bind $gutter_tag <Button-1> [list ctext::execute_gutter_cmd $win %y $value] 02682 } 02683 -onshiftclick { 02684 $win.l bind $gutter_tag <Shift-Button-1> [list ctext::execute_gutter_cmd $win %y $value] 02685 } 02686 -oncontrolclick { 02687 $win.l bind $gutter_tag <Control-Button-1> [list ctext::execute_gutter_cmd $win %y $value] 02688 } 02689 default { 02690 return -code error "Unknown gutter option ($opt) specified" 02691 } 02692 } 02693 } 02694 if {$update_needed} { 02695 linemapUpdate $win 1 02696 } 02697 } 02698 } 02699 names { 02700 set names [list] 02701 foreach gutter $data($win,config,gutters) { 02702 lappend names [lindex $gutter 0] 02703 } 02704 return $names 02705 } 02706 } 02707 02708 } 02709 02710 proc execute_gutter_cmd {win y cmd} { 02711 02712 # Get the line of the text widget 02713 set line [lindex [split [$win.t index @0,$y] .] 0] 02714 02715 # Execute the command 02716 uplevel #0 [list {*}$cmd $win $line] 02717 02718 } 02719 02720 proc getAutoMatchChars {win lang} { 02721 02722 variable data 02723 02724 set chars [list] 02725 02726 foreach name [array names data $win,config,matchChar,$lang,*] { 02727 lappend chars [lindex [split $name ,] 4] 02728 } 02729 02730 return $chars 02731 02732 } 02733 02734 proc setAutoMatchChars {win lang matchChars} { 02735 02736 variable data 02737 02738 # Clear the matchChars 02739 catch { array unset data $win,config,matchChar,$lang,* } 02740 02741 # Remove the brackets 02742 foreach type [list curly square paren angled] { 02743 catch { $win._t tag delete missing:$type } 02744 } 02745 02746 # Set the matchChars 02747 foreach matchChar $matchChars { 02748 set data($win,config,matchChar,$lang,$matchChar) 1 02749 } 02750 02751 # Set the bracket auditing tags 02752 foreach matchChar [list curly square paren angled] { 02753 if {[info exists data($win,config,matchChar,$lang,$matchChar)]} { 02754 $win._t tag configure missing:$matchChar -background $data($win,config,-matchaudit_bg) 02755 $win._t tag raise missing:$matchChar _visibleH 02756 } 02757 } 02758 02759 } 02760 02761 proc matchBracket {win} { 02762 02763 variable data 02764 02765 # Remove the match cursor 02766 catch { $win tag remove matchchar 1.0 end } 02767 02768 # If we are in block cursor mode, use the previous character 02769 if {![$win cget -blockcursor] && [$win compare insert != "insert linestart"]} { 02770 set pos "insert-1c" 02771 } else { 02772 set pos insert 02773 } 02774 02775 # If the current character is escaped, ignore the character 02776 if {[isEscaped $win $pos]} { 02777 return 02778 } 02779 02780 # Get the current language 02781 set lang [getLang $win $pos] 02782 02783 switch -- [$win get $pos] { 02784 "\}" { matchPair $win $lang $pos curlyL } 02785 "\{" { matchPair $win $lang $pos curlyR } 02786 "\]" { matchPair $win $lang $pos squareL } 02787 "\[" { matchPair $win $lang $pos squareR } 02788 "\)" { matchPair $win $lang $pos parenL } 02789 "\(" { matchPair $win $lang $pos parenR } 02790 ">" { matchPair $win $lang $pos angledL } 02791 "<" { matchPair $win $lang $pos angledR } 02792 "\"" { matchQuote $win $lang $pos comstr0d double } 02793 "'" { matchQuote $win $lang $pos comstr0s single } 02794 "`" { matchQuote $win $lang $pos comstr0b btick } 02795 } 02796 02797 } 02798 02799 ###################################################################### 02800 # Returns the index of the bracket type previous to the given index. 02801 proc getPrevBracket {win stype {index insert}} { 02802 02803 lassign [$win tag prevrange __$stype $index] first last 02804 02805 if {$last eq ""} { 02806 return "" 02807 } elseif {[$win compare $last < $index]} { 02808 return [$win index "$last-1c"] 02809 } else { 02810 return [$win index "$index-1c"] 02811 } 02812 02813 } 02814 02815 ###################################################################### 02816 # Returns the index of the bracket type after the given index. 02817 proc getNextBracket {win stype {index insert}} { 02818 02819 lassign [$win tag prevrange __$stype "$index+1c"] first last 02820 02821 if {($last ne "") && [$win compare "$index+1c" < $last]} { 02822 return [$win index "$index+1c"] 02823 } else { 02824 lassign [$win tag nextrange __$stype "$index+1c"] first last 02825 return $first 02826 } 02827 02828 } 02829 02830 ###################################################################### 02831 # Returns the index of the matching bracket type where 'type' is the 02832 # type of bracket to find. For example, if the current bracket is 02833 # a left square bracket, call this procedure as: 02834 # getMatchBracket $txt squareR 02835 proc getMatchBracket {win stype {index insert}} { 02836 02837 set count 1 02838 02839 if {[string index $stype end] eq "R"} { 02840 02841 set otype [string range $stype 0 end-1]L 02842 02843 lassign [$win tag nextrange __$stype "$index+1c"] sfirst slast 02844 lassign [$win tag prevrange __$otype $index] ofirst olast 02845 set ofirst "$index+1c" 02846 02847 if {($olast eq "") || [$win compare $olast < $index]} { 02848 lassign [$win tag nextrange __$otype $index] dummy olast 02849 } 02850 02851 while {($olast ne "") && ($slast ne "")} { 02852 if {[$win compare $slast < $olast]} { 02853 if {[incr count -[$win count -chars $sfirst $slast]] <= 0} { 02854 return "$slast-[expr 1 - $count]c" 02855 } 02856 lassign [$win tag nextrange __$stype "$slast+1c"] sfirst slast 02857 } else { 02858 incr count [$win count -chars $ofirst $olast] 02859 lassign [$win tag nextrange __$otype "$olast+1c"] ofirst olast 02860 } 02861 } 02862 02863 while {$slast ne ""} { 02864 if {[incr count -[$win count -chars $sfirst $slast]] <= 0} { 02865 return "$slast-[expr 1 - $count]c" 02866 } 02867 lassign [$win tag nextrange __$stype "$slast+1c"] sfirst slast 02868 } 02869 02870 } else { 02871 02872 set otype [string range $stype 0 end-1]R 02873 02874 lassign [$win tag prevrange __$stype $index] sfirst slast 02875 lassign [$win tag prevrange __$otype $index] ofirst olast 02876 02877 if {($olast ne "") && [$win compare $olast >= $index]} { 02878 set olast $index 02879 } 02880 02881 while {($ofirst ne "") && ($sfirst ne "")} { 02882 if {[$win compare $sfirst > $ofirst]} { 02883 if {[incr count -[$win count -chars $sfirst $slast]] <= 0} { 02884 return "$sfirst+[expr 0 - $count]c" 02885 } 02886 lassign [$win tag prevrange __$stype $sfirst] sfirst slast 02887 } else { 02888 incr count [$win count -chars $ofirst $olast] 02889 lassign [$win tag prevrange __$otype $ofirst] ofirst olast 02890 } 02891 } 02892 02893 while {$sfirst ne ""} { 02894 if {[incr count -[$win count -chars $sfirst $slast]] <= 0} { 02895 return "$sfirst+[expr 0 - $count]c" 02896 } 02897 lassign [$win tag prevrange __$stype $sfirst] sfirst slast 02898 } 02899 02900 } 02901 02902 return "" 02903 02904 } 02905 02906 proc matchPair {win lang pos type} { 02907 02908 variable data 02909 02910 if {![info exists data($win,config,matchChar,$lang,[string range $type 0 end-1])] || \ 02911 [inCommentString $win $pos]} { 02912 return 02913 } 02914 02915 if {[set pos [getMatchBracket $win $type [$win index $pos]]] ne ""} { 02916 $win tag add matchchar $pos 02917 } 02918 02919 } 02920 02921 proc matchQuote {win lang pos tag type} { 02922 02923 variable data 02924 02925 if {![info exists data($win,config,matchChar,$lang,$type)]} { 02926 return 02927 } 02928 02929 # Get the actual tag to check for 02930 set tag [lsearch -inline [$win tag names $pos] __$tag*] 02931 02932 lassign [$win tag nextrange $tag $pos] first last 02933 02934 if {$first eq [$win index $pos]} { 02935 if {[$win compare $last != end]} { 02936 $win tag add matchchar "$last-1c" 02937 } 02938 } else { 02939 lassign [$win tag prevrange $tag $pos] first last 02940 if {$first ne ""} { 02941 $win tag add matchchar $first 02942 } 02943 } 02944 02945 } 02946 02947 proc checkAllBrackets {win {str ""}} { 02948 02949 variable data 02950 02951 # If the mismcatching char option is cleared, don't continue 02952 if {!$data($win,config,-matchaudit)} { 02953 return 02954 } 02955 02956 # We don't have support for bracket auditing in embedded languages as of yet 02957 set lang "" 02958 02959 # If a string was supplied, only perform bracket check for brackets found in string 02960 if {$str ne ""} { 02961 if {[info exists data($win,config,matchChar,$lang,curly)] && ([string map {\{ {} \} {} \\ {}} $str] ne $str)} { checkBracketType $win curly } 02962 if {[info exists data($win,config,matchChar,$lang,square)] && ([string map {\[ {} \] {} \\ {}} $str] ne $str)} { checkBracketType $win square } 02963 if {[info exists data($win,config,matchChar,$lang,paren)] && ([string map {( {} ) {} \\ {}} $str] ne $str)} { checkBracketType $win paren } 02964 if {[info exists data($win,config,matchChar,$lang,angled)] && ([string map {< {} > {} \\ {}} $str] ne $str)} { checkBracketType $win angled } 02965 02966 # Otherwise, check all of the brackets 02967 } else { 02968 foreach type [list square curly paren angled] { 02969 if {[info exists data($win,config,matchChar,$lang,$type)]} { 02970 checkBracketType $win $type 02971 } 02972 } 02973 } 02974 02975 } 02976 02977 proc checkBracketType {win stype} { 02978 02979 variable data 02980 02981 # Clear missing 02982 $win._t tag remove missing:$stype 1.0 end 02983 02984 set count 0 02985 set other ${stype}R 02986 set olist [lassign [$win.t tag ranges __$other] ofirst olast] 02987 set missing [list] 02988 02989 # Perform count for all code containing left stypes 02990 foreach {sfirst slast} [$win.t tag ranges __${stype}L] { 02991 while {($ofirst ne "") && [$win.t compare $sfirst > $ofirst]} { 02992 if {[incr count -[$win._t count -chars $ofirst $olast]] < 0} { 02993 lappend missing "$olast+${count}c" $olast 02994 set count 0 02995 } 02996 set olist [lassign $olist ofirst olast] 02997 } 02998 if {$count == 0} { 02999 set start $sfirst 03000 } 03001 incr count [$win._t count -chars $sfirst $slast] 03002 } 03003 03004 # Perform count for all right types after the above code 03005 while {$ofirst ne ""} { 03006 if {[incr count -[$win._t count -chars $ofirst $olast]] < 0} { 03007 lappend missing "$olast+${count}c" $olast 03008 set count 0 03009 } 03010 set olist [lassign $olist ofirst olast] 03011 } 03012 03013 # Highlight all brackets that are missing right stypes 03014 while {$count > 0} { 03015 lappend missing $start "$start+1c" 03016 set start [getNextBracket $win ${stype}L $start] 03017 incr count -1 03018 } 03019 03020 # Highlight all brackets that are missing left stypes 03021 catch { $win._t tag add missing:$stype {*}$missing } 03022 03023 } 03024 03025 ###################################################################### 03026 # Places the cursor on the next or previous mismatching bracket and 03027 # makes it visible in the editing window. If the -check option is 03028 # set, returns 0 to indicate that the given option is invalid; otherwise, 03029 # returns 1. 03030 proc gotoBracketMismatch {win dir args} { 03031 03032 variable data 03033 03034 # If the current text buffer was not highlighted, do it now 03035 if {!$data($win,config,-matchaudit)} { 03036 return 0 03037 } 03038 03039 array set opts { 03040 -check 0 03041 } 03042 array set opts $args 03043 03044 # Find the previous/next index 03045 if {$dir eq "next"} { 03046 set index end 03047 foreach type [list square curly paren angled] { 03048 lassign [$win._t tag nextrange missing:$type "insert+1c"] first 03049 if {($first ne "") && [$win._t compare $first < $index]} { 03050 set index $first 03051 } 03052 } 03053 } else { 03054 set index 1.0 03055 foreach type [list square curly paren angled] { 03056 lassign [$win._t tag prevrange missing:$type insert] first 03057 if {($first ne "") && [$win._t compare $first > $index]} { 03058 set index $first 03059 } 03060 } 03061 } 03062 03063 # Make sure that the current bracket is in view 03064 if {[lsearch [$win._t tag names $index] missing:*] != -1} { 03065 if {!$opts(-check)} { 03066 ::tk::TextSetCursor $win.t $index 03067 $win._t see $index 03068 } 03069 return 1 03070 } 03071 03072 return 0 03073 03074 } 03075 03076 proc getLang {win index} { 03077 03078 return [lindex [split [lindex [$win tag names $index] 0] =] 1] 03079 03080 } 03081 03082 proc clearCommentStringPatterns {win} { 03083 03084 variable data 03085 03086 array unset data $win,config,csl_patterns,* 03087 array unset data $win,csl_char_tags,* 03088 array unset data $win,lc_char_tags,* 03089 03090 set data($win,config,csl_array) [list] 03091 set data($win,config,csl_markers) [list] 03092 set data($win,config,csl_tag_pair) [list] 03093 set data($win,config,csl_tags) [list] 03094 03095 } 03096 03097 proc addBlockCommentPatterns {win lang patterns} { 03098 03099 variable data 03100 03101 set start_patterns [list] 03102 set end_patterns [list] 03103 03104 foreach pattern $patterns { 03105 lappend start_patterns [lindex $pattern 0] 03106 lappend end_patterns [lindex $pattern 1] 03107 } 03108 03109 if {[llength $patterns] > 0} { 03110 lappend data($win,config,csl_patterns,$lang) __cCommentStart:$lang "" ([join $start_patterns |]) 03111 lappend data($win,config,csl_patterns,$lang) __cCommentEnd:$lang "" ([join $end_patterns |]) 03112 } 03113 03114 array set tags [list __cCommentStart:${lang}0 1 __cCommentStart:${lang}1 1 __cCommentEnd:${lang}0 1 __cCommentEnd:${lang}1 1 __comstr1c0 1 __comstr1c1 1] 03115 03116 if {[llength $patterns] > 0} { 03117 array set theme $data($win,config,-theme) 03118 $win tag configure __comstr1c0 -foreground $theme(comments) 03119 $win tag configure __comstr1c1 -foreground $theme(comments) 03120 $win tag lower __comstr1c0 _visibleH 03121 $win tag lower __comstr1c1 _visibleH 03122 foreach tag [list __cCommentStart:${lang}0 __cCommentStart:${lang}1 __cCommentEnd:${lang}0 __cCommentEnd:${lang}1] { 03123 $win tag configure $tag 03124 $win tag lower $tag _invisible 03125 } 03126 lappend data($win,config,csl_char_tags,$lang) __cCommentStart:$lang __cCommentEnd:$lang 03127 lappend data($win,config,csl_array) {*}[array get tags] 03128 lappend data($win,config,csl_markers) __cCommentStart:${lang}0 __cCommentStart:${lang}1 __cCommentEnd:${lang}0 __cCommentEnd:${lang}1 03129 lappend data($win,config,csl_tag_pair) __cCommentStart:$lang __comstr1c 03130 lappend data($win,config,csl_tags) __comstr1c0 __comstr1c1 03131 } else { 03132 catch { $win tag delete {*}[array names tags] } 03133 } 03134 03135 } 03136 03137 proc addLineCommentPatterns {win lang patterns} { 03138 03139 variable data 03140 03141 if {[llength $patterns] > 0} { 03142 lappend data($win,config,csl_patterns,$lang) __lCommentStart:$lang "" ([join $patterns |]) 03143 } 03144 03145 array set tags [list __lCommentStart:${lang}0 1 __lCommentStart:${lang}1 1 __comstr1l 1] 03146 03147 if {[llength $patterns] > 0} { 03148 array set theme $data($win,config,-theme) 03149 $win tag configure __comstr1l -foreground $theme(comments) 03150 $win tag lower __comstr1l _visibleH 03151 foreach tag [list __lCommentStart:${lang}0 __lCommentStart:${lang}1] { 03152 $win tag configure $tag 03153 $win tag lower $tag _invisible 03154 } 03155 lappend data($win,config,lc_char_tags,$lang) __lCommentStart:$lang 03156 lappend data($win,config,csl_array) {*}[array get tags] 03157 lappend data($win,config,csl_markers) __lCommentStart:${lang}0 __lCommentStart:${lang}1 03158 lappend data($win,config,csl_tags) __comstr1l 03159 } else { 03160 catch { $win tag delete {*}[array names tags] } 03161 } 03162 03163 } 03164 03165 proc addStringPatterns {win lang types} { 03166 03167 variable data 03168 03169 set csl_patterns [list] 03170 03171 # Combine types 03172 array set type_array [list] 03173 foreach type $types { set type_array($type) 1 } 03174 foreach {val pat1 pat2} [list double (\") (\"\"\") single (') (''') btick (`) (```)] { 03175 set c [string index $val 0] 03176 if {[info exists type_array($val)]} { 03177 if {[info exists type_array(triple$val)]} { 03178 lappend csl_patterns "__${c}Quote:$lang" "__[string toupper $c]Quote:$lang" $pat1|$pat2 03179 unset type_array(triple$val) 03180 } else { 03181 lappend csl_patterns "__${c}Quote:$lang" "" $pat1 03182 } 03183 unset type_array($val) 03184 } elseif {[info exists type_array(triple$val)]} { 03185 lappend csl_patterns "__[string toupper $c]Quote:$lang" "" $pat2 03186 unset type_array(triple$val) 03187 } 03188 } 03189 foreach type [array names type_array] { 03190 lappend csl_patterns "__sQuote:$lang" "" $type 03191 } 03192 03193 array set tags [list \ 03194 __sQuote:${lang}0 1 __sQuote:${lang}1 1 \ 03195 __SQuote:${lang}0 1 __SQuote:${lang}1 1 \ 03196 __dQuote:${lang}0 1 __dQuote:${lang}1 1 \ 03197 __DQuote:${lang}0 1 __DQuote:${lang}1 1 \ 03198 __bQuote:${lang}0 1 __bQuote:${lang}1 1 \ 03199 __BQuote:${lang}0 1 __BQuote:${lang}1 1 \ 03200 __comstr0s0 1 __comstr0s1 1 \ 03201 __comstr0S0 1 __comstr0S1 1 \ 03202 __comstr0d0 1 __comstr0d1 1 \ 03203 __comstr0D0 1 __comstr0D1 1 \ 03204 __comstr0b0 1 __comstr0b1 1 \ 03205 __comstr0B0 1 __comstr0B1 1 \ 03206 ] 03207 03208 array set comstr [list \ 03209 __dQuote:$lang __comstr0d \ 03210 __DQuote:$lang __comstr0D \ 03211 __sQuote:$lang __comstr0s \ 03212 __SQuote:$lang __comstr0S \ 03213 __bQuote:$lang __comstr0b \ 03214 __BQuote:$lang __comstr0B \ 03215 ] 03216 03217 if {[llength $types] > 0} { 03218 array set theme $data($win,config,-theme) 03219 foreach {tag1 tag2 pattern} $csl_patterns { 03220 foreach rb {0 1} { 03221 $win tag configure $comstr($tag1)$rb -foreground $theme(strings) 03222 $win tag configure $tag1$rb 03223 $win tag lower $comstr($tag1)$rb _visibleH 03224 $win tag lower $tag1$rb _invisible 03225 lappend data($win,config,csl_tags) $comstr($tag1)$rb 03226 } 03227 lappend data($win,config,csl_char_tags,$lang) $tag1 03228 if {$tag2 ne ""} { 03229 foreach rb {0 1} { 03230 $win tag configure $comstr($tag2)$rb -foreground $theme(strings) 03231 $win tag configure $tag2$rb 03232 $win tag lower $comstr($tag2)$rb _visibleH 03233 $win tag lower $tag2$rb _invisible 03234 } 03235 lappend data($win,config,csl_char_tags,$lang) $tag2 03236 lappend data($win,config,csl_tags) $comstr($tag2)$rb 03237 } 03238 } 03239 lappend data($win,config,csl_patterns,$lang) {*}$csl_patterns 03240 lappend data($win,config,csl_array) {*}[array get tags] 03241 lappend data($win,config,csl_markers) __dQuote:${lang}0 __dQuote:${lang}1 __DQuote:${lang}0 __DQuote:${lang}1 \ 03242 __sQuote:${lang}0 __sQuote:${lang}1 __SQuote:${lang}0 __SQuote:${lang}1 \ 03243 __bQuote:${lang}0 __bQuote:${lang}1 __BQuote:${lang}0 __BQuote:${lang}1 03244 lappend data($win,config,csl_tag_pair) {*}[array get comstr] 03245 } else { 03246 catch { $win tag delete {*}[array names tags] } 03247 } 03248 03249 } 03250 03251 proc addEmbedLangPattern {win lang patterns} { 03252 03253 variable data 03254 03255 # Coallesce the start/end patterns 03256 foreach pattern $patterns { 03257 lassign $pattern spat epat 03258 lappend start_patterns $spat 03259 lappend end_patterns $epat 03260 } 03261 03262 lappend data($win,config,csl_patterns,) __LangStart:$lang "" ([join $start_patterns |]) __LangEnd:$lang "" ([join $end_patterns |]) 03263 lappend data($win,config,langs) $lang 03264 03265 array set theme $data($win,config,-theme) 03266 03267 $win tag configure __Lang:$lang 03268 $win tag lower __Lang:$lang _invisible 03269 $win tag configure __Lang=$lang -background $theme(embedded) 03270 $win tag lower __Lang=$lang _invisible 03271 03272 lappend data($win,config,csl_char_tags,) __LangStart:$lang __LangEnd:$lang 03273 lappend data($win,config,csl_array) __LangStart:${lang}0 1 __LangStart:${lang}1 1 __LangEnd:${lang}0 1 __LangEnd:${lang}1 1 __Lang:$lang 1 03274 lappend data($win,config,csl_markers) __LangStart:${lang}0 __LangStart:${lang}1 __LangEnd:${lang}0 __LangEnd:${lang}1 03275 lappend data($win,config,csl_tag_pair) __LangStart:$lang __Lang=$lang 03276 03277 } 03278 03279 proc highlightAll {win lineranges ins {do_tag ""}} { 03280 03281 variable data 03282 variable range_cache 03283 03284 array set csl_array $data($win,config,csl_array) 03285 03286 # Delete all of the tags not associated with comments and strings that we created 03287 foreach tag [$win._t tag names] { 03288 if {([string range $tag 0 1] eq "__") && ![info exists csl_array($tag)]} { 03289 $win._t tag remove $tag {*}$lineranges 03290 } 03291 } 03292 03293 # Clear the caches 03294 array unset range_cache $win,* 03295 03296 # Group the ranges to remove as much regular expression text searching as possible 03297 set ranges [list] 03298 set laststart [lindex $lineranges 0] 03299 set lastend [lindex $lineranges 1] 03300 foreach {linestart lineend} [lrange $lineranges 2 end] { 03301 if {[$win count -lines $lastend $linestart] > 10} { 03302 lappend ranges $laststart $lastend 03303 set laststart $linestart 03304 } 03305 set lastend $lineend 03306 } 03307 lappend ranges $laststart $lastend 03308 03309 # Tag escapes and prewhite characters 03310 foreach {linestart lineend} $ranges { 03311 escapes $win $linestart $lineend 03312 prewhite $win $linestart $lineend 03313 } 03314 03315 # If highlighting is not specified, stop here 03316 if {!$data($win,config,-highlight)} { return 0 } 03317 03318 # Tag comments and strings 03319 set all [comments $win $ranges $do_tag] 03320 03321 # Update the language backgrounds for embedded languages 03322 updateLangBackgrounds $win 03323 03324 if {$all == 2} { 03325 foreach tag [$win._t tag names] { 03326 if {([string index $tag 0] eq "__") && ($tag ne "__escape") && ![info exists csl_array($tag)]} { 03327 $win._t tag remove $tag [lindex $lineranges 1] end 03328 } 03329 } 03330 highlight $win [lindex $lineranges 0] end $ins 03331 } else { 03332 foreach {linestart lineend} $ranges { 03333 highlight $win $linestart $lineend $ins 03334 } 03335 } 03336 03337 if {$all} { 03338 event generate $win.t <<StringCommentChanged>> 03339 } 03340 03341 return $all 03342 03343 } 03344 03345 proc getTagInRange {win tag start end} { 03346 03347 set indices [list] 03348 03349 while {1} { 03350 lassign [$win tag nextrange $tag $start] tag_start tag_end 03351 if {($tag_start ne "") && [$win compare $tag_start < $end]} { 03352 lappend indices $tag_start $tag_end 03353 } else { 03354 break 03355 } 03356 set start $tag_end 03357 } 03358 03359 return $indices 03360 03361 } 03362 03363 proc comments_chars_deleted {win start end pdo_tags} { 03364 03365 variable data 03366 03367 upvar $pdo_tags do_tags 03368 03369 foreach tag $data($win,config,csl_markers) { 03370 lassign [$win tag nextrange $tag $start] tag_start tag_end 03371 if {($tag_start ne "") && [$win compare $tag_start < $end]} { 03372 lappend do_tags $tag 1 03373 return 03374 } 03375 } 03376 03377 } 03378 03379 proc comments_do_tag {win start end pdo_tags} { 03380 03381 upvar $pdo_tags do_tags 03382 03383 if {($do_tags eq "") && [inLineComment $win $start] && ([string first \n [$win get $start $end]] != -1)} { 03384 lappend do_tags "stuff" 1 03385 } 03386 03387 } 03388 03389 proc comments {win ranges do_tags} { 03390 03391 variable data 03392 03393 array set tag_changed $do_tags 03394 set retval 0 03395 03396 # Go through each language 03397 foreach lang $data($win,config,langs) { 03398 03399 # If a csl_pattern does not exist for this language, go to the next language 03400 if {![info exists data($win,config,csl_patterns,$lang)]} continue 03401 03402 # Get the ranges to check 03403 if {$lang eq ""} { 03404 set lranges [list 1.0 end] 03405 } else { 03406 set lranges [$win._t tag ranges "__Lang:$lang"] 03407 } 03408 03409 # Perform highlighting for each range 03410 foreach {langstart langend} $lranges { 03411 03412 # Go through each range 03413 foreach {start end} $ranges { 03414 03415 if {[$win._t compare $start > $langend] || [$win._t compare $langstart > $end]} continue 03416 if {[$win._t compare $start <= $langstart]} { set pstart $langstart } else { set pstart $start } 03417 if {[$win._t compare $langend <= $end]} { set pend $langend } else { set pend $end } 03418 03419 set lines [split [$win._t get $pstart $pend] \n] 03420 set startrow [lindex [split $pstart .] 0] 03421 03422 # First, tag all string/comment patterns found between start and end 03423 foreach {tag1 tag2 pattern} $data($win,config,csl_patterns,$lang) { 03424 array set indices [list ${tag1}0 {} ${tag1}1 {}] 03425 if {$tag2 ne ""} { 03426 array set indices [list ${tag2}0 {} ${tag2}1 {}] 03427 } 03428 set i 0 03429 set row $startrow 03430 foreach line $lines { 03431 set col 0 03432 while {[regexp -indices -start $col {*}$data($win,config,re_opts) -- $pattern $line -> sres tres]} { 03433 lassign $sres scol ecol 03434 set tag $tag1 03435 if {$scol == -1} { 03436 lassign $tres scol ecol 03437 set tag $tag2 03438 } 03439 set col [expr $ecol + 1] 03440 if {![isEscaped $win $row.$scol]} { 03441 if {([string index $pattern 0] eq "^") && ([string index $tag 2] ne "L")} { 03442 set match [string range $line $scol $ecol] 03443 set diff [expr [string length $match] - [string length [string trimleft $match]]] 03444 lappend indices($tag[expr $i & 1]) $row.[expr $scol + $diff] $row.$col 03445 } else { 03446 lappend indices($tag[expr $i & 1]) $row.$scol $row.$col 03447 } 03448 } 03449 incr i 03450 } 03451 incr row 03452 } 03453 foreach tag [array names indices] { 03454 if {$indices($tag) ne [getTagInRange $win $tag $pstart $pend]} { 03455 $win._t tag remove $tag $pstart $pend 03456 catch { $win._t tag add $tag {*}$indices($tag) } 03457 set tag_changed([string range $tag 0 end-1]) 1 03458 } 03459 } 03460 array unset indices 03461 } 03462 03463 } 03464 03465 # If we didn't find any comment/string characters that changed, no need to continue. 03466 if {[array size tag_changed] == 0} continue 03467 03468 # Initialize tags 03469 array unset tags 03470 set char_tags [list] 03471 03472 # Gather the list of comment ranges in the char_tags list 03473 foreach i {0 1} { 03474 if {[info exists data($win,config,lc_char_tags,$lang)]} { 03475 foreach char_tag $data($win,config,lc_char_tags,$lang) { 03476 set index $langstart 03477 while {([set char_end [lassign [$win tag nextrange $char_tag$i $index] char_start]] ne "") && [$win compare $char_end <= $langend]} { 03478 set lineend [$win index "$char_start lineend"] 03479 set index $lineend 03480 lappend char_tags [list $char_start $char_end __lCommentStart:$lang] [list ${lineend}a "$lineend+1c" __lCommentEnd:$lang] 03481 } 03482 } 03483 } 03484 if {[info exists data($win,config,csl_char_tags,$lang)]} { 03485 foreach char_tag $data($win,config,csl_char_tags,$lang) { 03486 set index $langstart 03487 while {([set char_end [lassign [$win tag nextrange $char_tag$i $index] char_start]] ne "") && [$win compare $char_end <= $langend]} { 03488 lappend char_tags [list $char_start $char_end $char_tag] 03489 set index $char_end 03490 } 03491 } 03492 } 03493 } 03494 03495 # Sort the char tags 03496 set char_tags [lsort -dictionary -index 0 $char_tags] 03497 03498 # Create the tag lists 03499 set curr_lang $lang 03500 set curr_lang_start "" 03501 set curr_char_tag "" 03502 set rb 0 03503 array set tag_pairs $data($win,config,csl_tag_pair) 03504 foreach char_info $char_tags { 03505 lassign $char_info char_start char_end char_tag 03506 if {($curr_char_tag eq "") || [string match "__*End:$curr_lang" $curr_char_tag] || ($char_tag eq "__LangEnd:$curr_lang")} { 03507 if {[string range $char_tag 0 6] eq "__LangS"} { 03508 set curr_lang [lindex [split $char_tag :] 1] 03509 set curr_lang_start $char_start 03510 set curr_char_tag "" 03511 } elseif {$char_tag eq "__LangEnd:$curr_lang"} { 03512 if {[info exists tag_pairs($curr_char_tag)]} { 03513 lappend tags($tag_pairs($curr_char_tag)$rb) $curr_char_start $char_start 03514 set rb [expr $rb ^ 1] 03515 } 03516 if {$curr_lang_start ne ""} { 03517 lappend tags(__Lang:$curr_lang) $curr_lang_start $char_end 03518 } 03519 set curr_lang "" 03520 set curr_lang_start "" 03521 set curr_char_tag "" 03522 } elseif {[string match "*:$curr_lang" $char_tag]} { 03523 set curr_char_tag $char_tag 03524 set curr_char_start $char_start 03525 } 03526 } elseif {$curr_char_tag eq "__lCommentStart:$curr_lang"} { 03527 if {$char_tag eq "__lCommentEnd:$curr_lang"} { 03528 lappend tags(__comstr1l) $curr_char_start $char_end 03529 set curr_char_tag "" 03530 } 03531 } elseif {$curr_char_tag eq "__cCommentStart:$curr_lang"} { 03532 if {$char_tag eq "__cCommentEnd:$curr_lang"} { 03533 lappend tags(__comstr1c$rb) $curr_char_start $char_end 03534 set curr_char_tag "" 03535 set rb [expr $rb ^ 1] 03536 } 03537 } elseif {$curr_char_tag eq "__dQuote:$curr_lang"} { 03538 if {$char_tag eq "__dQuote:$curr_lang"} { 03539 lappend tags(__comstr0d$rb) $curr_char_start $char_end 03540 set curr_char_tag "" 03541 set rb [expr $rb ^ 1] 03542 } 03543 } elseif {$curr_char_tag eq "__sQuote:$curr_lang"} { 03544 if {$char_tag eq "__sQuote:$curr_lang"} { 03545 lappend tags(__comstr0s$rb) $curr_char_start $char_end 03546 set curr_char_tag "" 03547 set rb [expr $rb ^ 1] 03548 } 03549 } elseif {$curr_char_tag eq "__bQuote:$curr_lang"} { 03550 if {$char_tag eq "__bQuote:$curr_lang"} { 03551 lappend tags(__comstr0b$rb) $curr_char_start $char_end 03552 set curr_char_tag "" 03553 set rb [expr $rb ^ 1] 03554 } 03555 } elseif {$curr_char_tag eq "__DQuote:$curr_lang"} { 03556 if {$char_tag eq "__DQuote:$curr_lang"} { 03557 lappend tags(__comstr0D$rb) $curr_char_start $char_end 03558 set curr_char_tag "" 03559 set rb [expr $rb ^ 1] 03560 } 03561 } elseif {$curr_char_tag eq "__SQuote:$curr_lang"} { 03562 if {$char_tag eq "__SQuote:$curr_lang"} { 03563 lappend tags(__comstr0S$rb) $curr_char_start $char_end 03564 set curr_char_tag "" 03565 set rb [expr $rb ^ 1] 03566 } 03567 } elseif {$curr_char_tag eq "__BQuote:$curr_lang"} { 03568 if {$char_tag eq "__BQuote:$curr_lang"} { 03569 lappend tags(__comstr0B$rb) $curr_char_start $char_end 03570 set curr_char_tag "" 03571 set rb [expr $rb ^ 1] 03572 } 03573 } 03574 } 03575 if {[info exists tag_pairs($curr_char_tag)]} { 03576 lappend tags($tag_pairs($curr_char_tag)$rb) $curr_char_start [expr {($lang eq "") ? "end" : "$langend linestart"}] 03577 } 03578 if {($curr_lang ne "") && ($lang eq "")} { 03579 lappend tags(__Lang:$curr_lang) $curr_lang_start end 03580 } 03581 03582 # Delete old tags 03583 if {$lang eq ""} { 03584 foreach l $data($win,config,langs) { 03585 catch { $win._t tag remove __Lang:$l $langstart $langend } 03586 } 03587 } 03588 foreach tag $data($win,config,csl_tags) { 03589 catch { $win._t tag remove $tag $langstart $langend } 03590 } 03591 03592 # Add new tags 03593 foreach tag [array names tags] { 03594 $win._t tag add $tag {*}$tags($tag) 03595 } 03596 03597 # Calculate the return value 03598 set retval [expr (($retval == 2) || ([llength [array names tag_changed __Lang*:*]] > 0)) ? 2 : 1] 03599 03600 } 03601 03602 array unset tag_changed {*:$lang[01]} 03603 03604 } 03605 03606 return $retval 03607 03608 } 03609 03610 proc updateLangBackgrounds {win} { 03611 03612 variable data 03613 03614 foreach lang $data($win,config,langs) { 03615 set indices [list] 03616 foreach {start end} [$win._t tag ranges __Lang:$lang] { 03617 if {[$win compare "$start+1l linestart" < "$end linestart"]} { 03618 lappend indices "$start+1l linestart" "$end linestart" 03619 } 03620 } 03621 catch { $win._t tag remove __Lang=$lang 1.0 end } 03622 catch { $win._t tag add __Lang=$lang {*}$indices } 03623 } 03624 03625 } 03626 03627 proc setIndentation {twin lang indentations type} { 03628 03629 variable data 03630 03631 if {[llength $indentations] > 0} { 03632 set data($twin,config,indentation,$lang,$type) [join $indentations |] 03633 $twin tag configure __$type 03634 $twin tag lower __$type _invisible 03635 } else { 03636 catch { unset data($twin,config,indentation,$lang,$type) } 03637 } 03638 03639 } 03640 03641 proc escapes {win start end} { 03642 03643 variable data 03644 03645 if {$data($win,config,-escapes)} { 03646 foreach res [$win._t search -all -- "\\" $start $end] { 03647 if {[lsearch [$win._t tag names $res-1c] __escape] == -1} { 03648 $win._t tag add __escape $res 03649 } 03650 } 03651 } 03652 03653 } 03654 03655 # This procedure tags all of the whitespace from the beginning of a line. This 03656 # must be called prior to invoking the indentation procedure. 03657 proc prewhite {win start end} { 03658 03659 # Add prewhite tags 03660 set i 0 03661 set indices [list] 03662 foreach res [$win._t search -regexp -all -count lengths -- {^[ \t]*\S} $start $end] { 03663 lappend indices $res "$res+[lindex $lengths $i]c" 03664 incr i 03665 } 03666 03667 catch { $win._t tag add __prewhite {*}$indices } 03668 03669 } 03670 03671 proc brackets {win start end lang ptags} { 03672 03673 upvar $ptags tags 03674 03675 variable data 03676 variable REs 03677 variable bracket_map 03678 03679 array set ttags {} 03680 03681 # Handle special character matching 03682 set row [lindex [split $start .] 0] 03683 foreach line [split [$win._t get $start $end] \n] { 03684 set col 0 03685 while {[regexp -indices -start $col -- $REs(brackets) $line res]} { 03686 set scol [lindex $res 0] 03687 set col [expr $scol + 1] 03688 lappend ttags(__$bracket_map([string index $line $scol])) $row.$scol $row.$col 03689 } 03690 incr row 03691 } 03692 03693 foreach tag [array names ttags] { 03694 if {[info exists data($win,config,matchChar,$lang,[string range $tag 2 end-1])]} { 03695 dict lappend tags $tag {*}$ttags($tag) 03696 } 03697 } 03698 03699 } 03700 03701 proc indentation {win start end lang ptags} { 03702 03703 upvar $ptags tags 03704 03705 variable data 03706 03707 set lines [split [$win._t get $start $end] \n] 03708 set startrow [lindex [split $start .] 0] 03709 03710 # Add indentation 03711 foreach key [array names data $win,config,indentation,$lang,*] { 03712 set type [lindex [split $key ,] 4] 03713 set i 0 03714 set row $startrow 03715 foreach line $lines { 03716 set col 0 03717 while {[regexp -indices -start $col -- $data($key) $line res]} { 03718 lassign $res scol ecol 03719 set col [expr $ecol + 1] 03720 dict lappend tags __$type[expr $i & 1] $row.$scol $row.$col 03721 incr i 03722 } 03723 incr row 03724 } 03725 } 03726 03727 } 03728 03729 proc words {win start end lang ins ptags} { 03730 03731 upvar $ptags tags 03732 03733 variable data 03734 03735 set retval "" 03736 03737 if {[llength [array names data $win,highlight,w*,$lang,*]] > 0} { 03738 03739 set row [lindex [split $start .] 0] 03740 foreach line [split [$win._t get $start $end] \n] { 03741 set col 0 03742 while {[regexp -indices -start $col -- $data($win,config,-delimiters) $line res]} { 03743 lassign $res scol ecol 03744 set word [string range $line $scol $ecol] 03745 set col [expr $ecol + 1] 03746 if {!$data($win,config,-casesensitive)} { 03747 set word [string tolower $word] 03748 } 03749 set firstOfWord [string index $word 0] 03750 if {[info exists data($win,highlight,wkeyword,class,$lang,$word)]} { 03751 dict lappend tags $data($win,highlight,wkeyword,class,$lang,$word) $row.$scol $row.$col 03752 } elseif {[info exists data($win,highlight,wcharstart,class,$lang,$firstOfWord)]} { 03753 dict lappend tags $data($win,highlight,wcharstart,class,$lang,$firstOfWord) $row.$scol $row.$col 03754 } 03755 if {[info exists data($win,highlight,wkeyword,command,$lang,$word)] && \ 03756 ![catch { {*}$data($win,highlight,wkeyword,command,$lang,$word) $win $row $line [list 0 [list $scol $ecol]] $ins } retval] && ([llength $retval] == 3)} { 03757 dict lappend tags [lindex $retval 0] $row.[lindex $retval 1] $row.[expr [lindex $retval 2] + 1] 03758 } elseif {[info exists data($win,highlight,wcharstart,command,$lang,$firstOfWord)] && \ 03759 ![catch { {*}$data($win,highlight,wcharstart,command,$lang,$firstOfWord) $win $row $line [list 0 [list $scol $ecol]] $ins } retval] && ([llength $retval] == 3)} { 03760 dict lappend tags [lindex $retval 0] $row.[lindex $retval 1] $row.[expr [lindex $retval 2] + 1] 03761 } 03762 } 03763 incr row 03764 } 03765 03766 } 03767 03768 } 03769 03770 proc regexps {win start end lang ins ptags} { 03771 03772 variable data 03773 03774 if {![info exists data($win,highlight,regexps,$lang)]} return 03775 03776 upvar $ptags tags 03777 03778 set lines [split [$win._t get $start $end] \n] 03779 set startrow [lindex [split $start .] 0] 03780 03781 # Handle regular expression matching 03782 foreach name $data($win,highlight,regexps,$lang) { 03783 lassign [split $name ,] dummy1 type dummy2 value 03784 lassign $data($win,highlight,$name) re re_opts immediate 03785 set i 0 03786 if {$type eq "class"} { 03787 foreach res [$win._t search -count lengths -regexp {*}$re_opts -all -nolinestop -- $re $start $end] { 03788 set wordEnd [$win._t index "$res + [lindex $lengths $i] chars"] 03789 dict lappend tags $value $res $wordEnd 03790 incr i 03791 } 03792 } else { 03793 array unset itags 03794 set row $startrow 03795 foreach line $lines { 03796 set col 0 03797 array unset var 03798 while {[regexp {*}$re_opts -indices -start $col -- $re $line var(0) var(1) var(2) var(3) var(4) var(5) var(6) var(7) var(8) var(9)] && ([lindex $var(0) 0] <= [lindex $var(0) 1])} { 03799 if {![catch { {*}$value $win $row $line [array get var] $ins } retval] && ([llength $retval] == 2)} { 03800 lassign $retval rtags goback 03801 if {([llength $rtags] % 3) == 0} { 03802 foreach {rtag rstart rend} $rtags { 03803 if {[info exists data($win,classimmediate,$rtag)]} { 03804 if {$data($win,classimmediate,$rtag)} { 03805 lappend itags(__$rtag) $row.$rstart $row.[expr $rend + 1] 03806 } else { 03807 dict lappend tags __$rtag $row.$rstart $row.[expr $rend + 1] 03808 } 03809 } 03810 } 03811 } 03812 set col [expr {($goback ne "") ? $goback : ([lindex $var(0) 1] + 1)}] 03813 } else { 03814 set col [expr {[lindex $var(0) 1] + 1}] 03815 } 03816 } 03817 incr row 03818 } 03819 foreach tag [array names itags] { 03820 $win._t tag add $tag {*}$itags($tag) 03821 } 03822 } 03823 } 03824 03825 } 03826 03827 ###################################################################### 03828 # Performs any active searches on the given text range. 03829 proc searches {win start end ptags} { 03830 03831 upvar $ptags tags 03832 03833 variable data 03834 03835 foreach {key value} [array get data $win,highlight,searches,*] { 03836 03837 set class [lindex [split $key ,] 3] 03838 lassign $value str opts 03839 03840 # Perform the search now 03841 set i 0 03842 foreach res [$win._t search -count lengths {*}$opts -all -- $str $start $end] { 03843 dict lappend tags $class $res [$win._t index "$res + [lindex $lengths $i] chars"] 03844 incr i 03845 } 03846 03847 } 03848 03849 } 03850 03851 ###################################################################### 03852 # Updates the visibility of the characters marked as meta. 03853 proc updateMetaChars {win} { 03854 03855 variable data 03856 03857 set value $data($win,config,-hidemeta) 03858 03859 foreach tag $data($win,config,meta_classes) { 03860 $win._t tag configure __$tag -elide $value 03861 } 03862 03863 } 03864 03865 ###################################################################### 03866 # Create a fontname (if one does not already exist) and configure it 03867 # with the given modifiers. Returns the list of options that should 03868 # be applied to the tag 03869 proc add_font_opts {win modifiers popts} { 03870 03871 variable data 03872 03873 upvar $popts opts 03874 03875 if {[llength $modifiers] == 0} return 03876 03877 array set font_opts [font configure [$win cget -font]] 03878 array set line_opts [list] 03879 array set tag_opts [list] 03880 03881 set lsize "" 03882 set superscript 0 03883 set subscript 0 03884 set name_list [list 0 0 0 0 0 0] 03885 03886 foreach modifier $modifiers { 03887 switch $modifier { 03888 "bold" { set font_opts(-weight) "bold"; lset name_list 0 1 } 03889 "italics" { set font_opts(-slant) "italic"; lset name_list 1 1 } 03890 "underline" { set font_opts(-underline) 1; lset name_list 2 1 } 03891 "overstrike" { set tag_opts(-overstrike) 1; lset name_list 3 1 } 03892 "h6" { set font_opts(-size) [expr $font_opts(-size) + 1]; set lsize "6" } 03893 "h5" { set font_opts(-size) [expr $font_opts(-size) + 2]; set lsize "5" } 03894 "h4" { set font_opts(-size) [expr $font_opts(-size) + 3]; set lsize "4" } 03895 "h3" { set font_opts(-size) [expr $font_opts(-size) + 4]; set lsize "3" } 03896 "h2" { set font_opts(-size) [expr $font_opts(-size) + 5]; set lsize "2" } 03897 "h1" { set font_opts(-size) [expr $font_opts(-size) + 6]; set lsize "1" } 03898 "superscript" { 03899 set lsize "super" 03900 set size [expr $font_opts(-size) - 2] 03901 set font_opts(-size) $size 03902 set line_opts(-offset) [expr $size / 2] 03903 lset name_list 4 1 03904 } 03905 "subscript" { 03906 set lsize "sub" 03907 set size [expr $font_opts(-size) - 2] 03908 set font_opts(-size) $size 03909 set line_opts(-offset) [expr 0 - ($size / 2)] 03910 lset name_list 5 1 03911 } 03912 } 03913 } 03914 03915 set fontname ctext-[join $name_list ""]$lsize 03916 if {[lsearch [font names] $fontname] == -1} { 03917 font create $fontname {*}[array get font_opts] 03918 } 03919 03920 lappend opts -font $fontname {*}[array get tag_opts] {*}[array get line_opts] 03921 03922 } 03923 03924 proc addHighlightKeywords {win type value keywords {lang ""}} { 03925 03926 variable data 03927 03928 if {$type eq "class"} { 03929 checkHighlightClass $win $value 03930 set value __$value 03931 } 03932 03933 foreach word $keywords { 03934 set data($win,highlight,wkeyword,$type,$lang,$word) $value 03935 } 03936 03937 } 03938 03939 proc addHighlightRegexp {win type value re {lang ""}} { 03940 03941 variable data 03942 03943 if {$type eq "class"} { 03944 checkHighlightClass $win $value 03945 set value __$value 03946 } 03947 03948 if {![info exists data($win,highlight,regexps,$lang)]} { 03949 set index 0 03950 } else { 03951 set index [llength $data($win,highlight,regexps,$lang)] 03952 } 03953 03954 lappend data($win,highlight,regexps,$lang) "regexp,$type,$lang,$value,$index" 03955 03956 set data($win,highlight,regexp,$type,$lang,$value,$index) [list $re $data($win,config,re_opts)] 03957 03958 } 03959 03960 # For things like $blah 03961 proc addHighlightWithOnlyCharStart {win type value char {lang ""}} { 03962 03963 variable data 03964 03965 if {$type eq "class"} { 03966 checkHighlightClass $win $value 03967 set value __$value 03968 } 03969 03970 set data($win,highlight,wcharstart,$type,$lang,$char) $value 03971 03972 } 03973 03974 ###################################################################### 03975 # Performs a search and highlights all matches. 03976 proc highlightSearch {win class str {opts ""}} { 03977 03978 variable data 03979 03980 # Add the highlight class 03981 addHighlightClass $win $class -fgtheme search -bgtheme search -priority high 03982 03983 # Save the information 03984 set data($win,highlight,searches,__$class) [list $str $opts] 03985 03986 # Perform the search now 03987 set i 0 03988 foreach res [$win._t search -count lengths {*}$opts -all -- $str 1.0 end] { 03989 lappend matches $res [$win._t index "$res + [lindex $lengths $i] chars"] 03990 incr i 03991 } 03992 03993 catch { $win._t tag add __$class {*}$matches } 03994 03995 } 03996 03997 ###################################################################### 03998 # Verifies that the specified class is valid for the given text widget. 03999 proc checkHighlightClass {win class} { 04000 04001 variable data 04002 04003 if {![info exists data($win,classopts,$class)]} { 04004 return -code error "Unspecified highlight class ($class) specified in [dict get [info frame -1] proc]" 04005 } 04006 04007 } 04008 04009 ###################################################################### 04010 # Adds a highlight class with rendering information. 04011 proc addHighlightClass {win class args} { 04012 04013 variable data 04014 variable right_click 04015 04016 array set opts { 04017 -fgtheme "" 04018 -bgtheme "" 04019 -fontopts "" 04020 -clickcmd "" 04021 -priority "" 04022 -immediate 0 04023 -meta 0 04024 } 04025 array set opts $args 04026 04027 # Configure the class tag and place it in the correct position in the tag stack 04028 $win._t tag configure __$class 04029 if {$opts(-priority) ne ""} { 04030 switch $opts(-priority) { 04031 1 { $win._t tag lower __$class _visibleH } 04032 2 { $win._t tag raise __$class _visibleL } 04033 3 { $win._t tag lower __$class _visibleL } 04034 4 { $win._t tag raise __$class _invisible } 04035 high { $win._t tag raise __$class _visibleH } 04036 } 04037 } elseif {$opts(-bgtheme) ne ""} { 04038 $win._t tag lower __$class _visibleL 04039 } elseif {($opts(-fgtheme) ne "") || ($opts(-fontopts) ne "")} { 04040 $win._t tag raise __$class _visibleL 04041 } else { 04042 $win._t tag lower __$class _invisible 04043 } 04044 04045 if {$opts(-meta)} { 04046 lappend data($win,config,meta_classes) $class 04047 $win._t tag configure __$class -elide $data($win,config,-hidemeta) 04048 } 04049 04050 # If there is a command associated with the class, bind it to the right-click button 04051 if {$opts(-clickcmd) ne ""} { 04052 $win._t tag bind __$class <Button-$right_click> [list ctext::handleClickCommand $win __$class $opts(-clickcmd)] 04053 } 04054 04055 # Save the class name and options 04056 set data($win,classopts,$class) [array get opts] 04057 set data($win,classimmediate,$class) $opts(-immediate) 04058 04059 # Apply the class theming information 04060 applyClassTheme $win $class 04061 04062 } 04063 04064 ###################################################################### 04065 # Call the given command on click. 04066 proc handleClickCommand {win tag command} { 04067 04068 # Get the clicked text range 04069 lassign [$win._t tag prevrange $tag [$win._t index current+1c]] startpos endpos 04070 04071 # Call the command 04072 uplevel #0 [list {*}$command $win $startpos $endpos] 04073 04074 } 04075 04076 ###################################################################### 04077 # Updates the theming information for the given class. 04078 proc applyClassTheme {win class} { 04079 04080 variable data 04081 04082 array set opts $data($win,classopts,$class) 04083 array set themes $data($win,config,-theme) 04084 04085 set tag_opts [list] 04086 04087 if {([set fgtheme $opts(-fgtheme)] ne "") && [info exists themes($fgtheme)]} { 04088 lappend tag_opts -foreground $themes($fgtheme) 04089 } 04090 04091 if {([set bgtheme $opts(-bgtheme)] ne "") && [info exists themes($bgtheme)]} { 04092 lappend tag_opts -background $themes($bgtheme) 04093 } 04094 04095 if {$opts(-fontopts) ne ""} { 04096 add_font_opts $win $opts(-fontopts) tag_opts 04097 } 04098 04099 catch { $win._t tag configure __$class {*}$tag_opts } 04100 04101 } 04102 04103 ###################################################################### 04104 # Removes the specified highlighting class from the widget. 04105 proc deleteHighlightClass {win class} { 04106 04107 variable data 04108 04109 array unset data $win,highlight,regexp,class,*,__$class,* 04110 foreach key [array names data $win,highlight,regexps,*] { 04111 foreach index [lreverse [lsearch -all $data($key) *regexp,class,*,__$class,*]] { 04112 set data($key) [lreplace $data($key) $index $index] 04113 } 04114 } 04115 04116 foreach type [list wkeyword wcharstart] { 04117 foreach key [array names data $win,highlight,$type,class,*] { 04118 if {[string match $data($key) __$class]} { 04119 unset data($key) 04120 } 04121 } 04122 } 04123 04124 if {[set index [lsearch $data($win,config,meta_classes) $class]] != -1} { 04125 set data($win,config,meta_classes) [lreplace $data($win,config,meta_classes) $index $index] 04126 } 04127 04128 array unset data $win,highlight,searches,__$class 04129 array unset data $win,classopts,$class 04130 array unset data $win,classimmediate,$class 04131 04132 $win._t tag delete __$class 1.0 end 04133 04134 } 04135 04136 ###################################################################### 04137 # Deletes the given highlighting command from memory. 04138 proc deleteHighlightCommand {win command} { 04139 04140 variable data 04141 04142 array unset data $win,highlight,regexp,command,*,$command,* 04143 foreach key [array names data $win,highlight,regexps,*] { 04144 foreach index [lreverse [lsearch -all $data($key) regexp,command,*,$command,*]] { 04145 set data($key) [lreplace $data($key) $index $index] 04146 } 04147 } 04148 04149 foreach type [list wkeyword wcharstart] { 04150 foreach key [array names data $win,highlight,$type,command,*] { 04151 if {[string match $data($key) $command]} { 04152 unset data($key) 04153 } 04154 } 04155 } 04156 04157 } 04158 04159 ###################################################################### 04160 # Returns the highlight classes that are stored in the widget or at the 04161 # provided index (if specified). 04162 proc getHighlightClasses {win {index ""}} { 04163 04164 variable data 04165 04166 if {$index eq ""} { 04167 set classes [list] 04168 foreach class [array names data $win,classopts,*] { 04169 lappend classes [lindex [split $class ,] 2] 04170 } 04171 } else { 04172 foreach tag [$win._t tag names $index] { 04173 set t [string range $tag 2 end] 04174 if {[info exists data($win,classopts,$t)]} { 04175 lappend classes $t 04176 } 04177 } 04178 } 04179 04180 return $classes 04181 04182 } 04183 04184 proc highlight {win start end ins} { 04185 04186 variable data 04187 variable REs 04188 variable restart_from 04189 04190 set twin "$win._t" 04191 set tags [dict create] 04192 04193 foreach lang $data($win,config,langs) { 04194 04195 # Get the ranges to check 04196 if {$lang eq ""} { 04197 set ranges [list 1.0 end] 04198 } else { 04199 set ranges [$twin tag ranges "__Lang=$lang"] 04200 } 04201 04202 # Perform highlighting for each range 04203 foreach {langstart langend} $ranges { 04204 04205 if {[$twin compare $start > $langend] || [$twin compare $langstart > $end]} continue 04206 if {[$twin compare $start <= $langstart]} { set pstart $langstart } else { set pstart $start } 04207 if {[$twin compare $langend <= $end]} { set pend $langend } else { set pend $end } 04208 04209 brackets $win $pstart $pend $lang tags 04210 indentation $win $pstart $pend $lang tags 04211 words $win $pstart $pend $lang $ins tags 04212 regexps $win $pstart $pend $lang $ins tags 04213 searches $win $pstart $pend tags 04214 04215 } 04216 04217 } 04218 04219 # Update the tags 04220 dict for {tag indices} $tags { 04221 $win._t tag add $tag {*}$indices 04222 } 04223 04224 } 04225 04226 # Called when the given lines are about to be deleted. Allows the linemap_mark_command call to 04227 # be made when this occurs. 04228 proc linemapCheckOnDelete {win startpos {endpos ""}} { 04229 04230 variable data 04231 04232 if {$data($win,config,-linemap_mark_command) ne ""} { 04233 04234 if {$endpos eq ""} { 04235 set endpos $startpos 04236 } 04237 04238 if {[lindex [split $startpos .] 1] == 0} { 04239 if {[set lmark [lsearch -inline -glob [$win._t tag names $startpos] lmark*]] ne ""} { 04240 uplevel #0 [list {*}$data($win,config,-linemap_mark_command) $win unmarked $lmark] 04241 } 04242 } 04243 04244 while {[$win._t compare [set startpos [$win._t index "$startpos+1l linestart"]] < $endpos]} { 04245 if {[set lmark [lsearch -inline -glob [$win._t tag names $startpos] lmark*]] ne ""} { 04246 uplevel #0 [list {*}$data($win,config,-linemap_mark_command) $win unmarked $lmark] 04247 } 04248 } 04249 04250 } 04251 04252 } 04253 04254 proc linemapToggleMark {win x y} { 04255 04256 variable data 04257 04258 # If the linemap is not markable or the linemap command is in progress, ignore 04259 # further attempts to toggle the mark. 04260 if {!$data($win,config,-linemap_markable) || $data($win,config,linemap_cmd_ip)} { 04261 return 04262 } 04263 04264 set tline [lindex [split [set tmarkChar [$win.t index @0,$y]] .] 0] 04265 04266 # If the line is empty, we can't mark the line so just return now 04267 if {[$win._t compare "$tline.0 linestart" == "$tline.0 lineend"]} { 04268 return 04269 } 04270 04271 if {[set lmark [lsearch -inline -glob [$win.t tag names $tline.0] lmark*]] ne ""} { 04272 $win.t tag delete $lmark 04273 set type unmarked 04274 } else { 04275 set lmark "lmark[incr data($win,linemap,id)]" 04276 $win.t tag add $lmark $tmarkChar [$win.t index "$tmarkChar lineend"] 04277 set type marked 04278 } 04279 04280 # Update the linemap 04281 linemapUpdate $win 1 04282 04283 # Indicate that the linemap command is in progress 04284 set data($win,config,linemap_cmd_ip) 1 04285 04286 # Call the mark command, if one exists. If it returns a value of 0, remove 04287 # the mark. 04288 set cmd $data($win,config,-linemap_mark_command) 04289 if {[string length $cmd] && ![uplevel #0 [linsert $cmd end $win $type $lmark]]} { 04290 $win.t tag delete $lmark 04291 linemapUpdate $win 1 04292 } 04293 04294 # Indicate that the linemap command is no longer in progress 04295 set data($win,config,linemap_cmd_ip) 0 04296 04297 } 04298 04299 proc linemapSetMark {win line} { 04300 04301 variable data 04302 04303 if {[$win._t compare "$line.0 linestart" != "$line.0 lineend"] && [lsearch -inline -glob [$win.t tag names $line.0] lmark*] eq ""} { 04304 set lmark "lmark[incr data($win,linemap,id)]" 04305 $win.t tag add $lmark $line.0 04306 linemapUpdate $win 1 04307 return $lmark 04308 } 04309 04310 return "" 04311 04312 } 04313 04314 proc linemapClearMark {win line} { 04315 04316 if {[set lmark [lsearch -inline -glob [$win.t tag names $line.0] lmark*]] ne ""} { 04317 $win.t tag delete $lmark 04318 linemapUpdate $win 1 04319 } 04320 04321 } 04322 04323 proc linemapUpdateNeeded {win} { 04324 04325 variable data 04326 04327 set yview [$win yview] 04328 set lasty [lindex [$win dlineinfo end-1c] 1] 04329 04330 if {[info exists data($win,yview)] && ($data($win,yview) eq $yview) && \ 04331 [info exists data($win,lasty)] && ($data($win,lasty) eq $lasty)} { 04332 return 0 04333 } 04334 04335 set data($win,yview) $yview 04336 set data($win,lasty) $lasty 04337 04338 return 1 04339 04340 } 04341 04342 proc linemapUpdate {win {forceUpdate 0}} { 04343 04344 variable data 04345 04346 # Check to see if the current cursor is on a bracket and match it 04347 if {$data($win,config,-matchchar)} { 04348 matchBracket $win 04349 } 04350 04351 # If there is no need to update, return now 04352 if {![winfo exists $win.l] || (![linemapUpdateNeeded $win] && !$forceUpdate)} { 04353 return 04354 } 04355 04356 set first [lindex [split [$win.t index @0,0] .] 0] 04357 set last [lindex [split [$win.t index @0,[winfo height $win.t]] .] 0] 04358 set line_width [string length [lindex [split [$win._t index end-1c] .] 0]] 04359 set linenum_width [expr max( $data($win,config,-linemap_minwidth), $line_width )] 04360 set gutter_width [expr [llength [lsearch -index 2 -all -inline $data($win,config,gutters) 0]] + 1] 04361 04362 if {[$win._t compare "@0,0 linestart" != @0,0]} { 04363 incr first 04364 } 04365 04366 $win.l delete all 04367 04368 if {$data($win,config,-diff_mode)} { 04369 linemapDiffUpdate $win $first $last $linenum_width 04370 set full_width [expr ($linenum_width * 2) + 1 + $gutter_width] 04371 } elseif {$data($win,config,-linemap)} { 04372 linemapLineUpdate $win $first $last $linenum_width 04373 set full_width [expr $linenum_width + $gutter_width] 04374 } elseif {$gutter_width > 0} { 04375 linemapGutterUpdate $win $first $last $linenum_width 04376 set full_width [expr $data($win,config,-linemap_markable) + $gutter_width] 04377 } elseif {$data($win,config,-linemap_markable)} { 04378 linemapMarkUpdate $win $first $last 04379 set full_width 1 04380 } 04381 04382 # Resize the linemap window, if necessary 04383 if {[$win.l cget -width] != (($full_width * $data($win,fontwidth)) + 2)} { 04384 $win.l configure -width [expr ($full_width * $data($win,fontwidth)) + 2] 04385 } 04386 04387 } 04388 04389 proc linemapUpdateGutter {win ptags x y} { 04390 04391 variable data 04392 04393 upvar $ptags tags 04394 04395 set index 0 04396 set fontwidth $data($win,fontwidth) 04397 set font $data($win,config,-font) 04398 set fill $data($win,config,-linemapfg) 04399 04400 foreach gutter_data $data($win,config,gutters) { 04401 if {[lindex $gutter_data 2]} { continue } 04402 foreach gutter_tag [lsearch -inline -all -glob $tags gutter:[lindex $gutter_data 0]:*] { 04403 lassign [split $gutter_tag :] dummy dummy gutter_symname gutter_sym 04404 if {$gutter_sym ne ""} { 04405 set color [expr {[info exists data($win,gutterfg,$gutter_tag)] ? $data($win,gutterfg,$gutter_tag) : $fill}] 04406 $win.l create text [expr $x + ($index * $fontwidth)] $y -anchor sw -text $gutter_sym -fill $color -font $font -tags $gutter_tag 04407 } 04408 } 04409 incr index 04410 } 04411 04412 } 04413 04414 proc linemapDiffUpdate {win first last linenum_width} { 04415 04416 variable data 04417 04418 set normal $data($win,config,-linemapfg) 04419 set lmark $data($win,config,-linemap_mark_color) 04420 set font $data($win,config,-font) 04421 set linebx [expr (($linenum_width + 1) * $data($win,fontwidth)) + 1] 04422 set gutterx [expr $linebx + ((($linenum_width + 1) * $data($win,fontwidth)) + 1)] 04423 set descent $data($win,fontdescent) 04424 set fmt [expr {($data($win,config,-linemap_align) eq "left") ? "%-*s %-*s" : "%*s %*s"}] 04425 04426 # Calculate the starting line numbers for both files 04427 array set currline {A 0 B 0} 04428 foreach diff_tag [lsearch -inline -all -glob [$win.t tag names $first.0] diff:*] { 04429 lassign [split $diff_tag :] dummy index type start 04430 set currline($index) [expr $start - 1] 04431 if {$type eq "S"} { 04432 incr currline($index) [$win count -lines [lindex [$win tag ranges $diff_tag] 0] $first.0] 04433 } 04434 } 04435 04436 for {set line $first} {$line <= $last} {incr line} { 04437 if {[$win._t count -displaychars $line.0 [expr $line + 1].0] == 0} { continue } 04438 lassign [$win._t dlineinfo $line.0] x y w h b 04439 set ltags [$win._t tag names $line.0] 04440 set y [expr $y + $b + $descent] 04441 set lineA [expr {([lsearch -glob $ltags diff:A:S:*] != -1) ? [incr currline(A)] : ""}] 04442 set lineB [expr {([lsearch -glob $ltags diff:B:S:*] != -1) ? [incr currline(B)] : ""}] 04443 set marked [expr {[lsearch -glob $ltags lmark*] != -1}] 04444 set fill [expr {$marked ? $lmark : $normal}] 04445 $win.l create text 1 $y -anchor sw -text [format $fmt $linenum_width $lineA $linenum_width $lineB] -fill $fill -font $font 04446 linemapUpdateGutter $win ltags $gutterx $y 04447 } 04448 04449 } 04450 04451 proc linemapLineUpdate {win first last linenum_width} { 04452 04453 variable data 04454 04455 set abs [expr {$data($win,config,-linemap_type) eq "absolute"}] 04456 set curr [lindex [split [$win.t index insert] .] 0] 04457 set lmark $data($win,config,-linemap_mark_color) 04458 set normal $data($win,config,-linemapfg) 04459 set font $data($win,config,-font) 04460 set gutterx [expr (($linenum_width + 1) * $data($win,fontwidth)) + 1] 04461 set descent $data($win,fontdescent) 04462 set fmt [expr {($data($win,config,-linemap_align) eq "left") ? "%-*s" : "%*s"}] 04463 04464 if {$abs} { 04465 set curr 0 04466 } 04467 04468 for {set line $first} {$line <= $last} {incr line} { 04469 if {[$win._t count -displaychars $line.0 [expr $line + 1].0] == 0} { continue } 04470 lassign [$win._t dlineinfo $line.0] x y w h b 04471 set ltags [$win.t tag names $line.0] 04472 set linenum [expr abs( $line - $curr )] 04473 set marked [expr {[lsearch -glob $ltags lmark*] != -1}] 04474 set fill [expr {$marked ? $lmark : $normal}] 04475 set y [expr $y + $b + $descent] 04476 $win.l create text 1 $y -anchor sw -text [format $fmt $linenum_width $linenum] -fill $fill -font $font 04477 linemapUpdateGutter $win ltags $gutterx $y 04478 } 04479 04480 } 04481 04482 proc linemapGutterUpdate {win first last linenum_width} { 04483 04484 variable data 04485 04486 set gutterx [expr {$data($win,config,-linemap_markable) ? (($data($win,fontwidth) * 2) + 1) : 1}] 04487 set fill $data($win,config,-linemap_mark_color) 04488 set font $data($win,config,-font) 04489 set descent $data($win,fontdescent) 04490 04491 for {set line $first} {$line <= $last} {incr line} { 04492 if {[$win._t count -displaychars $line.0 [expr $line + 1].0] == 0} { continue } 04493 lassign [$win._t dlineinfo $line.0] x y w h b 04494 set ltags [$win.t tag names $line.0] 04495 set y [expr $y + $b + $descent] 04496 if {[lsearch -glob $ltags lmark*] != -1} { 04497 $win.l create text 1 $y -anchor sw -text "M" -fill $fill -font $font 04498 } 04499 linemapUpdateGutter $win ltags $gutterx $y 04500 } 04501 04502 } 04503 04504 proc linemapMarkUpdate {win first last} { 04505 04506 variable data 04507 04508 set fill $data($win,config,-linemap_mark_color) 04509 set font $data($win,config,-font) 04510 set descent $data($win,fontdescent) 04511 04512 for {set line $first} {$line <= $last} {incr line} { 04513 if {[$win._t count -displaychars $line.0 [expr $line + 1].0] == 0} { continue } 04514 lassign [$win._t dlineinfo $line.0] x y w h b 04515 set ltags [$win.t tag names $line.0] 04516 set y [expr $y + $b + $descent] 04517 if {[lsearch -glob $ltags lmark*] != -1} { 04518 $win.l create text 1 $y -anchor sw -text "M" -fill $fill -font $font 04519 } 04520 } 04521 04522 } 04523 04524 proc doConfigure {win} { 04525 04526 # Update the linemap 04527 linemapUpdate $win 04528 04529 # Update the rmargin 04530 adjust_rmargin $win 04531 04532 } 04533 04534 proc set_warnwidth {win {adjust 0}} { 04535 04536 variable data 04537 04538 if {$data($win,config,-warnwidth) eq ""} { 04539 place forget $win.t.w 04540 return 04541 } 04542 04543 set lmargin $data($win,config,-lmargin) 04544 set cwidth [font measure [$win._t cget -font] -displayof . m] 04545 set str [string repeat "m" $data($win,config,-warnwidth)] 04546 set newx [expr $lmargin + ($cwidth * $data($win,config,-warnwidth)) + $adjust] 04547 place configure $win.t.w -x $newx -relheight 1.0 04548 adjust_rmargin $win 04549 04550 } 04551 04552 proc set_rmargin {win startpos endpos} { 04553 04554 $win tag add rmargin $startpos $endpos 04555 $win tag add lmargin $startpos $endpos 04556 04557 } 04558 04559 proc adjust_rmargin {win} { 04560 04561 # If the warning width indicator is absent, remove rmargin and return 04562 if {[lsearch [place slaves $win.t] $win.t.w] == -1} { 04563 $win tag configure rmargin -rmargin "" 04564 return 04565 } 04566 04567 # Calculate the rmargin value to use 04568 set rmargin [expr [winfo width $win.t] - [lindex [place configure $win.t.w -x] 4]] 04569 04570 # Set the rmargin 04571 if {$rmargin > 0} { 04572 $win tag configure rmargin -rmargin $rmargin 04573 } else { 04574 $win tag configure rmargin -rmargin "" 04575 } 04576 04577 } 04578 04579 proc modified {win value {dat ""}} { 04580 04581 variable data 04582 04583 set data($win,config,modified) $value 04584 event generate $win <<Modified>> -data $dat 04585 04586 return $value 04587 04588 } 04589 04590 } 04591 04592 ###################################################################### 04593 # Creates a ctext widget and initializes it for use based on the given 04594 # settings. 04595 proc ctext {win args} { 04596 04597 set win [ctext::create $win {*}$args] 04598 04599 rename $win __ctextJunk$win 04600 rename $win.t $win._t 04601 04602 interp alias {} $win {} ctext::instanceCmd $win 04603 interp alias {} $win.t {} $win 04604 04605 ctext::update_linemap_separator $win 04606 ctext::modified $win 0 04607 ctext::buildArgParseTable $win 04608 ctext::adjust_rmargin $win 04609 04610 return $win 04611 04612 } 04613