##################################################### # proc richtext pathname [-option value ...] # # builds a text widget with word processing capability # i. e. wrap word, cursor up/down by displayed line. # # Usage: # richtext .wp ? option value ? ... # produces a widget with certain WP abilities: # # Cursor navigates as expected by some DAU even if line is wrapped. # Smart quotes: none, de, en ... (switchable). # Typographical dashes by key sequences -- and --- (switchable). # Triple-click selects grammatical sentence. # Quadruple-click selects logical line (= paragraph) # # ::Richtext::requireTypoDash ? (1 | 0) ? # switches double & triple key minus to produce typographical dashes # # ::Richtext::setQuotes ? (de | en | fr | ch | C) ? # switches keys \" and \' to produce national "smart" quotes # or just \" if lang is C (which is default). # # 2003-03-13 Wolf Busch, Oberkleen ###################################################### namespace eval Richtext { namespace export richtext array set object {} variable quoteMode C variable doubleQuotes [list \" \"] variable singleQuotes [list ' '] variable typoDashRequired 1 variable actualWindow {} variable actualObject {} } proc ::Richtext::richtext {widget {objectName {}}} { variable object eval text $widget -wrap word if {$objectName ne {}} { set object($widget) $objectName } set taglist {} foreach tag [bindtags $widget] { if {$tag eq "Text"} { # lappend taglist Beforetext Richtext Aftertext lappend taglist Richtext } else { lappend taglist $tag } } bindtags $widget $taglist $widget configure -cursor "" return $widget } proc ::Richtext::unselectTablePartiallySelected {text} { if {[$text tag ranges sel] ne {}} { foreach {from to} [$text tag ranges blockobject] { if {[$text compare $from < sel.first] &&\ [$text compare $to > sel.first]} { $text tag remove sel sel.first $to if {[$text compare insert < $to]} { $text mark set insert $to } if {[$text tag ranges sel] eq {}} { break } } if {[$text compare $to > sel.last] &&\ [$text compare $from < sel.last]} { $text tag remove sel $from-1chars sel.last if {[$text compare insert > $from-1chars]} { $text mark set insert $from-1chars } if {[$text tag ranges sel] eq {}} { break } } } } } proc ::Richtext::TextInsert {w s} { variable object if {[string equal $s ""] ||\ [string equal [$w cget -state] "disabled"]} { return } set compound 0 catch { if {[$w compare sel.first <= insert] &&\ [$w compare sel.last >= insert]} { set oldSeparator [$w cget -autoseparators] if { $oldSeparator } { $w configure -autoseparators 0 $w edit separator set compound 1 } unselectTablePartiallySelected $w $w delete sel.first sel.last } } # $w insert insert $s $w insert insert $s [$w tag names insert] $w see insert if { $compound && $oldSeparator } { $w edit separator $w configure -autoseparators 1 } if {[info exists object($w)]} { $object($w) configure -changed 1 } } proc ::Richtext::requireTypoDash {{typo 1}} { variable typoDashRequired set typoDashRequired $typo } proc ::Richtext::insertDash {widget {index insert}} { variable typoDashRequired set tags [$widget tag names $index] if {[atWordEnd $widget $index]} { eval lappend tags [$widget tag names $index-1chars] } if {[string is true $typoDashRequired] &&\ ([lsearch $tags pre] < 0) &&\ ([lsearch $tags tt] < 0)} { switch -- .[$widget get $index-1chars] { .- { $widget delete $index-1chars $widget insert $index \u2013 } .\u2013 { $widget delete $index-1chars $widget insert $index \u2014 } default { $widget insert $index - } } } else { $widget insert $index - } } proc ::Richtext::atWordEnd {widget {index insert}} { variable doubleQuotes variable singleQuotes set endpattern "" append endpattern \ \[^\[:space:\]\] \ \[ \ \[:space:\] \ {?!:.,} \ ">\)\\\]\}" \ \] # set startpattern "" append startpattern \ \[ \ "\{\[(<" \ [lindex $doubleQuotes 1]\ [lindex $singleQuotes 1]\ \]. # if {[$widget compare $index == 1.0]} { return 0 } elseif {[regexp\ $startpattern\ [$widget get $index-1chars $index+1chars]]} { return 0 } elseif {[regexp\ $endpattern\ [$widget get $index-1chars $index+1chars]]} { return 1 } else { return 0 } } proc ::Richtext::insertQuote {widget {index insert} {quotelist doubleQuotes}} { set tags [$widget tag names $index] if {[atWordEnd $widget $index]} { eval lappend tags [$widget tag names $index-1chars] } if {([lsearch $tags pre] >= 0) || ([lsearch $tags tt] >= 0)} { switch $quotelist { doubleQuotes { $widget insert $index \" $tags } default { $widget insert $index ' $tags } } return } variable doubleQuotes variable singleQuotes upvar 0 $quotelist quotes if {[atWordEnd $widget $index]} { $widget insert $index [lindex $quotes end] $tags } else { $widget insert $index [lindex $quotes 0] $tags } } proc ::Richtext::setQuotes {{language C}} { variable doubleQuotes variable singleQuotes variable quoteMode switch [string tolower $language] { german - deutsch - de { set quoteMode de set singleQuotes [list \u201a \u2018] set doubleQuotes [list \u201e \u201c] } englisch - english - en { set quoteMode en set singleQuotes [list \u2018 \u2019] set doubleQuotes [list \u201c \u201d] } schweiz - schweizerisch - swiss - suisse - ch { set quoteMode ch set singleQuotes [list \u203a \u2039] set doubleQuotes [list \u00bb \u00ab] } französisch - francais - fr { set quoteMode fr set singleQuotes [list \u2039 \u203a] set doubleQuotes [list \u00ab \u00bb] } default { set quoteMode C set singleQuotes [list ' '] set doubleQuotes [list \" \"] } } echo quoteMode $quoteMode } namespace import Richtext::richtext proc tmp {} { foreach binding [bind Text] { bind Richtext $binding\ [string map\ {tk::TextInsert Richtext::TextInsert}\ [bind Text $binding]] } # bind Richtext [bind Text ] # bind Richtext { # ::tk::TextSetCursor %W [list @%x,%y linestart] # ::tk::TextKeySelect %W insert+1lines # } bind Richtext { tk::TextInsert %W \u00ad } bind Richtext { tk::TextInsert %W \n\u000c\n } bind Richtext { tk::TextInsert %W \" } bind Richtext { tk::TextInsert %W ' } bind Richtext { tk::TextInsert %W \u20ac } bind Richtext [list [lambda {w x y} { # bind Richtext (this) set linestart [$w index "@$x,$y linestart"] if {[lsearch [$w tag names $linestart] prefix] >= 0} { set range [$w tag prevrange prefix $linestart+1chars] set linestart [lindex $range end] } ::tk::TextSetCursor $w $linestart ::tk::TextKeySelect $w "insert linestart + 1lines" }] %W %x %y] foreach {key script} { { set tk::Priv(selectMode) sentence tk::TextSetCursor %W\ [Richtext::prevSentenceIndex %W [%W index @%x,%y]] tk::TextKeySelect %W\ [Richtext::nextSentenceIndex %W insert] } { tk::TextResetAnchor %W @%x,%y tk::TextSelectTo %W %x %y 1 } { tk::TextSetCursor %W [Richtext::dLineUpIndex %W insert] } { tk::TextSetCursor %W [Richtext::dLineDownIndex %W insert] } { tk::TextKeySelect %W [Richtext::dLineUpIndex %W insert] } { tk::TextKeySelect %W [Richtext::dLineDownIndex %W insert] } { tk::TextSetCursor %W [Richtext::dLineStartIndex %W insert] } { tk::TextKeySelect %W [Richtext::dLineStartIndex %W insert] } { tk::TextSetCursor %W [Richtext::dLineEndIndex %W insert] } { tk::TextKeySelect %W [Richtext::dLineEndIndex %W insert] } } { bind Richtext $key $script } foreach {cursorKey letter} { Right f Left b Home a End e } { bind Richtext [subst { if {!\$tk_strictMotif} { event generate %W <$cursorKey> } }] } bind Richtext { ::Richtext::insertQuote %W insert doubleQuotes } bind Richtext { ::Richtext::insertQuote %W insert singleQuotes } bind Richtext { ::Richtext::insertDash %W insert } bind Richtext { ::Richtext::insertDash %W insert } bind Richtext { catch {::itcl::delete object $::Richtext::object(%W)} array unset ::Richtext::object %W } bind Richtext { %W insert insert \u00a0 [%W tag names insert] } } tmp rename tmp {} proc ::Richtext::prevSentenceIndex {widget {pos insert}} { # return index of previous grammatical sentence begin. set dotIndex\ [$widget search\ -count found\ -backwards\ -regexp {[\:.?!][\]\})]?( |\t|$)} $pos 1.0] if {$dotIndex eq ""} { # no previous dot, so return start index of doc. return 1.0 } # now find next non-blank index. set charIndex\ [$widget search -regexp {[^[:space:]]} "$dotIndex + $found chars" end] if {$charIndex eq ""} { # no non-blank, so return end index of doc. return [$widget index end-1chars] } else { set range [$widget tag prevrange blockobject $pos 1.0] if {($range ne {}) &&\ [$widget compare [lindex $range end] > $charIndex]} { return [lindex $range end] } else { return $charIndex } } } # end of ::Richtext::prevSentenceIndex proc ::Richtext::nextSentenceIndex {widget {pos insert}} { # return index of next grammatical sentce begin. set dotIndex\ [$widget search -regexp {[\:.?!][\]\})]?( |\t|$)} $pos end] if {$dotIndex eq ""} { # no dot found, so return end index of doc. $widget index end-1chars } else { $widget search -regexp {( |\t|$)} $dotIndex end } } # end of ::Richtext::nextSentenceIndex proc ::Richtext::dLineStartIndex {widget {pos insert}} { # return start index of displayed line $widget xview moveto 0 set dline [$widget dlineinfo $pos] set beginX [lindex $dline 0] set beginY [lindex $dline 1] # return this value: $widget index @$beginX,$beginY } proc ::Richtext::dLineEndIndex {widget {pos insert}} { # return end index of displayed line set dline [$widget dlineinfo $pos] set endY [lindex $dline 1] set endX [lindex $dline 0] incr endX [lindex $dline 2] set tooWide [expr {$endX > [winfo width $widget]}] if {$tooWide} { $widget xview moveto 1 } else { $widget xview moveto 0 } set index [$widget index @[winfo width $widget],$endY] $widget see $index return $index } proc ::Richtext::dLineUpIndex {widget {pos insert}} { # return index of next char upwards inside text widget $widget see $pos if {[$widget dlineinfo $pos] == [$widget dlineinfo 1.0]} { return [$widget index $pos] } set bbox [$widget bbox $pos] if {[string equal $bbox ""]} { set x 0 } elseif {[$widget get $pos] == "\n"} { set x [expr {[lindex $bbox 0] + [lindex $bbox 3] / 4}] } else { set x [expr {[lindex $bbox 0] + [lindex $bbox 2] / 2}] } set lbox [$widget dlineinfo $pos] set y [lindex $lbox 1] if {$y < 5} { $widget yview scroll -1 units set lbox [$widget dlineinfo $pos] set y [lindex $lbox 1] } incr y -1 # return this value: $widget index @$x,$y } proc ::Richtext::dLineDownIndex {widget {pos insert}} { # return index of next char downwards inside text widget $widget see $pos if {[$widget dlineinfo $pos] == [$widget dlineinfo end-1chars]} { return [$widget index $pos] } set bbox [$widget bbox $pos] if {[string equal $bbox ""]} { set x 0 } elseif {[$widget get $pos] == "\n"} { set x [expr {[lindex $bbox 0] + [lindex $bbox 3] / 4}] } else { set x [expr {[lindex $bbox 0] + [lindex $bbox 2] / 2}] } set lbox [$widget dlineinfo $pos] set y [lindex $lbox 1] incr y [lindex $lbox 3] incr y 5 if {$y > [winfo height $widget]} { # scrollDown $widget yview scroll 1 units set lbox [$widget dlineinfo $pos] set y [lindex $lbox 1] set dy [lindex $lbox 3] incr y $dy incr y 5 } # return this value: $widget index @$x,$y } # extending tk function: # extends switch $Priv(selectMode) by clause "sentence" # which should not matter functions of normal text widgets. proc ::tk::TextSelectTo {w x y {extend 0}} { global tcl_platform variable Priv set cur [TextClosestGap $w $x $y] if {[catch {$w index anchor}]} { $w mark set anchor $cur } set anchor [$w index anchor] if {[$w compare $cur != $anchor] || (abs($Priv(pressX) - $x) >= 3)} { set Priv(mouseMoved) 1 } switch $Priv(selectMode) { char { if {[$w compare $cur < anchor]} { set first $cur set last anchor } else { set first anchor set last $cur } } word { if {[$w compare $cur < anchor]} { set first [TextPrevPos $w "$cur + 1c" tcl_wordBreakBefore] if { !$extend } { set last [TextNextPos $w "anchor" tcl_wordBreakAfter] } else { set last anchor } } else { set last [TextNextPos $w "$cur - 1c" tcl_wordBreakAfter] if { !$extend } { set first [TextPrevPos $w anchor tcl_wordBreakBefore] } else { set first anchor } } } sentence { # here the extension! if {[$w compare $cur < anchor]} { set first [::Richtext::prevSentenceIndex $w $cur] set last [::Richtext::nextSentenceIndex $w anchor] } else { set first [::Richtext::prevSentenceIndex $w anchor] set last [::Richtext::nextSentenceIndex $w $cur] } } line { if {[$w compare $cur < anchor]} { set first [$w index "$cur linestart"] set last [$w index "anchor - 1c lineend + 1c"] } else { set first [$w index "anchor linestart"] set last [$w index "$cur lineend + 1c"] } # modification if {[lsearch [$w tag names $last] blockobject] >= 0} { set last [$w index $last-1chars] } } } if {$Priv(mouseMoved) || [string compare $Priv(selectMode) "char"]} { $w tag remove sel 0.0 end $w mark set insert $cur $w tag add sel $first $last $w tag remove sel $last end update idletasks } } proc ::tk_textPaste w { global tcl_platform if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} { set oldSeparator [$w cget -autoseparators] if { $oldSeparator } { $w configure -autoseparators 0 $w edit separator } # if {[string compare [tk windowingsystem] "x11"]} { # catch { $w delete sel.first sel.last } # } # catch { $w delete sel.first sel.last } # $w insert insert $sel if { $oldSeparator } { $w edit separator $w configure -autoseparators 1 } } }