1package provide richtext 1.0 2 3namespace eval richtext { 4 variable ID 5 variable BIND ; array set BIND {} 6 variable SysFunction ; array set SysFunction {} 7 variable widgetData ; array set widgetData {} 8 variable tagCollapse ; array set tagCollapse {} 9 variable IMAGE ; array set IMAGE {} 10 11 namespace export xml_add create Set_Style widget_pos 12 13 set IMAGE(notFound) " \ 14R0lGODdhQABAAOMAAD09PSsrKwAAAICAgNXV1f/////j4/9ycv85Of8AAP+qqv+Ojv/Hx/8d \ 15Hf9VVf///ywAAAAAQABAAAAE/hCESau9OOuNpfhgKI5kaZ7kJHBs625rsA50bd94ru98LauB \ 16AWFILBqPyKRySRj8fsKCdEqtWq/YbLb5nBG04LAYy415x+j01mkOftVweBkYjdvHc+j7zl93 \ 173X2BV3lngoZShICHhol1i4GNe498kZOQbHSSlnGVm3ednpyYeqF2oKVpp6h4o4WraKoFBgcI \ 18CbYIBwZYs7W3ubu0tgm4ulSqCsLJtgpWyMrCzFXOzwnRiK2KUtPUCQtU29TeU+DP4gWgBskI \ 19DLILycXpwuvt71Lxt+wG7sLFoPsJDaocEHZAyr+AVAbaKljgoECC1/44WuCgQTdpwhwYrHjx \ 20W8aN5hbNaft4DpsjLQoTaASTciVKkrGaJWOnZRvNLDYjtjl5JaVKlslcYvHpMqY9B0G1GEBK \ 21chdTW0KNFrDYFAtVqGCu/jRmUtMUnyJ7JgtrBawVo1fJWkkbhu3ZrliSiZEbhu5biV6l2NWy \ 22N0vfKVJfDYJ7xYFhoVkOI8aimAxhK3+vRIYszDHeuJXrZgYz2ejkKp+pdH4sTYFpMaZPh0lt \ 23rUpgwa5Jw9byerbOTLbD1La9e3Zv2L8FB381fFVxVMdLJQ+13FMkJtCjSzdisof169hz/HnB \ 24vTsHMyjCix+PQgX58+jFB4gAADs=" 25 26 proc widgetData { widget action name args } { 27 variable widgetData 28 # Standard Data: 29 # * css 30 # * xml 31 # * xml_root 32 # * auto-indent 33 # * show-tag (AUTO | OFF) default AUTO 34 # * fontSize (-n, 0, +n) 35 # * textModify (0 | 1) 36 37 switch -- $action { 38 set { 39 set widgetData($widget:$name) [lindex $args 0] 40 } ;# switch -- set 41 get { 42 if { [info exists widgetData($widget:$name)] } { 43 return $widgetData($widget:$name) 44 } else { 45 return -code error -errorinfo "Can't found Widget Data '$name' in '$widget'.\n" 46 } ;# if-else (Data present) 47 } ;# switch -- get 48 } ;# switch (action) 49 } ;# proc widgetData 50 51 52# proc updateWidget 53source library/richtext-updatewidget.tcl 54 55# proc insTag 56source library/richtext-instag.tcl 57 58 proc selection { widget action args } { 59 set a_args(-node) {} 60 catch { array set a_args $args } 61 switch -- $action { 62 set { 63 if { ! [string equal $a_args(-node) {}] } { 64 set start [lindex [tagIndex $widget $a_args(-node) -type open ] 0] 65 set end [lindex [tagIndex $widget $a_args(-node) -type close ] 1] 66 } else { 67 foreach { start end } $args { break } 68 } ;# if 69 $widget tag remove sel 1.0 end 70 $widget tag add sel $start $end 71 } 72 get { 73 switch -- [lindex $args 0] { 74 index { return [$widget tag ranges sel] } 75 } ;# switch GET - _type_ 76 } 77 } ;# switch ACTION 78 } ;# proc selection 79 80 proc canDeleteText { widget start end args } { 81 set c_open [set c_close [set count 0]] 82 foreach { mark value index } [$widget dump -tag $start $end] { 83 if { [regexp {.*:open$} $value] } { incr count ; incr c_open } 84 if { [regexp {.*:close$} $value] } { incr count -1 ; incr c_close } 85 } ;# foreach 86 if { [expr $c_open / 2] == [expr int($c_open / 2)] } { return 0 } 87 if { [expr $c_close / 2] == [expr int($c_close / 2)] } { return 0 } 88 return $count 89 } ;# proc canDeleteText 90 91 92 proc textDelete { widget start end args } { 93 variable SysFunction 94 set a_args(-update) false 95 array set a_args $args 96 97 set xml [widgetData $widget get xml] 98 99 if { [string equal $a_args(-update) {true}] } { 100 foreach { mark value index } [$widget dump -window $start $end] { 101 regexp {(.*):[close|open|element]} $value {} widget_tag 102 set node [simxml::getNodes $xml {} widget $widget_tag] 103 if { $node != {} } { 104 simxml::setParam $xml $node -widget {} 105 } ;# if 106 } ;# foreach 107 $widget delete $start $end 108 109# NEED DELETE TAG info from XML Structure 110 } else { 111 # Can we delete or not? 112 if { [canDeleteText $widget $start $end] != 0 } { 113 # BUG: Need raise event for ErrorTextDelete 114 return -code error -errorcode 10 -errorinfo "Can't Delete Text from $start to $end in $widget\n" 115 } ;# if 116 117 set text_tag {} 118 set node_tag {} 119 set empty_sel 0 120 121 foreach { type_key value_key index_key } [$widget dump -all $start $end] { 122 switch -- $type_key { 123 tagon { 124 if [regexp {(.*?):(open|element)} $value_key -> node_tag node_type_tag] { 125 if [simxml::isNodeExists $xml $node_tag] { 126 gui::msgDebug "(type=$node_type_tag); $node_tag [simxml::nodeInfo $xml $node_tag name] text=[simxml::nodeInfo $xml $node_tag text]" 127 simxml::del $xml $node_tag 128 } ;# if node exists 129 continue 130 } ;# if needed tag is TAG (open || elements) 131 } ;# switch --- tagon && tagoff 132 } ;# switch type_key 133 } ;# foreach DUMP all from START to END 134 135 if { $empty_sel == 0 } { 136 set node_tag [$widget tag names $start] 137 set text_pos [lsearch $node_tag *:text] 138 set text_tag [$widget tag ranges [lindex $node_tag $text_pos]] 139 set start_tag [lindex $text_tag 0] 140 set end_tag [lindex $text_tag 1] 141 if { [regexp {(.*):text$} [lindex $node_tag $text_pos] {} text_node] && \ 142 ![string equal $text_node {}]} { 143 simxml::setParam $xml $text_node -text "[$widget get $start_tag $start][$widget get $end $end_tag]" 144 } ;# if 145 } else { 146 $widget delete $start $end 147 simxml::nodeTextConcatenate $xml 2 148 catch { 149# BUG 150# updateWidget $widget [widgetData $widget get xml_root] 151 updateWidget $widget 2 152 } ;# catch 153 Cursor $widget set $start 154 } ;# if-else empty selection from tag 155 } ;# if DELETE or UPDATE widget 156 } ;# proc textDelete 157 158 159 proc createWidget { args } { 160 variable SysFunction 161 162 set a_args(-text) {} 163 array set a_args $args 164 set xml $a_args(-xml) 165 set css $a_args(-css) 166 set widget $a_args(-widget) 167 set tag $a_args(-tag) 168 set typeTag $a_args(-typeTag) 169 set text $a_args(-text) 170 set ID $a_args(-id) 171 172 set css_text [simcss::getCSS $css $tag -get "tag-${typeTag}Tag" -xml $xml] 173 set css_font [simcss::getCSS $css $tag -get tag-font -xml $xml] 174 set name_widget "${widget}.tag:$ID:$typeTag" 175 set new_widget [label $name_widget \ 176 -text "$css_text" \ 177 -font "$css_font" \ 178 -background "[simcss::getParam $css $tag tag-background -xml $xml]" \ 179 -foreground "[simcss::getParam $css $tag tag-color -xml $xml]"] 180 181 bind $new_widget <1> $SysFunction($widget:bindWidgetClick) 182 bind $new_widget <Double-1> $SysFunction($widget:bindWidgetDoubleClick) 183 184 return $new_widget 185 } ;# proc createWidget 186 187 188 proc widget_pos { widget found_widget } { 189 foreach {key win tmp} [eval {$widget dump -window 1.0 end}] { 190 if {[string equal $win $found_widget]} { return [lindex $tmp 0] } 191 } 192 return {} 193 } ;# proc widget_pos 194 195 196 proc Get_Source { widget } { 197 variable tmp {} 198 foreach {key value index} [$widget dump 1.0 end] { 199 append tmp "$index: key=$key; value=$value\n" 200 } 201 return $tmp 202 } ;# proc Get_Source 203 204 205 proc insNode { widget index node title args } { 206 set a_args(-type) {} 207 set a_args(-tag) {} 208 array set a_args $args 209 210 set type $a_args(-type) 211 switch -- $type { 212 image { 213 $widget image create $index -image $title 214 $widget mark set tag:$node:element $index 215 return "$index + 1 chars" 216 } 217 } ;# switch $type 218 $widget insert $index $title $a_args(-tag) 219 $widget mark set tag:$node:$type $index 220 if { [string equal $type text] } { $widget mark gravity tag:$node:$type left } 221 222 set index [$widget index "$index + [string length $title] chars"] 223 return $index 224 } ;# proc insTag 225 226 227 proc nextTag { widget index } { 228 set tag_id [ set node_type {} ] 229 set after [$widget mark next $index] 230 while { (![regexp {^tag:([^:]+):([^:]+)$} $after -> tag_id node_type]) && 231 (![string equal $after {}]) } { 232 set after [$widget mark next $after] 233 } ;# while 234 return [list $after $tag_id $node_type] 235 } ;# proc nextTag 236 237 proc previousTag { widget index } { 238 set tag_id [ set node_type {} ] 239 set before [$widget mark previous $index] 240 while { ! [regexp {^tag:([^:]+):([^:]+)$} $before -> tag_id node_type] } { 241 set before [$widget mark previous $before] 242 } ;# while before 243 return [list $before $tag_id $node_type] 244 } ;# proc currentTag 245 246 proc tagIndex { widget node args } { 247 set a_args(-type) "" 248 set a_args(-xml) "" 249 array set a_args $args 250 251 set curTag tag:$node:$a_args(-type) 252 if { [catch {$widget index $curTag}] } { 253 return {} 254 } else { 255 set nextTag [lindex [nextTag $widget $curTag] 0] 256 } 257 if { [string equal $nextTag {}] } { set nextTag end } 258 return [list $curTag $nextTag] 259 } ;# proc tagIndex 260 261 proc create { widget args } { 262 variable ID 263 variable SysFunction 264 265 set a_args(-wrap) word 266 set a_args(-widget) text 267 array set a_args $args 268 269 if { ![info exists ID] } { set ID 0 } 270 271 set wName $a_args(-widget) ; unset a_args(-widget) 272 set widget [eval "text $widget.$wName" [array get a_args]] 273 pack $widget -side left -fill both -expand true 274 275# EXTERNAL SOURCE 276# BUG!!!!!!!!!!!!!!!!!!!! path to library 277 source library/richtext-bind.tcl 278 279 setSysEvent $widget 280 setSysFunction $widget 281 282 $widget tag configure sel -borderwidth 1 -foreground black -background #EEEEEE 283 284 widgetData $widget set xml {} 285 widgetData $widget set css {} 286 widgetData $widget set auto-indent 0 287 widgetData $widget set show-tag AUTO 288 widgetData $widget set fontSize 0 289 widgetData $widget set textModify 0 290 291 $widget tag configure hightlightBorder -borderwidth 1 -relief solid 292 $widget tag configure tag -foreground gray50 -font {{Courier New} 11} 293 $widget tag configure emptyTag -foreground white -font {Arial 1} 294 $widget tag configure tagAttr -foreground #00a0a0 -font {{Ciurier New} 11} 295 foreach { indent } [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15] { 296 set res [expr $indent * 10] 297 $widget tag configure indent$indent -lmargin1 $res -lmargin2 $res 298 } ;# foreach INDENT 299 300 return $widget 301 } ;# proc create 302 303 304 proc setSysEvent { widget } { 305 # after <<TextChange>> --- Update XML Tree data 306if { 1 != 1 } { 307 Bind $widget after <<TextChange>> { 308 set cursor [Cursor %W get] 309 set tags [%W tag names $cursor] 310 set pos [lsearch $tags *:text] 311 set text_tag [%W tag ranges [lindex $tags $pos]] 312 set start_tag [lindex $text_tag 0] 313 set end_tag [lindex $text_tag 1] 314 set text_node {} 315 regexp {(.*):text$} [lindex $tags $pos] {} text_node 316# UPDATE XML Text Tag 317 if {![string equal $text_node {}]} { 318 # Cursor in first TEXT Tag position ?? 319 if { [%W compare $cursor != $start_tag] } { 320 simxml::setParam [widgetData %W get xml] $text_node -text [%W get $start_tag $end_tag] 321 } else { 322 simxml::setParam [widgetData %W get xml] $text_node -text [%W get "$cursor - 1 char" $end_tag] 323 %W tag add [lindex $tags $pos] "$cursor - 1 char" $end_tag 324 } ;# if-else Cursor in first TEXT Tag position 325 } else { 326 # CURSOR in end text:tag position. Need update text:TAG in widget 327 set text_node {} 328 set tags [%W tag names "$cursor - 2 char"] 329 set pos [lsearch $tags *:text] 330 set text_tag [%W tag ranges [lindex $tags $pos]] 331 set start_tag [lindex $text_tag 0] 332 regexp {(.*):text$} [lindex $tags $pos] {} text_node 333 if { ![string equal $text_node {}] } { 334 %W tag add [lindex $tags $pos] $start_tag $cursor 335 set xml [widgetData %W get xml] 336 if [simxml::isNodeExists $xml $text_node] { 337 simxml::setParam $xml $text_node -text "[%W get $start_tag $cursor]" 338 #continue 339 } ;# if node exists 340 # NEED UPDATE XML tree 341 } ;# if 342 } ;# if-else 343 } ;# Bind after <<TextChange>> 344} ;# IF COMMENT 345 346 } ;# proc setSysEvent 347 348 349 proc setSysFunction { widget } { 350 variable SysFunction 351 # BUG !!!!!!!!!!!!! EMPTY SET System function 352 foreach { typeFunction } [list {:system} {}] { 353 set SysFunction($widget:createWidget$typeFunction) \ 354 "createWidget" 355 set SysFunction($widget:bindWidgetClick$typeFunction) "" 356 set SysFunction($widget:bindWidgetDoubleClick$typeFunction) "" 357 } ;# foreach (systemFunction) 358 } ;# proc setSysFunction 359 360 361 proc Bind { widget event sequence args } { 362 variable BIND 363# BIND: KeyPress 364 365# ERORR 'event' attribute 366 if { ![string equal $event before] == ![string equal $event after] } { 367 return -code error -errorinfo "'$event' is not avaliable for Bind.\n" 368 } ;# 369 370 if { ![string equal $args {}] } { 371 lappend BIND($widget:$sequence:$event) [lindex $args 0] 372 } else { 373 if { ![info exists BIND($widget:$sequence:$event)] } { 374 return -code error -errorinfo "Not found script for sequence '$sequence'.\n" 375 } else { 376 return $BIND($widget:$sequence:$event) 377 } ;# if 378 } ;# if 379 } ;# proc bind 380 381 proc eventAfter { widget sequence args} { 382 variable BIND 383 384 if { [info exists BIND($widget:$sequence:after)] } { 385 foreach { command } $BIND($widget:$sequence:after) { 386 foreach { param value } $args { 387 regsub -all $param $command $value command 388 } ;# foreach 389 uplevel $command 390 } ;# foreach 391 } ;#if 392 } ;# proc eventAfter 393 394 395 proc eventBefore { widget sequence args} { 396 variable BIND 397 398 if { [info exists BIND($widget:$sequence:before)] } { 399 foreach { command } $BIND($widget:$sequence:before) { 400 foreach { param value } $args { 401 regsub -all $param $command $value command 402 } ;# foreach 403 uplevel $command 404 } ;# foreach 405 } ;#if 406 } ;# proc eventBefore 407 408 409 proc Cursor { widget action args } { 410 411 set cur_index {} 412 set xml [widgetData $widget get xml] 413 414 if { [string equal $action "set"] && (![string equal [lindex $args 0] "TAG"]) } { 415 if { ![string match *-no-event $args] } { 416 eval $widget mark set insert {[lindex $args 0]} 417 event generate $widget {<<CursorMove>>} -root $widget 418 } else { 419 eval $widget mark set insert {[lindex $args 0]} 420 } ;# if 421 return 422 } ;# if (action eq "set") 423 424# GET Cursor position (default) 425 if { [string equal $args {}] } { 426 switch -- $action { 427 get { 428 set cur_index insert 429 } ;# get 430 } ;# switch 431 432# IF needed get Tag ID in Cursor position 433 } elseif { [string equal [lindex $args 0] {TAG}] } { 434 switch -- $action { 435 get { 436 return [lindex [previousTag $widget insert] 1] 437 return $xml_node 438 } ;# get 439 set { 440 set xml_node [lindex $args 1] 441 #set xml_index [$widget tag ranges "${xml_node}:open"] 442 switch -- [simxml::nodeInfo $xml $xml_node type] { 443 ELEMENT { set xml_type element } 444 TAG { set xml_type open } 445 TEXT { set xml_type text } 446 } ;# switch 447 set xml_index [tagIndex $widget $xml_node -type $xml_type] 448 if { [llength $xml_index] != 0 } { 449 Cursor $widget set [lindex $xml_index 1] 450 } ;# if 451 } 452 } ;# switch 453 } ;# if 454 455 return $cur_index 456 } ;# proc Cursor 457 458 459 proc Paste { widget args } { 460 set a_args(-text) {} 461 set a_args(-index) insert 462 array set a_args $args 463 464 465 set a_args(-text) [gui::clipboardGet] 466 467 set cur_tag [previousTag $widget insert] 468 switch -- [lindex $cur_tag 2] { 469 text { 470 $widget insert $a_args(-index) $a_args(-text) 471 updateTag $widget -index $a_args(-index) 472 } 473 empty { 474 set cur_tag [richtext::previousTag $widget insert] 475 set cur_insert [$widget index [lindex $cur_tag 0]] 476 set next_tag [richtext::nextTag $widget [lindex $cur_tag 0]] 477 if { [string equal $next_tag {}] } { set next_tag end } 478 $widget tag delete [lindex $cur_tag 1]:empty 479 $widget delete [lindex $cur_tag 0] [lindex $next_tag 0] 480 set xml [richtext::widgetData $widget get xml] 481 set xml_node [simxml::add $xml [lindex $cur_tag 1] {} -text $a_args(-text) -type TEXT] 482 richtext::updateWidget $widget [lindex $cur_tag 1] 483 richtext::Cursor $widget set "$cur_insert + [string length $a_args(-text)] chars" 484 } 485 default { return } 486 }; # switch 487 richtext::eventAfter $widget <<CursorMove>> %A "" %W $widget %K "" 488 } ;# proc Paste 489 490 491 proc updateTag { widget args } { 492 set a_args(-index) insert 493 set a_args(-tag) [previousTag $widget insert] 494 array set a_args $args 495 496 # BUG !!!!!!!!! Esli vyzyvat' ne -index, a -tag 497 set cur_tag $a_args(-tag) 498 set next_tag [richtext::nextTag $widget [lindex $cur_tag 0]] 499 500 if { [string equal $next_tag {}] } { set next_tag end } 501 simxml::setParam [richtext::widgetData $widget get xml] [lindex $cur_tag 1] \ 502 -text [$widget get [lindex $cur_tag 0] [lindex $next_tag 0]] 503 # BUG!!!!!!! zestko zavyazan na imeni text TAG pri izmenenii 504 # algoritma budut problemy. 505 $widget tag add [lindex $cur_tag 1]:text [lindex $cur_tag 0] [lindex $next_tag 0] 506 507 } ;# proc updateTag 508 509# source for STATUS widget 510source library/richtext-status.tcl 511 512} 513 514