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
110
111
112
113
114
115
116
117
|
#!perl -w
use strict;
use Test qw(plan ok);
plan tests => 5;
use Tkx;
my $delay = shift || 1;
my $mw = Tkx::widget->new(".");
$mw->configure(-border => 10);
$mw->new_label(-text => "Foo")->g_pack;
$mw->new_foo(-name => "myfoo", -text => "Bar")->g_pack;
my $f = $mw->new_frame(-border => 5, -background => "#555555");
$f->g_pack;
my $foo = $f->new_wrapped("foo", -text => "Other", -foo => 42);
$foo->g_pack;
ok($foo->cget("-foo"), 42);
ok($foo->blurb, "...");
$foo = $mw->_kid("myfoo");
ok(ref($foo), "Foo");
ok($foo->cget("-foo"), undef);
$foo->configure(-background => "yellow", -foo => 1);
ok($foo->cget("-foo"), 1);
Tkx::after($delay * 1000, sub {
$mw->g_destroy;
});
Tkx::MainLoop;
sub j { join(":", @_) }
BEGIN {
package Foo;
use base 'Tkx::widget';
Tkx::widget->_Mega("foo");
sub _Populate {
my($class, $widget, $path, %opt) = @_;
my $parent = $class->new($path)->_parent;
my $self = $parent->new_frame(-name => $path);
$self->_data->{foo} = $opt{-foo};
$self->new_label(-name => "lab", -text => delete $opt{-text})->g_pack(-side => "left");
$self->new_entry->g_pack(-side => "left", -fill => "both", -expand => 1);
$self->_class($class);
$self;
}
sub _mpath {
my $self = shift;
"$self.lab"; # delegate
}
sub m_configure {
my($self, %opt) = @_;
if (exists $opt{-foo}) {
$self->_data->{foo} = delete $opt{-foo};
}
return $self->SUPER::m_configure(%opt);
}
sub m_cget {
my($self, $opt) = @_;
if ($opt eq "-foo") {
return $self->_data->{foo};
}
return $self->SUPER::m_cget($opt);
}
sub m_blurb {
return "...";
}
package Tkx::Wrapped;
use base qw(Tkx::widget Tkx::MegaConfig);
__PACKAGE__->_Mega('wrapped');
__PACKAGE__->_Config(
DEFAULT => [".wrapped"],
);
sub _Populate {
my $class = shift;
my $widget = shift;
my $path = shift;
my $type = shift;
my %opt = @_;
my $self = $class->new($path)->_parent->new_frame(-name => $path);
$self->_class($class);
my $new_thing = "new_$type";
my $w = $self->$new_thing(-name => 'wrapped', %opt);
$w->g_pack();
return $self;
}
sub _mpath {
my $self = shift;
$$self . '.wrapped';
}
}
|
