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