Tkx
view release on metacpan or search on metacpan
"t",
"inc"
]
},
"prereqs" : {
"build" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"configure" : {
"requires" : {
"ExtUtils::MakeMaker" : "0"
}
},
"runtime" : {
"requires" : {
"Tcl" : "1.00",
"perl" : "5.008"
}
}
---
abstract: 'Yet another Tk interface'
author:
- 'Gisle Aas <gisle@activestate.com>'
build_requires:
ExtUtils::MakeMaker: '0'
configure_requires:
ExtUtils::MakeMaker: '0'
dynamic_config: 1
generated_by: 'ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: '1.4'
name: Tkx
no_index:
directory:
Tkx::package_require("BWidget");
Tkx::DynamicHelp__add(".", -text => "Hi there");
if (Tkx::tk_windowingsystem() eq "x11") { ... }
if (Tkx::tk___messageBox( ... ) eq "yes") { ... }
One part of the Tcl namespace that is not conveniently mapped to Perl
using the rules above are commands that use "." as part of their name, mostly Tk
widget instances. If you insist you can invoke these by quoting the
Perl function name
&{"Tkx::._configure"}(-background => "black");
or by invoking this as C<< Tkx::i::call(".", "configure", "-background",
"black") >>; but the real solution is to use C<Tkx::widget> objects to wrap
these as described in L</"Widget handles"> below.
=head3 Passing arguments
The arguments passed to Tcl can be plain scalars, array references, code
references, scalar references, or hash references.
Plain scalars (strings and numbers) as just passed on unchanged to Tcl.
);
When using the array reference syntax, if the I<second> element of the
array (i.e. the first argument to the callback) is a Tkx::Ev() object
the templates it contains will be expanded at the time of the callback.
Tkx::bind(".", "<Key>", [
sub { print "$_[0]\n"; }, Tkx::Ev("%A")
]);
$entry->configure(-validatecommand => [
\&check, Tkx::Ev('%P'), $entry,
]);
The order of the arguments to the Perl callback code is as follows:
=over
=item 1
The expanded results from Tkx::Ev(), if used.
is the same as:
$func = "Tkx::$w";
&$func(expand("foo"), @args);
where the expand() function expands underscores as described in
L</"Calling Tcl and Tk Commands"> above.
Example:
$w->m_configure(-background => "red");
Subclasses might override the _mpath() method to have m_I<foo> forward
the subcommand somewhere else than the current widget.
=item $w->g_I<foo>( @args )
This will invoke the I<foo> Tcl command with the current widget as
first argument. This is the same as:
$func = "Tkx::foo";
class.
Of the standard Tk widgets only frames support C<-class> which means
that (practically speaking) Tkx megawidgets must use a frame as the root
widget. The ttk widgets do support C<-class>, so you may be able to
dispense with the frame if your megawidget is really just subclassing
one of them.
The implementation class can (and probably should) define an _mpath()
method to delegate any m_I<foo> method calls to one of its subwidgets.
It might want to override the m_configure() and m_cget() methods if it
implements additional options or wants more control over delegation. The
class C<Tkx::MegaConfig> provide implementations of m_configure() and
m_cget() that can be useful for controlling delegation of configuration
options.
Public methods defined by a megawidget should have an "m_" prefix. This
serves two purposes:
=over
=item *
lib/Tkx/MegaConfig.pm view on Meta::CPAN
my %spec;
sub _Config {
my $class = shift;
while (@_) {
my($opt, $spec) = splice(@_, 0, 2);
$spec{$class}{$opt} = $spec;
}
}
sub m_configure {
my $self = shift;
my @rest;
while (@_) {
my($opt, $val) = splice(@_, 0, 2);
my $spec = $spec{ref($self)}{$opt} || $spec{ref($self)}{DEFAULT};
unless ($spec) {
push(@rest, $opt => $val);
next;
}
my $where = $spec->[0];
my @where_args;
if (ref($where) eq "ARRAY") {
($where, @where_args) = @$where;
}
if ($where =~ s/^\.//) {
my $fwd_opt = $where_args[0] || $opt;
if ($where eq "") {
$self->Tkx::widget::m_configure($fwd_opt, $val);
next;
}
if ($where eq "*") {
for my $kid ($self->_kids) {
$kid->m_configure($fwd_opt, $val);
}
next;
}
$self->_kid($where)->m_configure($fwd_opt, $val);
next;
}
if ($where eq "METHOD") {
my $method = $where_args[0] || "_config_" . substr($opt, 1);
$self->$method($val);
next;
}
if ($where eq "PASSIVE") {
$self->_data->{$opt} = $val;
next;
}
die;
}
$self->Tkx::widget::m_configure(@rest) if @rest; # XXX want NEXT instead
}
sub m_cget {
my($self, $opt) = @_;
my $spec = $spec{ref($self)}{$opt} || $spec{ref($self)}{DEFAULT};
return $self->Tkx::widget::m_cget($opt) unless $spec; # XXX want NEXT instead
my $where = $spec->[0];
my @where_args;
if (ref($where) eq "ARRAY") {
lib/Tkx/MegaConfig.pm view on Meta::CPAN
package Foo;
use base qw(Tkx::widget Tkx::MegaConfig);
__PACKAGE__->_Mega("foo");
__PACKAGE__->_Config(
-option => [$where, $dbName, $dbClass, $default],
);
=head1 DESCRIPTION
The C<Tkx::MegaConfig> class provide implementations of m_configure()
and m_cget() that can handle configuration options for megawidgets.
How these methods behave is set up by calling the _Config() class
method. The _Config() method takes a set option/option spec pairs as
argument.
An option argument is either the name of an option with leading '-'
or the string 'DEFAULT' if this spec applies to all option with no
explicit spec.
If there is no 'DEFAULT' then unmatched options are applied directly
lib/Tkx/MegaConfig.pm view on Meta::CPAN
configuration name on the "foo" widget. Examples:
-foo => [".inner"], # forward -foo
-bg => [[".", "-background]], # alias
-bg2 => [[".inner", "-background]], # forward as -background
-background => [".*"] # forward --background to kids
=item METHOD
Call the _config_I<opt> method. For m_cget() no arguments are given,
while for m_configure() the new value is passed. If an extra $where
argument is given it will be the method called instead of
_config_I<opt>. Examples:
__PACKAGE__->_Config(
-foo => ["METHOD"];
-bar => [["METHOD", "bar"]],
}
sub _config_foo {
my $self = shift;
lib/Tkx/Tutorial.pod view on Meta::CPAN
This documents core Tk and useful add-on packages that are part of
ActiveTcl. The ActiveTcl HTML documentation can also be downloaded from
L<http://downloads.activestate.com/ActiveTcl/html/> and installed
locally. The official Tcl/Tk docs are found at
L<http://www.tcl.tk/doc/>.
A major complication in the mapping to Perl is how to invoke
subcommands on Tk widgets. For example, if you want to change the
text of the button created above you might in Tcl do:
.b configure -text "Goodbye, cuel world"
a literal translation to Tkx would be:
Tkx::.b("configure", -text => "Goodbye, cruel world");
or
Tkx::.b_configure(-text => "Goodbye, cruel world");
but neither of those work as you can't use "." as part of function
names in Perl. Because of this we almost always use objects when
working with Tkx widgets.
=head2 Hello World with objects
The windows and controls that make up a Tk interface are called
I<widgets>. The widgets are identified by path names of the form
C<.foo.bar.baz>. These names are hierarchical in the same way as file
lib/Tkx/Tutorial.pod view on Meta::CPAN
2 use Tkx;
3
4 my $mw = Tkx::widget->new(".");
5 $mw->g_wm_title("Hello, world");
6 $mw->g_wm_minsize(300, 200);
7
8 my $b;
9 $b = $mw->new_button(
10 -text => "Hello, world",
11 -command => sub {
12 $b->m_configure(
13 -text => "Goodbye, cruel world",
14 );
15 Tkx::after(1500, sub { $mw->g_destroy });
16 },
17 );
18 $b->g_pack(
19 -padx => 10,
20 -pady => 10,
21 );
22
lib/Tkx/Tutorial.pod view on Meta::CPAN
wm minsize . 300 200
The rule is: A single underscore on the Perl side turns into space on
the Tcl side.
In line 11 to 16 we have expanded the button callback to change the text
of button and wait 1.5 seconds before shutting down the application. In
addition to the "g_" methods described in the previous section,
C<Tkx::widget> also provides "m_" methods which are forwarded as Tcl
subcommands of the current widget. The most commonly used subcommand is
"configure" that is used to change the attributes of a widget as we do
in line 12. Since we now reference $b from the callback, we had to
declare the variable upfront in line 8 instead of declaring it together
with the assignment as we did previously. In line 15 we destroy the
window after a delay of 1500ms, which should be enough time to read the
new "Goodbye, cruel world" text.
The "m_" method prefix is optional, you might prefer to leave it out.
Line 18 adds padding around buttons, which is usually a good idea.
lib/Tkx/Tutorial.pod view on Meta::CPAN
5
6 our $VERSION = "1.00";
7
8 (my $progname = $0) =~ s,.*[\\/],,;
9 my $IS_AQUA = Tkx::tk_windowingsystem() eq "aqua";
10
11 Tkx::package_require("style");
12 Tkx::style__use("as", -priority => 70);
13
14 my $mw = Tkx::widget->new(".");
15 $mw->configure(-menu => mk_menu($mw));
16
17 Tkx::MainLoop();
18 exit;
19
20 sub mk_menu {
21 my $mw = shift;
22 my $menu = $mw->new_menu;
23
24 my $file = $menu->new_menu(
25 -tearoff => 0,
eval {
Tkx::package_require("style");
Tkx::style__use("lobster", -priority => 70);
};
if ($@) {
$@ =~ s/ at .*//;
print "Can't update style: $@";
}
my $mw = Tkx::widget->new(".");
$mw->configure(-menu => mk_menu($mw));
Tkx::MainLoop();
exit;
sub mk_menu {
my $mw = shift;
my $menu = $mw->new_menu;
my $file = $menu->new_menu(
-tearoff => 0,
);
my $t = $sw->new_text(
-padx => 5,
-pady => 5,
-background => "white",
);
$sw->setwidget($t);
unless ($bold) {
my $font = $t->cget("-font");
if (Tkx::font_configure($font, "-weight") ne "bold") {
$bold = Tkx::font_create(Tkx::SplitList(Tkx::font_configure($font)));
Tkx::font_configure($bold,
-weight => "bold",
-size => int(Tkx::font_configure($font, "-size") * 1.4),
);
}
else {
$bold = $font;
}
}
$t->tag_configure("head1",
-background => "gray90",
-font => $bold,
);
for my $line (@pod) {
local $_ = $line; # copy since we modify
if (s/^=(head[1-4])\s+//) {
$t->insert("end", $_, $1);
}
else {
t/LabEntry.t view on Meta::CPAN
use Test qw(plan ok);
plan tests => 2;
use Tkx;
use Tkx::LabEntry;
my $delay = shift || 1;
my $mw = Tkx::widget->new(".");
$mw->configure(-border => 10);
$mw->new_tkx_LabEntry(-label => "foo", -name => "e")->g_pack;
my $e = $mw->_kid("e");
$mw->new_button(
-text => "Hit me",
-command => sub {
my $text = $e->get;
print "It is [$text] now\n";
$e->configure(-label => $text, -background => $text);
}
)->g_pack;
ok($e->cget("-label"), "foo");
ok($e->g_winfo_class, "Tkx_LabEntry");
Tkx::after($delay * 1000, sub {
$mw->g_destroy;
});
t/mega-config.t view on Meta::CPAN
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(":", @_) }
t/mega-config.t view on Meta::CPAN
);
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 {
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(":", @_) }
$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);
}
use strict;
use Test qw(plan ok);
plan tests => 12;
use Tkx;
my $delay = shift || 1;
my $mw = Tkx::widget->new(".");
$mw->configure(-border => 10);
my $b = $mw->new_button(
-text => "Test",
-background => "gray",
-command => sub {
if (Tkx::tk_messageBox(
-title => "Hi there",
-icon => "question",
-message => "Is this a fine day?",
-parent => ".",
-type => "yesno",
) eq "yes")
{
$mw->configure(-background => "#AAAAFF");
}
else {
$mw->configure(-background => "#444444");
}
},
);
$b->g_pack;
ok(j($mw->g_winfo_children), $b);
ok(j($mw->_kids), $b);
ok(ref(($mw->_kids)[0]), "Tkx::widget");
ok(j($b->g_winfo_children), "");
ok($b, ".b");
ok($b->m_cget("-text"), "Test");
ok($b->cget("-text"), "Test");
ok($b->configure(-text => "Test me!"), '');
ok(!$b->g_winfo_ismapped);
ok(ref($b->_data), "HASH");
$b->_data->{foo} = "bar";
ok($b->_data->{foo}, "bar");
Tkx::after($delay * 1000, sub {
ok($b->g_winfo_ismapped);
$mw->g_destroy;
});
use Test qw(plan ok);
plan tests => 1;
use Tkx;
my $delay = shift || 1;
my $text = "«1000 \x{2030}»";
my $mw = Tkx::widget->new(".");
#$mw->configure(-border => 10);
my $b = $mw->new_button(
-text => "«1000 \x{2030}»",
-width => 40,
);
$b->g_pack(-fill => "x", -expand => 1);
my $e = $mw->new_entry(
-textvariable => \$text,
);
$t = $sw->new_ctext();
$tw = $t->_kid("t");
};
if ($@) {
# fallback is the standard widget
$@ =~ s/ at .*//;
warn "Using plain text: $@";
$t = $sw->new_text();
$tw = $t;
}
$t->configure(
-bd => 1,
-undo => 1,
-wrap => "none",
);
$sw->setwidget($t);
$mw->configure(-menu => mk_menu($mw));
if (@ARGV) {
Tkx::after_idle([\&load, $ARGV[0]])
}
else {
new();
}
Tkx::MainLoop();
exit;
my $sb = $frame->new_ttk__scrollbar(
-orient => "vertical",
-command => [$tree, "yview"],
);
$sb->g_pack(
-side => "right",
-fill => "y",
);
$tree->configure(-yscrollcommand => [$sb, "set"]);
$tree->g_pack(
-expand => 1,
-fill => "both",
-side => "left",
);
my $text = $pane->new_text(
-font => "Helvetica 10",
-width => 10,
-height => 2,
);
$text->tag_configure("heading", -font => "Helvetica 12 bold");
$text->tag_configure("code", -font => "Courier 8");
$pane->add($text, -weight => 3);
$frame = $mw->new_frame(
-bd => 5,
);
$frame->g_pack(-fill => "x");
my $bb = $frame->new_ttk__button(
-text => "Run all tests",
-command => sub { run_tests(Tkx::SplitList($tree->children(""))) },
);
( run in 0.435 second using v1.01-cache-2.11-cpan-3989ada0592 )