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
|
#!perl -w
use strict;
use Test qw(plan ok);
plan tests => 8;
use Tkx;
my $delay = shift || 1;
my $mw = Tkx::widget->new(".");
$mw->configure(-border => 10);
$mw->new_foo(-name => "myfoo", -text => "Bar")->g_pack;
my $foo = $mw->new_foo(-text => "Other", -foo => 42);
$foo->g_pack;
$foo->configure(-foo => 42);
ok($foo->cget("-foo"), 42);
ok($foo->_data->{"-foo"}, 42);
$foo->configure(-bw => 10, -bg => "blue");
ok($foo->cget("-bw"), 10);
$foo->configure(-cbg => "red");
ok($foo->cget("-cbg"), "red");
$foo->configure(-bar, sub { ok(1) });
ok($foo->cget("-bar"), "_config_bar");
$foo->configure(-baz, sub { ok(1) });
ok($foo->cget("-baz"), "_config_bar");
Tkx::after($delay * 1000, sub {
$mw->g_destroy;
});
Tkx::MainLoop;
sub j { join(":", @_) }
BEGIN {
package Foo;
use base qw(Tkx::widget Tkx::MegaConfig);
__PACKAGE__->_Mega("foo");
__PACKAGE__->_Config(
DEFAULT => ["PASSIVE"],
-bg => ["."],
-bw => [[".", "-borderwidth"]],
-cbg => [[".*", "-background"]],
-text => [".t"],
-bar => ["METHOD"],
-baz => [["METHOD", "baz"]],
);
sub _Populate {
my($class, $widget, $path, %opt) = @_;
my $parent = $class->new($path)->_parent;
my $self = $parent->new_frame(-name => $path);
$self->_class($class);
$self->new_label(-name => "t")->g_pack;
$self->configure(%opt) if %opt;
$self;
}
sub _config_bar {
my $self = shift;
if (@_) {
my $cb = shift;
&$cb();
}
else {
return "_config_bar";
}
}
*baz = \&_config_bar; # lazy
}
|
