Tkx-1.09/000755 000765 000024 00000000000 11473245576 012475 5ustar00gislestaff000000 000000 Tkx-1.09/Changes000644 000765 000024 00000005250 11473245526 013765 0ustar00gislestaff000000 000000 2010-11-24 Gisle Aas Release 1.09 Improved documentation 2009-11-29 Gisle Aas Release 1.08 Improved documentation Add callback test and made Tcl-0.98 a prereq 2009-01-30 Gisle Aas Release 1.07 Tkx::widget now have a $w->_kids method Tkx::MegaConfig now support option delegation to all its kids The Tkx::LabEntry example now overide its Tkx class Improved documentation 2009-01-17 Gisle Aas Release 1.06 Sources moved to public repository at http://github.com/gisle/tkx/ For sub-widgets implemented in perl we should call perl methods [RT#42454] Additional "Mac OS X" tweaks to tkx-ed. The GIT repository also have a full *.app wrapper to demonstrate how to integrate Tkx based GUI apps on OS X. Fixed error message when tkx-ed can't load the given file Tweak to Tkx::widget's AUTOLOAD function to make it slightly faster 2008-07-30 Gisle Aas Release 1.05 [286656] Documentation update Tutorial cleanup by Troy Topnik 2006-06-30 Gisle Aas Release 1.04 [265087] Some Tkx::MegaConfig fixes by Jeff Hobbs: - 'METHOD' where spec would not call the documented method - '.' where spec didn't work at all Added test for Tkx::MegaConfig 2006-06-21 Gisle Aas Release 1.03 [264696] Renamed tkxed as tkx-ed. Jeff Hobbs made the program have a proper File/Edit menu and make it use the ctext widget. There are also improvements to make it look nicer on Mac OS X. Included another sample program; tkx-prove, which allows you to run perl test suites in a handy window. 2005-08-29 Gisle Aas Release 1.02 [186229] Prettier error if Tk fails to initialize. This might happen if the you can't connect to the X11-server or if Tcl has been installed without Tk. Report Tcl exceptions relative to the code that uses Tkx instead of somewhere internally in Tcl.pm. Don't require style.tcl to be present for 'tkxed' and 'menu' to run. Improved the documentation some more. 2005-08-25 Gisle Aas Release 1.01 [182713] Expanded the Tkx::Tutorial. Added sample program called menu. Make the tkxed menu available with Ctrl-Button-1 on Mac OS. The README was not included because it was missing from the MANIFEST. 2005-08-24 Gisle Aas Release 1.00 [181521] Initial public release Tkx-1.09/lib/000755 000765 000024 00000000000 11473245576 013243 5ustar00gislestaff000000 000000 Tkx-1.09/Makefile.PL000644 000765 000024 00000002062 11473245526 014442 0ustar00gislestaff000000 000000 #!perl -w use strict; use ExtUtils::MakeMaker; WriteMakefile( NAME => "Tkx", VERSION_FROM => 'lib/Tkx.pm', ABSTRACT_FROM => 'lib/Tkx.pm', PREREQ_PM => { Tcl => 1.00, }, AUTHOR => 'Gisle Aas ', EXE_FILES => [qw(tkx-ed tkx-prove)], LICENSE => "perl", MIN_PERL_VERSION => 5.008, META_MERGE => { resources => { repository => 'http://github.com/gisle/tkx/', MailingList => 'mailto:tcltk@perl.org', } }, ); BEGIN { # compatibility with older versions of MakeMaker my $developer = -f ".gitignore"; my %mm_req = ( LICENCE => 6.31, META_MERGE => 6.45, META_ADD => 6.45, MIN_PERL_VERSION => 6.48, ); undef(*WriteMakefile); *WriteMakefile = sub { my %arg = @_; for (keys %mm_req) { unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { warn "$_ $@" if $developer; delete $arg{$_}; } } ExtUtils::MakeMaker::WriteMakefile(%arg); }; } Tkx-1.09/MANIFEST000644 000765 000024 00000000504 11473245576 013625 0ustar00gislestaff000000 000000 Changes Makefile.PL MANIFEST This list of files README menu t/LabEntry.t t/mega.t t/mega-config.t t/nul-char.t t/tcl.t t/tcl-callback.t t/tk.t t/utf8.t tkx-ed tkx-prove lib/Tkx.pm lib/Tkx/LabEntry.pm lib/Tkx/MegaConfig.pm lib/Tkx/Tutorial.pod META.yml Module meta-data (added by MakeMaker) Tkx-1.09/menu000644 000765 000024 00000007414 11304555314 013355 0ustar00gislestaff000000 000000 #!/usr/bin/perl -w use strict; use Tkx; our $VERSION = "1.00"; (my $progname = $0) =~ s,.*[\\/],,; my $IS_AQUA = Tkx::tk_windowingsystem() eq "aqua"; 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, ); $menu->add_cascade( -label => "File", -underline => 0, -menu => $file, ); $file->add_command( -label => "New", -underline => 0, -accelerator => "Ctrl+N", -command => \&new, ); $mw->g_bind("", \&new); $file->add_command( -label => "Exit", -underline => 1, -command => [\&Tkx::destroy, $mw], ) unless $IS_AQUA; my $help = $menu->new_menu( -name => "help", -tearoff => 0, ); $menu->add_cascade( -label => "Help", -underline => 0, -menu => $help, ); $help->add_command( -label => "\u$progname Manual", -command => \&show_manual, ); my $about_menu = $help; if ($IS_AQUA) { # On Mac OS we want about box to appear in the application # menu. Anything added to a menu with the name "apple" will # appear in this menu. $about_menu = $menu->new_menu( -name => "apple", ); $menu->add_cascade( -menu => $about_menu, ); } $about_menu->add_command( -label => "About \u$progname", -command => \&about, ); return $menu; } sub about { Tkx::tk___messageBox( -parent => $mw, -title => "About \u$progname", -type => "ok", -icon => "info", -message => "$progname v$VERSION\nCopyright 2005 ActiveState. All rights reserved.", ); } BEGIN { my @pod; my $manual_window; my $bold; sub show_manual { if ($manual_window && Tkx::winfo_exists($manual_window)) { $manual_window->g_wm_deiconify; $manual_window->g_raise; return $manual_window; } unless (@pod) { @pod = ; shift(@pod) while $pod[0] =~ /^\s*$/; } my $w = $manual_window = $mw->new_toplevel(); $w->g_wm_title("\u$progname Manual"); Tkx::package_require("BWidget"); my $sw = $w->new_ScrolledWindow( -managed => 0, ); $sw->g_pack( -fill => "both", -expand => 1, ); 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 { s/[A-Z]<([^>]*)>/$1/g; $t->insert("end", $_); } } return $manual_window; } } __DATA__ =head1 NAME menu - Application framework demo =head1 SYNOPSIS menu =head1 DESCRIPTION This program demonstrates how a standard menu is set up, so please take a look at its source code. =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. =head1 SEE ALSO L Tkx-1.09/META.yml000644 000765 000024 00000001201 11473245576 013740 0ustar00gislestaff000000 000000 --- #YAML:1.0 name: Tkx version: 1.09 abstract: Yet another Tk interface author: - Gisle Aas license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: perl: 5.008 Tcl: 1 resources: MailingList: mailto:tcltk@perl.org repository: http://github.com/gisle/tkx/ no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.56 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Tkx-1.09/README000644 000765 000024 00000004073 11304555314 013344 0ustar00gislestaff000000 000000 Tkx.pm ------ The Tkx module provides yet another Tk interface for Perl. Tk is a GUI toolkit tied to the Tcl language, and Tkx provides a bridge to Tcl that allows Tk based applications to be written in Perl. The main idea behind Tkx is that it is a very thin wrapper on top of Tcl, i.e. that what you get is exactly the behaviour you read about in the Tcl/Tk documentation with no surprises added by the Perl layer. In order to use Tkx, you need to understand enough Tcl to be able to read the documentation for Tcl/Tk and figure out how this maps to the Tkx. You will not need to write any Tcl code though, as all your GUI work, including the creation of megawidgets can be done in Perl using Tkx. The benefit of this approach compared Nick Ing-Simmons's classic Tk.pm module is that you can always use the latest features that Tk/Tcl provides and that you can use Tcl's native megawidgets directly. Tk.pm has stagnated recently because of the huge effort needed to port it to run with newer versions of Tk. The downside of the Tkx approach is that you will need to know a bit about Tcl and that you have to install Tcl/Tk on both your development and deployment systems. Another downside is that you will not be able to use any of the Tk:: add-ons or megawidgets already present on CPAN. Tkx is the toolkit used to implement the GUI frontends of ActiveState's PDK tools. In order to install Tkx, you will need to have Tcl/Tk-8.4 and perl-5.8 with the Tcl.pm module installed. Installation otherwise follow the normal drill: perl Makefile.PL make make test make install If you have questions about this code or want to report bugs send a message to the mailing list. To subscribe to this list send an empty message to . The official source repository for Tkx is http://github.com/gisle/tkx/. You can grab the latest sources with: git clone git://github.com/gisle/tkx.git This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. Tkx-1.09/t/000755 000765 000024 00000000000 11473245576 012740 5ustar00gislestaff000000 000000 Tkx-1.09/tkx-ed000644 000765 000024 00000014016 11304555314 013601 0ustar00gislestaff000000 000000 #!/usr/bin/perl -w # tkx-ed - Simple text editor use strict; use Tkx; use File::Basename qw(basename); (my $PROGNAME = $0) =~ s,.*[\\/],,; my $IS_AQUA = Tkx::tk_windowingsystem() eq "aqua"; if ($IS_AQUA) { $PROGNAME = "Tkx Editor"; # when invoked directly via "open 'Tkx Editor.app'" it will be passed # something like "-psn_0_5154026" which we don't really care about. shift(@ARGV) if @ARGV && $ARGV[0] =~ /-psn/; # The console can pop up unexpectedly from the tkkit Tkx::catch("console hide"); # Set the process name that is displayed in the Activity Monitor # and the Force Quit dialog eval { Tkx::package_require('tclCarbonProcesses'); my $psn = Tkx::carbon__getCurrentProcess(); Tkx::carbon__setFrontProcess($psn); Tkx::carbon__setProcessName($psn, $PROGNAME); }; warn $@ if $@; Tkx::interp_alias("", "::tk::mac::OpenDocument", "", [\&load]); } Tkx::package_require("BWidget"); eval { Tkx::package_require("style"); Tkx::style__use("as", -priority => 70); }; if ($@) { $@ =~ s/ at .*//; warn "Using plain look: $@"; } # state my $file = ""; # set up main window my $mw = Tkx::widget->new("."); my $sw = $mw->new_ScrolledWindow(); $sw->g_pack( -fill => "both", -expand => 1, ); my($t, $tw); eval { Tkx::package_require("ctext"); # A ctext's true text widget is a subwidget $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; sub mk_menu { my $mw = shift; Tkx::option_add("*Menu.tearOff", 0); my $m = $mw->new_menu(); my $fm = $m->new_menu(); my $em = $m->new_menu(); my $hm = $m->new_menu(); my $control = ($^O eq "darwin") ? "Command" : "Control"; my $ctrl = ($^O eq "darwin") ? "Command-" : "Ctrl+"; $m->add_cascade( -label => "File", -menu => $fm, ); $m->add_cascade( -label => "Edit", -menu => $em, ); $m->add_cascade( -label => "Help", -menu => $hm, ); # File menu $fm->add_command( -label => "New", -accelerator => $ctrl . "N", -command => \&new, ); Tkx::bind("all", "<$control-n>", \&new); $fm->add_command( -label => "Open...", -accelerator => $ctrl . "O", -command => \&my_open, ); Tkx::bind("all", "<$control-o>", \&my_open); $fm->add_command( -label => "Save", -accelerator => $ctrl . "S", -command => \&save, ); Tkx::bind("all", "<$control-s>", \&save); $fm->add_command( -label => "Save As...", -command => \&save_as, ); unless ($IS_AQUA) { $fm->add_command( -label => "Exit", -underline => 1, -accelerator => $ctrl . "Q", -command => [\&Tkx::destroy, $mw], ); Tkx::bind("all", "<$control-q>", [\&Tkx::destroy, $mw]); } # Edit menu $em->add_command( -label => "Cut", -command => [\&Tkx::event_generate, $tw, "<>"] ); $em->add_command( -label => "Copy", -command => [\&Tkx::event_generate, $tw, "<>"], ); $em->add_command( -label => "Paste", -command => [\&Tkx::event_generate, $tw, "<>"], ); # Help menu $hm->add_command( -label => "View $PROGNAME source", -command => sub { load(__FILE__) }, ); my $about_menu = $hm; if ($IS_AQUA) { # On Mac OS we want about box to appear in the application # menu. Anything added to a menu with the name "apple" will # appear in this menu. $about_menu = $m->new_menu( -name => "apple", ); $m->add_cascade( -menu => $about_menu, ); } $about_menu->add_command( -label => "About $PROGNAME", -command => sub { Tkx::tk___messageBox( -parent => $mw, -title => "About \u$PROGNAME", -type => "ok", -icon => "info", -message => "$PROGNAME v$Tkx::VERSION\n" . "Copyright 2005 ActiveState. " . "All rights reserved.", ); }, ); return $m; } sub new { $t->delete("1.0", "end"); set_file(""); } sub my_open { my $f = Tkx::tk___getOpenFile( -parent => $mw, ); load($f) if length $f; } sub load { my $f = shift; open(my $fh, "<:utf8", $f) || die "Can't open '$f': $!"; $t->delete("1.0", "end"); $t->insert("end", scalar do { local $/; <$fh> }); set_file($f); } sub set_file { $file = shift; update_title(); } sub save { return save_as() unless length $file; _save($file); } sub save_as { my $f = Tkx::tk___getSaveFile( -parent => $mw, ); if (length $f) { _save($f); set_file($f); } } sub _save { my $f = shift; open(my $fh, ">", $f) || die "Can't open '$file': $!"; print $fh $t->get("1.0", "end - 1 char"); close($fh) || die "Can't write '$file': $!"; } sub update_title { my $title; if (length $file) { $title = basename($file); } else { $title = ""; } $title .= " - " . $PROGNAME unless $IS_AQUA; $mw->g_wm_title($title); } __END__ =head1 NAME tkx-ed - Simple editor =head1 SYNOPSIS tkx-ed [] =head1 DESCRIPTION The F program is a simple text editor implemented with the C toolkit. Its main purpose is to demonstrate how this kind of application is written, so please take a look at its source code. When the editor starts up it shows a blank page where you can start entering text directly. If a file name is passed on the command line then the editor will visit this file initially. =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. =head1 SEE ALSO L Tkx-1.09/tkx-prove000755 000765 000024 00000012415 11304555314 014350 0ustar00gislestaff000000 000000 #!/usr/bin/perl -w use strict; use Tkx; use Time::HiRes qw(time); Tkx::package_require("tile"); my $mw = Tkx::widget->new("."); my $pane = $mw->new_ttk__panedwindow( -orient => "vertical", ); $pane->g_pack( -expand => 1, -fill => "both", ); my $frame = $pane->new_frame; $pane->add($frame, -weight => 1); my $tree = $frame->new_ttk__treeview( -columns => [qw(status time)], -height => 5, ); $tree->heading("#0", -text => "Test Name", -command => sub { sort_rows("#0") }); $tree->heading("status", -text => "Status", -command => sub { sort_rows("status") }); $tree->column("status", -width => 45, -anchor => "center"); $tree->heading("time", -text => "Time", -command => sub { sort_rows("time") }); $tree->column("time", -width => 45, -anchor => "e"); 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(""))) }, ); $bb->g_pack(-side => "left"); $bb = $frame->new_ttk__button( -text => "Run selected tests", -command => sub { run_tests(Tkx::SplitList($tree->selection)) }, ); $bb->g_pack(-side => "left"); $bb = $frame->new_ttk__button( -text => "New dir", -command => \&new_test_dir, ); $bb->g_pack(-side => "left"); my $dir; my %result; sub new_test_dir { my $dir = Tkx::tk___chooseDirectory( -parent => $mw, -title => "New test directory", -mustexist => 1, ); if ($dir) { $dir =~ s,/t/?$,,; set_dir($dir); } } sub set_dir { $dir = shift; %result = (); $tree->delete($tree->children("")); $text->delete("1.0", "end"); use File::Find qw(find); find({ wanted => sub { return unless -f $_; return unless /\.t$/; my $name = substr($File::Find::name, length("$dir/t") + 1); substr($name, -2, 2, ""); $tree->insert("", "end", -text => $name, -values => ["-", "-"]); }, no_chdir => 1, }, "$dir/t"); } use Test::Harness::Straps; my $strap = Test::Harness::Straps->new; $tree->g_bind("<>", \&tree_select); new_test_dir(); Tkx::MainLoop(); sub run_tests { my $old_selection = $tree->selection; for my $item (@_) { my $test = "t/" . $tree->item($item, "-text") . ".t"; #print "Item $item $test\n"; delete $result{$item}; $tree->selection_set($item); $tree->see($item); $tree->set($item, "status", "-"); $tree->set($item, "time", "-"); Tkx::update(); my $cmd = $strap->_command_line("$dir/$test"); my $before = time; my @output = qx($cmd); my $used = time - $before; my $status = $?; my %res = $strap->analyze($item, \@output); $res{output} = join("", @output); $res{start_time} = $before; $res{used_time} = sprintf "%.03f", $used; $res{status} = $status; #use Data::Dump; print Data::Dump::dump(\%res), "\n"; $result{$item} = \%res; $tree->set($item, "status", $res{passing} ? ($res{skip_all} ? "skipped" : "ok") : "fail"); $tree->set($item, "time", sprintf "%.2f", $used); tree_select(); Tkx::update(); #select(undef, undef, undef, 0.4); } $tree->selection_set($old_selection); #$tree->yview_moveto(0); } sub tree_select { my @sel = Tkx::SplitList($tree->selection); #print "[select @sel]\n"; $text->delete("1.0", "end"); if (@sel == 0) { $text->insert("end", "No test selected\n"); } elsif (@sel == 1) { my $name = $tree->item($sel[0], "-text"); #$text->insert("end", "$name\n"); if (my $res = $result{$sel[0]}) { $text->insert("end", "Skipped: $res->{skip_all}\n", "heading") if $res->{skip_all}; $text->insert("end", "Passed $res->{ok} of $res->{max} tests in $res->{used_time} seconds.\n"); $text->insert("end", "Todo tests: $res->{todo}\n") if $res->{todo}; $text->insert("end", "Bonus tests: $res->{bonus}\n") if $res->{bonus}; $text->insert("end", "Skipped tests: $res->{skip}\n") if $res->{skip}; $text->insert("end", "Status: $res->{status}\n") if $res->{status}; $text->insert("end", "\nComplete test output\n\n", "heading"); $text->insert("end", $res->{output}, "code"); } else { $text->insert("end", "No result\n"); } } else { my $num_tests = @sel; $text->insert("end", "$num_tests tests selected\n"); } } BEGIN { my %ascending; sub sort_rows { my $col = shift; $ascending{$col} = !$ascending{$col}; my $kids = $tree->children(""); my @kids = Tkx::SplitList($kids); @kids = map { $_->[0] } sort { my $cmp = $a->[1] cmp $b->[1]; $cmp = -$cmp if $ascending{$col}; $cmp } map { [$_, $col eq "#0" ? $tree->item($_, "-text") : $tree->set($_, $col) ] } @kids; $tree->detach($kids); for my $item (@kids) { $tree->move($item, "", "end"); } } } Tkx-1.09/t/LabEntry.t000644 000765 000024 00000001130 11304555346 014630 0ustar00gislestaff000000 000000 #!perl -w use strict; 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; }); Tkx::MainLoop; Tkx-1.09/t/mega-config.t000644 000765 000024 00000003043 11304555346 015271 0ustar00gislestaff000000 000000 #!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 } Tkx-1.09/t/mega.t000644 000765 000024 00000004400 11304557147 014025 0ustar00gislestaff000000 000000 #!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'; } } Tkx-1.09/t/nul-char.t000644 000765 000024 00000005402 11304555314 014622 0ustar00gislestaff000000 000000 #!perl -w # This test is more useful as an interactive test where you can # verify that what is displayed look right. The \x{2030} is the # permille sign. # # On Unix this progam shows different wrong behaviour depending # on what kind of locale it runs under. use strict; use Test qw(plan ok); plan tests => 1; use Tkx; my $delay = shift || 1; my $mw = Tkx::widget->new("."); my $t = $mw->new_text(); $t->g_pack(-fill => "both", -expand => 1); $t->insert("end", "This is a string\n"); $t->insert("end", "This is a string containing NUL (\0) and some other controls (\a\r)\n"); $t->insert("end", "\0 \x{2030}\n"); $t->insert("end", "[\0 \x{2030}]\n"); $t->insert("end", "bytes: " . join("", map chr, 0 .. 255) . "\n"); $t->insert("end", "uni: " . join("", map chr, 0 .. 300) . "\n"); Tkx::eval("$t insert end \"\\0\\1\\2\\n\""); ok($t->get("1.0", "end"), <<"EOT"); This is a string This is a string containing NUL (\0) and some other controls (\a\r) \0 \x{2030} [\0 \x{2030}] bytes: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF uni: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\x{100}\x{101}\x{102}\x{103}\x{104}\x{105}\x{106}\x{107}\x{108}\x{109}\x{10A}\x{10B}\x{10C}\x{10D}\x{10E}\x{10F}\x{110}\x{111}\x{112}\x{113}\x{114}\x{115}\x{116}\x{117}\x{118}\x{119}\x{11A}\x{11B}\x{11C}\x{11D}\x{11E}\x{11F}\x{120}\x{121}\x{122}\x{123}\x{124}\x{125}\x{126}\x{127}\x{128}\x{129}\x{12A}\x{12B}\x{12C} \0\1\2 EOT Tkx::after($delay * 1000, sub { $mw->g_destroy; }); Tkx::MainLoop; sub j { join(":", @_) } Tkx-1.09/t/tcl-callback.t000644 000765 000024 00000000713 11304555346 015432 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test; plan tests => 7; use Tkx qw(set after); set("foo", sub { ok @_, 2; ok "@_", "a b c"; }); ok set("foo"), qr/^::perl::CODE\(0x/; Tkx::eval('[set foo] a {b c}'); set("foo", [sub { ok @_, 4; ok "@_", "a b c d e f"; }, "d", "e f"]); Tkx::eval('[set foo] a {b c}'); set("foo", [sub { ok @_, 6; ok "@_", "2 3 a b c d"; }, Tkx::Ev('[expr 1+1]', '[expr 1+2]'), "c", "d"]); Tkx::eval('eval [set foo] a b'); Tkx-1.09/t/tcl.t000644 000765 000024 00000001651 11304555314 013675 0ustar00gislestaff000000 000000 #!perl -w use strict; use Test qw(plan ok); plan tests => 18; use Tkx qw(expr list lindex error); ok(expr("2 + 2"), 4); ok(expr("2", "+", "2"), 4); my $list = Tkx::eval("list 2 [list 3 4] 5"); ok($list, "2 {3 4} 5"); ok(ref($list), "Tcl::List"); ok($list->[0], 2); ok($list->[1][0], 3); ok(j(@$list), "2:3 4:5"); ok(list(2, Tkx::SplitList(list(3, 4)), 5), "2 3 4 5"); ok(list(2, scalar(list(3, 4)), 5), "2 {3 4} 5"); ok(j(Tkx::SplitList(list(2, scalar(list(3, 4)), 5))), "2:3 4:5"); ok(lindex([0..9, [], "}"], 5), 5); ok(lindex([0..9], "end"), 9); my @list = Tkx::SplitList("a b"); ok(@list, 2); ok($list[0], "a"); ok($list[1], "b"); eval { $list = Tkx::SplitList("a b") }; ok($@ && $@ =~ /^Tkx::SplitList needs list context/); eval { @list = Tkx::SplitList("a {") }; #print "# '$@'\n"; ok($@ && $@ =~ /valid Tcl list/); eval { error("Foo") }; ok($@, "Foo at @{[__FILE__]} line @{[__LINE__ - 1]}.\n"); sub j { join(":", @_) } Tkx-1.09/t/tk.t000644 000765 000024 00000002147 11304555346 013537 0ustar00gislestaff000000 000000 #!perl -w 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; }); Tkx::MainLoop; sub j { join(":", @_) } Tkx-1.09/t/utf8.t000644 000765 000024 00000001531 11304555314 013776 0ustar00gislestaff000000 000000 #!perl -w # This test is more useful as an interactive test where you can # verify that what is displayed look right. The \x{2030} is the # permille sign. # # On Unix this progam shows different wrong behaviour depending # on what kind of locale it runs under. use strict; 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, ); $e->g_pack(-fill => "x", -expand => 1); $mw->g_wm_title("«1000 \x{2030}» is enough"); ok($mw->g_wm_title, "«1000 \x{2030}» is enough"); Tkx::after($delay * 1000, sub { $mw->g_destroy; }); Tkx::MainLoop; sub j { join(":", @_) } Tkx-1.09/lib/Tkx/000755 000765 000024 00000000000 11473245576 014011 5ustar00gislestaff000000 000000 Tkx-1.09/lib/Tkx.pm000644 000765 000024 00000061432 11473245526 014350 0ustar00gislestaff000000 000000 package Tkx; use strict; our $VERSION = '1.09'; { # predeclare package Tkx::widget; package Tkx::i; } eval { package_require("Tk"); }; if ($@) { $@ =~ s/^this isn't a Tk application//; # what crap die $@; } our $TRACE; our $TRACE_MAX_STRING; our $TRACE_COUNT; our $TRACE_TIME; our $TRACE_CALLER; $TRACE = $ENV{PERL_TKX_TRACE} unless defined $TRACE; $TRACE_MAX_STRING = 64 unless defined $TRACE_MAX_STRING; $TRACE_COUNT = 1 unless defined $TRACE_COUNT; $TRACE_TIME = 1 unless defined $TRACE_TIME; $TRACE_CALLER = 1 unless defined $TRACE_CALLER; sub import { my($class, @subs) = @_; my $pkg = caller; for (@subs) { s/^&//; if (/^[a-zA-Z]\w*/ && $_ ne "import") { no strict 'refs'; *{"$pkg\::$_"} = \&$_; } else { die qq("$_" is not exported by the $class module); } } } sub AUTOLOAD { our $AUTOLOAD; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); return scalar(Tkx::i::call(Tkx::i::expand_name($method), @_)); } sub MainLoop () { while (eval { local $TRACE; Tkx::i::call("winfo", "exists", ".") }) { Tkx::i::DoOneEvent(0); } } sub SplitList ($) { my $list = shift; unless (wantarray) { require Carp; Carp::croak("Tkx::SplitList needs list context"); } return @$list if ref($list) eq "ARRAY" || ref($list) eq "Tcl::List"; return Tkx::i::call("concat", $list); } *Ev = \&Tcl::Ev; package Tkx::widget; use overload '""' => sub { ${$_[0]} }, fallback => 1; my %data; my %class; my %mega; sub new { my $class = shift; my $name = shift; return bless \$name, $class{$name} || $class; } sub _data { my $self = shift; return $data{$$self} ||= {}; } sub _kid { my($self, $name) = @_; substr($name, 0, 0) = $$self eq "." ? "." : "$$self."; return $self->_nclass->new($name); } sub _kids { my $self = shift; my $nclass = $self->_nclass; return map $nclass->new($_), Tkx::SplitList(Tkx::winfo_children($self)); } sub _parent { my $self = shift; my $name = $$self; return undef if $name eq "."; substr($name, rindex($name, ".")) = ""; $name = "." unless length($name); return $self->_nclass->new($name); } sub _class { my $self = shift; my $old = ref($self); if (@_) { my $class = shift; $class{$$self} = $class; bless $self, $class; } $old; } sub _Mega { my $class = shift; my $widget = shift; my $impclass = shift || caller; $mega{$widget} = $impclass; } sub _nclass { __PACKAGE__; } sub _mpath { my $self = shift; $$self; } sub AUTOLOAD { my $self = shift; our $AUTOLOAD; my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); if (substr($method, 0, 4) eq "new_") { my $widget = Tkx::i::expand_name(substr($method, 4)); my $name; for (my $i = 0; $i < @_; $i += 2) { if ($_[$i] eq "-name") { (undef, $name) = splice(@_, $i, 2); substr($name, 0, 0) = ($$self eq "." ? "." : "$$self.") if index($name, ".") == -1; last; } } $name ||= Tkx::i::wname($widget, $$self); if (my $mega = $mega{$widget}) { return $mega->_Populate($widget, $name, @_); } return $self->_nclass->new(scalar(Tkx::i::call($widget, $name, @_))); } my $prefix = substr($method, 0, 2); if ($prefix eq "m_") { my @i = Tkx::i::expand_name(substr($method, 2)); my $p = $self->_mpath($i[0]); return scalar(Tkx::i::call($p, @i, @_)) if $p eq $$self || !$class{$p}; return (bless \$p, $class{$p})->$method(@_); } if ($prefix eq "g_") { return scalar(Tkx::i::call(Tkx::i::expand_name(substr($method, 2)), $$self, @_)); } if (index($prefix, "_") != -1) { require Carp; Carp::croak("method '$method' reserved by Tkx"); } $method = "m_$method"; return $self->$method(@_); } sub DESTROY {} # avoid AUTOLOADing it package Tkx::widget::_destroy; sub new { my($class, @paths) = @_; bless \@paths, $class; } sub DESTROY { my $self = shift; for my $path (@$self) { if ($path eq ".") { %data = (); return; } my $path_re = qr/^\Q$path\E(?:\.|\z)/; for my $hash (\%data, \%class) { for my $key (keys %$hash) { next unless $key =~ $path_re; delete $hash->{$key}; } } } } package Tkx::i; use Tcl; my $interp; my $trace_count = 0; my $trace_start_time = 0; BEGIN { $Tcl::STACK_TRACE = 0; $interp = Tcl->new; $interp->Init; } sub interp { return $interp; } sub expand_name { my(@f) = (shift); @f = split(/(? 1 } @kids; my $count = 2; $count++ while $kids{"$name$count"}; $name .= $count; } $name; } sub call { if ($Tkx::TRACE) { my @prefix = "Tkx"; if ($Tkx::TRACE_COUNT) { push(@prefix, ++$trace_count); } if ($Tkx::TRACE_TIME) { my $ts; unless ($trace_start_time) { if (eval { require Time::HiRes }) { $trace_start_time = Time::HiRes::time(); } else { $trace_start_time = time; } } if (defined &Time::HiRes::time) { $ts = sprintf "%.1fs", Time::HiRes::time() - $trace_start_time; } else { $ts = time - $trace_start_time; $ts .= "s"; } push(@prefix, $ts); } if ($Tkx::TRACE_CALLER) { my $i = 0; while (my($pkg, $file, $line) = caller($i)) { unless ($pkg eq "Tkx" || $pkg =~ /^Tkx::/) { $file =~ s,.*[/\\],,; push(@prefix, $file, $line); last; } $i++; } } my($cmd, @args) = @_; for (@args) { if (ref eq "CODE" || ref eq "ARRAY" && ref($_->[0]) eq "CODE") { $_ = "perl::callback"; } elsif (ref eq "ARRAY" || ref eq "Tcl::List") { $_ = $interp->call("format", "[list %s]", $_); } else { if ($TRACE_MAX_STRING && length > $TRACE_MAX_STRING) { substr($_, 2*$TRACE_MAX_STRING/3, -$TRACE_MAX_STRING/3) = " ... "; } s/([\\{}\"\[\]\$])/\\$1/g; s/\r/\\r/g; s/\n/\\n/g; s/\t/\\t/g; s/([^\x00-\xFF])/sprintf "\\u%04x", ord($1)/ge; s/([^\x20-\x7e])/sprintf "\\x%02x", ord($1)/ge; $_ = "{$_}" if / /; } } print STDERR join(" ", (join("-", @prefix) . ":"), $cmd, @args) . "\n"; } my @cleanup; if ($_[0] eq "destroy") { my @paths = @_; shift(@paths); push(@cleanup, Tkx::widget::_destroy->new(@paths)); } if (wantarray) { my @a = eval { $interp->call(@_) }; return @a unless $@; } else { my $a = eval { $interp->call(@_) }; return $a unless $@; } # report exception relative to the non-Tkx caller if (!ref($@) && $@ =~ s/( at .*[\\\/](Tkx|Tcl)\.pm line \d+\.\n\z)//) { my $i = 1; my($pkg, $file, $line); while (($pkg, $file, $line) = caller($i)) { last if $pkg !~ /^Tkx(::|$)/; $i++; }; $@ .= " at $file line $line.\n"; } die $@; } sub DoOneEvent { $interp->DoOneEvent(@_); } 1; __END__ =pod =head1 NAME Tkx - Yet another Tk interface =head1 SYNOPSIS use Tkx; my $mw = Tkx::widget->new("."); $mw->new_button( -text => "Hello, world", -command => sub { $mw->g_destroy; }, )->g_pack; Tkx::MainLoop(); =head1 DESCRIPTION The C module provides yet another Tk interface for Perl. Tk is a GUI toolkit tied to the Tcl language, and C provides a bridge to Tcl that allows Tk based applications to be written in Perl. The main idea behind Tkx is that it is a very thin wrapper on top of Tcl, i.e. that what you get is exactly the behaviour you read about in the Tcl/Tk documentation with no surprises added by the Perl layer. This is the "reference manual" for Tkx. For a gentle introduction please read the L. The tutorial at L is also strongly recommended. =head2 Functions The following functions are provided: =over =item Tkx::AUTOLOAD( @args ) All calls into the C<< Tkx:: >> namespace not explicitly listed here are trapped by Perl's AUTOLOAD mechanism and turned into a call of the corresponding Tcl or Tk command. The Tcl string result is returned as a single value in both scalar and list context. Tcl errors are propagated as Perl exceptions. For example: $res = Tkx::expr("3 + 3") This will call the Tcl command C passing it the argument C<"3 + 3"> and return the result back to Perl. The value of C<$res> after this call should be C<6>. The exact rules for mapping functions names into the Tcl name space and the details of passing arguments to Tcl is described in L below. Don't call Tkx::AUTOLOAD() directly yourself. The available Tcl commands are documented at L. The available Tk commands are documented at L. =item Tkx::Ev( $field, ... ) This creates an object that if set up as the first argument to a callback will expand the corresponding Tcl template substitutions in the context of that callback. L below explain how callback arguments are provided. The $field should be a string like "%A" or "%x". The available substitutions are described in the Tcl documentation for the C command; see L. =item Tkx::MainLoop( ) This will enter the Tk mainloop and start processing events. The function returns when the main window has been destroyed. There is no return value. =item Tkx::SplitList( $list ) This will split up a Tcl list into a Perl list. The individual elements of the list are returned as separate elements. This function will croak if the argument is not a well formed list or if called in scalar context. Example: my @list = Tkx::SplitList("a {b c}"); # @list is now ("a", "b c") This function is needed because direct calls Tcl don't expand lists even if called in list context, so if you want to process the elements returned as a Tcl list you need to wrap the call in a call to SplitList: for my $file (Tkx::SplitList(Tkx::glob('*.pm'))) { # ... } Since Perl also have a built in glob function there is no need to actually let Tcl do the globbing for you. The example above is purely educational. The Tkx::list() function would invoke the Tcl command that does the reverse operation -- creating a list from the arguments passed in. You seldom need to call Tkx::list() explicitly as arrays are automatically converted to Tcl lists when passed as arguments to Tcl commands. =back All these functions, even the autoloaded ones, can be exported by Tkx if you grow tired of typing the C prefix. Example: use strict; use Tkx qw(MainLoop button pack destroy); pack(button(".b", -text => "Press me!", -command => [\&destroy, "."])); MainLoop; No functions are exported by default. =head2 Calling Tcl and Tk Commands Tcl and Tk commands are easily invoked by calling the corresponding function in the Tkx:: namespace. Calling the function C<< Tkx::expr() >> will invoke the C<< expr >> command on the Tcl side. Function names containing underlines are a bit special. The name passed from the Perl side undergo the following substitutions: foo_bar --> "foo", "bar" # break into words foo__bar --> "foo::bar" # access Tcl namespaces foo___bar --> "foo_bar" # when you actually need a '_' This allow us conveniently to map the Tcl namespace to Perl. If this mapping does not suit you, an alternative is to use C<< Tkx::i::call($cmd, @args) >>. This will invoke the command named by C<$cmd> with no name substitutions or magic. Examples: Tkx::expr("3 + 3"); 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 objects to wrap these as described in L 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. Array references, where the first element is not a code reference, are converted into Tcl lists and passed on. The arrays can contain strings, numbers, and/or array references to form nested lists. Code references, and arrays where the first element is a code reference, are converted into special Tcl command names in the "::perl" Tcl namespace that will call back into the corresponding Perl function when invoked from Tcl. See L for a description how how this is used. Scalar references are converted into special Tcl variables in the "::perl" Tcl namespace that is tied to the corresponding variable on the Perl side. Any changes to the variable on the Perl side will be reflected in the value on the Tcl side. Any changes to the variable on the Tcl side will be reflected in the value on the Perl side. Hash references are converted into special Tcl array variables in the "::perl" Tcl namespace that is tied to the corresponding hash on the Perl side. Any changes to the hash on the Perl side will be reflected in the array on the Tcl side. Any changes to the array on the Tcl side will be reflected in the hash on the Perl side. Anything else will just be converted to strings using the Perl rules for stringification and passed on to Tcl. =head3 Tracing If the boolean variable $Tkx::TRACE is set to a true value, then a trace of all commands passed to Tcl will be printed on STDERR. This variable is initialized from the C environment variable. The trace is useful for debugging and if you need to report errors to the Tcl/Tk maintainers in terms of Tcl statements. The trace lines are prefixed with: Tkx-$seq-$ts-$file-$line: where C<$seq> is a sequence number, C<$ts> is a timestamp in seconds since the first command was issued, and C<$file> and C<$line> indicate on which source line this call was triggered. =head2 Callbacks to Perl For Tcl APIs that require callbacks you can provide a reference to a Perl subroutine: Tkx::after(3000, sub { print "Hi" }); $button = $w->new_button( -text => 'Press Me', -command => \&foo, ); Alternately, you can provide an array reference containing a subroutine reference and a list of values to be passed back to the subroutine as arguments when it is invoked: Tkx::button(".b", -command => [\&Tkx::destroy, "."]); $button = $w->new_button( -text => 'Press Me', -command => [\&foo, 42], ); When using the array reference syntax, if the I 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(".", "", [ 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. =item 2 Any arguments that the command/function is called with from the Tcl side. For example, in callbacks to scrollbars Tcl provides values corresponding to the visible portion of a scrollable widget. Tcl arguments are passed regardless of the syntax used when specifying the callback. =item 3 Any extra values provided when the callback defined; the values passed after the Tkx::Ev() object in the array. =back =head2 Widget handles The class C is used to wrap Tk widget paths. These objects stringify as the path they wrap. The following methods are provided: =over =item $w = Tkx::widget->new( $path ) This constructs a new widget handle for a given path. It is not a problem to have multiple handle objects to the same path or to create handles for paths that do not yet exist. =item $w->_data Returns a hash that can be used to keep instance specific data. This is useful for holding instance data for megawidgets. The data is attached to the underlying widget, so if you create another handle to the same widget it will return the same hash via its _data() method. The data hash is automatically destroyed when the corresponding widget is destroyed. =item $w->_parent Returns a handle for the parent widget. Returns C if there is no parent, which will only happen if $w is ".", the main window. =item $w->_kid( $name ) Returns a handle for a kid widget with the given name. The $name can contain dots to access grandkids. There is no check that a kid with the given name actually exists; which can be taken advantage of to construct names of Tk widgets to be created later. =item $w->_kids Returns all existing kids as widget objects. =item $w->_class( $class ) Sets the widget handle class for the current path. This will both change the class of the current handle and make sure later handles created for the path belong to the given class. The class should normally be a subclass of C. Overriding the class for a path is useful for implementing megawidgets. Kids of $w are not affected by this, unless the class overrides the C<_nclass> method. =item $w->_nclass This returns the default widget handle class that will be used for kids and parent. Subclasses might want to override this method. The default implementation always returns C. =item $w->_mpath( $method ) This method determine the Tk widget path that will be invoked for m_I method calls. The argument passed in is the method name without the C prefix. Megawidget classes might want to override this method. The default implementation always returns C<$w>. =item $new_w = $w->new_I( @args ) This creates a new I widget as a child of the current widget. It will call the I Tcl command and pass it a new unique subpath of the current path. The handle to the new widget is returned. Any double underscores in the name I is expanded as described in L above. Example: $w->new_label(-text => "Hello", -relief => "sunken"); The name selected for the child will be the first letter of the widget type; for the example above "l". If that name is not unique a number is appended to ensure uniqueness among the children. If a C<-name> argument is passed it is used as the name and then removed from the arglist passed on to Tcl. Example: $w->new_iwidgets__calendar(-name => "cal"); If a megawidget implementation class has be registered for I, then its C<_Populate> method is called instead of passing widget creation to Tcl. =item $w->m_I( @args ) This will invoke the I subcommand for the current widget. This is the same as: $func = "Tkx::$w"; &$func(expand("foo"), @args); where the expand() function expands underscores as described in L above. Example: $w->m_configure(-background => "red"); Subclasses might override the _mpath() method to have m_I forward the subcommand somewhere else than the current widget. =item $w->g_I( @args ) This will invoke the I Tcl command with the current widget as first argument. This is the same as: $func = "Tkx::foo"; &$func($w, @args); Any underscores in the name I are expanded as described in L above. Example: $w->g_pack_forget; =item $w->I( @args ) If the method does not start with "new_" or have a prefix of the form /^_/ or /^[a-zA-Z]_/, the call will just forward to the method "m_I" (described above). This is just a convenience for people that have grown tired of the "m_" prefix. The method names with prefix /^_/ and /^[a-zA-Z]_/ are reserved for future extensions to this API. =item Tkx::widget->_Mega( $widget, $class ) This register $class as the one implementing $widget widgets. See L. =back =head2 Subclassing Tk widgets You can't subclass a Tk widget in Perl, but you can emulate it by creating a megawidget. =head2 Megawidgets Megawidgets can be implemented in Perl and used by Tkx. To declare a megawidget make a Perl class like this one: package Foo; use base 'Tkx::widget'; Foo->_Mega("foo"); sub _Populate { my($class, $widget, $path, %opt) = @_; ... } The megawidget class should inherit from C and will register itself by calling the _Mega() class method. In the example above we tell Tkx that any "foo" widgets should be handled by the Perl class "Foo" instead of Tcl. When a new "foo" widget is instantiated with: $w->new_foo(-text => "Hi", -foo => 1); then the _Populate() class method of C is called. It will be passed the widget type to create, the full path to use as widget name and any options passed in. The widget name is passed in so that a single Perl class can implement multiple widget types. The _Populate() class should create a root object with the given $path as name and populate it with the internal widgets. Normally the root object will be forced to belong to the implementation class so that it can trap various method calls on it. By using the _class() method to set the class _Populate() can ensure that new handles to this megawidget also use this class. To make Tk aware of your megawidget you must register it by providing a C<-class> argument when creating the root widget. Doing this sets the value returned by the C<< $w->g_winfo_class >> method. It also makes it possible for your megawidget to have to have class-specific bindings and be configurable via Xdefaults and the options database. By convention class names start with a capital letter, so Tkx megawidgets should have names like "Tkx_Foo". If you don't register your megawidget with Tk, C will return the class of whatever you use as a root widget and your megawidget will be subject to the bindings for that 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 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 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 * It makes them behave the same as native widget methods. That is, they may be called either with or without the "m_" prefix as the user of the widget prefers. =item * It enables the megawidget to accept method delegation from another widget via the parent widget's _mpath() method. =back See L for a trivial example megawidget. =head1 ENVIRONMENT The C environment variable initialize the $Tkx::TRACE setting. The C environment variable can be set to override the Tcl/Tk used. =head1 SUPPORT If you have questions about this code or want to report bugs send a message to the mailing list. To subscribe to this list send an empty message to . =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. =head1 SEE ALSO L, L, L At L you find a very nice Tk tutorial that uses Tkx for the Perl examples. More information about Tcl/Tk can be found at L. Tk documentation is also available at L. The official source repository for Tkx is L. Alternative Tk bindings for Perl are described in L and L. ActivePerl bundles a Tcl interpreter and a selection of Tk widgets from ActiveTcl in order to provide a functional Tkx module out-of-box. L documents the version of Tcl/Tk you get and whats available in addition to the core commands. You need to set the C environment variable to make Tkx reference other Tcl installations. =cut Tkx-1.09/lib/Tkx/LabEntry.pm000644 000765 000024 00000003243 11304561337 016056 0ustar00gislestaff000000 000000 package Tkx::LabEntry; use base qw(Tkx::widget Tkx::MegaConfig); __PACKAGE__->_Mega("tkx_LabEntry"); __PACKAGE__->_Config( -label => [[".lab" => "-text"]], ); sub _Populate { my($class, $widget, $path, %opt) = @_; my $self = $class->new($path)->_parent->new_frame(-name => $path, -class => "Tkx_LabEntry"); $self->_class($class); $self->new_label(-name => "lab", -text => delete $opt{-label})->g_pack(-side => "left"); $self->new_entry(-name => "e", %opt)->g_pack(-side => "left", -fill => "both", -expand => 1); $self; } sub _mpath { my $self = shift; "$self.e"; } 1; =head1 NAME Tkx::LabEntry - Labeled entry widget =head1 SYNOPSIS use Tkx; use Tkx::LabEntry; my $mw = Tkx::widget->new("."); my $e = $mw->new_tkx_LabEntry(-label => "Name"); $e->g_pack; my $b = $mw->new_button( -text => "Done", -command => sub { print $e->get, "\n"; $mw->g_destroy; }, ); $b->g_pack; Tkx::MainLoop(); =head1 DESCRIPTION The C module implements a trivial megawidget. Its main purpose is to demonstrate how to use the C baseclass. Once the C module has been loaded, then its widgets can be constructed in the normal way using the C name. Besides having a label (whose text can be accessed with the C<-label> configuration option), these widgets behave exactly like an C would. =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. =head1 SEE ALSO The source code of Tkx::LabEntry. L, L Tkx-1.09/lib/Tkx/MegaConfig.pm000644 000765 000024 00000011650 11304561337 016336 0ustar00gislestaff000000 000000 package Tkx::MegaConfig; use strict; our $VERSION = "1.07"; 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") { ($where, @where_args) = @$where; } if ($where =~ s/^\.//) { my $fwd_opt = $where_args[0] || $opt; return $self->Tkx::widget::m_cget($fwd_opt) if $where eq ""; return ($self->_kids)[0]->m_cget($fwd_opt) if $where eq "*"; return $self->_kid($where)->m_cget($fwd_opt); } if ($where eq "METHOD") { my $method = $where_args[0] || "_config_" .substr($opt, 1); return $self->$method; } if ($where eq "PASSIVE") { return $self->_data->{$opt}; } die; } 1; __END__ =head1 NAME Tkx::MegaConfig - handle configuration options for megawidgets =head1 SYNOPSIS package Foo; use base qw(Tkx::widget Tkx::MegaConfig); __PACKAGE__->_Mega("foo"); __PACKAGE__->_Config( -option => [$where, $dbName, $dbClass, $default], ); =head1 DESCRIPTION The C 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 explict spec. If there is no 'DEFAULT' then unmatched options are applied directly to the megawidget root itself. This is the same behaviour you get if you specify: __PACKAGE__->_Config( ... DEFAULT => ['.'], ); The option spec should be an array reference. The first element of the array ($where) describe how this option is handled. Some $where specs take arguments. If you need to provide argument replace $where with an array reference containg [$where, @args]. The rest of the option spec specify names and default for the options database, but is currently ignored (feature unimplemented). The following $where specs are understood: =over =item .foo Delegate the given configuration option to the "foo" kid of the mega widget root. The name "." can be used to delegate to the megawidget root itself. The name ".*" can be used to delegate to all kids of the megawidget root. An argument can be given to delegate using a different configuration name 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 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. Examples: __PACKAGE__->_Config( -foo => ["METHOD"]; -bar => [["METHOD", "bar"]], } sub _config_foo { my $self = shift; return "foo" unless @_; print "Ignoring setting configuration option -foo to '$_[0]'"; } sub handle_bar { my $self = shift; return "bar" unless @_; print "Ignoring setting configuration option -bar to '$_[0]'"; } =item PASSIVE Store or retrieve option from $self->_data. =back =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Copyright 2005 ActiveState. All rights reserved. =head1 SEE ALSO L, L Inspiration for this module comes from L. Tkx-1.09/lib/Tkx/Tutorial.pod000644 000765 000024 00000047423 11304561337 016317 0ustar00gislestaff000000 000000 =head1 NAME Tkx::Tutorial - How to use Tkx =head1 DESCRIPTION I is a toolkit for creating applications with graphical interfaces on Windows, Mac OS X and X11. The Tk toolkit is native to the I programming language, but its ease of use and cross-platform availability has made it the GUI toolkit of choice for many other dynamic languages. I is a Perl module that makes the Tk toolkit available to Perl programs. By loading the Tkx module Perl programs can create windows and fill them with text, images, buttons and other controls that make up the user interface of the application. =head2 Hello World Let's start with the mandatory exercise of creating an application that greats the world. We'll make the application window contain a single button which will shut down the application if clicked. The code to make this happen is: use Tkx; Tkx::button(".b", -text => "Hello, world", -command => sub { Tkx::destroy("."); }, ); Tkx::pack(".b"); Tkx::MainLoop() Save this to a file called F and then run C to start the application. A window with the text "Hello, world" should appear on your screen. Let's look at what this code is doing. After the Tkx module has been loaded by the C statement, the application will show an empty window called ".". We create a I