├── .gitignore ├── Changes ├── MANIFEST ├── MANIFEST.SKIP ├── Makefile.PL ├── README ├── Tkx Editor.app └── Contents │ ├── Info.plist │ ├── MacOS │ ├── Tkx Editor │ ├── perl │ └── script │ └── Resources │ └── leisure.icns ├── lib ├── Tkx.pm └── Tkx │ ├── Handy.pm │ ├── LabEntry.pm │ ├── MegaConfig.pm │ └── Tutorial.pod ├── menu ├── t ├── LabEntry.t ├── mega-config.t ├── mega.t ├── nul-char.t ├── tcl-callback.t ├── tcl.t ├── tk.t └── utf8.t ├── table.pl ├── tkx-ed └── tkx-prove /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.old 3 | blib 4 | pm_to_blib 5 | *.tar.gz 6 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 2010-11-24 Gisle Aas 2 | 3 | Release 1.09 4 | 5 | Improved documentation 6 | 7 | 8 | 9 | 2009-11-29 Gisle Aas 10 | 11 | Release 1.08 12 | 13 | Improved documentation 14 | 15 | Add callback test and made Tcl-0.98 a prereq 16 | 17 | 18 | 19 | 2009-01-30 Gisle Aas 20 | 21 | Release 1.07 22 | 23 | Tkx::widget now have a $w->_kids method 24 | 25 | Tkx::MegaConfig now support option delegation to all its kids 26 | 27 | The Tkx::LabEntry example now overide its Tkx class 28 | 29 | Improved documentation 30 | 31 | 32 | 33 | 2009-01-17 Gisle Aas 34 | 35 | Release 1.06 36 | 37 | Sources moved to public repository at http://github.com/gisle/tkx/ 38 | 39 | For sub-widgets implemented in perl we should call perl methods [RT#42454] 40 | 41 | Additional "Mac OS X" tweaks to tkx-ed. The GIT repository 42 | also have a full *.app wrapper to demonstrate how to integrate 43 | Tkx based GUI apps on OS X. 44 | 45 | Fixed error message when tkx-ed can't load the given file 46 | 47 | Tweak to Tkx::widget's AUTOLOAD function to make it slightly faster 48 | 49 | 50 | 51 | 2008-07-30 Gisle Aas 52 | 53 | Release 1.05 [286656] 54 | 55 | Documentation update 56 | 57 | Tutorial cleanup by Troy Topnik 58 | 59 | 60 | 61 | 2006-06-30 Gisle Aas 62 | 63 | Release 1.04 [265087] 64 | 65 | Some Tkx::MegaConfig fixes by Jeff Hobbs: 66 | - 'METHOD' where spec would not call the documented method 67 | - '.' where spec didn't work at all 68 | 69 | Added test for Tkx::MegaConfig 70 | 71 | 72 | 73 | 2006-06-21 Gisle Aas 74 | 75 | Release 1.03 [264696] 76 | 77 | Renamed tkxed as tkx-ed. Jeff Hobbs made the program have a 78 | proper File/Edit menu and make it use the ctext widget. There 79 | are also improvements to make it look nicer on Mac OS X. 80 | 81 | Included another sample program; tkx-prove, which allows you to 82 | run perl test suites in a handy window. 83 | 84 | 85 | 86 | 2005-08-29 Gisle Aas 87 | 88 | Release 1.02 [186229] 89 | 90 | Prettier error if Tk fails to initialize. This might happen if 91 | the you can't connect to the X11-server or if Tcl has been installed 92 | without Tk. 93 | 94 | Report Tcl exceptions relative to the code that uses Tkx instead of 95 | somewhere internally in Tcl.pm. 96 | 97 | Don't require style.tcl to be present for 'tkxed' and 'menu' to run. 98 | 99 | Improved the documentation some more. 100 | 101 | 102 | 103 | 2005-08-25 Gisle Aas 104 | 105 | Release 1.01 [182713] 106 | 107 | Expanded the Tkx::Tutorial. 108 | 109 | Added sample program called menu. 110 | 111 | Make the tkxed menu available with Ctrl-Button-1 on Mac OS. 112 | 113 | The README was not included because it was missing from the 114 | MANIFEST. 115 | 116 | 117 | 118 | 2005-08-24 Gisle Aas 119 | 120 | Release 1.00 [181521] 121 | 122 | Initial public release 123 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | Makefile.PL 3 | MANIFEST This list of files 4 | README 5 | menu 6 | t/LabEntry.t 7 | t/mega.t 8 | t/mega-config.t 9 | t/nul-char.t 10 | t/tcl.t 11 | t/tcl-callback.t 12 | t/tk.t 13 | t/utf8.t 14 | tkx-ed 15 | tkx-prove 16 | lib/Tkx.pm 17 | lib/Tkx/LabEntry.pm 18 | lib/Tkx/MegaConfig.pm 19 | lib/Tkx/Tutorial.pod 20 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | .git/ 2 | .gitignore 3 | pm_to_blib 4 | blib/ 5 | Makefile 6 | Makefile.old 7 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use strict; 4 | use ExtUtils::MakeMaker; 5 | 6 | WriteMakefile( 7 | NAME => "Tkx", 8 | VERSION_FROM => 'lib/Tkx.pm', 9 | ABSTRACT_FROM => 'lib/Tkx.pm', 10 | PREREQ_PM => { 11 | Tcl => 1.00, 12 | }, 13 | AUTHOR => 'Gisle Aas ', 14 | EXE_FILES => [qw(tkx-ed tkx-prove)], 15 | LICENSE => "perl", 16 | MIN_PERL_VERSION => 5.008, 17 | META_MERGE => { 18 | resources => { 19 | repository => 'http://github.com/gisle/tkx/', 20 | MailingList => 'mailto:tcltk@perl.org', 21 | } 22 | }, 23 | ); 24 | 25 | BEGIN { 26 | # compatibility with older versions of MakeMaker 27 | my $developer = -f ".gitignore"; 28 | my %mm_req = ( 29 | LICENCE => 6.31, 30 | META_MERGE => 6.45, 31 | META_ADD => 6.45, 32 | MIN_PERL_VERSION => 6.48, 33 | ); 34 | undef(*WriteMakefile); 35 | *WriteMakefile = sub { 36 | my %arg = @_; 37 | for (keys %mm_req) { 38 | unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { 39 | warn "$_ $@" if $developer; 40 | delete $arg{$_}; 41 | } 42 | } 43 | ExtUtils::MakeMaker::WriteMakefile(%arg); 44 | }; 45 | } 46 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Tkx.pm 2 | ------ 3 | 4 | The Tkx module provides yet another Tk interface for Perl. Tk is a GUI 5 | toolkit tied to the Tcl language, and Tkx provides a bridge to Tcl that 6 | allows Tk based applications to be written in Perl. 7 | 8 | The main idea behind Tkx is that it is a very thin wrapper on top of 9 | Tcl, i.e. that what you get is exactly the behaviour you read about in 10 | the Tcl/Tk documentation with no surprises added by the Perl layer. 11 | In order to use Tkx, you need to understand enough Tcl to be able to 12 | read the documentation for Tcl/Tk and figure out how this maps to the 13 | Tkx. You will not need to write any Tcl code though, as all your GUI 14 | work, including the creation of megawidgets can be done in Perl using 15 | Tkx. 16 | 17 | The benefit of this approach compared Nick Ing-Simmons's classic Tk.pm 18 | module is that you can always use the latest features that Tk/Tcl 19 | provides and that you can use Tcl's native megawidgets directly. 20 | Tk.pm has stagnated recently because of the huge effort needed to port 21 | it to run with newer versions of Tk. The downside of the Tkx approach 22 | is that you will need to know a bit about Tcl and that you have to 23 | install Tcl/Tk on both your development and deployment systems. 24 | Another downside is that you will not be able to use any of the Tk:: 25 | add-ons or megawidgets already present on CPAN. 26 | 27 | Tkx is the toolkit used to implement the GUI frontends of ActiveState's 28 | PDK tools. 29 | 30 | In order to install Tkx, you will need to have Tcl/Tk-8.4 and perl-5.8 31 | with the Tcl.pm module installed. Installation otherwise follow the 32 | normal drill: 33 | 34 | perl Makefile.PL 35 | make 36 | make test 37 | make install 38 | 39 | If you have questions about this code or want to report bugs send a 40 | message to the mailing list. To subscribe to this 41 | list send an empty message to . 42 | 43 | The official source repository for Tkx is 44 | http://github.com/gisle/tkx/. You can grab the latest sources 45 | with: 46 | 47 | git clone git://github.com/gisle/tkx.git 48 | 49 | This library is free software; you can redistribute it and/or modify 50 | it under the same terms as Perl itself. 51 | 52 | Copyright 2005 ActiveState. All rights reserved. 53 | -------------------------------------------------------------------------------- /Tkx Editor.app/Contents/Info.plist: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | CFBundlePackageType 6 | APPL 7 | CFBundleExecutable 8 | Tkx Editor 9 | CFBundleIconFile 10 | leisure.icns 11 | CFBundleDocumentTypes 12 | 13 | 14 | CFBundleTypeExtensions 15 | 16 | * 17 | 18 | CFBundleTypeName 19 | All 20 | CFBundleTypeRole 21 | Viewer 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /Tkx Editor.app/Contents/MacOS/Tkx Editor: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | dir=${0%/*} 3 | exec "$dir/perl" "$dir/script" "$@" 4 | -------------------------------------------------------------------------------- /Tkx Editor.app/Contents/MacOS/perl: -------------------------------------------------------------------------------- 1 | /usr/local/ActivePerl-5.10/bin/perl -------------------------------------------------------------------------------- /Tkx Editor.app/Contents/MacOS/script: -------------------------------------------------------------------------------- 1 | ../../../tkx-ed -------------------------------------------------------------------------------- /Tkx Editor.app/Contents/Resources/leisure.icns: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gisle/tkx/2c96533e06ac4e00d10d1b6099f880c5d4b57ff1/Tkx Editor.app/Contents/Resources/leisure.icns -------------------------------------------------------------------------------- /lib/Tkx.pm: -------------------------------------------------------------------------------- 1 | package Tkx; 2 | 3 | use strict; 4 | our $VERSION = '1.09'; 5 | 6 | { 7 | # predeclare 8 | package Tkx::widget; 9 | package Tkx::i; 10 | } 11 | 12 | eval { 13 | package_require("Tk"); 14 | }; 15 | if ($@) { 16 | $@ =~ s/^this isn't a Tk application//; # what crap 17 | die $@; 18 | } 19 | 20 | our $TRACE; 21 | our $TRACE_MAX_STRING; 22 | our $TRACE_COUNT; 23 | our $TRACE_TIME; 24 | our $TRACE_CALLER; 25 | 26 | $TRACE = $ENV{PERL_TKX_TRACE} unless defined $TRACE; 27 | $TRACE_MAX_STRING = 64 unless defined $TRACE_MAX_STRING; 28 | $TRACE_COUNT = 1 unless defined $TRACE_COUNT; 29 | $TRACE_TIME = 1 unless defined $TRACE_TIME; 30 | $TRACE_CALLER = 1 unless defined $TRACE_CALLER; 31 | 32 | 33 | sub import { 34 | my($class, @subs) = @_; 35 | my $pkg = caller; 36 | for (@subs) { 37 | s/^&//; 38 | if (/^[a-zA-Z]\w*/ && $_ ne "import") { 39 | no strict 'refs'; 40 | *{"$pkg\::$_"} = \&$_; 41 | } 42 | else { 43 | die qq("$_" is not exported by the $class module); 44 | } 45 | } 46 | } 47 | 48 | sub AUTOLOAD { 49 | our $AUTOLOAD; 50 | my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); 51 | return scalar(Tkx::i::call(Tkx::i::expand_name($method), @_)); 52 | } 53 | 54 | sub MainLoop () { 55 | while (eval { local $TRACE; Tkx::i::call("winfo", "exists", ".") }) { 56 | Tkx::i::DoOneEvent(0); 57 | } 58 | } 59 | 60 | sub SplitList ($) { 61 | my $list = shift; 62 | unless (wantarray) { 63 | require Carp; 64 | Carp::croak("Tkx::SplitList needs list context"); 65 | } 66 | return @$list if ref($list) eq "ARRAY" || ref($list) eq "Tcl::List"; 67 | return Tkx::i::call("concat", $list); 68 | } 69 | 70 | *Ev = \&Tcl::Ev; 71 | 72 | package Tkx::widget; 73 | 74 | use overload '""' => sub { ${$_[0]} }, 75 | fallback => 1; 76 | 77 | my %data; 78 | my %class; 79 | my %mega; 80 | 81 | sub new { 82 | my $class = shift; 83 | my $name = shift; 84 | return bless \$name, $class{$name} || $class; 85 | } 86 | 87 | sub _data { 88 | my $self = shift; 89 | return $data{$$self} ||= {}; 90 | } 91 | 92 | sub _kid { 93 | my($self, $name) = @_; 94 | substr($name, 0, 0) = $$self eq "." ? "." : "$$self."; 95 | return $self->_nclass->new($name); 96 | } 97 | 98 | sub _kids { 99 | my $self = shift; 100 | my $nclass = $self->_nclass; 101 | return map $nclass->new($_), Tkx::SplitList(Tkx::winfo_children($self)); 102 | } 103 | 104 | sub _parent { 105 | my $self = shift; 106 | my $name = $$self; 107 | return undef if $name eq "."; 108 | substr($name, rindex($name, ".")) = ""; 109 | $name = "." unless length($name); 110 | return $self->_nclass->new($name); 111 | } 112 | 113 | sub _class { 114 | my $self = shift; 115 | my $old = ref($self); 116 | if (@_) { 117 | my $class = shift; 118 | $class{$$self} = $class; 119 | bless $self, $class; 120 | } 121 | $old; 122 | } 123 | 124 | sub _Mega { 125 | my $class = shift; 126 | my $widget = shift; 127 | my $impclass = shift || caller; 128 | $mega{$widget} = $impclass; 129 | } 130 | 131 | sub _nclass { 132 | __PACKAGE__; 133 | } 134 | 135 | sub _mpath { 136 | my $self = shift; 137 | $$self; 138 | } 139 | 140 | sub AUTOLOAD { 141 | my $self = shift; 142 | 143 | our $AUTOLOAD; 144 | my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2); 145 | 146 | if (substr($method, 0, 4) eq "new_") { 147 | my $widget = Tkx::i::expand_name(substr($method, 4)); 148 | my $name; 149 | for (my $i = 0; $i < @_; $i += 2) { 150 | if ($_[$i] eq "-name") { 151 | (undef, $name) = splice(@_, $i, 2); 152 | substr($name, 0, 0) = ($$self eq "." ? "." : "$$self.") 153 | if index($name, ".") == -1; 154 | last; 155 | } 156 | } 157 | $name ||= Tkx::i::wname($widget, $$self); 158 | if (my $mega = $mega{$widget}) { 159 | return $mega->_Populate($widget, $name, @_); 160 | } 161 | return $self->_nclass->new(scalar(Tkx::i::call($widget, $name, @_))); 162 | } 163 | 164 | my $prefix = substr($method, 0, 2); 165 | if ($prefix eq "m_") { 166 | my @i = Tkx::i::expand_name(substr($method, 2)); 167 | my $p = $self->_mpath($i[0]); 168 | return scalar(Tkx::i::call($p, @i, @_)) if $p eq $$self || !$class{$p}; 169 | return (bless \$p, $class{$p})->$method(@_); 170 | } 171 | 172 | if ($prefix eq "g_") { 173 | return scalar(Tkx::i::call(Tkx::i::expand_name(substr($method, 2)), $$self, @_)); 174 | } 175 | 176 | if (index($prefix, "_") != -1) { 177 | require Carp; 178 | Carp::croak("method '$method' reserved by Tkx"); 179 | } 180 | 181 | $method = "m_$method"; 182 | return $self->$method(@_); 183 | } 184 | 185 | sub DESTROY {} # avoid AUTOLOADing it 186 | 187 | 188 | package Tkx::widget::_destroy; 189 | 190 | sub new { 191 | my($class, @paths) = @_; 192 | bless \@paths, $class; 193 | } 194 | 195 | sub DESTROY { 196 | my $self = shift; 197 | for my $path (@$self) { 198 | if ($path eq ".") { 199 | %data = (); 200 | return; 201 | } 202 | 203 | my $path_re = qr/^\Q$path\E(?:\.|\z)/; 204 | for my $hash (\%data, \%class) { 205 | for my $key (keys %$hash) { 206 | next unless $key =~ $path_re; 207 | delete $hash->{$key}; 208 | } 209 | } 210 | } 211 | } 212 | 213 | package Tkx::i; 214 | 215 | use Tcl; 216 | 217 | my $interp; 218 | my $trace_count = 0; 219 | my $trace_start_time = 0; 220 | 221 | BEGIN { 222 | $Tcl::STACK_TRACE = 0; 223 | $interp = Tcl->new; 224 | $interp->Init; 225 | } 226 | 227 | sub interp { 228 | return $interp; 229 | } 230 | 231 | sub expand_name { 232 | my(@f) = (shift); 233 | @f = split(/(? 1 } @kids; 250 | my $count = 2; 251 | $count++ while $kids{"$name$count"}; 252 | $name .= $count; 253 | } 254 | $name; 255 | } 256 | 257 | sub call { 258 | if ($Tkx::TRACE) { 259 | my @prefix = "Tkx"; 260 | if ($Tkx::TRACE_COUNT) { 261 | push(@prefix, ++$trace_count); 262 | } 263 | if ($Tkx::TRACE_TIME) { 264 | my $ts; 265 | unless ($trace_start_time) { 266 | if (eval { require Time::HiRes }) { 267 | $trace_start_time = Time::HiRes::time(); 268 | } 269 | else { 270 | $trace_start_time = time; 271 | } 272 | } 273 | if (defined &Time::HiRes::time) { 274 | $ts = sprintf "%.1fs", Time::HiRes::time() - $trace_start_time; 275 | } 276 | else { 277 | $ts = time - $trace_start_time; 278 | $ts .= "s"; 279 | } 280 | push(@prefix, $ts); 281 | } 282 | if ($Tkx::TRACE_CALLER) { 283 | my $i = 0; 284 | while (my($pkg, $file, $line) = caller($i)) { 285 | unless ($pkg eq "Tkx" || $pkg =~ /^Tkx::/) { 286 | $file =~ s,.*[/\\],,; 287 | push(@prefix, $file, $line); 288 | last; 289 | } 290 | $i++; 291 | } 292 | } 293 | 294 | my($cmd, @args) = @_; 295 | for (@args) { 296 | if (ref eq "CODE" || ref eq "ARRAY" && ref($_->[0]) eq "CODE") { 297 | $_ = "perl::callback"; 298 | } 299 | elsif (ref eq "ARRAY" || ref eq "Tcl::List") { 300 | $_ = $interp->call("format", "[list %s]", $_); 301 | } 302 | else { 303 | if ($TRACE_MAX_STRING && length > $TRACE_MAX_STRING) { 304 | substr($_, 2*$TRACE_MAX_STRING/3, -$TRACE_MAX_STRING/3) = " ... "; 305 | } 306 | s/([\\{}\"\[\]\$])/\\$1/g; 307 | s/\r/\\r/g; 308 | s/\n/\\n/g; 309 | s/\t/\\t/g; 310 | s/([^\x00-\xFF])/sprintf "\\u%04x", ord($1)/ge; 311 | s/([^\x20-\x7e])/sprintf "\\x%02x", ord($1)/ge; 312 | $_ = "{$_}" if / /; 313 | } 314 | } 315 | print STDERR join(" ", (join("-", @prefix) . ":"), $cmd, @args) . "\n"; 316 | } 317 | my @cleanup; 318 | if ($_[0] eq "destroy") { 319 | my @paths = @_; 320 | shift(@paths); 321 | push(@cleanup, Tkx::widget::_destroy->new(@paths)); 322 | } 323 | 324 | if (wantarray) { 325 | my @a = eval { $interp->call(@_) }; 326 | return @a unless $@; 327 | } 328 | else { 329 | my $a = eval { $interp->call(@_) }; 330 | return $a unless $@; 331 | } 332 | 333 | # report exception relative to the non-Tkx caller 334 | if (!ref($@) && $@ =~ s/( at .*[\\\/](Tkx|Tcl)\.pm line \d+\.\n\z)//) { 335 | my $i = 1; 336 | my($pkg, $file, $line); 337 | while (($pkg, $file, $line) = caller($i)) { 338 | last if $pkg !~ /^Tkx(::|$)/; 339 | $i++; 340 | }; 341 | $@ .= " at $file line $line.\n"; 342 | } 343 | die $@; 344 | } 345 | 346 | sub DoOneEvent { 347 | $interp->DoOneEvent(@_); 348 | } 349 | 350 | 1; 351 | 352 | __END__ 353 | 354 | =pod 355 | 356 | =head1 NAME 357 | 358 | Tkx - Yet another Tk interface 359 | 360 | =head1 SYNOPSIS 361 | 362 | use Tkx; 363 | my $mw = Tkx::widget->new("."); 364 | $mw->new_button( 365 | -text => "Hello, world", 366 | -command => sub { $mw->g_destroy; }, 367 | )->g_pack; 368 | Tkx::MainLoop(); 369 | 370 | =head1 DESCRIPTION 371 | 372 | The C module provides yet another Tk interface for Perl. Tk is a 373 | GUI toolkit tied to the Tcl language, and C provides a bridge to 374 | Tcl that allows Tk based applications to be written in Perl. 375 | 376 | The main idea behind Tkx is that it is a very thin wrapper on top of 377 | Tcl, i.e. that what you get is exactly the behaviour you read about in 378 | the Tcl/Tk documentation with no surprises added by the Perl layer. 379 | 380 | This is the "reference manual" for Tkx. For a gentle introduction please 381 | read the L. The tutorial at 382 | L is also strongly recommended. 383 | 384 | =head2 Functions 385 | 386 | The following functions are provided: 387 | 388 | =over 389 | 390 | =item Tkx::AUTOLOAD( @args ) 391 | 392 | All calls into the C<< Tkx:: >> namespace not explicitly listed here are trapped 393 | by Perl's AUTOLOAD mechanism and turned into a call of the corresponding Tcl or 394 | Tk command. The Tcl string result is returned as a single value in both scalar 395 | and list context. Tcl errors are propagated as Perl exceptions. 396 | 397 | For example: 398 | 399 | $res = Tkx::expr("3 + 3") 400 | 401 | This will call the Tcl command C passing it the argument C<"3 + 3"> and 402 | return the result back to Perl. The value of C<$res> after this call should be C<6>. 403 | 404 | The exact rules for mapping functions names into the Tcl name space and the 405 | details of passing arguments to Tcl is described in L below. 407 | 408 | Don't call Tkx::AUTOLOAD() directly yourself. 409 | 410 | The available Tcl commands are documented at 411 | L. The available Tk commands are 412 | documented at L. 413 | 414 | =item Tkx::Ev( $field, ... ) 415 | 416 | This creates an object that if set up as the first argument to a callback will 417 | expand the corresponding Tcl template substitutions in the context of that 418 | callback. L below explain how callback 419 | arguments are provided. 420 | 421 | The $field should be a string like "%A" or "%x". The available 422 | substitutions are described in the Tcl documentation for the C 423 | command; see L. 424 | 425 | =item Tkx::MainLoop( ) 426 | 427 | This will enter the Tk mainloop and start processing events. The 428 | function returns when the main window has been destroyed. There is no 429 | return value. 430 | 431 | =item Tkx::SplitList( $list ) 432 | 433 | This will split up a Tcl list into a Perl list. The individual elements of the 434 | list are returned as separate elements. This function will croak if the 435 | argument is not a well formed list or if called in scalar context. 436 | 437 | Example: 438 | 439 | 440 | my @list = Tkx::SplitList("a {b c}"); 441 | # @list is now ("a", "b c") 442 | 443 | This function is needed because direct calls Tcl don't expand lists even if 444 | called in list context, so if you want to process the elements returned 445 | as a Tcl list you need to wrap the call in a call to SplitList: 446 | 447 | for my $file (Tkx::SplitList(Tkx::glob('*.pm'))) { 448 | # ... 449 | } 450 | 451 | Since Perl also have a built in glob function there is no need to actually 452 | let Tcl do the globbing for you. The example above is purely educational. 453 | 454 | The Tkx::list() function would invoke the Tcl command that does the reverse 455 | operation -- creating a list from the arguments passed in. You seldom need to 456 | call Tkx::list() explicitly as arrays are automatically converted to Tcl lists 457 | when passed as arguments to Tcl commands. 458 | 459 | =back 460 | 461 | All these functions, even the autoloaded ones, can be exported by Tkx if you 462 | grow tired of typing the C prefix. Example: 463 | 464 | use strict; 465 | use Tkx qw(MainLoop button pack destroy); 466 | 467 | pack(button(".b", -text => "Press me!", -command => [\&destroy, "."])); 468 | MainLoop; 469 | 470 | No functions are exported by default. 471 | 472 | =head2 Calling Tcl and Tk Commands 473 | 474 | Tcl and Tk commands are easily invoked by calling the corresponding function 475 | in the Tkx:: namespace. Calling the function C<< Tkx::expr() >> will invoke the 476 | C<< expr >> command on the Tcl side. Function names containing underlines are a bit 477 | special. The name passed from the Perl side undergo the following 478 | substitutions: 479 | 480 | foo_bar --> "foo", "bar" # break into words 481 | foo__bar --> "foo::bar" # access Tcl namespaces 482 | foo___bar --> "foo_bar" # when you actually need a '_' 483 | 484 | This allow us conveniently to map the Tcl namespace to Perl. If this mapping 485 | does not suit you, an alternative is to use C<< Tkx::i::call($cmd, @args) >>. 486 | This will invoke the command named by C<$cmd> with no name substitutions or magic. 487 | 488 | Examples: 489 | 490 | Tkx::expr("3 + 3"); 491 | Tkx::package_require("BWidget"); 492 | Tkx::DynamicHelp__add(".", -text => "Hi there"); 493 | if (Tkx::tk_windowingsystem() eq "x11") { ... } 494 | if (Tkx::tk___messageBox( ... ) eq "yes") { ... } 495 | 496 | One part of the Tcl namespace that is not conveniently mapped to Perl 497 | using the rules above are commands that use "." as part of their name, mostly Tk 498 | widget instances. If you insist you can invoke these by quoting the 499 | Perl function name 500 | 501 | &{"Tkx::._configure"}(-background => "black"); 502 | 503 | or by invoking this as C<< Tkx::i::call(".", "configure", "-background", 504 | "black") >>; but the real solution is to use C objects to wrap 505 | these as described in L below. 506 | 507 | =head3 Passing arguments 508 | 509 | The arguments passed to Tcl can be plain scalars, array references, code 510 | references, scalar references, or hash references. 511 | 512 | Plain scalars (strings and numbers) as just passed on unchanged to Tcl. 513 | 514 | Array references, where the first element is not a code reference, are converted into Tcl 515 | lists and passed on. The arrays can contain strings, numbers, and/or array 516 | references to form nested lists. 517 | 518 | Code references, and arrays where the first element is a code reference, are 519 | converted into special Tcl command names in the "::perl" Tcl namespace that 520 | will call back into the corresponding Perl function when invoked from Tcl. See 521 | L for a description how this is used. 522 | 523 | Scalar references are converted into special Tcl variables in the "::perl" Tcl 524 | namespace that is tied to the corresponding variable on the Perl side. 525 | Any changes to the variable on the Perl side will be reflected in the value 526 | on the Tcl side. Any changes to the variable on the Tcl side will be reflected 527 | in the value on the Perl side. 528 | 529 | Hash references are converted into special Tcl array variables in the "::perl" Tcl 530 | namespace that is tied to the corresponding hash on the Perl side. Any changes to 531 | the hash on the Perl side will be reflected in the array on the Tcl side. Any 532 | changes to the array on the Tcl side will be reflected in the hash on the Perl side. 533 | 534 | Anything else will just be converted to strings using the Perl rules for 535 | stringification and passed on to Tcl. 536 | 537 | =head3 Tracing 538 | 539 | If the boolean variable $Tkx::TRACE is set to a true value, then a 540 | trace of all commands passed to Tcl will be printed on STDERR. This 541 | variable is initialized from the C environment 542 | variable. The trace is useful for debugging and if you need to report 543 | errors to the Tcl/Tk maintainers in terms of Tcl statements. The trace 544 | lines are prefixed with: 545 | 546 | Tkx-$seq-$ts-$file-$line: 547 | 548 | where C<$seq> is a sequence number, C<$ts> is a timestamp in seconds since 549 | the first command was issued, and C<$file> and C<$line> indicate on which 550 | source line this call was triggered. 551 | 552 | 553 | =head2 Callbacks to Perl 554 | 555 | For Tcl APIs that require callbacks you can provide a reference to a 556 | Perl subroutine: 557 | 558 | Tkx::after(3000, sub { print "Hi" }); 559 | 560 | $button = $w->new_button( 561 | -text => 'Press Me', 562 | -command => \&foo, 563 | ); 564 | 565 | Alternately, you can provide an array reference containing a subroutine 566 | reference and a list of values to be passed back to the subroutine as 567 | arguments when it is invoked: 568 | 569 | Tkx::button(".b", -command => [\&Tkx::destroy, "."]); 570 | 571 | $button = $w->new_button( 572 | -text => 'Press Me', 573 | -command => [\&foo, 42], 574 | ); 575 | 576 | When using the array reference syntax, if the I element of the 577 | array (i.e. the first argument to the callback) is a Tkx::Ev() object 578 | the templates it contains will be expanded at the time of the callback. 579 | 580 | Tkx::bind(".", "", [ 581 | sub { print "$_[0]\n"; }, Tkx::Ev("%A") 582 | ]); 583 | 584 | $entry->configure(-validatecommand => [ 585 | \&check, Tkx::Ev('%P'), $entry, 586 | ]); 587 | 588 | The order of the arguments to the Perl callback code is as follows: 589 | 590 | =over 591 | 592 | =item 1 593 | 594 | The expanded results from Tkx::Ev(), if used. 595 | 596 | =item 2 597 | 598 | Any arguments that the command/function is called with from the Tcl 599 | side. For example, in callbacks to scrollbars Tcl provides values 600 | corresponding to the visible portion of a scrollable widget. Tcl 601 | arguments are passed regardless of the syntax used when specifying the 602 | callback. 603 | 604 | 605 | =item 3 606 | 607 | Any extra values provided when the callback defined; the values passed after 608 | the Tkx::Ev() object in the array. 609 | 610 | =back 611 | 612 | =head2 Widget handles 613 | 614 | The class C is used to wrap Tk widget paths. 615 | These objects stringify as the path they wrap. 616 | 617 | The following methods are provided: 618 | 619 | =over 620 | 621 | =item $w = Tkx::widget->new( $path ) 622 | 623 | This constructs a new widget handle for a given path. It is not a 624 | problem to have multiple handle objects to the same path or to create 625 | handles for paths that do not yet exist. 626 | 627 | =item $w->_data 628 | 629 | Returns a hash that can be used to keep instance specific data. This 630 | is useful for holding instance data for megawidgets. The data is 631 | attached to the underlying widget, so if you create another handle to 632 | the same widget it will return the same hash via its _data() method. 633 | 634 | The data hash is automatically destroyed when the corresponding widget 635 | is destroyed. 636 | 637 | =item $w->_parent 638 | 639 | Returns a handle for the parent widget. Returns C if there is 640 | no parent, which will only happen if $w is ".", the main window. 641 | 642 | =item $w->_kid( $name ) 643 | 644 | Returns a handle for a kid widget with the given name. The $name can 645 | contain dots to access grandkids. There is no check that a kid with 646 | the given name actually exists; which can be taken advantage of to construct 647 | names of Tk widgets to be created later. 648 | 649 | =item $w->_kids 650 | 651 | Returns all existing kids as widget objects. 652 | 653 | =item $w->_class( $class ) 654 | 655 | Sets the widget handle class for the current path. This will both 656 | change the class of the current handle and make sure later handles 657 | created for the path belong to the given class. The class should 658 | normally be a subclass of C. Overriding the class for a 659 | path is useful for implementing megawidgets. Kids of $w are not 660 | affected by this, unless the class overrides the C<_nclass> method. 661 | 662 | =item $w->_nclass 663 | 664 | This returns the default widget handle class that will be used for 665 | kids and parent. Subclasses might want to override this method. 666 | The default implementation always returns C. 667 | 668 | =item $w->_mpath( $method ) 669 | 670 | This method determine the Tk widget path that will be invoked for 671 | m_I method calls. The argument passed in is the method name 672 | without the C prefix. Megawidget classes might want to override 673 | this method. The default implementation always returns C<$w>. 674 | 675 | =item $new_w = $w->new_I( @args ) 676 | 677 | This creates a new I widget as a child of the current widget. It 678 | will call the I Tcl command and pass it a new unique subpath of 679 | the current path. The handle to the new widget is returned. Any 680 | double underscores in the name I is expanded as described in 681 | L above. 682 | 683 | Example: 684 | 685 | $w->new_label(-text => "Hello", -relief => "sunken"); 686 | 687 | The name selected for the child will be the first letter of the widget type; 688 | for the example above "l". If that name is not unique a number is 689 | appended to ensure uniqueness among the children. If a C<-name> argument is 690 | passed it is used as the name and then removed from the arglist passed on to 691 | Tcl. Example: 692 | 693 | $w->new_iwidgets__calendar(-name => "cal"); 694 | 695 | If a megawidget implementation class has be registered for I, 696 | then its C<_Populate> method is called instead of passing widget 697 | creation to Tcl. 698 | 699 | =item $w->m_I( @args ) 700 | 701 | This will invoke the I subcommand for the current widget. This 702 | is the same as: 703 | 704 | $func = "Tkx::$w"; 705 | &$func(expand("foo"), @args); 706 | 707 | where the expand() function expands underscores as described in 708 | L above. 709 | 710 | Example: 711 | 712 | $w->m_configure(-background => "red"); 713 | 714 | Subclasses might override the _mpath() method to have m_I forward 715 | the subcommand somewhere else than the current widget. 716 | 717 | =item $w->g_I( @args ) 718 | 719 | This will invoke the I Tcl command with the current widget as 720 | first argument. This is the same as: 721 | 722 | $func = "Tkx::foo"; 723 | &$func($w, @args); 724 | 725 | Any underscores in the name I are expanded as described in 726 | L above. 727 | 728 | Example: 729 | 730 | $w->g_pack_forget; 731 | 732 | =item $w->I( @args ) 733 | 734 | If the method does not start with "new_" or have a prefix of the form 735 | /^_/ or /^[a-zA-Z]_/, the call will just forward to the method "m_I" 736 | (described above). This is just a convenience for people that have 737 | grown tired of the "m_" prefix. 738 | 739 | The method names with prefix /^_/ and /^[a-zA-Z]_/ are reserved for 740 | future extensions to this API. 741 | 742 | =item Tkx::widget->_Mega( $widget, $class ) 743 | 744 | This register $class as the one implementing $widget widgets. See 745 | L. 746 | 747 | =back 748 | 749 | =head2 Subclassing Tk widgets 750 | 751 | You can't subclass a Tk widget in Perl, but you can emulate it by 752 | creating a megawidget. 753 | 754 | =head2 Megawidgets 755 | 756 | Megawidgets can be implemented in Perl and used by Tkx. To declare a 757 | megawidget make a Perl class like this one: 758 | 759 | package Foo; 760 | use base 'Tkx::widget'; 761 | Foo->_Mega("foo"); 762 | 763 | sub _Populate { 764 | my($class, $widget, $path, %opt) = @_; 765 | ... 766 | } 767 | 768 | The megawidget class should inherit from C and will 769 | register itself by calling the _Mega() class method. In the example 770 | above we tell Tkx that any "foo" widgets should be handled by the Perl 771 | class "Foo" instead of Tcl. When a new "foo" widget is instantiated 772 | with: 773 | 774 | $w->new_foo(-text => "Hi", -foo => 1); 775 | 776 | then the _Populate() class method of C is called. It will be 777 | passed the widget type to create, the full path to use as widget 778 | name and any options passed in. The widget name is passed in so that a 779 | single Perl class can implement multiple widget types. 780 | 781 | The _Populate() class should create a root object with the given $path 782 | as name and populate it with the internal widgets. Normally the root 783 | object will be forced to belong to the implementation class so that it 784 | can trap various method calls on it. By using the _class() method to 785 | set the class _Populate() can ensure that new handles to this megawidget 786 | also use this class. 787 | 788 | To make Tk aware of your megawidget you must register it by providing a 789 | C<-class> argument when creating the root widget. Doing this sets the 790 | value returned by the C<< $w->g_winfo_class >> method. It also makes it 791 | possible for your megawidget to have to have class-specific bindings and 792 | be configurable via Xdefaults and the options database. By convention 793 | class names start with a capital letter, so Tkx megawidgets should have 794 | names like "Tkx_Foo". If you don't register your megawidget with Tk, 795 | C will return the class of whatever you use as a root 796 | widget and your megawidget will be subject to the bindings for that 797 | class. 798 | 799 | Of the standard Tk widgets only frames support C<-class> which means 800 | that (practically speaking) Tkx megawidgets must use a frame as the root 801 | widget. The ttk widgets do support C<-class>, so you may be able to 802 | dispense with the frame if your megawidget is really just subclassing 803 | one of them. 804 | 805 | The implementation class can (and probably should) define an _mpath() 806 | method to delegate any m_I method calls to one of its subwidgets. 807 | It might want to override the m_configure() and m_cget() methods if it 808 | implements additional options or wants more control over delegation. The 809 | class C provide implementations of m_configure() and 810 | m_cget() that can be useful for controlling delegation of configuration 811 | options. 812 | 813 | Public methods defined by a megawidget should have an "m_" prefix. This 814 | serves two purposes: 815 | 816 | =over 817 | 818 | =item * 819 | 820 | It makes them behave the same as native widget methods. That is, they 821 | may be called either with or without the "m_" prefix as the user of the 822 | widget prefers. 823 | 824 | =item * 825 | 826 | It enables the megawidget to accept method delegation from another 827 | widget via the parent widget's _mpath() method. 828 | 829 | =back 830 | 831 | See L for a trivial example megawidget. 832 | 833 | =head1 ENVIRONMENT 834 | 835 | The C environment variable initialize the $Tkx::TRACE setting. 836 | 837 | The C environment variable can be set to override 838 | the Tcl/Tk used. 839 | 840 | =head1 SUPPORT 841 | 842 | If you have questions about this code or want to report bugs send a 843 | message to the mailing list. To subscribe to this 844 | list send an empty message to . 845 | 846 | =head1 LICENSE 847 | 848 | This library is free software; you can redistribute it and/or modify 849 | it under the same terms as Perl itself. 850 | 851 | Copyright 2005 ActiveState. All rights reserved. 852 | 853 | =head1 SEE ALSO 854 | 855 | L, L, L 856 | 857 | At L you find a very nice Tk tutorial that 858 | uses Tkx for the Perl examples. 859 | 860 | More information about Tcl/Tk can be found at L. 861 | Tk documentation is also available at L. 862 | 863 | The official source repository for Tkx is L. 864 | 865 | Alternative Tk bindings for Perl are described in L and L. 866 | 867 | ActivePerl bundles a Tcl interpreter and a selection of Tk widgets from 868 | ActiveTcl in order to provide a functional Tkx module out-of-box. 869 | L documents the version of Tcl/Tk you get and whats available in 870 | addition to the core commands. You need to set the C 871 | environment variable to make Tkx reference other Tcl installations. 872 | 873 | =cut 874 | -------------------------------------------------------------------------------- /lib/Tkx/Handy.pm: -------------------------------------------------------------------------------- 1 | package Tkx::Handy; 2 | 3 | # Experimental module that populates the Tkx::widget with 4 | # various convenience methods. 5 | 6 | use strict; 7 | 8 | package Tkx::widget; 9 | 10 | # versions of the geometry methods that return $self 11 | for (qw(grid pack place)) { 12 | my $m = "g_$_"; 13 | no strict 'refs'; 14 | *{"c_$_"} = sub { 15 | my $self = shift; 16 | $self->$m(@_); 17 | $self; 18 | }; 19 | } 20 | 21 | sub c_messageBox { 22 | my $self = shift; 23 | return Tkx::tk___messageBox(-parent => $self, @_); 24 | } 25 | 26 | sub c_getOpenFile { 27 | my $self = shift; 28 | return Tkx::tk___getOpenFile(-parent => $self, @_); 29 | } 30 | 31 | sub c_getSaveFile { 32 | my $self = shift; 33 | return Tkx::tk___getSaveFile(-parent => $self, @_); 34 | } 35 | 36 | sub c_chooseColor { 37 | my $self = shift; 38 | return Tkx::tk___chooseColor(-parent => $self, @_); 39 | } 40 | 41 | sub c_chooseDirectory { 42 | my $self = shift; 43 | return Tkx::tk___chooseDirectory(-parent => $self, @_); 44 | } 45 | 46 | sub c_bell { 47 | my $self = shift; 48 | Tkx::bell(-displayof => $self, @_); 49 | } 50 | 51 | sub c_children { 52 | my $self = shift; 53 | croak("c_children must be called in list context") 54 | unless wantarray; 55 | return map { $self->_nclass->new($_) } 56 | Tkx::SplitList($self->g_winfo_children); 57 | } 58 | 59 | 1; 60 | -------------------------------------------------------------------------------- /lib/Tkx/LabEntry.pm: -------------------------------------------------------------------------------- 1 | package Tkx::LabEntry; 2 | 3 | use base qw(Tkx::widget Tkx::MegaConfig); 4 | 5 | __PACKAGE__->_Mega("tkx_LabEntry"); 6 | __PACKAGE__->_Config( 7 | -label => [[".lab" => "-text"]], 8 | ); 9 | 10 | sub _Populate { 11 | my($class, $widget, $path, %opt) = @_; 12 | 13 | my $self = $class->new($path)->_parent->new_frame(-name => $path, -class => "Tkx_LabEntry"); 14 | $self->_class($class); 15 | 16 | $self->new_label(-name => "lab", -text => delete $opt{-label})->g_pack(-side => "left"); 17 | $self->new_entry(-name => "e", %opt)->g_pack(-side => "left", -fill => "both", -expand => 1); 18 | 19 | $self; 20 | } 21 | 22 | sub _mpath { 23 | my $self = shift; 24 | "$self.e"; 25 | } 26 | 27 | 1; 28 | 29 | =head1 NAME 30 | 31 | Tkx::LabEntry - Labeled entry widget 32 | 33 | =head1 SYNOPSIS 34 | 35 | use Tkx; 36 | use Tkx::LabEntry; 37 | 38 | my $mw = Tkx::widget->new("."); 39 | 40 | my $e = $mw->new_tkx_LabEntry(-label => "Name"); 41 | $e->g_pack; 42 | 43 | my $b = $mw->new_button( 44 | -text => "Done", 45 | -command => sub { 46 | print $e->get, "\n"; 47 | $mw->g_destroy; 48 | }, 49 | ); 50 | $b->g_pack; 51 | 52 | Tkx::MainLoop(); 53 | 54 | =head1 DESCRIPTION 55 | 56 | The C module implements a trivial megawidget. Its main 57 | purpose is to demonstrate how to use the C baseclass. 58 | 59 | Once the C module has been loaded, then its widgets 60 | can be constructed in the normal way using the C name. 61 | Besides having a label (whose text can be accessed with the C<-label> 62 | configuration option), these widgets behave exactly like an C 63 | would. 64 | 65 | =head1 LICENSE 66 | 67 | This library is free software; you can redistribute it and/or modify 68 | it under the same terms as Perl itself. 69 | 70 | Copyright 2005 ActiveState. All rights reserved. 71 | 72 | =head1 SEE ALSO 73 | 74 | The source code of Tkx::LabEntry. 75 | 76 | L, L 77 | -------------------------------------------------------------------------------- /lib/Tkx/MegaConfig.pm: -------------------------------------------------------------------------------- 1 | package Tkx::MegaConfig; 2 | 3 | use strict; 4 | our $VERSION = "1.07"; 5 | 6 | my %spec; 7 | 8 | sub _Config { 9 | my $class = shift; 10 | while (@_) { 11 | my($opt, $spec) = splice(@_, 0, 2); 12 | $spec{$class}{$opt} = $spec; 13 | } 14 | } 15 | 16 | sub m_configure { 17 | my $self = shift; 18 | my @rest; 19 | while (@_) { 20 | my($opt, $val) = splice(@_, 0, 2); 21 | my $spec = $spec{ref($self)}{$opt} || $spec{ref($self)}{DEFAULT}; 22 | unless ($spec) { 23 | push(@rest, $opt => $val); 24 | next; 25 | } 26 | 27 | my $where = $spec->[0]; 28 | my @where_args; 29 | if (ref($where) eq "ARRAY") { 30 | ($where, @where_args) = @$where; 31 | } 32 | 33 | if ($where =~ s/^\.//) { 34 | my $fwd_opt = $where_args[0] || $opt; 35 | if ($where eq "") { 36 | $self->Tkx::widget::m_configure($fwd_opt, $val); 37 | next; 38 | } 39 | if ($where eq "*") { 40 | for my $kid ($self->_kids) { 41 | $kid->m_configure($fwd_opt, $val); 42 | } 43 | next; 44 | } 45 | $self->_kid($where)->m_configure($fwd_opt, $val); 46 | next; 47 | } 48 | 49 | if ($where eq "METHOD") { 50 | my $method = $where_args[0] || "_config_" . substr($opt, 1); 51 | $self->$method($val); 52 | next; 53 | } 54 | 55 | if ($where eq "PASSIVE") { 56 | $self->_data->{$opt} = $val; 57 | next; 58 | } 59 | 60 | die; 61 | } 62 | 63 | $self->Tkx::widget::m_configure(@rest) if @rest; # XXX want NEXT instead 64 | } 65 | 66 | sub m_cget { 67 | my($self, $opt) = @_; 68 | my $spec = $spec{ref($self)}{$opt} || $spec{ref($self)}{DEFAULT}; 69 | return $self->Tkx::widget::m_cget($opt) unless $spec; # XXX want NEXT instead 70 | 71 | my $where = $spec->[0]; 72 | my @where_args; 73 | if (ref($where) eq "ARRAY") { 74 | ($where, @where_args) = @$where; 75 | } 76 | 77 | if ($where =~ s/^\.//) { 78 | my $fwd_opt = $where_args[0] || $opt; 79 | return $self->Tkx::widget::m_cget($fwd_opt) if $where eq ""; 80 | return ($self->_kids)[0]->m_cget($fwd_opt) if $where eq "*"; 81 | return $self->_kid($where)->m_cget($fwd_opt); 82 | } 83 | 84 | if ($where eq "METHOD") { 85 | my $method = $where_args[0] || "_config_" .substr($opt, 1); 86 | return $self->$method; 87 | } 88 | 89 | if ($where eq "PASSIVE") { 90 | return $self->_data->{$opt}; 91 | } 92 | 93 | die; 94 | } 95 | 96 | 1; 97 | 98 | __END__ 99 | 100 | =head1 NAME 101 | 102 | Tkx::MegaConfig - handle configuration options for megawidgets 103 | 104 | =head1 SYNOPSIS 105 | 106 | package Foo; 107 | use base qw(Tkx::widget Tkx::MegaConfig); 108 | 109 | __PACKAGE__->_Mega("foo"); 110 | __PACKAGE__->_Config( 111 | -option => [$where, $dbName, $dbClass, $default], 112 | ); 113 | 114 | =head1 DESCRIPTION 115 | 116 | The C class provide implementations of m_configure() 117 | and m_cget() that can handle configuration options for megawidgets. 118 | How these methods behave is set up by calling the _Config() class 119 | method. The _Config() method takes a set option/option spec pairs as 120 | argument. 121 | 122 | An option argument is either the name of an option with leading '-' 123 | or the string 'DEFAULT' if this spec applies to all option with no 124 | explicit spec. 125 | 126 | If there is no 'DEFAULT' then unmatched options are applied directly 127 | to the megawidget root itself. This is the same behaviour you get if 128 | you specify: 129 | 130 | __PACKAGE__->_Config( 131 | ... 132 | DEFAULT => ['.'], 133 | ); 134 | 135 | The option spec should be an array reference. The first element of 136 | the array ($where) describe how this option is handled. Some $where 137 | specs take arguments. If you need to provide argument replace $where 138 | with an array reference containing [$where, @args]. The rest of the 139 | option spec specify names and default for the options database, but is 140 | currently ignored (feature unimplemented). 141 | 142 | The following $where specs are understood: 143 | 144 | =over 145 | 146 | =item .foo 147 | 148 | Delegate the given configuration option to the "foo" kid of the mega 149 | widget root. The name "." can be used to delegate to the megawidget 150 | root itself. The name ".*" can be used to delegate to all kids of the 151 | megawidget root. 152 | 153 | An argument can be given to delegate using a different 154 | configuration name on the "foo" widget. Examples: 155 | 156 | -foo => [".inner"], # forward -foo 157 | -bg => [[".", "-background]], # alias 158 | -bg2 => [[".inner", "-background]], # forward as -background 159 | -background => [".*"] # forward --background to kids 160 | 161 | =item METHOD 162 | 163 | Call the _config_I method. For m_cget() no arguments are given, 164 | while for m_configure() the new value is passed. If an extra $where 165 | argument is given it will be the method called instead of 166 | _config_I. Examples: 167 | 168 | __PACKAGE__->_Config( 169 | -foo => ["METHOD"]; 170 | -bar => [["METHOD", "bar"]], 171 | } 172 | 173 | sub _config_foo { 174 | my $self = shift; 175 | return "foo" unless @_; 176 | print "Ignoring setting configuration option -foo to '$_[0]'"; 177 | } 178 | 179 | sub handle_bar { 180 | my $self = shift; 181 | return "bar" unless @_; 182 | print "Ignoring setting configuration option -bar to '$_[0]'"; 183 | } 184 | 185 | =item PASSIVE 186 | 187 | Store or retrieve option from $self->_data. 188 | 189 | =back 190 | 191 | =head1 LICENSE 192 | 193 | This library is free software; you can redistribute it and/or modify 194 | it under the same terms as Perl itself. 195 | 196 | Copyright 2005 ActiveState. All rights reserved. 197 | 198 | =head1 SEE ALSO 199 | 200 | L, L 201 | 202 | Inspiration for this module comes from L. 203 | -------------------------------------------------------------------------------- /lib/Tkx/Tutorial.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | Tkx::Tutorial - How to use Tkx 4 | 5 | =head1 DESCRIPTION 6 | 7 | I is a toolkit for creating applications with 8 | graphical interfaces on Windows, Mac OS X and X11. The Tk toolkit 9 | is native to the I programming language, but its ease of use and 10 | cross-platform availability has made it the GUI toolkit of choice for 11 | many other dynamic languages. 12 | 13 | I is a Perl module that makes the Tk toolkit available to Perl 14 | programs. By loading the Tkx module Perl programs can create 15 | windows and fill them with text, images, buttons and other controls 16 | that make up the user interface of the application. 17 | 18 | =head2 Hello World 19 | 20 | Let's start with the mandatory exercise of creating an application 21 | that greats the world. We'll make the application window contain a 22 | single button which will shut down the application if clicked. The 23 | code to make this happen is: 24 | 25 | use Tkx; 26 | 27 | Tkx::button(".b", 28 | -text => "Hello, world", 29 | -command => sub { Tkx::destroy("."); }, 30 | ); 31 | Tkx::pack(".b"); 32 | 33 | Tkx::MainLoop() 34 | 35 | Save this to a file called F and then run C 36 | to start the application. A window with the text "Hello, world" 37 | should appear on your screen. Let's look at what this code is doing. 38 | 39 | After the Tkx module has been loaded by the C statement, the 40 | application will show an empty window called ".". We create a I