From 661c41a09e39a182865e0b51e34cc995a0dc96e8 Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Wed, 12 May 2010 16:54:37 +0000 Subject: move tlperl.straw to tlperl git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Tk/Spinbox.pm | 115 ++++++++++++++++++++++++++++++++++ 1 file changed, 115 insertions(+) create mode 100755 Master/tlpkg/tlperl/lib/Tk/Spinbox.pm (limited to 'Master/tlpkg/tlperl/lib/Tk/Spinbox.pm') diff --git a/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm new file mode 100755 index 00000000000..673a1e181ce --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/Spinbox.pm @@ -0,0 +1,115 @@ +package Tk::Spinbox; +use strict; + +use vars qw($VERSION); +$VERSION = sprintf '4.%03d',q$Revision: #6 $ =~ /#(\d+)/; + +use base 'Tk::Entry'; + +sub Tk_cmd { \&Tk::spinbox } + +# Also inherits Entry's methods +Tk::Methods( "identify", "invoke", "set" ); +use Tk::Submethods ( 'selection' => ["element"] ); + +Construct Tk::Widget 'Spinbox'; + +sub ClassInit +{ + my ($class,$mw) = @_; + + $class->SUPER::ClassInit($mw); + + $mw->bind($class, '', [invoke => 'buttonup']); + $mw->bind($class, '<4>', [invoke => 'buttonup']); + $mw->bind($class, '',[invoke => 'buttondown']); + $mw->bind($class, '<5>', [invoke => 'buttondown']); + + return $class; +} + +sub Invoke +{ + my ($w,$elem) = @_; + unless ($w->{_outside}) + { + $w->invoke($elem); + $w->{_repeated}++; + } + my $delay = $w->cget('-repeatinterval'); + if ($delay > 0) + { + $w->RepeatId($w->after($delay,[Invoke => $w,$elem])); + } +} + +sub Button1 +{ + my ($w,$x,$y) = @_; + my $elem = $w->identify($x,$y); + $w->{_element} = $elem || 'entry'; + if ($w->{_element} eq 'entry') + { + $w->SUPER::Button1($x,$y); + } + elsif ($w->cget('-state') ne 'disabled') + { + $w->selectionElement($elem); + $w->{_repeated} = 0; + $w->{_outside} = 0; + $w->{_relief} = $w->cget("-${elem}relief"); + $w->CancelRepeat; + my $delay = $w->cget('-repeatdelay'); + $w->RepeatId($w->after($delay,[Invoke => $w,$elem])) if $delay > 0; + } +} + +sub Motion +{ + my ($w,$x,$y) = @_; + my $elem = $w->identify($x,$y); + $w->{_element} = $elem || 'entry' unless $w->{_element}; + if ($w->{_element} eq 'entry') + { + $w->SUPER::Motion($x,$y); + } + else + { + if (!defined($elem) || $elem ne $w->{_element}) + { + # Moved outside the button + unless ($w->{_outside}) + { + $w->{_outside} = 1; + $w->selectionElement('none'); + } + } + elsif ($w->{_outside}) + { + # Moved back over the button + $w->selectionElement($elem); + $w->{_outside} = 0; + } + } +} + +sub Button1Release +{ + my ($w,$x,$y) = @_; + $w->SUPER::Button1Release($x,$y); + my $elem = $w->{_element}; + if (defined($elem) && $elem ne 'entry') + { + my $repeated = $w->{_repeated}; + if (defined($repeated) && !$repeated) + { + $w->invoke($elem); + } + my $relief = delete $w->{_relief}; + $w->configure("-${elem}relief",$relief) if $relief + } + $w->selectionElement('none'); +} + +1; +__END__ -- cgit v1.2.3