From 9fc19ef8e2dcd8bcf6a1d034b95c1de2b88e485c Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 15:05:13 +0000 Subject: New tlperl part II git-svn-id: svn://tug.org/texlive/trunk@21424 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl | 315 ++++++++++++++++++++++++ 1 file changed, 315 insertions(+) create mode 100644 Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl (limited to 'Master/tlpkg/tlperl/lib/Tk/demos/widtrib/all.pl') 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("" => 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 => "bar"); + }, 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__ -- cgit v1.2.3