summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Entry.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Entry.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Entry.pm615
1 files changed, 0 insertions, 615 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Entry.pm b/Master/tlpkg/tlperl/lib/Tk/Entry.pm
deleted file mode 100644
index 51b3f0c6767..00000000000
--- a/Master/tlpkg/tlperl/lib/Tk/Entry.pm
+++ /dev/null
@@ -1,615 +0,0 @@
-package Tk::Entry;
-
-# Converted from entry.tcl --
-#
-# This file defines the default bindings for Tk entry widgets.
-#
-# @(#) entry.tcl 1.22 94/12/17 16:05:14
-#
-# Copyright (c) 1992-1994 The Regents of the University of California.
-# Copyright (c) 1994 Sun Microsystems, Inc.
-# Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved.
-# This program is free software; you can redistribute it and/or
-
-use vars qw($VERSION);
-use strict;
-$VERSION = sprintf '4.%03d',q$Revision: #17 $ =~ /#(\d+)/;
-
-# modify it under the same terms as Perl itself, subject
-# to additional disclaimer in license.terms due to partial
-# derivation from Tk4.0 sources.
-
-use Tk::Widget ();
-use Tk::Clipboard ();
-use base qw(Tk::Clipboard Tk::Widget);
-
-import Tk qw(Ev $XS_VERSION);
-
-Construct Tk::Widget 'Entry';
-
-bootstrap Tk::Entry;
-
-sub Tk_cmd { \&Tk::entry }
-
-Tk::Methods('bbox','delete','get','icursor','index','insert','scan',
- 'selection','validate','xview');
-
-use Tk::Submethods ( 'selection' => [qw(clear range adjust present to from)],
- 'xview' => [qw(moveto scroll)],
- );
-
-sub wordstart
-{my ($w,$pos) = @_;
- my $string = $w->get;
- $pos = $w->index('insert')-1 unless(defined $pos);
- $string = substr($string,0,$pos);
- $string =~ s/\S*$//;
- length $string;
-}
-
-sub wordend
-{my ($w,$pos) = @_;
- my $string = $w->get;
- my $anc = length $string;
- $pos = $w->index('insert') unless(defined $pos);
- $string = substr($string,$pos);
- $string =~ s/^(?:((?=\s)\s*|(?=\S)\S*))//x;
- $anc - length($string);
-}
-
-sub deltainsert
-{
- my ($w,$d) = @_;
- return $w->index('insert')+$d;
-}
-
-#
-# Bind --
-# This procedure is invoked the first time the mouse enters an
-# entry widget or an entry widget receives the input focus. It creates
-# all of the class bindings for entries.
-#
-# Arguments:
-# event - Indicates which event caused the procedure to be invoked
-# (Enter or FocusIn). It is used so that we can carry out
-# the functions of that event in addition to setting up
-# bindings.
-sub ClassInit
-{
- my ($class,$mw) = @_;
-
- $class->SUPER::ClassInit($mw);
-
- # <<Cut>>, <<Copy>> and <<Paste>> defined in Tk::Clipboard
- $mw->bind($class,'<<Clear>>' => sub {
- my $w = shift;
- $w->delete("sel.first", "sel.last");
- });
- $mw->bind($class,'<<PasteSelection>>' => [sub {
- my($w, $x) = @_;
- # XXX logic in Tcl/Tk version screwed up?
- if (!$Tk::strictMotif && !$Tk::mouseMoved) {
- $w->Paste($x);
- }
- }, Ev('x')]);
-
- # Standard Motif bindings:
- # The <Escape> binding is different from the Tcl/Tk version:
- $mw->bind($class,'<Escape>','selectionClear');
-
- $mw->bind($class,'<1>',['Button1',Ev('x'),Ev('y')]);
- $mw->bind($class,'<ButtonRelease-1>',['Button1Release',Ev('x'),Ev('y')]);
- $mw->bind($class,'<B1-Motion>',['Motion',Ev('x'),Ev('y')]);
-
- $mw->bind($class,'<Double-1>',['MouseSelect',Ev('x'),'word','sel.first']);
- $mw->bind($class,'<Double-Shift-1>',['MouseSelect',Ev('x'),'word']);
- $mw->bind($class,'<Triple-1>',['MouseSelect',Ev('x'),'line',0]);
- $mw->bind($class,'<Triple-Shift-1>',['MouseSelect',Ev('x'),'line']);
-
- $mw->bind($class,'<Shift-1>','Shift_1');
-
-
- $mw->bind($class,'<B1-Leave>',['AutoScan',Ev('x')]);
- $mw->bind($class,'<B1-Enter>','CancelRepeat');
- $mw->bind($class,'<Control-1>','Control_1');
- $mw->bind($class,'<Left>', ['SetCursor',Ev('deltainsert',-1)]);
- $mw->bind($class,'<Right>',['SetCursor',Ev('deltainsert',1)]);
- $mw->bind($class,'<Shift-Left>',['KeySelect',Ev('deltainsert',-1)]);
- $mw->bind($class,'<Shift-Right>',['KeySelect',Ev('deltainsert',1)]);
- $mw->bind($class,'<Control-Left>',['SetCursor',Ev(['wordstart'])]);
- $mw->bind($class,'<Control-Right>',['SetCursor',Ev(['wordend'])]);
- $mw->bind($class,'<Shift-Control-Left>',['KeySelect',Ev(['wordstart'])]);
- $mw->bind($class,'<Shift-Control-Right>',['KeySelect',Ev(['wordend'])]);
- $mw->bind($class,'<Home>',['SetCursor',0]);
- $mw->bind($class,'<Shift-Home>',['KeySelect',0]);
- $mw->bind($class,'<End>',['SetCursor','end']);
- $mw->bind($class,'<Shift-End>',['KeySelect','end']);
- $mw->bind($class,'<Delete>','Delete');
-
- $mw->bind($class,'<BackSpace>','Backspace');
-
- $mw->bind($class,'<Control-space>',['selectionFrom','insert']);
- $mw->bind($class,'<Select>',['selectionFrom','insert']);
- $mw->bind($class,'<Control-Shift-space>',['selectionAdjust','insert']);
- $mw->bind($class,'<Shift-Select>',['selectionAdjust','insert']);
-
- $mw->bind($class,'<Control-slash>',['selectionRange',0,'end']);
- $mw->bind($class,'<Control-backslash>','selectionClear');
-
- # $class->clipboardOperations($mw,qw[Copy Cut Paste]);
-
- $mw->bind($class,'<KeyPress>', ['Insert',Ev('A')]);
-
- # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
- # Otherwise, if a widget binding for one of these is defined, the
- # <KeyPress> class binding will also fire and insert the character,
- # which is wrong. Ditto for Return, and Tab.
-
- $mw->bind($class,'<Alt-KeyPress>' ,'NoOp');
- $mw->bind($class,'<Meta-KeyPress>' ,'NoOp');
- $mw->bind($class,'<Control-KeyPress>' ,'NoOp');
- $mw->bind($class,'<Return>' ,'NoOp');
- $mw->bind($class,'<KP_Enter>' ,'NoOp');
- $mw->bind($class,'<Tab>' ,'NoOp');
- if ($mw->windowingsystem =~ /^(?:classic|aqua)$/)
- {
- $mw->bind($class,'<Command-KeyPress>', 'NoOp');
- }
-
- # On Windows, paste is done using Shift-Insert. Shift-Insert already
- # generates the <<Paste>> event, so we don't need to do anything here.
- if ($Tk::platform ne 'MSWin32')
- {
- $mw->bind($class,'<Insert>','InsertSelection');
- }
-
- if (!$Tk::strictMotif)
- {
- # Additional emacs-like bindings:
- $mw->bind($class,'<Control-a>',['SetCursor',0]);
- $mw->bind($class,'<Control-b>',['SetCursor',Ev('deltainsert',-1)]);
- $mw->bind($class,'<Control-d>',['delete','insert']);
- $mw->bind($class,'<Control-e>',['SetCursor','end']);
- $mw->bind($class,'<Control-f>',['SetCursor',Ev('deltainsert',1)]);
- $mw->bind($class,'<Control-h>','Backspace');
- $mw->bind($class,'<Control-k>',['delete','insert','end']);
-
- $mw->bind($class,'<Control-t>','Transpose');
-
- # XXX The original Tcl/Tk bindings use NextWord/PreviousWord instead
- $mw->bind($class,'<Meta-b>',['SetCursor',Ev(['wordstart'])]);
- $mw->bind($class,'<Meta-d>',['delete','insert',Ev(['wordend'])]);
- $mw->bind($class,'<Meta-f>',['SetCursor',Ev(['wordend'])]);
- $mw->bind($class,'<Meta-BackSpace>',['delete',Ev(['wordstart']),'insert']);
- $mw->bind($class,'<Meta-Delete>',['delete',Ev(['wordstart']),'insert']);
-
- # A few additional bindings from John Ousterhout.
-# XXX conflicts with <<Copy>>: $mw->bind($class,'<Control-w>',['delete',Ev(['wordstart']),'insert']);
- $mw->bind($class,'<2>','Button_2');
- $mw->bind($class,'<B2-Motion>','B2_Motion');
-# XXX superseded by <<PasteSelection>>: $mw->bind($class,'<ButtonRelease-2>','ButtonRelease_2');
- }
- return $class;
-}
-
-
-sub Shift_1
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- $Tk::selectMode = 'char';
- $w->selectionAdjust('@' . $Ev->x)
-}
-
-
-sub Control_1
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- $w->icursor('@' . $Ev->x)
-}
-
-
-sub Delete
-{
- my $w = shift;
- if ($w->selectionPresent)
- {
- $w->deleteSelected
- }
- else
- {
- $w->delete('insert')
- }
-}
-
-
-sub InsertSelection
-{
- my $w = shift;
- eval {local $SIG{__DIE__}; $w->Insert($w->GetSelection)}
-}
-
-
-# Original is ::tk::EntryScanMark
-sub Button_2
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- $w->scan('mark',$Ev->x);
- $Tk::x = $Ev->x;
- $Tk::y = $Ev->y;
- $Tk::mouseMoved = 0
-}
-
-
-# Original is ::tk::EntryScanDrag
-sub B2_Motion
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- # Make sure these exist, as some weird situations can trigger the
- # motion binding without the initial press. [Tcl/Tk Bug #220269]
- if (!defined $Tk::x) { $Tk::x = $Ev->x }
- if (abs(($Ev->x-$Tk::x)) > 2)
- {
- $Tk::mouseMoved = 1
- }
- $w->scan('dragto',$Ev->x)
-}
-
-
-# XXX Not needed anymore
-sub ButtonRelease_2
-{
- my $w = shift;
- my $Ev = $w->XEvent;
- if (!$Tk::mouseMoved)
- {
- eval
- {local $SIG{__DIE__};
- $w->insert('insert',$w->SelectionGet);
- $w->SeeInsert;
- }
- }
-}
-
-sub Button1Release
-{
- shift->CancelRepeat;
-}
-
-# ::tk::EntryClosestGap --
-# Given x and y coordinates, this procedure finds the closest boundary
-# between characters to the given coordinates and returns the index
-# of the character just after the boundary.
-#
-# Arguments:
-# w - The entry window.
-# x - X-coordinate within the window.
-sub ClosestGap
-{
- my($w, $x) = @_;
- my $pos = $w->index('@'.$x);
- my @bbox = $w->bbox($pos);
- if ($x - $bbox[0] < $bbox[2] / 2)
- {
- return $pos;
- }
- $pos + 1;
-}
-
-# Button1 --
-# This procedure is invoked to handle button-1 presses in entry
-# widgets. It moves the insertion cursor, sets the selection anchor,
-# and claims the input focus.
-#
-# Arguments:
-# w - The entry window in which the button was pressed.
-# x - The x-coordinate of the button press.
-sub Button1
-{
- my $w = shift;
- my $x = shift;
- $Tk::selectMode = 'char';
- $Tk::mouseMoved = 0;
- $Tk::pressX = $x;
- $w->icursor($w->ClosestGap($x));
- $w->selectionFrom('insert');
- $w->selectionClear;
- if ($w->cget('-state') ne 'disabled')
- {
- $w->focus()
- }
-}
-
-sub Motion
-{
- my ($w,$x,$y) = @_;
- $Tk::x = $x; # XXX ?
- $w->MouseSelect($x);
-}
-
-# MouseSelect --
-# This procedure is invoked when dragging out a selection with
-# the mouse. Depending on the selection mode (character, word,
-# line) it selects in different-sized units. This procedure
-# ignores mouse motions initially until the mouse has moved from
-# one character to another or until there have been multiple clicks.
-#
-# Arguments:
-# w - The entry window in which the button was pressed.
-# x - The x-coordinate of the mouse.
-sub MouseSelect
-{
-
- my $w = shift;
- my $x = shift;
- return if UNIVERSAL::isa($w, 'Tk::Spinbox') and $w->{_element} ne 'entry';
- $Tk::selectMode = shift if (@_);
- my $cur = $w->index($w->ClosestGap($x));
- return unless defined $cur;
- my $anchor = $w->index('anchor');
- return unless defined $anchor;
- $Tk::pressX ||= $x; # XXX Better use "if !defined $Tk::pressX"?
- if (($cur != $anchor) || (abs($Tk::pressX - $x) >= 3))
- {
- $Tk::mouseMoved = 1
- }
- my $mode = $Tk::selectMode;
- return unless $mode;
- if ($mode eq 'char')
- {
- # The Tcl version uses selectionRange here XXX
- if ($Tk::mouseMoved)
- {
- if ($cur < $anchor)
- {
- $w->selectionTo($cur)
- }
- else
- {
- $w->selectionTo($cur+1)
- }
- }
- }
- elsif ($mode eq 'word')
- {
- # The Tcl version uses tcl_wordBreakBefore/After here XXX
- if ($cur < $w->index('anchor'))
- {
- $w->selectionRange($w->wordstart($cur),$w->wordend($anchor-1))
- }
- else
- {
- $w->selectionRange($w->wordstart($anchor),$w->wordend($cur))
- }
- }
- elsif ($mode eq 'line')
- {
- $w->selectionRange(0,'end')
- }
- if (@_)
- {
- my $ipos = shift;
- eval {local $SIG{__DIE__}; $w->icursor($ipos) };
- }
- $w->idletasks;
-}
-# ::tk::EntryPaste --
-# This procedure sets the insertion cursor to the current mouse position,
-# pastes the selection there, and sets the focus to the window.
-#
-# Arguments:
-# w - The entry window.
-# x - X position of the mouse.
-sub Paste
-{
- my($w, $x) = @_;
- $w->icursor($w->ClosestGap($x));
- eval { local $SIG{__DIE__};
- $w->insert("insert", $w->GetSelection);
- $w->SeeInsert; # Perl/Tk extension
- };
- if ($w->cget(-state) ne 'disabled')
- {
- $w->focus;
- }
-}
-# AutoScan --
-# This procedure is invoked when the mouse leaves an entry window
-# with button 1 down. It scrolls the window left or right,
-# depending on where the mouse is, and reschedules itself as an
-# 'after' command so that the window continues to scroll until the
-# mouse moves back into the window or the mouse button is released.
-#
-# Arguments:
-# w - The entry window.
-# x - The x-coordinate of the mouse when it left the window.
-sub AutoScan
-{
- my $w = shift;
- my $x = shift;
- return if !Tk::Exists($w);
- if ($x >= $w->width)
- {
- $w->xview('scroll',2,'units')
- }
- elsif ($x < 0)
- {
- $w->xview('scroll',-2,'units')
- }
- else
- {
- return;
- }
- $w->MouseSelect($x);
- $w->RepeatId($w->after(50,['AutoScan',$w,$x]))
-}
-# KeySelect
-# This procedure is invoked when stroking out selections using the
-# keyboard. It moves the cursor to a new position, then extends
-# the selection to that position.
-#
-# Arguments:
-# w - The entry window.
-# new - A new position for the insertion cursor (the cursor hasn't
-# actually been moved to this position yet).
-sub KeySelect
-{
- my $w = shift;
- my $new = shift;
- if (!$w->selectionPresent)
- {
- $w->selectionFrom('insert');
- $w->selectionTo($new)
- }
- else
- {
- $w->selectionAdjust($new)
- }
- $w->icursor($new);
- $w->SeeInsert;
-}
-# Insert --
-# Insert a string into an entry at the point of the insertion cursor.
-# If there is a selection in the entry, and it covers the point of the
-# insertion cursor, then delete the selection before inserting.
-#
-# Arguments:
-# w - The entry window in which to insert the string
-# s - The string to insert (usually just a single character)
-sub Insert
-{
- my $w = shift;
- my $s = shift;
- return unless (defined $s && $s ne '');
- eval
- {local $SIG{__DIE__};
- my $insert = $w->index('insert');
- if ($w->index('sel.first') <= $insert && $w->index('sel.last') >= $insert)
- {
- $w->deleteSelected
- }
- };
- $w->insert('insert',$s);
- $w->SeeInsert
-}
-# Backspace --
-# Backspace over the character just before the insertion cursor.
-#
-# Arguments:
-# w - The entry window in which to backspace.
-sub Backspace
-{
- my $w = shift;
- if ($w->selectionPresent)
- {
- $w->deleteSelected
- }
- else
- {
- my $x = $w->index('insert')-1;
- $w->delete($x) if ($x >= 0);
- # XXX Missing repositioning part from Tcl/Tk source
- }
-}
-# SeeInsert
-# Make sure that the insertion cursor is visible in the entry window.
-# If not, adjust the view so that it is.
-#
-# Arguments:
-# w - The entry window.
-sub SeeInsert
-{
- my $w = shift;
- my $c = $w->index('insert');
-#
-# Probably a bug in your version of tcl/tk (I've not this problem
-# when I test Entry in the widget demo for tcl/tk)
-# index('\@0') give always 0. Consequence :
-# if you make <Control-E> or <Control-F> view is adapted
-# but with <Control-A> or <Control-B> view is not adapted
-#
- my $left = $w->index('@0');
- if ($left > $c)
- {
- $w->xview($c);
- return;
- }
- my $x = $w->width;
- while ($w->index('@' . $x) <= $c && $left < $c)
- {
- $left += 1;
- $w->xview($left)
- }
-}
-# SetCursor
-# Move the insertion cursor to a given position in an entry. Also
-# clears the selection, if there is one in the entry, and makes sure
-# that the insertion cursor is visible.
-#
-# Arguments:
-# w - The entry window.
-# pos - The desired new position for the cursor in the window.
-sub SetCursor
-{
- my $w = shift;
- my $pos = shift;
- $w->icursor($pos);
- $w->selectionClear;
- $w->SeeInsert;
-}
-# Transpose
-# This procedure implements the 'transpose' function for entry widgets.
-# It tranposes the characters on either side of the insertion cursor,
-# unless the cursor is at the end of the line. In this case it
-# transposes the two characters to the left of the cursor. In either
-# case, the cursor ends up to the right of the transposed characters.
-#
-# Arguments:
-# w - The entry window.
-sub Transpose
-{
- my $w = shift;
- my $i = $w->index('insert');
- $i++ if ($i < $w->index('end'));
- my $first = $i-2;
- return if ($first < 0);
- my $str = $w->get;
- my $new = substr($str,$i-1,1) . substr($str,$first,1);
- $w->delete($first,$i);
- $w->insert('insert',$new);
- $w->SeeInsert;
-}
-
-sub tabFocus
-{
- my $w = shift;
- $w->selectionRange(0,'end');
- $w->icursor('end');
- $w->SUPER::tabFocus;
-}
-
-# ::tk::EntryGetSelection --
-#
-# Returns the selected text of the entry with respect to the -show option.
-#
-# Arguments:
-# w - The entry window from which the text to get
-sub getSelected
-{
- my $w = shift;
- return undef unless $w->selectionPresent;
- my $str = $w->get;
- my $show = $w->cget('-show');
- $str = $show x length($str) if (defined $show);
- my $s = $w->index('sel.first');
- my $e = $w->index('sel.last');
- return substr($str,$s,$e-$s);
-}
-
-
-1;
-
-__END__