Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Tranlation of FloatEnt.tcl in Tix4.1 |
2 | ||
3 | # TODO/IDEA: | |
4 | # o extract a widget (SimpleEntry?) without post/unpost methods | |
5 | # and derive FloatEntry fron this widget. | |
6 | ||
7 | package Tk::FloatEntry; | |
8 | use strict; | |
9 | ||
10 | BEGIN | |
11 | { | |
12 | use vars '$DEBUG'; | |
13 | $DEBUG = (defined($ENV{USER}) and $ENV{USER} eq 'achx') ? 1 : 0; | |
14 | print STDERR "tixGrid: debug = $DEBUG\n" if $DEBUG; | |
15 | } | |
16 | ||
17 | require Tk; | |
18 | require Tk::Widget; | |
19 | require Tk::Derived; | |
20 | require Tk::Entry; | |
21 | ||
22 | use vars qw($VERSION); | |
23 | $VERSION = '3.006'; # $Id: //depot/Tk8/TixGrid/FloatEntry.pm#6 $ | |
24 | ||
25 | use base qw(Tk::Derived Tk::Entry); | |
26 | ||
27 | Construct Tk::Widget 'FloatEntry'; | |
28 | ||
29 | sub ClassInit | |
30 | { | |
31 | my ($class, $mw) = @_; | |
32 | $class->SUPER::ClassInit($mw); | |
33 | $mw->bind($class, '<Return>', 'invoke'); | |
34 | $mw->bind($class, '<FocusIn>', 'FocusIn'); | |
35 | $class; | |
36 | } | |
37 | ||
38 | sub Populate | |
39 | { | |
40 | my ($e, $args) = @_; | |
41 | $e->ConfigSpecs( | |
42 | -value => ['METHOD', 'value', 'Value', undef], | |
43 | -highlightthickness => [$e, 'highlightThickness', 'HighlightThickness', 0 ], | |
44 | -command => ['CALLBACK', 'command', 'Command', undef], | |
45 | ); | |
46 | print "FloatEntry Init: $e\n" if $DEBUG; | |
47 | $e; | |
48 | } | |
49 | ||
50 | ## option method | |
51 | ||
52 | sub value | |
53 | { | |
54 | my $e = shift; | |
55 | unless (@_) | |
56 | { | |
57 | return $e->get | |
58 | } | |
59 | $e->delete(0,'end'); | |
60 | $e->insert(0,$_[0]); | |
61 | $e->selection('from', 0); | |
62 | $e->selection('to', 'end'); | |
63 | ||
64 | } | |
65 | ||
66 | ## public methods | |
67 | ||
68 | sub invoke | |
69 | { | |
70 | my ($e) = @_; | |
71 | $e->Callback('-command', $e->get); | |
72 | } | |
73 | ||
74 | sub post | |
75 | { | |
76 | my ($e, $x, $y, $dx, $dy) = @_; | |
77 | ||
78 | $dx = $e->reqwidth unless defined $dx; | |
79 | $dy = $e->reqheight unless defined $dy; | |
80 | ||
81 | $e->place('-x'=>$x, '-y'=>$y, -width=>$dx, -height=>$dy, -bordermode=>'ignore'); | |
82 | $e->raise; | |
83 | $e->focus; | |
84 | } | |
85 | ||
86 | sub unpost | |
87 | { | |
88 | my ($e) = @_; | |
89 | $e->place('forget'); | |
90 | } | |
91 | ||
92 | ## bindings | |
93 | ||
94 | sub FocusIn | |
95 | { | |
96 | my ($e) = @_; | |
97 | ||
98 | # FIX: xxx only if entry has not already focus | |
99 | { | |
100 | $e->focus; | |
101 | $e->selection('from', 0); | |
102 | $e->selection('to', 'end'); | |
103 | $e->icursor('end'); | |
104 | } | |
105 | } | |
106 | ||
107 | 1; | |
108 | __END__ | |
109 |