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

   1 # entry.tcl --
   2 #
   3 # This file contains Tcl procedures used to manage Tk entries.
   4 #
   5 # $Header: /user6/ouster/wish/scripts/RCS/entry.tcl,v 1.2 92/05/23 16:40:57 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 # The procedure below is invoked to backspace over one character
  18 # in an entry widget.  The name of the widget is passed as argument.
  19
  20 proc tk_entryBackspace w {
  21     set x [expr {[$w index cursor] - 1}]
  22     if {$x != -1} {$w delete $x}
  23 }
  24
  25 # The procedure below is invoked to backspace over one word in an
  26 # entry widget.  The name of the widget is passed as argument.
  27
  28 proc tk_entryBackword w {
  29     set string [$w get]
  30     set curs [expr [$w index cursor]-1]
  31     if {$curs < 0} return
  32     for {set x $curs} {$x > 0} {incr x -1} {
  33         if {([string first [string index $string $x] " \t"] < 0)
  34                 && ([string first [string index $string [expr $x-1]] " \t"]
  35                 >= 0)} {
  36             break
  37         }
  38     }
  39     $w delete $x $curs
  40 }
  41
  42 # The procedure below is invoked after insertions.  If the caret is not
  43 # visible in the window then the procedure adjusts the entry's view to
  44 # bring the caret back into the window again.
  45
  46 proc tk_entrySeeCaret w {
  47     set c [$w index cursor]
  48     set left [$w index @0]
  49     if {$left > $c} {
  50         $w view $c
  51         return
  52     }
  53     while {[$w index @[expr [winfo width $w]-5]] < $c} {
  54         set left [expr $left+1]
  55         $w view $left
  56     }
  57 }
  58
  59 proc tk_entryCopyPress {w} {
  60   set sel ""
  61   catch {set sel [selection -window $w get]}
  62   $w insert cursor $sel
  63   tk_entrySeeCaret $w
  64 }
  65
  66 proc tk_entryCutPress {w} {
  67   catch {$w delete sel.first sel.last}
  68   tk_entrySeeCaret $w
  69 }
  70
  71 proc tk_entryDelLine {w} {
  72   $w delete 0 end
  73 }
  74
  75 proc tk_entryDelPress {w} {
  76   tk_entryBackspace $w
  77   tk_entrySeeCaret $w
  78 }