git.zerfleddert.de Git - micropolis/blob - res/text.tcl

   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