Return to text.tcl CVS log

Up to [Micropolis - Activity] / micropolis / res

Annotation of micropolis/res/text.tcl, revision 1.1

1.1     ! root        1: # text.tcl --
        !             2: #
        !             3: # This file contains Tcl procedures used to manage Tk entries.
        !             4: #
        !             5: # $Header: /user6/ouster/wish/scripts/RCS/text.tcl,v 1.2 92/07/16 16:26:33 ouster Exp $ SPRITE (Berkeley)
        !             6: #
        !             7: # Copyright 1992 Regents of the University of California
        !             8: # Permission to use, copy, modify, and distribute this
        !             9: # software and its documentation for any purpose and without
        !            10: # fee is hereby granted, provided that this copyright
        !            11: # notice appears in all copies.  The University of California
        !            12: # makes no representations about the suitability of this
        !            13: # software for any purpose.  It is provided "as is" without
        !            14: # express or implied warranty.
        !            15: #
        !            16: 
        !            17: # $tk_priv(selectMode@$w) holds one of "char", "word", or "line" to
        !            18: # indicate which selection mode is active.
        !            19: 
        !            20: # The procedure below is invoked when dragging one end of the selection.
        !            21: # The arguments are the text window name and the index of the character
        !            22: # that is to be the new end of the selection.
        !            23: 
        !            24: proc tk_textSelectTo {w x {y ""}} {
        !            25:     global tk_priv
        !            26:     if {$y != ""} {
        !            27:       set index @$x,$y
        !            28:     } else {
        !            29:       set index $x
        !            30:     }
        !            31: 
        !            32:     if {![info exists tk_priv(selectMode@$w)]} {
        !            33:       set tk_priv(selectMode@$w) "char"
        !            34:     }
        !            35:     case $tk_priv(selectMode@$w) {
        !            36:        char {
        !            37:            if [$w compare $index < anchor] {
        !            38:                set first $index
        !            39:                set last anchor
        !            40:            } else {
        !            41:                set first anchor
        !            42:                set last [$w index $index+1c]
        !            43:            }
        !            44:        }
        !            45:        word {
        !            46:            if [$w compare $index < anchor] {
        !            47:                set first [$w index "$index wordstart"]
        !            48:                set last [$w index "anchor wordend"]
        !            49:            } else {
        !            50:                set first [$w index "anchor wordstart"]
        !            51:                set last [$w index "$index wordend"]
        !            52:            }
        !            53:        }
        !            54:        line {
        !            55:            if [$w compare $index < anchor] {
        !            56:                set first [$w index "$index linestart"]
        !            57:                set last [$w index "anchor lineend + 1c"]
        !            58:            } else {
        !            59:                set first [$w index "anchor linestart"]
        !            60:                set last [$w index "$index lineend + 1c"]
        !            61:            }
        !            62:        }
        !            63:     }
        !            64:     $w tag remove sel 0.0 $first
        !            65:     $w tag add sel $first $last
        !            66:     $w tag remove sel $last end
        !            67: }
        !            68: 
        !            69: # The procedure below is invoked to backspace over one character in
        !            70: # a text widget.  The name of the widget is passed as argument.
        !            71: 
        !            72: proc tk_textBackspace w {
        !            73:     catch {$w delete insert-1c insert}
        !            74: }
        !            75: 
        !            76: # The procedure below compares three indices, a, b, and c.  Index b must
        !            77: # be less than c.  The procedure returns 1 if a is closer to b than to c,
        !            78: # and 0 otherwise.  The "w" argument is the name of the text widget in
        !            79: # which to do the comparison.
        !            80: 
        !            81: proc tk_textIndexCloser {w a b c} {
        !            82:     set a [$w index $a]
        !            83:     set b [$w index $b]
        !            84:     set c [$w index $c]
        !            85:     if [$w compare $a <= $b] {
        !            86:        return 1
        !            87:     }
        !            88:     if [$w compare $a >= $c] {
        !            89:        return 0
        !            90:     }
        !            91:     scan $a "%d.%d" lineA chA
        !            92:     scan $b "%d.%d" lineB chB
        !            93:     scan $c "%d.%d" lineC chC
        !            94:     if {$chC == 0} {
        !            95:        incr lineC -1
        !            96:        set chC [string length [$w get $lineC.0 $lineC.end]]
        !            97:     }
        !            98:     if {$lineB != $lineC} {
        !            99:        return [expr {($lineA-$lineB) < ($lineC-$lineA)}]
        !           100:     }
        !           101:     return [expr {($chA-$chB) < ($chC-$chA)}]
        !           102: }
        !           103: 
        !           104: # The procedure below is called to reset the selection anchor to
        !           105: # whichever end is FARTHEST from the index argument.
        !           106: 
        !           107: proc tk_textResetAnchor {w x y} {
        !           108:     global tk_priv
        !           109:     set index @$x,$y
        !           110:     if {[$w tag ranges sel] == ""} {
        !           111:        set tk_priv(selectMode@$w) char
        !           112:        $w mark set anchor $index
        !           113:        return
        !           114:     }
        !           115:     if [tk_textIndexCloser $w $index sel.first sel.last] {
        !           116:        if {![info exists tk_priv(selectMode@$w)]} {
        !           117:          set tk_priv(selectMode@$w) "char"
        !           118:        }
        !           119:        if {$tk_priv(selectMode@$w) == "char"} {
        !           120:            $w mark set anchor sel.last
        !           121:        } else {
        !           122:            $w mark set anchor sel.last-1c
        !           123:        }
        !           124:     } else {
        !           125:        $w mark set anchor sel.first
        !           126:     }
        !           127: }
        !           128: 
        !           129: proc tk_textDown {w x y} {
        !           130:     global tk_priv
        !           131:     set tk_priv(selectMode@$w) char
        !           132:     $w mark set insert @$x,$y
        !           133:     $w mark set anchor insert
        !           134:     if {[lindex [$w config -state] 4] == "normal"} {focus $w}
        !           135: }
        !           136: 
        !           137: proc tk_textDoubleDown {w x y} {
        !           138:     global tk_priv
        !           139:     set tk_priv(selectMode@$w) word
        !           140:     $w mark set insert "@$x,$y wordstart"
        !           141:     tk_textSelectTo $w insert
        !           142: }
        !           143: 
        !           144: proc tk_textTripleDown {w x y} {
        !           145:     global tk_priv
        !           146:     set tk_priv(selectMode@$w) line
        !           147:     $w mark set insert "@$x,$y linestart"
        !           148:     tk_textSelectTo $w insert
        !           149: }
        !           150: 
        !           151: proc tk_textAdjustTo {w x y} {
        !           152:     tk_textResetAnchor $w $x $y
        !           153:     tk_textSelectTo $w $x $y
        !           154: }
        !           155: 
        !           156: proc tk_textKeyPress {w a} {
        !           157:     if {"$a" != ""} {
        !           158:        $w insert insert $a
        !           159:        $w yview -pickplace insert
        !           160:     }
        !           161: }
        !           162: 
        !           163: proc tk_textReturnPress {w} {
        !           164:     $w insert insert \n
        !           165:     $w yview -pickplace insert
        !           166: }
        !           167: 
        !           168: proc tk_textDelPress {w} {
        !           169:   tk_textBackspace $w
        !           170:   $w yview -pickplace insert
        !           171: }
        !           172: 
        !           173: proc tk_textCutPress {w} {
        !           174:   catch {$w delete sel.first sel.last}
        !           175: }
        !           176: 
        !           177: proc tk_textCopyPress {w} {
        !           178:     set sel ""
        !           179:     catch {set sel [selection -window $w get]}
        !           180:     $w insert $sel
        !           181:     $w yview -pickplace insert
        !           182: }
        !           183: 
        !           184: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.