Portage depuis Perl

1 files changed, 186 insertions, 0 deletions

diff --git a/library/zincText.tcl b/library/zincText.tcl
new file mode 100644
index 0000000..3aef8a1
--- /dev/null
+++ b/library/zincText.tcl
@@ -0,0 +1,186 @@
+#
+# ZincText - Zinc extension for text input on text items and fields
+#
+# $Id$
+#
+# AUTHOR
+#
+# Patrick Lecoanet <lecoanet@cena.fr>
+# (and documentation by Christophe Mertz <mertz@cena.fr>)
+#
+# Copyright (c) 2002 - 2003 CENA, Patrick Lecoanet
+#
+# This code is free software; you can redistribute it and/or
+# modify it under the terms of the GNU Library General Public
+# License as published by the Free Software Foundation; either
+# version 2 of the License, or (at your option) any later version.
+#
+# This code is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+# Library General Public License for more details.
+#
+# You should have received a copy of the GNU Library General Public
+# License along with this code; if not, write to the Free
+# Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+#
+#
+# SYNOPSIS
+#
+#  package require ZincText;
+#
+#  zn_TextBindings $zinc
+#
+#  $zinc addtag text withtag $a_text
+#  $zinc addtag text withtag $a_track
+#  $zinc addtag text withtag $a_waypoint
+#  $zinc addtag text withtag $a_tabular
+#
+#
+# DESCRIPTION
+#
+# This module implements text input with the mouse and keyboard 'a la emacs'.
+# Text items must have the 'text' tag and must of course be sensitive.
+# Track, waypoint and tabular items have fields and these fields can
+# be edited the same way. Only sensitive fields can be edited. the following
+# interactions are supported:
+#
+#   <click 1>      To set the cursor position
+#   <click 2>      To paste the current selection
+#   <drag 1>       To make a selection
+#   <shift drag 1> To extend the current selection
+#   <shift 1>      To extend the current selection
+#   <left arrow>,
+#   <right arrow>  To move the cursor to the left or to the right
+#   <up arrow>,
+#   <down arrow>   To move the cursor up or down a line
+#   <ctrl+a>,
+#   <home>         To move the cursor at the begining of the line
+#   <ctrl+e>
+#   <end>          To move the cursor at the end of the line
+#   <meta+<>,
+#   <meta+>>       To move the cursor at the beginning / end of the text
+#   <BackSpace>
+#   <ctrl+h>       To delete the char just before the cursor
+#   <Delete>       To delete the char just after the cursor
+#   <Return>       To insert a return char. This does not validate the input!
+#
+#
+
+
+proc zn_TextBindings {zinc} {
+    $zinc bind text <1>              "startSel $zinc %x %y"
+    $zinc bind text <2>              "pasteSel $zinc %x %y"
+    $zinc bind text <B1-Motion>      "extendSel $zinc %x %y"
+    $zinc bind text <Shift-B1-Motion> "extendSel $zinc %x %y"
+    $zinc bind text <Shift-1>        "$zinc select adjust current @%x,%y"
+    $zinc bind text <Left> sub       "moveCur $zinc -1"
+    $zinc bind text <Right> sub      "moveCur $zinc 1"
+    $zinc bind text <Up> sub         "setCur $zinc up"
+    $zinc bind text <Down> sub       "setCur $zinc down"
+    $zinc bind text <Control-a>      "setCur $zinc bol"
+    $zinc bind text <Home>           "setCur $zinc bol"
+    $zinc bind text <Control-e>      "setCur $zinc eol"
+    $zinc bind text <End>            "setCur $zinc eol"
+    $zinc bind text <Meta-less>      "setCur $zinc 0"
+    $zinc bind text <Meta-greater>   "setCur $zinc end"
+    $zinc bind text <KeyPress>       "insertKey $zinc %A"
+    $zinc bind text <Shift-KeyPress> "insertKey $zinc %A"
+    $zinc bind text <Return>         "insertChar $zinc \n"
+    $zinc bind text <BackSpace>      "textDel $zinc -1"
+    $zinc bind text <Control-h>      "textDel $zinc -1"
+    $zinc bind text <Delete>         "textDel $zinc 0"
+}
+
+
+proc pasteSel {w x y} {
+    set item [$w focus]
+
+    if {[llength $item] != 0} {
+	catch {$w insert $item @$x,$y [selection get]}
+    }
+}
+
+
+proc insertChar {w c} {
+    set item [$w focus]
+    set selItem [$w select item]
+
+    if {[llength $item] == 0} {
+	return;
+    }
+    
+    if {([llength $selItem] == [llength $item]) &&
+	([lindex $selItem 0] == [lindex $item 0]) &&
+	([lindex $selItem 1] == [lindex $item 1])} {
+	$w dchars $item sel.first sel.last
+    }
+    $w insert $item insert $c
+}
+
+
+proc insertKey {w c} {
+    if {($c < 32) || ($c == 128)} {
+	return;
+    }
+    
+    insertChar($w, $c);
+}
+
+
+proc setCur {w where} {
+    set item [$w focus]
+
+    if {[llength $item] != 0} {
+	$w cursor $item $where
+    }
+}
+
+
+proc moveCur {w dir} {
+    set item [$w focus]
+
+    if {[llength $item] != 0} {
+	set index [$w index $item insert]
+	$w cursor $item [expr $index + $dir]
+    }
+}
+
+
+proc startSel {w x y} {
+    set part [$w currentpart 1]
+
+    $w cursor current $part @$x,$y
+    $w focus current $part
+    focus $w
+    $w select from current $part @$x,$y
+}
+
+
+proc extendSel {w x y} {
+    set part [$w currentpart 1]
+
+    $w select to current $part @$x,$y
+}
+
+
+proc textDel {w dir} {
+    set item [$w focus]
+    set selItem [$w select item]
+  my $ind;
+
+    if {[llength $item] == 0} {
+	return;
+    }
+
+    if {([llength $selItem] == [llength $item]) &&
+	([lindex $selItem 0] == [lindex $item 0]) &&
+	([lindex $selItem 1] == [lindex $item 1])} {
+	$w dchars $item sel.first sel.last
+    } else {
+	set ind [expr [$w index $item insert] + $dir]
+	if { $ind >= 0 } {
+	    $w dchars $item $ind $ind
+	}
+    }
+}