File: FloatEntry.pm

package info (click to toggle)
perl-tk 1%3A800.025-2
  • links: PTS
  • area: main
  • in suites: sarge
  • size: 18,444 kB
  • ctags: 19,081
  • sloc: ansic: 206,740; perl: 40,187; makefile: 4,371; sh: 2,373; yacc: 762
file content (109 lines) | stat: -rw-r--r-- 2,034 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
# Tranlation of FloatEnt.tcl in Tix4.1

# TODO/IDEA:
#	o extract a widget (SimpleEntry?) without post/unpost methods
#	  and derive FloatEntry fron this widget.

package Tk::FloatEntry;
use strict;

BEGIN
  {
    use vars '$DEBUG';
    $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0;
    print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG;
  }

require Tk;
require Tk::Widget;
require Tk::Derived;
require Tk::Entry;

use vars qw($VERSION);
$VERSION = '3.006'; # $Id: //depot/Tk8/TixGrid/FloatEntry.pm#6 $

use base  qw(Tk::Derived Tk::Entry);

Construct Tk::Widget 'FloatEntry';

sub ClassInit
  {
    my ($class, $mw) = @_;
    $class->SUPER::ClassInit($mw);
    $mw->bind($class, '<Return>', 'invoke');
    $mw->bind($class, '<FocusIn>', 'FocusIn');
    $class;
  }

sub Populate
  {
    my ($e, $args) = @_;
    $e->ConfigSpecs(
	-value	 =>            ['METHOD',   'value',              'Value',              undef],
	-highlightthickness => [$e,         'highlightThickness', 'HighlightThickness', 0    ],
	-command =>            ['CALLBACK', 'command',            'Command',            undef],
	);
    print "FloatEntry Init: $e\n" if $DEBUG;
    $e;
  }

## option method

sub value
  {
    my $e = shift;
    unless (@_)
      {
	return $e->get
      }
    $e->delete(0,'end');
    $e->insert(0,$_[0]);
    $e->selection('from', 0);
    $e->selection('to', 'end');

  }

## public methods

sub invoke
  {
    my ($e) = @_;
    $e->Callback('-command', $e->get);
  }

sub post
  {
    my ($e, $x, $y, $dx, $dy) = @_;

    $dx = $e->reqwidth  unless defined $dx;
    $dy = $e->reqheight unless defined $dy;

    $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore');
    $e->raise;
    $e->focus;
  }

sub unpost
  {
    my ($e) = @_;
    $e->place('forget');
  }

## bindings

sub FocusIn
  {
    my ($e) = @_;

    # FIX: xxx only if entry has not already focus
      {
	$e->focus;
	$e->selection('from', 0);
	$e->selection('to', 'end');
	$e->icursor('end');
      }
  }

1;
__END__