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
|
use strict;
use vars '$loaded';
my $top;
BEGIN {
if (!eval {
require Tk;
$top = MainWindow->new;
}) {
print "1..0 # skip cannot open DISPLAY\n";
CORE::exit;
}
}
BEGIN { $^W= 1; $| = 1; print "1..6\n"; }
END {print "not ok 1\n" unless $loaded;}
use Tk::NumEntry;
$loaded = 1;
my $ok = 1;
print "ok " . $ok++ . "\n";
######################################################################
# This test script defines a new NumEntry class, consisting of new
# FireButton and NumEntryPlain classes.
#
# The MyFireButton class replaces the increment and decrement pictures
# with some predefined Tk bitmaps.
#
# The MyNumEntryPlain class adds new key events: Prior and Next for
# fast keyboard spinning and Home to reset to the default value.
#
######################################################################
# define own FireButton class
package Tk::MyFireButton;
use base qw(Tk::FireButton);
Construct Tk::Widget "MyFireButton";
sub INCBITMAP { "error" }
sub DECBITMAP { "gray75" }
sub HORIZINCBITMAP { "gray50" }
sub HORIZDECBITMAP { "gray25" }
######################################################################
# define own NumEntryPlain class
package Tk::MyNumEntryPlain;
use base qw(Tk::NumEntryPlain);
Construct Tk::Widget "MyNumEntryPlain";
sub ClassInit {
my($class, $mw) = @_;
$class->SUPER::ClassInit($mw);
$mw->bind($class, '<Shift-Prior>', 'Up10');
$mw->bind($class, '<Shift-Next>', 'Down10');
$mw->bind($class, '<Shift-Home>', 'Set0');
}
sub Set0 { my $w = shift;
$w->_parent->value($w->cget(-defaultvalue));
}
sub Up10 { shift->_parent->incdec(10,'initial') }
sub Down10 { shift->_parent->incdec(-10,'initial') }
######################################################################
# define own NumEntry class
package Tk::MyNumEntry;
use base qw(Tk::NumEntry);
Construct Tk::Widget "MyNumEntry";
sub FireButtonWidget { "MyFireButton" }
sub NumEntryPlainWidget { "MyNumEntryPlain" }
######################################################################
# back to main again
package main;
my $ne;
eval {
$ne = $top->MyNumEntry(-defaultvalue => 42,
-increment => '1.0')->pack;
};
if ($@) { print "not " } print "ok " . $ok++ . "\n";
eval {
$top->MyNumEntry(-orient => "horizontal",
-defaultvalue => 4711,
-minvalue => -10000,
-maxvalue => +10000,
-increment => 0.1,
-bigincrement => 50)->pack;
};
if ($@) { print "not " } print "ok " . $ok++ . "\n";
$ne->configure(-value => 1);
if ($ne->cget(-value) != 1) { print "not " } print "ok " . $ok++ . "\n";
$ne->incdec(1);
if ($ne->cget(-value) != 2) { print "not " } print "ok " . $ok++ . "\n";
$ne->incdec(-1);
if ($ne->cget(-value) != 1) { print "not " } print "ok " . $ok++ . "\n";
$top->update;
#Tk::MainLoop;
|
