summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 15:05:13 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 15:05:13 +0000
commit9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c (patch)
treeee28de37fe0de6137d535fee2e64ecafaffefb91 /Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
parent73b942cfb4ccf168f9c2b7f20a289b06f1f54a4b (diff)
New tlperl part II
git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl315
1 files changed, 315 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
new file mode 100644
index 00000000000..2152465c462
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl
@@ -0,0 +1,315 @@
+# All widgets at a glance.
+# -*- perl -*-
+
+#
+# $Id: $
+# Author: Slaven Rezic
+#
+# Copyright (C) 2007 Slaven Rezic. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+# Mail: slaven@rezic.de
+# WWW: http://www.rezic.de/eserte/
+#
+
+use strict;
+use Tk::Pane;
+
+use vars qw/$TOP $MW $DEMO_FILE/;
+
+sub all {
+ my($demo) = @_;
+ $TOP = $MW->WidgetDemo(
+ -name => $demo,
+ -text => <<"EOF",
+All Tk widgets at a glance in one Toplevel.
+
+The left column contains the class name, the middle column a sample representation of this widget, and the right column a button to the widget's Pod (requires Tk::Pod from CPAN).
+
+There are two sections: core Tk modules which come with stock Tk $Tk::VERSION and a sample of non-standard Tk modules from CPAN. The non-standard modules are only displayed if installed, otherwise they are skipped.
+EOF
+ -geometry_manager => 'pack',
+ -title => 'All widgets',
+ -iconname => 'All widgets',
+ );
+
+ my($px_w, $px_h) = (400, 200);
+ my($txt_w, $txt_h) = (40, 6);
+ my @px_geom = (-width => $px_w, -height => $px_h);
+ my @txt_geom = (-height => $txt_h, -width => $txt_w);
+ my $insert_txt = sub {
+ my $w = shift;
+ if ($w->can("Subwidget") && $w->Subwidget("scrolled")) {
+ $w = $w->Subwidget("scrolled");
+ }
+ $w->insert("end", "This is some sample text for the widget class " . $w->Class);
+ };
+ my $insert_lb = sub {
+ shift->insert("end", sort grep { !m{^/} } keys %INC);
+ };
+
+ my $f = $TOP->Scrolled('Pane',
+ qw(-width 900 -height 500), # XXX check for screensize!
+ -gridded => 'xy',
+ -scrollbars => 'osoe',
+ -sticky => 'news',
+ )->pack(qw(-expand 1 -fill both));
+ $f = $f->Subwidget("scrolled");
+ my @w_def = (
+ {separator => 'Core Tk modules'},
+
+ 'Adjuster',
+ # XXX 'Balloon',
+ {class => 'BrowseEntry', action => $insert_lb},
+ {class => 'Button', w_args => [-text => 'This is a button']},
+ {class => 'Canvas', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->createLine(rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h),
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'Checkbutton', w_args => [-text => 'This is a checkbutton']},
+ {class => 'ColorEditor', dialog => 1},
+ {class => 'Dialog', dialog => 1},
+ {class => 'DialogBox', dialog => 1},
+ {class => 'DirTree', scrolled => 'oe'},
+ {class => 'Dirlist', scrolled => 'oe'},
+ {class => 'Entry', w_args => [-width => 20], action => $insert_txt},
+ {class => 'FBox', dialog => 1},
+ {class => 'FileDialog', dialog => 1},
+ {class => 'FileSelect', dialog => 1},
+ {class => 'Frame', w_args => [@px_geom, -bg => 'red']},
+ {class => 'Label', w_args => [-text => 'This is a label']},
+ {class => 'Labelframe', w_args => [@px_geom, -bg => 'red', -text => 'Title of frame']},
+ {class => 'Listbox', action => $insert_lb, scrolled => 'oe'},
+ # XXX Menubar?
+ {class => 'Menubutton', w_args => [-text => 'Menu button']},#XXX menuitems
+ {class => 'Message', w_args => [-text => 'This is a message widget']},
+ {class => 'MsgBox', dialog => 1},
+ {class => 'NoteBook', action => sub {
+ my $w = shift;
+ for (1..5) {
+ my $p = $w->add("page$_", -label => "Page $_");
+ $p->Label(-text => "A label in the page $_")->pack;
+ }
+ },
+ },
+ # XXX Pane
+ {class => 'Radiobutton', w_args => [-text => 'This is a radiobutton']},
+ {class => 'ROText', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'Scale', w_args => [-orient => 'horiz', -from => 0, -showvalue => 1, -to => 100]},
+ {class => 'Scrollbar', w_args => [-orient => 'horiz']},
+ {class => 'Spinbox', w_args => [-from => 0, -to => 100]},
+ {class => 'Text', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # disabled because of warning loop, line 189 ... {class => 'TextEdit', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ {class => 'TextList', w_args => [@txt_geom], action => $insert_lb, scrolled => 'oe'},
+ {class => 'TextUndo', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
+ # XXX Toplevel
+ qw(FloatEntry HList IconList InputO
+ LabEntry LabFrame LabRadio NBFrame Optionmenu
+ Panedwindow ProgressBar TList Table
+ Tiler TixGrid Tree
+ ),
+
+ {separator => 'Installed non-core Tk modules'},
+
+ qw(Date DateEntry NumEntry NumEntryPlain
+ PathEntry
+ ),
+ {class => 'FireButton', action => sub {
+ my $w = shift;
+ my $text = 'This is a firebutton 0';
+ $w->configure(-textvariable => \$text,
+ -command => sub {
+ $text =~ s{(\d+)}{$1+1}e;
+ },
+ );
+ },
+ },
+ {class => 'TFrame', w_args => [@px_geom, -bg => 'red',
+ -label => [ -text => 'Title' ],
+ -borderwidth => 2,
+ -relief => 'groove',
+ ],
+ },
+ {class => 'ToolBar', w_args => [qw/-movable 1 -side top
+ -indicatorcolor blue/],
+ action => sub {
+ my $tb = shift;
+ $tb->ToolButton (-text => 'Button',
+ -tip => 'tool tip',
+ -command => sub { print "hi\n" });
+ $tb->ToolLabel (-text => 'A Label');
+ $tb->Label (-text => 'Another Label');
+ $tb->ToolLabEntry(-label => 'A LabEntry',
+ -labelPack => [-side => "left",
+ -anchor => "w"]);
+ },
+ },
+ {class => 'HistEntry', action => sub {
+ my $w = shift;
+ $w->bind("<Return>" => sub {
+ # do something with value, and then:
+ $w->historyAdd;
+ $w->delete('0', 'end');
+ });
+ },
+ },
+ {class => 'MListbox', w_args => [-columns=>[[-text=>'Heading1',
+ -sortable=>0],
+ [-text=>'Heading2']]],
+ action => sub {
+ my $w = shift;
+ $w->insert("end", [qw(Cell11 Cell12)], [qw(Cell21 Cell22)]);
+ },
+ },
+ {class => 'Cloth', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..50) {
+ $w->Line(-coords => [rand($px_w),rand($px_h),
+ rand($px_w),rand($px_h)],
+ -fill => $colors[rand @colors],
+ -width => rand(4)+1,
+ );
+ }
+ },
+ },
+ {class => 'DirSelect', dialog => 1},
+ {class => 'ExecuteCommand', w_args => [@txt_geom]},
+ {class => 'FontDialog', dialog => 1},
+ {class => 'JBrowseEntry', action => $insert_lb},
+ {class => 'JFileDialog', dialog => 1},
+ {class => 'More', w_args => [@txt_geom], action => sub {
+ shift->Load($DEMO_FILE),
+ }, scrolled => 'oe'},
+ {class => 'ObjEditor', w_args => [@txt_geom, -caller => { dummy => 'object'}]},
+ {class => 'ObjScanner', w_args => [@txt_geom, -caller => $TOP]},
+ {class => 'PodText', require => 'Tk::Pod::Text',
+ w_args => [@txt_geom, -file => 'Tk']},
+ {class => 'XMLViewer', w_args => [@txt_geom], action => sub {
+ shift->insertXML(-text => "<?xml version='1.0' ?><a><bla /><foo>bar</foo></a>");
+ }, scrolled => 'oe'},
+ {class => 'Zinc', w_args => [@px_geom],
+ action => sub {
+ my($w) = @_;
+ my @colors = qw(red green blue orange black white);
+ for (1..20) {
+ $w->add('curve', 1, [map { (rand($px_w),rand($px_h)) } (1..5)],
+ -relief => 'roundgroove',
+ -filled => 1,
+ -fillcolor => $colors[rand @colors],
+ );
+ }
+ },
+ },
+ );
+ $f->grid('columnconfigure', $_, -pad => 3, -weight => 1) for (0 .. 1);
+ $f->grid('rowconfigure', $_, -pad => 3, -weight => 1) for (0 .. $#w_def);
+ my $row = -1;
+ for my $w_def (@w_def) {
+ my($separator, $text, $class, @w_args, $action, $scrolled, $dialog, $dialog_action);
+ if (UNIVERSAL::isa($w_def, "HASH")) {
+ $separator = $w_def->{separator};
+ if (!$separator) {
+ $class = $w_def->{class};
+ $text = $w_def->{text} || $class;
+ @w_args = @{ $w_def->{w_args} || [] };
+ $action = $w_def->{action};
+ $scrolled = $w_def->{scrolled};
+ $dialog = $w_def->{dialog};
+ $dialog_action = $w_def->{dialog_action};
+ if ($dialog && !$dialog_action) {
+ $dialog_action = sub { shift->Show };
+ }
+ if ($w_def->{require}) {
+ eval 'require ' . $w_def->{require};
+ if ($@) {
+ warn $@;
+ next;
+ }
+ }
+ }
+ } else {
+ ($text, $class) = ($w_def, $w_def);
+ }
+
+ $row++;
+
+ if ($separator) {
+ $f->Label(-text => $separator,
+ -font => 'Helvetica 18',
+ -pady => 5,
+ )->grid(-row => $row,
+ -column => 0,
+ -columnspan => 3,
+ );
+ next;
+ }
+
+ my $bgcolor = $row%2==0 ? '#c0c0c0' : '#a0a0a0';
+ my $ff = $f->Frame(-background => $bgcolor,
+ )->grid(-row => $row,
+ -column => 1,
+ -sticky => 'news',
+ );
+ my $cw = eval {
+ if ($dialog) {
+ $ff->$class(@w_args)->destroy; # just load it...
+ $ff->Button(-text => 'Open ' . $class,
+ -command => sub {
+ # There are some buggy dialogs which display
+ # already without calling a Show method (e.g. Tk::FBox),
+ # so create here
+ my $d = $ff->$class(@w_args);
+ $dialog_action->($d) if $dialog_action;
+ })->pack;
+ } else {
+ if ($scrolled) {
+ $ff->Scrolled($class, @w_args, -scrollbars => $scrolled)->pack;
+ } else {
+ $ff->$class(@w_args)->pack;
+ }
+ }
+ };
+ if ($@ || !$cw) {
+ warn $@;
+ $row--;
+ $ff->destroy;
+ next;
+ }
+
+ $action->($cw) if $action && !$dialog;
+
+ $f->Label(-text => $text,
+ -background => $bgcolor,
+ -anchor => 'w',
+ )->grid(-row => $row,
+ -column => 0,
+ -sticky => "news",
+ );
+
+ $f->Button(-text => 'Pod',
+ -background => $bgcolor,
+ -command => sub {
+ require Tk::Pod;
+ $TOP->Pod(-file => 'Tk::' . $class);
+ },
+ )->grid(-row => $row,
+ -column => 2,
+ -sticky => 'news',
+ );
+ }
+ # $TOP->WidgetDump;
+}
+
+__END__