"Fossies" - the Fresh Open Source Software Archive

Member "Tk-804.036/demos/demos/widtrib/all.pl" (15 Nov 2013, 10318 Bytes) of package /linux/misc/Tk-804.036.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # All widgets at a glance.
    2 # -*- perl -*-
    3 
    4 #
    5 # $Id: $
    6 # Author: Slaven Rezic
    7 #
    8 # Copyright (C) 2007 Slaven Rezic. All rights reserved.
    9 # This program is free software; you can redistribute it and/or
   10 # modify it under the same terms as Perl itself.
   11 #
   12 # Mail: slaven@rezic.de
   13 # WWW:  http://www.rezic.de/eserte/
   14 #
   15 
   16 use strict;
   17 use Tk::Pane;
   18 
   19 use vars qw/$TOP $MW $DEMO_FILE/;
   20 
   21 sub all {
   22     my($demo) = @_;
   23     $TOP = $MW->WidgetDemo(
   24     -name         => $demo,
   25     -text         => <<"EOF",
   26 All Tk widgets at a glance in one Toplevel.
   27 
   28 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).
   29 
   30 There are three sections: core Tk modules and Tix 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.
   31 EOF
   32     -geometry_manager => 'pack',
   33     -title        => 'All widgets',
   34     -iconname     => 'All widgets',
   35     );
   36 
   37     my($px_w, $px_h) = (400, 200);
   38     my($txt_w, $txt_h) = (40, 6);
   39     my @px_geom  = (-width => $px_w, -height => $px_h);
   40     my @txt_geom = (-height => $txt_h, -width => $txt_w);
   41     my $insert_txt = sub {
   42     my $w = shift;
   43     if ($w->can("Subwidget") && $w->Subwidget("scrolled")) {
   44         $w = $w->Subwidget("scrolled");
   45     }
   46     $w->insert("end", "This is some sample text for the widget class " . $w->Class);
   47     };
   48     my $insert_lb = sub {
   49     shift->insert("end", sort grep { !m{^/} } keys %INC);
   50     };
   51 
   52     my $f = $TOP->Scrolled('Pane',
   53                qw(-width 900 -height 500), # XXX check for screensize!
   54                -gridded => 'xy',
   55                -scrollbars => 'osoe',
   56                -sticky => 'news',
   57               )->pack(qw(-expand 1 -fill both));
   58     $f = $f->Subwidget("scrolled");
   59     my @w_def = (
   60          {separator => 'Core Tk modules'},
   61 
   62          'Adjuster',
   63          # XXX 'Balloon',
   64          {class => 'BrowseEntry', action => $insert_lb},
   65          {class => 'Button', w_args => [-text => 'This is a button']},
   66          {class => 'Canvas', w_args => [@px_geom],
   67           action => sub {
   68               my($w) = @_;
   69               my @colors = qw(red green blue orange black white);
   70               for (1..50) {
   71               $w->createLine(rand($px_w),rand($px_h),
   72                      rand($px_w),rand($px_h),
   73                      -fill => $colors[rand @colors],
   74                      -width => rand(4)+1,
   75                     );
   76               }
   77               $w->configure(-scrollregion => [$w->bbox("all")]);
   78           },
   79          },
   80          {class => 'Checkbutton', w_args => [-text => 'This is a checkbutton']},
   81          {class => 'ColorEditor', dialog => 1},
   82          {class => 'Dialog', dialog => 1},
   83          {class => 'DialogBox', dialog => 1},
   84          {class => 'DirTree', scrolled => 'oe'},
   85          {class => 'Dirlist', scrolled => 'oe'},
   86          {class => 'Entry', w_args => [-width => 20], action => $insert_txt},
   87          {class => 'FBox', dialog => 1},
   88          {class => 'FileDialog', dialog => 1},
   89          {class => 'FileSelect', dialog => 1},
   90          {class => 'Frame', w_args => [@px_geom, -bg => 'red']},
   91          {class => 'Label', w_args => [-text => 'This is a label']},
   92          {class => 'Labelframe', w_args => [@px_geom, -bg => 'red', -text => 'Title of frame']},
   93          {class => 'Listbox', action => $insert_lb, scrolled => 'oe'},
   94          # XXX Menubar?
   95          {class => 'Menubutton', w_args => [-text => 'Menu button']},#XXX menuitems
   96          {class => 'Message', w_args => [-text => 'This is a message widget']},
   97          {class => 'MsgBox', dialog => 1},
   98          {class => 'NoteBook', action => sub {
   99               my $w = shift;
  100               for (1..5) {
  101               my $p = $w->add("page$_", -label => "Page $_");
  102               $p->Label(-text => "A label in the page $_")->pack;
  103               }
  104           },
  105          },
  106          # XXX Pane
  107          {class => 'Radiobutton', w_args => [-text => 'This is a radiobutton']},
  108          {class => 'ROText', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
  109          {class => 'Scale', w_args => [-orient => 'horiz', -from => 0, -showvalue => 1, -to => 100]},
  110          {class => 'Scrollbar', w_args => [-orient => 'horiz']},
  111          {class => 'Spinbox', w_args => [-from => 0, -to => 100]},
  112          {class => 'Text', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
  113          # disabled because of warning loop, line 189 ... {class => 'TextEdit', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
  114          {class => 'TextList', w_args => [@txt_geom], action => $insert_lb, scrolled => 'oe'},
  115          {class => 'TextUndo', w_args => [@txt_geom], action => $insert_txt, scrolled => 'oe'},
  116          # XXX Toplevel
  117 
  118          {separator => 'Tix modules'},
  119 
  120          'FloatEntry',
  121          {class => 'HList', action => sub {
  122               my $w = shift;
  123               my $b = $w->Balloon;
  124               my %binfo;
  125               for my $path ('1', '1.1', '1.2', '2', '2.1') {
  126               $w->add($path, -text => $path);
  127               $binfo{$path} = "BalloonInfo: $path";
  128               }
  129               $b->attach($w, -balloonposition => "mouse", -msg => \%binfo);
  130           },
  131          },
  132          qw(IconList InputO
  133             LabEntry LabFrame LabRadio NBFrame Optionmenu
  134             Panedwindow ProgressBar TList Table
  135             Tiler TixGrid Tree
  136           ),
  137 
  138          {separator => 'Installed non-core Tk modules'},
  139 
  140          qw(Date DateEntry NumEntry NumEntryPlain
  141             PathEntry
  142           ),
  143          {class => 'FireButton', action => sub {
  144               my $w = shift;
  145               my $text = 'This is a firebutton 0';
  146               $w->configure(-textvariable => \$text,
  147                     -command => sub {
  148                     $text =~ s{(\d+)}{$1+1}e;
  149                     },
  150                    );
  151           },
  152          },
  153          {class => 'TFrame', w_args => [@px_geom, -bg => 'red',
  154                         -label => [ -text => 'Title' ],
  155                         -borderwidth => 2,
  156                         -relief => 'groove',
  157                            ],
  158          },
  159          {class => 'ToolBar', w_args => [qw/-movable 1 -side top
  160                             -indicatorcolor blue/],
  161           action => sub {
  162               my $tb = shift;
  163               $tb->ToolButton  (-text  => 'Button',
  164                     -tip   => 'tool tip',
  165                     -command => sub { print "hi\n" });
  166               $tb->ToolLabel   (-text  => 'A Label');
  167               $tb->Label       (-text  => 'Another Label');
  168               $tb->ToolLabEntry(-label => 'A LabEntry',
  169                     -labelPack => [-side => "left",
  170                                -anchor => "w"]);
  171           },
  172          },
  173          {class => 'HistEntry', action => sub {
  174               my $w = shift;
  175               $w->bind("<Return>" => sub {
  176                    # do something with value, and then:
  177                    $w->historyAdd;
  178                    $w->delete('0', 'end');
  179                    });
  180           },
  181          },
  182          {class => 'MListbox', w_args => [-columns=>[[-text=>'Heading1',
  183                                   -sortable=>0],
  184                                  [-text=>'Heading2']]],
  185           action => sub {
  186               my $w = shift;
  187               $w->insert("end", [qw(Cell11 Cell12)], [qw(Cell21 Cell22)]);
  188           },
  189          },
  190          {class => 'Cloth', w_args => [@px_geom],
  191           action => sub {
  192               my($w) = @_;
  193               my @colors = qw(red green blue orange black white);
  194               for (1..50) {
  195               $w->Line(-coords => [rand($px_w),rand($px_h),
  196                            rand($px_w),rand($px_h)],
  197                    -fill => $colors[rand @colors],
  198                    -width => rand(4)+1,
  199                   );
  200               }
  201           },
  202          },
  203          {class => 'DirSelect', dialog => 1},
  204          {class => 'ExecuteCommand', w_args => [@txt_geom]},
  205          {class => 'FontDialog', dialog => 1},
  206          {class => 'JBrowseEntry', action => $insert_lb},
  207          {class => 'JFileDialog', dialog => 1},
  208          {class => 'More', w_args => [@txt_geom], action => sub {
  209               shift->Load($DEMO_FILE),
  210           }, scrolled => 'oe'},
  211          {class => 'ObjEditor', w_args => [@txt_geom, -caller => { dummy => 'object'}]},
  212          {class => 'ObjScanner', w_args => [@txt_geom, -caller => $TOP]},
  213          {class => 'PodText', require => 'Tk::Pod::Text',
  214           w_args => [@txt_geom, -file => 'Tk']},
  215          {class => 'XMLViewer', w_args => [@txt_geom], action => sub {
  216               shift->insertXML(-text => "<?xml version='1.0' ?><a><bla /><foo>bar</foo></a>");
  217           }, scrolled => 'oe'},
  218          {class => 'Zinc', w_args => [@px_geom],
  219           action => sub {
  220               my($w) = @_;
  221               my @colors = qw(red green blue orange black white);
  222               for (1..20) {
  223               $w->add('curve', 1, [map { (rand($px_w),rand($px_h)) } (1..5)],
  224                   -relief => 'roundgroove',
  225                   -filled => 1,
  226                   -fillcolor => $colors[rand @colors],
  227                  );
  228               }
  229           },
  230          },
  231         );
  232     $f->grid('columnconfigure', $_, -pad => 3, -weight => 1) for (0 .. 1);
  233     $f->grid('rowconfigure', $_, -pad => 3, -weight => 1) for (0 .. $#w_def);
  234     my $row = -1;
  235     for my $w_def (@w_def) {
  236     my($separator, $text, $class, @w_args, $action, $scrolled, $dialog, $dialog_action);
  237     if (UNIVERSAL::isa($w_def, "HASH")) {
  238         $separator = $w_def->{separator};
  239         if (!$separator) {
  240         $class    = $w_def->{class};
  241         $text     = $w_def->{text} || $class;
  242         @w_args   = @{ $w_def->{w_args} || [] };
  243         $action   = $w_def->{action};
  244         $scrolled = $w_def->{scrolled};
  245         $dialog   = $w_def->{dialog};
  246         $dialog_action = $w_def->{dialog_action};
  247         if ($dialog && !$dialog_action) {
  248             $dialog_action = sub { shift->Show };
  249         }
  250         if ($w_def->{require}) {
  251             eval 'require ' . $w_def->{require};
  252             if ($@) {
  253             warn $@;
  254             next;
  255             }
  256         }
  257         }
  258     } else {
  259         ($text, $class) = ($w_def, $w_def);
  260     }
  261 
  262     $row++;
  263 
  264     if ($separator) {
  265         $f->Label(-text => $separator,
  266               -font => 'Helvetica 18',
  267               -pady => 5,
  268              )->grid(-row => $row,
  269                  -column => 0,
  270                  -columnspan => 3,
  271                 );
  272         next;
  273     }
  274 
  275     my $bgcolor = $row%2==0 ? '#c0c0c0' : '#a0a0a0';
  276     my $ff = $f->Frame(-background => $bgcolor,
  277                )->grid(-row => $row,
  278                    -column => 1,
  279                    -sticky => 'news',
  280                   );
  281     my $cw = eval {
  282         if ($dialog) {
  283         $ff->$class(@w_args)->destroy; # just load it...
  284         $ff->Button(-text => 'Open ' . $class,
  285                 -command => sub {
  286                 # There are some buggy dialogs which display
  287                 # already without calling a Show method (e.g. Tk::FBox),
  288                 # so create here
  289                 my $d = $ff->$class(@w_args);
  290                 $dialog_action->($d) if $dialog_action;
  291                 })->pack;
  292         } else {
  293         if ($scrolled) {
  294             $ff->Scrolled($class, @w_args, -scrollbars => $scrolled)->pack;
  295         } else {
  296             $ff->$class(@w_args)->pack;
  297         }
  298         }
  299     };
  300     if ($@ || !$cw) {
  301         warn $@;
  302         $row--;
  303         $ff->destroy;
  304         next;
  305     }
  306 
  307     $action->($cw) if $action && !$dialog;
  308 
  309     $f->Label(-text => $text,
  310           -background => $bgcolor,
  311           -anchor => 'w',
  312          )->grid(-row => $row,
  313              -column => 0,
  314              -sticky => "news",
  315             );
  316 
  317     $f->Button(-text => 'Pod',
  318            -background => $bgcolor,
  319            -command => sub {
  320                require Tk::Pod;
  321                $TOP->Pod(-file => 'Tk::' . $class);
  322            },
  323           )->grid(-row => $row,
  324               -column => 2,
  325               -sticky => 'news',
  326              );
  327     }
  328     # $TOP->WidgetDump;
  329 }
  330 
  331 __END__